xmonad-contrib/XMonad/Hooks/EventHook.hs

{-# 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
    , HandleEvent
    ) 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 = HandlerOff deriving ( Typeable )
instance Message EventHandleMsg

instance (EventHook eh, LayoutClass l a) => LayoutClass (HandleEvent eh l) a where
    runLayout (Workspace i (HandleEvent Nothing True eh l) ms) r = do
      broadcastMessage HandlerOff
      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 mi b eh l) ms) r = do
      (wrs, ml) <- runLayout (Workspace i l ms) r
      return (wrs, Just $ HandleEvent mi b eh (fromMaybe l ml))

    handleMessage (HandleEvent i True eh l) m
        | Just HandlerOff <- fromMessage m = return . Just $ HandleEvent i False eh l
        | Just e          <- fromMessage m = handleMessage l (SomeMessage e) >>= \ml ->
                                             handleEvent eh e >>
                                             maybe (return Nothing) (\l' -> return . Just $ HandleEvent i True eh l') ml
    handleMessage (HandleEvent i b eh l) m = handleMessage l m >>=
                                             maybe (return Nothing) (\l' -> return . Just $ HandleEvent i b    eh l')

    description (HandleEvent _ _ _ l) = description l