diff options
| -rw-r--r-- | XMonad/Core.hs | 19 | ||||
| -rw-r--r-- | XMonad/ManageHook.hs | 30 | ||||
| -rw-r--r-- | XMonad/Operations.hs | 2 |
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 |