ManageHook is a Monoid

darcs-hash:20071119060820-a5988-f70bb442a74c5ca8f6670184fb7eea6ca40ec793

3 files changed, 34 insertions, 17 deletions

diff --git a/XMonad/Core.hs b/XMonad/Core.hs
index dd8de32..5eaa991 100644
--- a/XMonad/Core.hs
+++ b/XMonad/Core.hs
@@ -27,7 +27,7 @@ module XMonad.Core (
     runX, catchX, userCode, io, catchIO,
     withDisplay, withWindowSet, isRoot,
     getAtom, spawn, restart, recompile, trace, whenJust, whenX,
-    atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW
+    atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, ManageHook, Query(..), runManageHook
   ) where
 
 import XMonad.StackSet
@@ -45,6 +45,7 @@ import System.Environment
 import Graphics.X11.Xlib
 import Graphics.X11.Xlib.Extras (Event)
 import Data.Typeable
+import Data.Monoid
 
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -75,7 +76,7 @@ data XConfig l = XConfig
     , focusedBorderColor :: !String             -- ^ Focused windows border color. Default: \"#ff0000\"
     , terminal           :: !String             -- ^ The preferred terminal application. Default: \"xterm\"
     , layoutHook         :: !(l Window)         -- ^ The avaiable layouts
-    , manageHook         :: Window -> X (WindowSet -> WindowSet) 
+    , manageHook         :: !ManageHook
                                                 -- ^ The action to run when a new window is opened
     , workspaces         :: [String]            -- ^ The list of workspaces' names
     , defaultGaps        :: [(Int,Int,Int,Int)] -- ^ The list of gaps, per screen
@@ -116,6 +117,20 @@ data ScreenDetail   = SD { screenRect :: !Rectangle
 newtype X a = X (ReaderT XConf (StateT XState IO) a)
     deriving (Functor, Monad, MonadIO, MonadState XState, MonadReader XConf)
 
+instance (Monoid a) => Monoid (X a) where
+    mempty  = return mempty
+    mappend = liftM2 mappend
+
+type ManageHook = Query (Endo WindowSet)
+newtype Query a = Query (ReaderT Window X a) deriving (Functor, Monad, MonadReader Window)
+
+runManageHook :: ManageHook -> Window -> X (WindowSet -> WindowSet)
+runManageHook (Query m) w = fmap appEndo $ runReaderT m w
+
+instance Monoid a => Monoid (Query a) where
+    mempty  = return mempty
+    mappend = liftM2 mappend
+
 -- | Run the X monad, given a chunk of X monad code, and an initial state
 -- Return the result, and final state
 runX :: XConf -> XState -> X a -> IO (a, XState)
diff --git a/XMonad/ManageHook.hs b/XMonad/ManageHook.hs
index 8d379a9..fac3889 100644
--- a/XMonad/ManageHook.hs
+++ b/XMonad/ManageHook.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad/ManageHook.hs
@@ -17,15 +19,15 @@
 module XMonad.ManageHook where
 
 import XMonad.Core
-import Graphics.X11
 import Graphics.X11.Xlib.Extras
-import Control.Monad
+import Control.Monad.Reader
 import Data.Maybe
+import Data.Monoid
 import qualified XMonad.StackSet as W
 import XMonad.Operations (floatLocation, reveal)
 
-type ManageHook = Query (WindowSet -> WindowSet)
-type Query a    = Window -> X a
+liftX :: X a -> Query a
+liftX = Query . lift
 
 -- | The identity hook that returns the WindowSet unchanged.
 idHook :: ManageHook
@@ -33,34 +35,34 @@ idHook = doF id
 
 -- | Compose two 'ManageHook's
 (<+>) :: ManageHook -> ManageHook -> ManageHook
-f <+> g = \w -> liftM2 (.) (f w) (g w)
+f <+> g = mappend f g
 
 -- | Compose the list of 'ManageHook's
 composeAll :: [ManageHook] -> ManageHook
-composeAll = foldr (<+>) idHook
+composeAll = mconcat
 
 -- | 'p --> x'.  If 'p' returns 'True', execute the 'ManageHook'.
 (-->) :: Query Bool -> ManageHook -> ManageHook
-p --> f = \w -> p w >>= \b -> if b then f w else idHook w
+p --> f = p >>= \b -> if b then f else mempty
 
 -- | 'q =? x'. if the result of 'q' equals 'x', return 'True'.
 (=?) :: Eq a => Query a -> a -> Query Bool
-q =? x = \w -> fmap (== x) (q w)
+q =? x = fmap (== x) q
 
 -- | Queries that return the window title, resource, or class.
 title, resource, className :: Query String
-title     = \w -> withDisplay $ \d -> fmap (fromMaybe "") $ io $ fetchName d w
-resource  = \w -> withDisplay $ \d -> fmap resName $ io $ getClassHint d w
-className = \w -> withDisplay $ \d -> fmap resClass $ io $ getClassHint d w
+title     = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ io $ fetchName d w)
+resource  = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resName $ io $ getClassHint d w)
+className = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resClass $ io $ getClassHint d w)
 
 -- | Modify the 'WindowSet' with a pure function.
 doF :: (WindowSet -> WindowSet) -> ManageHook
-doF f = const (return f)
+doF = return . Endo
 
 -- | Move the window to the floating layer.
 doFloat :: ManageHook
-doFloat = \w -> fmap (W.float w . snd) (floatLocation w)
+doFloat = ask >>= \w -> doF . W.float w . snd =<< liftX (floatLocation w)
 
 -- | Map the window and remove it from the 'WindowSet'.
 doIgnore :: ManageHook
-doIgnore = \w -> reveal w >> return (W.delete w)
+doIgnore = ask >>= \w -> liftX (reveal w) >> doF (W.delete w)
diff --git a/XMonad/Operations.hs b/XMonad/Operations.hs
index 1c18690..2d2a6ce 100644
--- a/XMonad/Operations.hs
+++ b/XMonad/Operations.hs
@@ -64,7 +64,7 @@ manage w = whenX (fmap not $ isClient w) $ withDisplay $ \d -> do
             where i = fromMaybe (W.tag . W.workspace . W.current $ ws) $ W.lookupWorkspace sc ws
 
     mh <- asks (manageHook . config)
-    g <- mh w `catchX` return id
+    g <- runManageHook mh w `catchX` return id
     windows (g . f)
 
 -- | unmanage. A window no longer exists, remove it from the window