Add EventHook: a layout modifier to handle X events

darcs-hash:20080224112432-32816-39c2c29649bfbf285107e019a4fb76ff535f6fbb.gz

1 files changed, 107 insertions, 0 deletions

diff --git a/XMonad/Hooks/EventHook.hs b/XMonad/Hooks/EventHook.hs
new file mode 100644
index 0000000..a45e39f
--- /dev/null
+++ b/XMonad/Hooks/EventHook.hs
@@ -0,0 +1,107 @@
+{-# OPTIONS_GHC -fglasgow-exts #-} -- for deriving Typeable
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Hooks.EventHook
+-- Copyright   :  (c) 2007 Andrea Rossato
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  andrea.rossato@unibz.it
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- A layout modifier that implements an event hook at the layout level.
+--
+-- Since it operates at the 'Workspace' level, it will install itself
+-- on the first current 'Workspace' and will broadcast a 'Message' to
+-- all other 'Workspace's not to handle events.
+-----------------------------------------------------------------------------
+
+module XMonad.Hooks.EventHook
+    ( -- * Usage:
+      -- $usage
+
+      -- * Writing a hook
+      -- $hook
+      EventHook (..)
+    , eventHook
+    ) where
+
+import Control.Applicative ((<$>))
+import Data.Maybe
+
+import XMonad
+import XMonad.StackSet (StackSet (..), Screen (..), Workspace (..))
+
+-- $usage
+-- You can use this module with the following in your
+-- @~\/.xmonad\/xmonad.hs@:
+--
+-- > import XMonad.Hooks.EventHook
+--
+-- Then edit your @layoutHook@ by adding the 'eventHook':
+--
+-- > layoutHook = eventHook EventHookExample $ avoidStruts $ simpleTabbed ||| Full ||| etc..
+--
+-- and then:
+--
+-- > main = xmonad defaultConfig { layoutHook = myLayouts }
+--
+-- For more detailed instructions on editing the layoutHook see:
+--
+-- "XMonad.Doc.Extending#Editing_the_layout_hook"
+
+-- $hook
+-- Writing a hook is very simple.
+--
+-- This is a basic example to log all events:
+--
+-- > data EventHookExample = EventHookExample deriving ( Show, Read )
+-- > instance EventHook EventHookExample where
+-- >     handleEvent _ e = io $ hPutStrLn stderr . show $ e --return ()
+--
+-- This is an 'EventHook' to log mouse button events:
+--
+-- > data EventHookButton = EventHookButton deriving ( Show, Read )
+-- > instance EventHook EventHookButton where
+-- >    handleEvent _ (ButtonEvent {ev_window = w}) = do
+-- >         io $ hPutStrLn stderr $ "This is a button event on window " ++ (show w)
+-- >    handleEvent _ _ = return ()
+--
+-- Obviously you can compose event hooks:
+--
+-- > layoutHook = eventHook EventHookButton $ eventHook EventHookExample $ avoidStruts $ simpleTabbed ||| Full ||| etc..
+
+eventHook :: EventHook eh => eh -> l a -> (HandleEvent eh l) a
+eventHook = HandleEvent Nothing True
+
+class (Read eh, Show eh) => EventHook eh where
+    handleEvent :: eh -> Event -> X ()
+    handleEvent _ _ = return ()
+
+data HandleEvent eh l a = HandleEvent (Maybe WorkspaceId) Bool eh (l a) deriving ( Show, Read )
+
+data EventHandleMsg = ReceiverOff deriving ( Typeable )
+instance Message EventHandleMsg
+
+instance (EventHook eh, LayoutClass l a) => LayoutClass (HandleEvent eh l) a where
+    runLayout (Workspace i (HandleEvent Nothing _ eh l) ms) r = do
+      broadcastMessage ReceiverOff
+      iws <- (tag . workspace . current) <$> gets windowset
+      (wrs, ml) <- runLayout (Workspace i l ms) r
+      return (wrs, Just $ HandleEvent (Just iws) True eh (fromMaybe l ml))
+
+    runLayout (Workspace i (HandleEvent j b eh l) ms) r = do
+      (wrs, ml) <- runLayout (Workspace i l ms) r
+      return (wrs, Just $ HandleEvent j b eh (fromMaybe l ml))
+
+    handleMessage (HandleEvent mi True eh l) m
+        | Just ReceiverOff <- fromMessage m = return . Just $ HandleEvent mi False eh l
+        | Just e           <- fromMessage m = handleEvent eh e >>
+                                              handleMessage l (SomeMessage e) >>=
+                                              maybe (return Nothing) (\l' -> return . Just $ HandleEvent mi True eh l')
+    handleMessage (HandleEvent mi b eh l) m = handleMessage l m >>=
+                                              maybe (return Nothing) (\l' -> return . Just $ HandleEvent mi b eh l')
+
+    description (HandleEvent _ _ _ l) = description l