Provide top level XMonad.hs export module

This commit is contained in:
Don Stewart 2007-11-07 03:06:17 +00:00
parent 6eb23670bb
commit dbfd13207d
8 changed files with 553 additions and 540 deletions

View File

@ -14,7 +14,7 @@
module Main (main) where module Main (main) where
import XMonad.Core import XMonad.Main
import XMonad.Config import XMonad.Config
import Control.Exception (handle) import Control.Exception (handle)

298
XMonad.hs
View File

@ -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 ( 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 module XMonad.Main,
module XMonad.Core,
module XMonad.Config
import Prelude hiding ( catch ) ) where
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 XMonad.Main
import qualified Data.Set as S import XMonad.Core
import XMonad.Config
-- | XState, the window manager state. -- import XMonad.StackSet -- conflicts with 'workspaces' defined in XMonad.hs
-- 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
-- | 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

View File

@ -20,10 +20,10 @@ module XMonad.Config (defaultConfig) where
-- --
-- Useful imports -- Useful imports
-- --
import XMonad hiding import XMonad.Core as XMonad hiding
(workspaces,manageHook,numlockMask,keys,logHook,borderWidth,mouseBindings (workspaces,manageHook,numlockMask,keys,logHook,borderWidth,mouseBindings
,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor) ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor)
import qualified XMonad import qualified XMonad.Core as XMonad
(workspaces,manageHook,numlockMask,keys,logHook,borderWidth,mouseBindings (workspaces,manageHook,numlockMask,keys,logHook,borderWidth,mouseBindings
,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor) ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor)

View File

@ -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 -- Copyright : (c) Spencer Janssen 2007
-- License : BSD3-style (see LICENSE) -- License : BSD3-style (see LICENSE)
-- --
-- Maintainer : sjanssen@cse.unl.edu -- Maintainer : sjanssen@cse.unl.edu
-- Stability : unstable -- 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.Map as M
import qualified Data.Set as S 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 ())) }
import Graphics.X11.Xlib hiding (refreshKeyboardMapping) data XConf = XConf
import Graphics.X11.Xlib.Extras { display :: Display -- ^ the X11 display
import Graphics.X11.Xinerama (getScreenInfo) , 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
}
import XMonad -- todo, better name
import XMonad.StackSet (new, floating, member) data XConfig = XConfig
import qualified XMonad.StackSet as W { normalBorderColor :: !String
import XMonad.Operations , 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 ()
}
import System.IO 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
-- | -- |
-- The main entry point -- A wrapped value of some type in the Message class.
-- --
xmonad :: XConfig -> IO () data SomeMessage = forall a. Message a => SomeMessage a
xmonad xmc = do
dpy <- openDisplay ""
let dflt = defaultScreen dpy
rootw <- rootWindow dpy dflt -- |
xinesc <- getScreenInfo dpy -- And now, unwrap a given, unknown Message type, performing a (dynamic)
nbc <- initColor dpy $ normalBorderColor xmc -- type check on the result.
fbc <- initColor dpy $ focusedBorderColor xmc --
hSetBuffering stdout NoBuffering fromMessage :: Message m => SomeMessage -> Maybe m
args <- getArgs fromMessage (SomeMessage m) = cast m
let layout = layoutHook xmc -- | X Events are valid Messages
lreads = readsLayout layout instance Message Event
initialWinset = new layout (workspaces xmc) $ zipWith SD xinesc gaps
maybeRead reads' s = case reads' s of -- | LayoutMessages are core messages that all layouts (especially stateful
[(x, "")] -> Just x -- layouts) should consider handling.
_ -> Nothing data LayoutMessages = Hide -- ^ sent when a layout becomes non-visible
| ReleaseResources -- ^ sent when xmonad is exiting or restarting
deriving (Typeable, Eq)
winset = fromMaybe initialWinset $ do instance Message LayoutMessages
("--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) -- ---------------------------------------------------------------------
-- | General utilities
--
-- Lift an IO action into the X monad
io :: IO a -> X a
io = liftIO
cf = XConf -- | Lift an IO action into the X monad. If the action results in an IO
{ display = dpy -- exception, log the exception to stderr and continue normal execution.
, config = xmc catchIO :: IO () -> X ()
, theRoot = rootw catchIO f = liftIO (f `catch` \e -> hPrint stderr e >> hFlush stderr)
, 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)
-- | 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 () return ()
where forever_ a = a >> forever_ a
-- | Restart xmonad via exec().
-- ---------------------------------------------------------------------
-- | 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: -- 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.
-- --
-- [ButtonPress] = buttonpress, -- When the second parameter is 'True', xmonad will attempt to resume with the
-- [Expose] = expose, -- current window state.
-- [PropertyNotify] = propertynotify, restart :: Maybe String -> Bool -> X ()
-- restart mprog resume = do
handle :: Event -> X () 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 window manager command -- | Run a side effecting action with the current workspace. Like 'when' but
handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) whenJust :: Maybe a -> (a -> X ()) -> X ()
| t == keyPress = withDisplay $ \dpy -> do whenJust mg f = maybe (return ()) f mg
s <- io $ keycodeToKeysym dpy code 0
mClean <- cleanMask m
ks <- asks keyActions
userCode $ whenJust (M.lookup (mClean, s) ks) id
-- manage a new window -- | Conditionally run an action, using a X event to decide
handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do whenX :: X Bool -> X () -> X ()
wa <- io $ getWindowAttributes dpy w -- ignore override windows whenX a f = a >>= \b -> when b f
-- 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 -- | A 'trace' for the X monad. Logs a string to stderr. The result may
-- window gone, unmanage it -- be found in your .xsession-errors file
handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w trace :: String -> X ()
trace msg = io $! do hPutStrLn stderr msg; hFlush stderr
-- 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)

View File

@ -19,7 +19,7 @@ module XMonad.Layouts (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(.
Full(..), Tall(..), Mirror(..), mirrorRect, splitVertically, Full(..), Tall(..), Mirror(..), mirrorRect, splitVertically,
splitHorizontally, splitHorizontallyBy, splitVerticallyBy) where splitHorizontally, splitHorizontallyBy, splitVerticallyBy) where
import XMonad import XMonad.Core
import Graphics.X11 (Rectangle(..)) import Graphics.X11 (Rectangle(..))
import qualified XMonad.StackSet as W import qualified XMonad.StackSet as W

277
XMonad/Main.hs Normal file
View File

@ -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)

View File

@ -18,7 +18,7 @@
module XMonad.Operations where module XMonad.Operations where
import XMonad import XMonad.Core
import XMonad.Layouts (Full(..)) import XMonad.Layouts (Full(..))
import qualified XMonad.StackSet as W import qualified XMonad.StackSet as W

View File

@ -26,8 +26,9 @@ flag small_base
library library
exposed-modules: XMonad exposed-modules: XMonad
XMonad.Config XMonad.Main
XMonad.Core XMonad.Core
XMonad.Config
XMonad.Layouts XMonad.Layouts
XMonad.Operations XMonad.Operations
XMonad.StackSet XMonad.StackSet
@ -45,6 +46,6 @@ library
executable xmonad executable xmonad
main-is: Main.hs 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-options: -funbox-strict-fields -Wall -Werror -optl-Wl,-s
ghc-prof-options: -prof -auto-all ghc-prof-options: -prof -auto-all