diff options
| -rw-r--r-- | Main.hs | 2 | ||||
| -rw-r--r-- | XMonad.hs | 298 | ||||
| -rw-r--r-- | XMonad/Config.hs | 4 | ||||
| -rw-r--r-- | XMonad/Core.hs | 517 | ||||
| -rw-r--r-- | XMonad/Layouts.hs | 2 | ||||
| -rw-r--r-- | XMonad/Main.hs | 277 | ||||
| -rw-r--r-- | XMonad/Operations.hs | 2 | ||||
| -rw-r--r-- | xmonad.cabal | 5 |
8 files changed, 560 insertions, 547 deletions
@@ -14,7 +14,7 @@ module Main (main) where -import XMonad.Core +import XMonad.Main import XMonad.Config import Control.Exception (handle) @@ -1,294 +1,12 @@ -{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, TypeSynonymInstances #-} --- required for deriving Typeable -{-# OPTIONS_GHC -fglasgow-exts #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonad.hs --- Copyright : (c) Spencer Janssen 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : sjanssen@cse.unl.edu --- Stability : unstable --- Portability : not portable, uses cunning newtype deriving --- --- The X monad, a state monad transformer over IO, for the window --- manager state, and support routines. --- ------------------------------------------------------------------------------ - module XMonad ( - X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), XConfig(..), LayoutClass(..), Layout(..), readsLayout, Typeable, Message, SomeMessage(..), fromMessage, runLayout, LayoutMessages(..), - runX, catchX, userCode, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, trace, whenJust, whenX, - atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW - ) where - -import XMonad.StackSet - -import Prelude hiding ( catch ) -import Control.Exception (catch, throw, Exception(ExitException)) -import Control.Monad.State -import Control.Monad.Reader -import System.IO -import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession) -import System.Exit -import System.Environment -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras (Event) -import Data.Typeable - -import qualified Data.Map as M -import qualified Data.Set as S - --- | XState, the window manager state. --- Just the display, width, height and a window list -data XState = XState - { windowset :: !WindowSet -- ^ workspace list - , mapped :: !(S.Set Window) -- ^ the Set of mapped windows - , waitingUnmap :: !(M.Map Window Int) -- ^ the number of expected UnmapEvents - , dragging :: !(Maybe (Position -> Position -> X (), X ())) } - -data XConf = XConf - { display :: Display -- ^ the X11 display - , config :: !XConfig -- ^ initial user configuration - , theRoot :: !Window -- ^ the root window - , normalBorder :: !Pixel -- ^ border color of unfocused windows - , focusedBorder :: !Pixel -- ^ border color of the focused window - , keyActions :: !(M.Map (KeyMask, KeySym) (X ())) - -- ^ a mapping of key presses to actions - , buttonActions :: !(M.Map (KeyMask, Button) (Window -> X ())) - -- ^ a mapping of button presses to actions - } - --- todo, better name -data XConfig = XConfig - { normalBorderColor :: !String - , focusedBorderColor :: !String - , terminal :: !String - , layoutHook :: !(Layout Window) - , manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet) - , workspaces :: [String] - , defaultGaps :: [(Int,Int,Int,Int)] - , numlockMask :: !KeyMask - , modMask :: !KeyMask - , keys :: XConfig -> M.Map (ButtonMask,KeySym) (X ()) - , mouseBindings :: XConfig -> M.Map (ButtonMask, Button) (Window -> X ()) - , borderWidth :: !Dimension - , logHook :: X () - } - -type WindowSet = StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail -type WindowSpace = Workspace WorkspaceId (Layout Window) Window - --- | Virtual workspace indicies -type WorkspaceId = String - --- | Physical screen indicies -newtype ScreenId = S Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real) - --- | TODO Comment me -data ScreenDetail = SD { screenRect :: !Rectangle - , statusGap :: !(Int,Int,Int,Int) -- ^ width of status bar on the screen - } deriving (Eq,Show, Read) - ------------------------------------------------------------------------- - --- | The X monad, a StateT transformer over IO encapsulating the window --- manager state --- --- Dynamic components may be retrieved with 'get', static components --- with 'ask'. With newtype deriving we get readers and state monads --- instantiated on XConf and XState automatically. --- -newtype X a = X (ReaderT XConf (StateT XState IO) a) - deriving (Functor, Monad, MonadIO, MonadState XState, MonadReader XConf) - --- | 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) -runX c st (X a) = runStateT (runReaderT a c) st - --- | Run in the X monad, and in case of exception, and catch it and log it --- to stderr, and run the error case. -catchX :: X a -> X a -> X a -catchX job errcase = do - st <- get - c <- ask - (a, s') <- io $ runX c st job `catch` \e -> case e of - ExitException {} -> throw e - _ -> do hPrint stderr e; runX c st errcase - put s' - return a - --- | Execute the argument, catching all exceptions. Either this function or --- catchX should be used at all callsites of user customized code. -userCode :: X () -> X () -userCode a = catchX (a >> return ()) (return ()) - --- --------------------------------------------------------------------- --- Convenient wrappers to state - --- | Run a monad action with the current display settings -withDisplay :: (Display -> X a) -> X a -withDisplay f = asks display >>= f - --- | Run a monadic action with the current stack set -withWindowSet :: (WindowSet -> X a) -> X a -withWindowSet f = gets windowset >>= f - --- | True if the given window is the root window -isRoot :: Window -> X Bool -isRoot w = liftM (w==) (asks theRoot) - --- | Wrapper for the common case of atom internment -getAtom :: String -> X Atom -getAtom str = withDisplay $ \dpy -> io $ internAtom dpy str False - --- | Common non-predefined atoms -atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_STATE :: X Atom -atom_WM_PROTOCOLS = getAtom "WM_PROTOCOLS" -atom_WM_DELETE_WINDOW = getAtom "WM_DELETE_WINDOW" -atom_WM_STATE = getAtom "WM_STATE" - ------------------------------------------------------------------------- --- | LayoutClass handling. See particular instances in Operations.hs - --- | An existential type that can hold any object that is in Read and LayoutClass. -data Layout a = forall l. (LayoutClass l a, Read (l a)) => Layout (l a) - --- | Using the 'Layout' as a witness, parse existentially wrapped windows --- from a 'String' -readsLayout :: Layout a -> String -> [(Layout a, String)] -readsLayout (Layout l) s = [(Layout (asTypeOf x l), rs) | (x, rs) <- reads s] - --- | The different layout modes --- --- 'doLayout': given a Rectangle and a Stack, layout the stack elements --- inside the given Rectangle. If an element is not given a Rectangle --- by 'doLayout', then it is not shown on screen. Windows are restacked --- according to the order they are returned by 'doLayout'. --- -class Show (layout a) => LayoutClass layout a where - - -- | Given a Rectangle in which to place the windows, and a Stack of - -- windows, return a list of windows and their corresponding Rectangles. - -- The order of windows in this list should be the desired stacking order. - -- Also return a modified layout, if this layout needs to be modified - -- (e.g. if we keep track of the windows we have displayed). - doLayout :: layout a -> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (layout a)) - doLayout l r s = return (pureLayout l r s, Nothing) - - -- | This is a pure version of doLayout, for cases where we don't need - -- access to the X monad to determine how to layou out the windows, and - -- we don't need to modify our layout itself. - pureLayout :: layout a -> Rectangle -> Stack a -> [(a, Rectangle)] - pureLayout _ r s = [(focus s, r)] - - -- | 'handleMessage' performs message handling for that layout. If - -- 'handleMessage' returns Nothing, then the layout did not respond to - -- that message and the screen is not refreshed. Otherwise, 'handleMessage' - -- returns an updated 'LayoutClass' and the screen is refreshed. - -- - handleMessage :: layout a -> SomeMessage -> X (Maybe (layout a)) - handleMessage l = return . pureMessage l - - -- | Respond to a message by (possibly) changing our layout, but taking - -- no other action. If the layout changes, the screen will be refreshed. - pureMessage :: layout a -> SomeMessage -> Maybe (layout a) - pureMessage _ _ = Nothing - - -- | This should be a human-readable string that is used when selecting - -- layouts by name. - description :: layout a -> String - description = show - -instance LayoutClass Layout Window where - doLayout (Layout l) r s = fmap (fmap Layout) `liftM` doLayout l r s - handleMessage (Layout l) = fmap (fmap Layout) . handleMessage l - description (Layout l) = description l - -instance Show (Layout a) where show (Layout l) = show l - --- | This calls doLayout if there are any windows to be laid out. -runLayout :: LayoutClass l a => l a -> Rectangle -> Maybe (Stack a) -> X ([(a, Rectangle)], Maybe (l a)) -runLayout l r = maybe (return ([], Nothing)) (doLayout l r) - --- | Based on ideas in /An Extensible Dynamically-Typed Hierarchy of Exceptions/, --- Simon Marlow, 2006. Use extensible messages to the handleMessage handler. --- --- User-extensible messages must be a member of this class. --- -class Typeable a => Message a - --- | --- A wrapped value of some type in the Message class. --- -data SomeMessage = forall a. Message a => SomeMessage a - --- | --- And now, unwrap a given, unknown Message type, performing a (dynamic) --- type check on the result. --- -fromMessage :: Message m => SomeMessage -> Maybe m -fromMessage (SomeMessage m) = cast m - --- | X Events are valid Messages -instance Message Event - --- | LayoutMessages are core messages that all layouts (especially stateful --- layouts) should consider handling. -data LayoutMessages = Hide -- ^ sent when a layout becomes non-visible - | ReleaseResources -- ^ sent when xmonad is exiting or restarting - deriving (Typeable, Eq) - -instance Message LayoutMessages - --- --------------------------------------------------------------------- --- | General utilities --- --- Lift an IO action into the X monad -io :: IO a -> X a -io = liftIO - --- | Lift an IO action into the X monad. If the action results in an IO --- exception, log the exception to stderr and continue normal execution. -catchIO :: IO () -> X () -catchIO f = liftIO (f `catch` \e -> hPrint stderr e >> hFlush stderr) - --- | spawn. Launch an external application -spawn :: String -> X () -spawn x = io $ do - pid <- forkProcess $ do - forkProcess (createSession >> executeFile "/bin/sh" False ["-c", x] Nothing) - exitWith ExitSuccess - getProcessStatus True False pid - return () - --- | Restart xmonad via exec(). --- --- If the first parameter is 'Just name', restart will attempt to execute the --- program corresponding to 'name'. Otherwise, xmonad will attempt to execute --- the name of the current program. --- --- When the second parameter is 'True', xmonad will attempt to resume with the --- current window state. -restart :: Maybe String -> Bool -> X () -restart mprog resume = do - prog <- maybe (io getProgName) return mprog - args <- if resume then gets (("--resume":) . return . showWs . windowset) else return [] - catchIO (executeFile prog True args Nothing) - where showWs = show . mapLayout show --- | Run a side effecting action with the current workspace. Like 'when' but -whenJust :: Maybe a -> (a -> X ()) -> X () -whenJust mg f = maybe (return ()) f mg + module XMonad.Main, + module XMonad.Core, + module XMonad.Config --- | Conditionally run an action, using a X event to decide -whenX :: X Bool -> X () -> X () -whenX a f = a >>= \b -> when b f + ) where --- | A 'trace' for the X monad. Logs a string to stderr. The result may --- be found in your .xsession-errors file -trace :: String -> X () -trace msg = io $! do hPutStrLn stderr msg; hFlush stderr +import XMonad.Main +import XMonad.Core +import XMonad.Config +-- import XMonad.StackSet -- conflicts with 'workspaces' defined in XMonad.hs diff --git a/XMonad/Config.hs b/XMonad/Config.hs index 5021328..5c988c9 100644 --- a/XMonad/Config.hs +++ b/XMonad/Config.hs @@ -20,10 +20,10 @@ module XMonad.Config (defaultConfig) where -- -- Useful imports -- -import XMonad hiding +import XMonad.Core as XMonad hiding (workspaces,manageHook,numlockMask,keys,logHook,borderWidth,mouseBindings ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor) -import qualified XMonad +import qualified XMonad.Core as XMonad (workspaces,manageHook,numlockMask,keys,logHook,borderWidth,mouseBindings ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor) diff --git a/XMonad/Core.hs b/XMonad/Core.hs index edf7530..728fb61 100644 --- a/XMonad/Core.hs +++ b/XMonad/Core.hs @@ -1,277 +1,294 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- +{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, TypeSynonymInstances #-} +-- required for deriving Typeable +{-# OPTIONS_GHC -fglasgow-exts #-} + +----------------------------------------------------------------------------- -- | --- Module : Core.hs +-- Module : XMonad/Core.hs -- Copyright : (c) Spencer Janssen 2007 -- License : BSD3-style (see LICENSE) -- -- Maintainer : sjanssen@cse.unl.edu -- Stability : unstable --- Portability : not portable, uses mtl, X11, posix +-- Portability : not portable, uses cunning newtype deriving -- --- xmonad, a minimalist, tiling window manager for X11 +-- The X monad, a state monad transformer over IO, for the window +-- manager state, and support routines. -- ----------------------------------------------------------------------------- -module XMonad.Core (xmonad) where +module XMonad.Core ( + X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), XConfig(..), LayoutClass(..), Layout(..), readsLayout, Typeable, Message, SomeMessage(..), fromMessage, runLayout, LayoutMessages(..), + runX, catchX, userCode, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, trace, whenJust, whenX, + atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW + ) where + +import XMonad.StackSet + +import Prelude hiding ( catch ) +import Control.Exception (catch, throw, Exception(ExitException)) +import Control.Monad.State +import Control.Monad.Reader +import System.IO +import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession) +import System.Exit +import System.Environment +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras (Event) +import Data.Typeable -import Data.Bits import qualified Data.Map as M import qualified Data.Set as S -import Control.Monad.Reader -import Control.Monad.State -import Data.Maybe (fromMaybe) -import System.Environment (getArgs) +-- | XState, the window manager state. +-- Just the display, width, height and a window list +data XState = XState + { windowset :: !WindowSet -- ^ workspace list + , mapped :: !(S.Set Window) -- ^ the Set of mapped windows + , waitingUnmap :: !(M.Map Window Int) -- ^ the number of expected UnmapEvents + , dragging :: !(Maybe (Position -> Position -> X (), X ())) } + +data XConf = XConf + { display :: Display -- ^ the X11 display + , config :: !XConfig -- ^ initial user configuration + , theRoot :: !Window -- ^ the root window + , normalBorder :: !Pixel -- ^ border color of unfocused windows + , focusedBorder :: !Pixel -- ^ border color of the focused window + , keyActions :: !(M.Map (KeyMask, KeySym) (X ())) + -- ^ a mapping of key presses to actions + , buttonActions :: !(M.Map (KeyMask, Button) (Window -> X ())) + -- ^ a mapping of button presses to actions + } + +-- todo, better name +data XConfig = XConfig + { normalBorderColor :: !String + , focusedBorderColor :: !String + , terminal :: !String + , layoutHook :: !(Layout Window) + , manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet) + , workspaces :: [String] + , defaultGaps :: [(Int,Int,Int,Int)] + , numlockMask :: !KeyMask + , modMask :: !KeyMask + , keys :: XConfig -> M.Map (ButtonMask,KeySym) (X ()) + , mouseBindings :: XConfig -> M.Map (ButtonMask, Button) (Window -> X ()) + , borderWidth :: !Dimension + , logHook :: X () + } + +type WindowSet = StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail +type WindowSpace = Workspace WorkspaceId (Layout Window) Window + +-- | Virtual workspace indicies +type WorkspaceId = String + +-- | Physical screen indicies +newtype ScreenId = S Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real) + +-- | TODO Comment me +data ScreenDetail = SD { screenRect :: !Rectangle + , statusGap :: !(Int,Int,Int,Int) -- ^ width of status bar on the screen + } deriving (Eq,Show, Read) + +------------------------------------------------------------------------ + +-- | The X monad, a StateT transformer over IO encapsulating the window +-- manager state +-- +-- Dynamic components may be retrieved with 'get', static components +-- with 'ask'. With newtype deriving we get readers and state monads +-- instantiated on XConf and XState automatically. +-- +newtype X a = X (ReaderT XConf (StateT XState IO) a) + deriving (Functor, Monad, MonadIO, MonadState XState, MonadReader XConf) + +-- | 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) +runX c st (X a) = runStateT (runReaderT a c) st + +-- | Run in the X monad, and in case of exception, and catch it and log it +-- to stderr, and run the error case. +catchX :: X a -> X a -> X a +catchX job errcase = do + st <- get + c <- ask + (a, s') <- io $ runX c st job `catch` \e -> case e of + ExitException {} -> throw e + _ -> do hPrint stderr e; runX c st errcase + put s' + return a + +-- | Execute the argument, catching all exceptions. Either this function or +-- catchX should be used at all callsites of user customized code. +userCode :: X () -> X () +userCode a = catchX (a >> return ()) (return ()) -import Graphics.X11.Xlib hiding (refreshKeyboardMapping) -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xinerama (getScreenInfo) +-- --------------------------------------------------------------------- +-- Convenient wrappers to state -import XMonad -import XMonad.StackSet (new, floating, member) -import qualified XMonad.StackSet as W -import XMonad.Operations +-- | Run a monad action with the current display settings +withDisplay :: (Display -> X a) -> X a +withDisplay f = asks display >>= f -import System.IO +-- | Run a monadic action with the current stack set +withWindowSet :: (WindowSet -> X a) -> X a +withWindowSet f = gets windowset >>= f --- | --- The main entry point --- -xmonad :: XConfig -> IO () -xmonad xmc = do - dpy <- openDisplay "" - let dflt = defaultScreen dpy - - rootw <- rootWindow dpy dflt - xinesc <- getScreenInfo dpy - nbc <- initColor dpy $ normalBorderColor xmc - fbc <- initColor dpy $ focusedBorderColor xmc - hSetBuffering stdout NoBuffering - args <- getArgs - - let layout = layoutHook xmc - lreads = readsLayout layout - initialWinset = new layout (workspaces xmc) $ zipWith SD xinesc gaps - - maybeRead reads' s = case reads' s of - [(x, "")] -> Just x - _ -> Nothing - - winset = fromMaybe initialWinset $ do - ("--resume" : s : _) <- return args - ws <- maybeRead reads s - return . W.ensureTags layout (workspaces xmc) - $ W.mapLayout (fromMaybe layout . maybeRead lreads) ws - - gaps = take (length xinesc) $ defaultGaps xmc ++ repeat (0,0,0,0) - - cf = XConf - { display = dpy - , config = xmc - , theRoot = rootw - , normalBorder = nbc - , focusedBorder = fbc - , keyActions = keys xmc xmc - , buttonActions = mouseBindings xmc xmc } - st = XState - { windowset = initialWinset - , mapped = S.empty - , waitingUnmap = M.empty - , dragging = Nothing } - - xSetErrorHandler -- in C, I'm too lazy to write the binding: dons - - -- setup initial X environment - sync dpy False - selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask - .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask - - allocaXEvent $ \e -> - runX cf st $ do - - grabKeys - grabButtons - - io $ sync dpy False - - -- bootstrap the windowset, Operations.windows will identify all - -- the windows in winset as new and set initial properties for - -- those windows - windows (const winset) - - -- scan for all top-level windows, add the unmanaged ones to the - -- windowset - ws <- io $ scan dpy rootw - mapM_ manage ws - - -- main loop, for all you HOF/recursion fans out there. - forever_ $ handle =<< io (nextEvent dpy e >> getEvent e) +-- | True if the given window is the root window +isRoot :: Window -> X Bool +isRoot w = liftM (w==) (asks theRoot) - return () - where forever_ a = a >> forever_ a +-- | Wrapper for the common case of atom internment +getAtom :: String -> X Atom +getAtom str = withDisplay $ \dpy -> io $ internAtom dpy str False +-- | Common non-predefined atoms +atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_STATE :: X Atom +atom_WM_PROTOCOLS = getAtom "WM_PROTOCOLS" +atom_WM_DELETE_WINDOW = getAtom "WM_DELETE_WINDOW" +atom_WM_STATE = getAtom "WM_STATE" --- --------------------------------------------------------------------- --- | Event handler. Map X events onto calls into Operations.hs, which --- modify our internal model of the window manager state. +------------------------------------------------------------------------ +-- | LayoutClass handling. See particular instances in Operations.hs + +-- | An existential type that can hold any object that is in Read and LayoutClass. +data Layout a = forall l. (LayoutClass l a, Read (l a)) => Layout (l a) + +-- | Using the 'Layout' as a witness, parse existentially wrapped windows +-- from a 'String' +readsLayout :: Layout a -> String -> [(Layout a, String)] +readsLayout (Layout l) s = [(Layout (asTypeOf x l), rs) | (x, rs) <- reads s] + +-- | The different layout modes -- --- Events dwm handles that we don't: +-- 'doLayout': given a Rectangle and a Stack, layout the stack elements +-- inside the given Rectangle. If an element is not given a Rectangle +-- by 'doLayout', then it is not shown on screen. Windows are restacked +-- according to the order they are returned by 'doLayout'. -- --- [ButtonPress] = buttonpress, --- [Expose] = expose, --- [PropertyNotify] = propertynotify, +class Show (layout a) => LayoutClass layout a where + + -- | Given a Rectangle in which to place the windows, and a Stack of + -- windows, return a list of windows and their corresponding Rectangles. + -- The order of windows in this list should be the desired stacking order. + -- Also return a modified layout, if this layout needs to be modified + -- (e.g. if we keep track of the windows we have displayed). + doLayout :: layout a -> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (layout a)) + doLayout l r s = return (pureLayout l r s, Nothing) + + -- | This is a pure version of doLayout, for cases where we don't need + -- access to the X monad to determine how to layou out the windows, and + -- we don't need to modify our layout itself. + pureLayout :: layout a -> Rectangle -> Stack a -> [(a, Rectangle)] + pureLayout _ r s = [(focus s, r)] + + -- | 'handleMessage' performs message handling for that layout. If + -- 'handleMessage' returns Nothing, then the layout did not respond to + -- that message and the screen is not refreshed. Otherwise, 'handleMessage' + -- returns an updated 'LayoutClass' and the screen is refreshed. + -- + handleMessage :: layout a -> SomeMessage -> X (Maybe (layout a)) + handleMessage l = return . pureMessage l + + -- | Respond to a message by (possibly) changing our layout, but taking + -- no other action. If the layout changes, the screen will be refreshed. + pureMessage :: layout a -> SomeMessage -> Maybe (layout a) + pureMessage _ _ = Nothing + + -- | This should be a human-readable string that is used when selecting + -- layouts by name. + description :: layout a -> String + description = show + +instance LayoutClass Layout Window where + doLayout (Layout l) r s = fmap (fmap Layout) `liftM` doLayout l r s + handleMessage (Layout l) = fmap (fmap Layout) . handleMessage l + description (Layout l) = description l + +instance Show (Layout a) where show (Layout l) = show l + +-- | This calls doLayout if there are any windows to be laid out. +runLayout :: LayoutClass l a => l a -> Rectangle -> Maybe (Stack a) -> X ([(a, Rectangle)], Maybe (l a)) +runLayout l r = maybe (return ([], Nothing)) (doLayout l r) + +-- | Based on ideas in /An Extensible Dynamically-Typed Hierarchy of Exceptions/, +-- Simon Marlow, 2006. Use extensible messages to the handleMessage handler. -- -handle :: Event -> X () - --- run window manager command -handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) - | t == keyPress = withDisplay $ \dpy -> do - s <- io $ keycodeToKeysym dpy code 0 - mClean <- cleanMask m - ks <- asks keyActions - userCode $ whenJust (M.lookup (mClean, s) ks) id - --- manage a new window -handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do - wa <- io $ getWindowAttributes dpy w -- ignore override windows - -- need to ignore mapping requests by managed windows not on the current workspace - managed <- isClient w - when (not (wa_override_redirect wa) && not managed) $ do manage w - --- window destroyed, unmanage it --- window gone, unmanage it -handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w - --- We track expected unmap events in waitingUnmap. We ignore this event unless --- it is synthetic or we are not expecting an unmap notification from a window. -handle (UnmapEvent {ev_window = w, ev_send_event = synthetic}) = whenX (isClient w) $ do - e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap) - if (synthetic || e == 0) - then unmanage w - else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) }) - --- set keyboard mapping -handle e@(MappingNotifyEvent {}) = do - io $ refreshKeyboardMapping e - when (ev_request e == mappingKeyboard) grabKeys - --- handle button release, which may finish dragging. -handle e@(ButtonEvent {ev_event_type = t}) - | t == buttonRelease = do - drag <- gets dragging - case drag of - -- we're done dragging and have released the mouse: - Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f - Nothing -> broadcastMessage e - --- handle motionNotify event, which may mean we are dragging. -handle e@(MotionEvent {ev_event_type = _t, ev_x = x, ev_y = y}) = do - drag <- gets dragging - case drag of - Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging - Nothing -> broadcastMessage e - --- click on an unfocused window, makes it focused on this workspace -handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b }) - | t == buttonPress = do - -- If it's the root window, then it's something we - -- grabbed in grabButtons. Otherwise, it's click-to-focus. - isr <- isRoot w - m <- cleanMask $ ev_state e - ba <- asks buttonActions - if isr then userCode $ whenJust (M.lookup (m, b) ba) ($ ev_subwindow e) - else focus w - sendMessage e -- Always send button events. - --- entered a normal window, makes this focused. -handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) - | t == enterNotify && ev_mode e == notifyNormal - && ev_detail e /= notifyInferior = focus w - --- left a window, check if we need to focus root -handle e@(CrossingEvent {ev_event_type = t}) - | t == leaveNotify - = do rootw <- asks theRoot - when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw - --- configure a window -handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do - ws <- gets windowset - wa <- io $ getWindowAttributes dpy w - - bw <- asks (borderWidth . config) - - if M.member w (floating ws) - || not (member w ws) - then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges - { wc_x = ev_x e - , wc_y = ev_y e - , wc_width = ev_width e - , wc_height = ev_height e - , wc_border_width = fromIntegral bw - , wc_sibling = ev_above e - , wc_stack_mode = ev_detail e } - when (member w ws) (float w) - else io $ allocaXEvent $ \ev -> do - setEventType ev configureNotify - setConfigureEvent ev w w - (wa_x wa) (wa_y wa) (wa_width wa) - (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) - sendEvent dpy w False 0 ev - io $ sync dpy False - --- configuration changes in the root may mean display settings have changed -handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen - --- property notify -handle PropertyEvent { ev_event_type = t, ev_atom = a } - | t == propertyNotify && a == wM_NAME = userCode =<< asks (logHook . config) - -handle e = broadcastMessage e -- trace (eventName e) -- ignoring +-- User-extensible messages must be a member of this class. +-- +class Typeable a => Message a +-- | +-- A wrapped value of some type in the Message class. +-- +data SomeMessage = forall a. Message a => SomeMessage a + +-- | +-- And now, unwrap a given, unknown Message type, performing a (dynamic) +-- type check on the result. +-- +fromMessage :: Message m => SomeMessage -> Maybe m +fromMessage (SomeMessage m) = cast m + +-- | X Events are valid Messages +instance Message Event + +-- | LayoutMessages are core messages that all layouts (especially stateful +-- layouts) should consider handling. +data LayoutMessages = Hide -- ^ sent when a layout becomes non-visible + | ReleaseResources -- ^ sent when xmonad is exiting or restarting + deriving (Typeable, Eq) + +instance Message LayoutMessages -- --------------------------------------------------------------------- --- IO stuff. Doesn't require any X state --- Most of these things run only on startup (bar grabkeys) - --- | scan for any new windows to manage. If they're already managed, --- this should be idempotent. -scan :: Display -> Window -> IO [Window] -scan dpy rootw = do - (_, _, ws) <- queryTree dpy rootw - filterM ok ws - -- TODO: scan for windows that are either 'IsViewable' or where WM_STATE == - -- Iconic - where ok w = do wa <- getWindowAttributes dpy w - a <- internAtom dpy "WM_STATE" False - p <- getWindowProperty32 dpy a w - let ic = case p of - Just (3:_) -> True -- 3 for iconified - _ -> False - return $ not (wa_override_redirect wa) - && (wa_map_state wa == waIsViewable || ic) - --- | Grab the keys back -grabKeys :: X () -grabKeys = do - XConf { display = dpy, theRoot = rootw } <- ask - let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync - io $ ungrabKey dpy anyKey anyModifier rootw - ks <- asks keyActions - forM_ (M.keys ks) $ \(mask,sym) -> do - kc <- io $ keysymToKeycode dpy sym - -- "If the specified KeySym is not defined for any KeyCode, - -- XKeysymToKeycode() returns zero." - when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) =<< extraModifiers - --- | XXX comment me -grabButtons :: X () -grabButtons = do - XConf { display = dpy, theRoot = rootw } <- ask - let grab button mask = io $ grabButton dpy button mask rootw False buttonPressMask - grabModeAsync grabModeSync none none - io $ ungrabButton dpy anyButton anyModifier rootw - ems <- extraModifiers - ba <- asks buttonActions - mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ ba) +-- | General utilities +-- +-- Lift an IO action into the X monad +io :: IO a -> X a +io = liftIO + +-- | Lift an IO action into the X monad. If the action results in an IO +-- exception, log the exception to stderr and continue normal execution. +catchIO :: IO () -> X () +catchIO f = liftIO (f `catch` \e -> hPrint stderr e >> hFlush stderr) + +-- | spawn. Launch an external application +spawn :: String -> X () +spawn x = io $ do + pid <- forkProcess $ do + forkProcess (createSession >> executeFile "/bin/sh" False ["-c", x] Nothing) + exitWith ExitSuccess + getProcessStatus True False pid + return () + +-- | Restart xmonad via exec(). +-- +-- If the first parameter is 'Just name', restart will attempt to execute the +-- program corresponding to 'name'. Otherwise, xmonad will attempt to execute +-- the name of the current program. +-- +-- When the second parameter is 'True', xmonad will attempt to resume with the +-- current window state. +restart :: Maybe String -> Bool -> X () +restart mprog resume = do + prog <- maybe (io getProgName) return mprog + args <- if resume then gets (("--resume":) . return . showWs . windowset) else return [] + catchIO (executeFile prog True args Nothing) + where showWs = show . mapLayout show + +-- | Run a side effecting action with the current workspace. Like 'when' but +whenJust :: Maybe a -> (a -> X ()) -> X () +whenJust mg f = maybe (return ()) f mg + +-- | Conditionally run an action, using a X event to decide +whenX :: X Bool -> X () -> X () +whenX a f = a >>= \b -> when b f + +-- | A 'trace' for the X monad. Logs a string to stderr. The result may +-- be found in your .xsession-errors file +trace :: String -> X () +trace msg = io $! do hPutStrLn stderr msg; hFlush stderr diff --git a/XMonad/Layouts.hs b/XMonad/Layouts.hs index ed85ffe..5d8d2bd 100644 --- a/XMonad/Layouts.hs +++ b/XMonad/Layouts.hs @@ -19,7 +19,7 @@ module XMonad.Layouts (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(. Full(..), Tall(..), Mirror(..), mirrorRect, splitVertically, splitHorizontally, splitHorizontallyBy, splitVerticallyBy) where -import XMonad +import XMonad.Core import Graphics.X11 (Rectangle(..)) import qualified XMonad.StackSet as W diff --git a/XMonad/Main.hs b/XMonad/Main.hs new file mode 100644 index 0000000..c40e45e --- /dev/null +++ b/XMonad/Main.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +---------------------------------------------------------------------------- +-- | +-- Module : Core.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : sjanssen@cse.unl.edu +-- Stability : unstable +-- Portability : not portable, uses mtl, X11, posix +-- +-- xmonad, a minimalist, tiling window manager for X11 +-- +----------------------------------------------------------------------------- + +module XMonad.Main (xmonad) where + +import Data.Bits +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Monad.Reader +import Control.Monad.State +import Data.Maybe (fromMaybe) + +import System.Environment (getArgs) + +import Graphics.X11.Xlib hiding (refreshKeyboardMapping) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xinerama (getScreenInfo) + +import XMonad.Core +import XMonad.StackSet (new, floating, member) +import qualified XMonad.StackSet as W +import XMonad.Operations + +import System.IO + +-- | +-- The main entry point +-- +xmonad :: XConfig -> IO () +xmonad xmc = do + dpy <- openDisplay "" + let dflt = defaultScreen dpy + + rootw <- rootWindow dpy dflt + xinesc <- getScreenInfo dpy + nbc <- initColor dpy $ normalBorderColor xmc + fbc <- initColor dpy $ focusedBorderColor xmc + hSetBuffering stdout NoBuffering + args <- getArgs + + let layout = layoutHook xmc + lreads = readsLayout layout + initialWinset = new layout (workspaces xmc) $ zipWith SD xinesc gaps + + maybeRead reads' s = case reads' s of + [(x, "")] -> Just x + _ -> Nothing + + winset = fromMaybe initialWinset $ do + ("--resume" : s : _) <- return args + ws <- maybeRead reads s + return . W.ensureTags layout (workspaces xmc) + $ W.mapLayout (fromMaybe layout . maybeRead lreads) ws + + gaps = take (length xinesc) $ defaultGaps xmc ++ repeat (0,0,0,0) + + cf = XConf + { display = dpy + , config = xmc + , theRoot = rootw + , normalBorder = nbc + , focusedBorder = fbc + , keyActions = keys xmc xmc + , buttonActions = mouseBindings xmc xmc } + st = XState + { windowset = initialWinset + , mapped = S.empty + , waitingUnmap = M.empty + , dragging = Nothing } + + xSetErrorHandler -- in C, I'm too lazy to write the binding: dons + + -- setup initial X environment + sync dpy False + selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask + .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask + + allocaXEvent $ \e -> + runX cf st $ do + + grabKeys + grabButtons + + io $ sync dpy False + + -- bootstrap the windowset, Operations.windows will identify all + -- the windows in winset as new and set initial properties for + -- those windows + windows (const winset) + + -- scan for all top-level windows, add the unmanaged ones to the + -- windowset + ws <- io $ scan dpy rootw + mapM_ manage ws + + -- main loop, for all you HOF/recursion fans out there. + forever_ $ handle =<< io (nextEvent dpy e >> getEvent e) + + return () + where forever_ a = a >> forever_ a + + +-- --------------------------------------------------------------------- +-- | Event handler. Map X events onto calls into Operations.hs, which +-- modify our internal model of the window manager state. +-- +-- Events dwm handles that we don't: +-- +-- [ButtonPress] = buttonpress, +-- [Expose] = expose, +-- [PropertyNotify] = propertynotify, +-- +handle :: Event -> X () + +-- run window manager command +handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) + | t == keyPress = withDisplay $ \dpy -> do + s <- io $ keycodeToKeysym dpy code 0 + mClean <- cleanMask m + ks <- asks keyActions + userCode $ whenJust (M.lookup (mClean, s) ks) id + +-- manage a new window +handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do + wa <- io $ getWindowAttributes dpy w -- ignore override windows + -- need to ignore mapping requests by managed windows not on the current workspace + managed <- isClient w + when (not (wa_override_redirect wa) && not managed) $ do manage w + +-- window destroyed, unmanage it +-- window gone, unmanage it +handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w + +-- We track expected unmap events in waitingUnmap. We ignore this event unless +-- it is synthetic or we are not expecting an unmap notification from a window. +handle (UnmapEvent {ev_window = w, ev_send_event = synthetic}) = whenX (isClient w) $ do + e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap) + if (synthetic || e == 0) + then unmanage w + else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) }) + +-- set keyboard mapping +handle e@(MappingNotifyEvent {}) = do + io $ refreshKeyboardMapping e + when (ev_request e == mappingKeyboard) grabKeys + +-- handle button release, which may finish dragging. +handle e@(ButtonEvent {ev_event_type = t}) + | t == buttonRelease = do + drag <- gets dragging + case drag of + -- we're done dragging and have released the mouse: + Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f + Nothing -> broadcastMessage e + +-- handle motionNotify event, which may mean we are dragging. +handle e@(MotionEvent {ev_event_type = _t, ev_x = x, ev_y = y}) = do + drag <- gets dragging + case drag of + Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging + Nothing -> broadcastMessage e + +-- click on an unfocused window, makes it focused on this workspace +handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b }) + | t == buttonPress = do + -- If it's the root window, then it's something we + -- grabbed in grabButtons. Otherwise, it's click-to-focus. + isr <- isRoot w + m <- cleanMask $ ev_state e + ba <- asks buttonActions + if isr then userCode $ whenJust (M.lookup (m, b) ba) ($ ev_subwindow e) + else focus w + sendMessage e -- Always send button events. + +-- entered a normal window, makes this focused. +handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) + | t == enterNotify && ev_mode e == notifyNormal + && ev_detail e /= notifyInferior = focus w + +-- left a window, check if we need to focus root +handle e@(CrossingEvent {ev_event_type = t}) + | t == leaveNotify + = do rootw <- asks theRoot + when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw + +-- configure a window +handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do + ws <- gets windowset + wa <- io $ getWindowAttributes dpy w + + bw <- asks (borderWidth . config) + + if M.member w (floating ws) + || not (member w ws) + then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges + { wc_x = ev_x e + , wc_y = ev_y e + , wc_width = ev_width e + , wc_height = ev_height e + , wc_border_width = fromIntegral bw + , wc_sibling = ev_above e + , wc_stack_mode = ev_detail e } + when (member w ws) (float w) + else io $ allocaXEvent $ \ev -> do + setEventType ev configureNotify + setConfigureEvent ev w w + (wa_x wa) (wa_y wa) (wa_width wa) + (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) + sendEvent dpy w False 0 ev + io $ sync dpy False + +-- configuration changes in the root may mean display settings have changed +handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen + +-- property notify +handle PropertyEvent { ev_event_type = t, ev_atom = a } + | t == propertyNotify && a == wM_NAME = userCode =<< asks (logHook . config) + +handle e = broadcastMessage e -- trace (eventName e) -- ignoring + + +-- --------------------------------------------------------------------- +-- IO stuff. Doesn't require any X state +-- Most of these things run only on startup (bar grabkeys) + +-- | scan for any new windows to manage. If they're already managed, +-- this should be idempotent. +scan :: Display -> Window -> IO [Window] +scan dpy rootw = do + (_, _, ws) <- queryTree dpy rootw + filterM ok ws + -- TODO: scan for windows that are either 'IsViewable' or where WM_STATE == + -- Iconic + where ok w = do wa <- getWindowAttributes dpy w + a <- internAtom dpy "WM_STATE" False + p <- getWindowProperty32 dpy a w + let ic = case p of + Just (3:_) -> True -- 3 for iconified + _ -> False + return $ not (wa_override_redirect wa) + && (wa_map_state wa == waIsViewable || ic) + +-- | Grab the keys back +grabKeys :: X () +grabKeys = do + XConf { display = dpy, theRoot = rootw } <- ask + let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync + io $ ungrabKey dpy anyKey anyModifier rootw + ks <- asks keyActions + forM_ (M.keys ks) $ \(mask,sym) -> do + kc <- io $ keysymToKeycode dpy sym + -- "If the specified KeySym is not defined for any KeyCode, + -- XKeysymToKeycode() returns zero." + when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) =<< extraModifiers + +-- | XXX comment me +grabButtons :: X () +grabButtons = do + XConf { display = dpy, theRoot = rootw } <- ask + let grab button mask = io $ grabButton dpy button mask rootw False buttonPressMask + grabModeAsync grabModeSync none none + io $ ungrabButton dpy anyButton anyModifier rootw + ems <- extraModifiers + ba <- asks buttonActions + mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ ba) diff --git a/XMonad/Operations.hs b/XMonad/Operations.hs index dc2d090..3d9a3b0 100644 --- a/XMonad/Operations.hs +++ b/XMonad/Operations.hs @@ -18,7 +18,7 @@ module XMonad.Operations where -import XMonad +import XMonad.Core import XMonad.Layouts (Full(..)) import qualified XMonad.StackSet as W diff --git a/xmonad.cabal b/xmonad.cabal index 9587993..2884587 100644 --- a/xmonad.cabal +++ b/xmonad.cabal @@ -26,8 +26,9 @@ flag small_base library exposed-modules: XMonad - XMonad.Config + XMonad.Main XMonad.Core + XMonad.Config XMonad.Layouts XMonad.Operations XMonad.StackSet @@ -45,6 +46,6 @@ library executable xmonad main-is: Main.hs - other-modules: XMonad.Core XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad + other-modules: XMonad.Core XMonad.Main XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad ghc-options: -funbox-strict-fields -Wall -Werror -optl-Wl,-s ghc-prof-options: -prof -auto-all |