diff options
Diffstat (limited to 'XMonad/Core.hs')
| -rw-r--r-- | XMonad/Core.hs | 574 |
1 files changed, 0 insertions, 574 deletions
diff --git a/XMonad/Core.hs b/XMonad/Core.hs deleted file mode 100644 index 18ca213..0000000 --- a/XMonad/Core.hs +++ /dev/null @@ -1,574 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, PatternGuards, - MultiParamTypeClasses, TypeSynonymInstances, CPP, DeriveDataTypeable #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonad.Core --- Copyright : (c) Spencer Janssen 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : spencerjanssen@gmail.com --- 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.Core ( - X, WindowSet, WindowSpace, WorkspaceId, BorderWidth(..), WindowState(..), - ScreenId(..), ScreenDetail(..), XState(..), - XConf(..), XConfig(..), LayoutClass(..), - Layout(..), readsLayout, Typeable, Message, - SomeMessage(..), fromMessage, LayoutMessages(..), - StateExtension(..), ExtensionClass(..), - runX, catchX, userCode, userCodeDef, io, catchIO, installSignalHandlers, uninstallSignalHandlers, - withDisplay, withWindowSet, isRoot, runOnWorkspaces, getWindowState, getsWindowState, setWindowState, modifyWindowState, - getAtom, spawn, spawnPID, xfork, getXMonadDir, recompile, trace, whenJust, whenX, - atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_TAKE_FOCUS, ManageHook, Query(..), runQuery - ) where - -import XMonad.StackSet hiding (modify) - -import Prelude hiding ( catch ) -import Codec.Binary.UTF8.String (encodeString) -import Control.Exception.Extensible (catch, fromException, try, bracket, throw, finally, SomeException(..)) -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Monad.State -import Control.Monad.Reader -import Data.Default -import Data.Function (on) -import System.FilePath -import System.IO -import System.Info -import System.Posix.Process (executeFile, forkProcess, getAnyProcessStatus, createSession) -import System.Posix.Signals -import System.Posix.IO -import System.Posix.Types (ProcessID) -import System.Process -import System.Directory -import System.Exit -import Graphics.X11.Xlib hiding (Screen) -import Graphics.X11.Xlib.Extras (Event, none) -import Data.Typeable -import Data.List ((\\)) -import Data.Maybe (isJust,fromMaybe) -import Data.Monoid - -import qualified Data.Map as M - - -data BorderWidth = BorderWidth - { bwTop :: !Dimension - , bwRight :: !Dimension - , bwBottom :: !Dimension - , bwLeft :: !Dimension - } deriving Show - -data WindowState = WindowState - { wsMapped :: !Bool - , wsWaitingUnmap :: !Int -- ^ the number of expected UnmapEvents - , wsFrame :: !Window - , wsBorderWidth :: !BorderWidth - } deriving Show - -instance Eq WindowState where - (==) = (==) `on` (wsMapped &&& wsWaitingUnmap &&& wsFrame) - - --- | XState, the (mutable) window manager state. -data XState = XState - { windowset :: !WindowSet -- ^ workspace list - , windowState :: !(M.Map Window WindowState) -- ^ the extended window state - , dragging :: !(Maybe (Position -> Position -> X (), X ())) - , numberlockMask :: !KeyMask -- ^ The numlock modifier - , extensibleState :: !(M.Map String (Either String StateExtension)) - -- ^ stores custom state information. - -- - -- The module "XMonad.Utils.ExtensibleState" in xmonad-contrib - -- provides additional information and a simple interface for using this. - } - --- | XConf, the (read-only) window manager configuration. -data XConf = XConf - { display :: Display -- ^ the X11 display - , config :: !(XConfig Layout) -- ^ 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 - , mouseFocused :: !Bool -- ^ was refocus caused by mouse action? - , mousePosition :: !(Maybe (Position, Position)) - -- ^ position of the mouse according to - -- the event currently being processed - , currentEvent :: !(Maybe Event) - -- ^ event currently being processed - } - --- todo, better name -data XConfig l = XConfig - { normalBorderColor :: !String -- ^ Non focused windows border color. Default: \"#dddddd\" - , focusedBorderColor :: !String -- ^ Focused windows border color. Default: \"#ff0000\" - , defaultBorderWidth :: !BorderWidth - , terminal :: !String -- ^ The preferred terminal application. Default: \"xterm\" - , layoutHook :: !(l Window) -- ^ The available layouts - , manageHook :: !ManageHook -- ^ The action to run when a new window is opened - , handleEventHook :: !(Event -> X All) -- ^ Handle an X event, returns (All True) if the default handler - -- should also be run afterwards. mappend should be used for combining - -- event hooks in most cases. - , workspaces :: ![String] -- ^ The list of workspaces' names - , modMask :: !KeyMask -- ^ the mod modifier - , keys :: !(XConfig Layout -> M.Map (ButtonMask,KeySym) (X ())) - -- ^ The key binding: a map from key presses and actions - , mouseBindings :: !(XConfig Layout -> M.Map (ButtonMask, Button) (Window -> X ())) - -- ^ The mouse bindings - , logHook :: !(X ()) -- ^ The action to perform when the windows set is changed - , startupHook :: !(X ()) -- ^ The action to perform on startup - , focusFollowsMouse :: !Bool -- ^ Whether window entry events can change focus - , clickJustFocuses :: !Bool -- ^ False to make a click which changes focus to be additionally passed to the window - , clientMask :: !EventMask -- ^ The client events that xmonad is interested in - , frameMask :: !EventMask -- ^ The frame events that xmonad is interested in - , rootMask :: !EventMask -- ^ The root events that xmonad is interested in - } - - -type WindowSet = StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail -type WindowSpace = Workspace WorkspaceId (Layout Window) Window - --- | Virtual workspace indices -type WorkspaceId = String - --- | Physical screen indices -newtype ScreenId = S Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real) - --- | The 'Rectangle' with screen dimensions -data ScreenDetail = SD { screenRect :: !Rectangle } deriving (Eq,Show, Read) - ------------------------------------------------------------------------- - --- | The X monad, 'ReaderT' and 'StateT' transformers over 'IO' --- encapsulating the window manager configuration and state, --- respectively. --- --- 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, Typeable) - -instance Applicative X where - pure = return - (<*>) = ap - -instance (Monoid a) => Monoid (X a) where - mempty = return mempty - mappend = liftM2 mappend - -instance Default a => Default (X a) where - def = return def - -type ManageHook = Query (Endo WindowSet) -newtype Query a = Query (ReaderT Window X a) - deriving (Functor, Monad, MonadReader Window, MonadIO) - -runQuery :: Query a -> Window -> X a -runQuery (Query m) w = runReaderT m w - -instance Monoid a => Monoid (Query a) where - mempty = return mempty - mappend = liftM2 mappend - -instance Default a => Default (Query a) where - def = return def - --- | 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 fromException e of - Just x -> throw e `const` (x `asTypeOf` ExitSuccess) - _ -> 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 a -> X (Maybe a) -userCode a = catchX (Just `liftM` a) (return Nothing) - --- | Same as userCode but with a default argument to return instead of using --- Maybe, provided for convenience. -userCodeDef :: a -> X a -> X a -userCodeDef defValue a = fromMaybe defValue `liftM` userCode a - --- --------------------------------------------------------------------- --- 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 = (w==) <$> asks theRoot - --- | Wrapper for the common case of atom internment -getAtom :: String -> X Atom -getAtom str = withDisplay $ \dpy -> io $ internAtom dpy str False - -emptyWindowState :: X WindowState -emptyWindowState = asks (defaultBorderWidth . config) >>= return . WindowState False 0 none - -getWindowState :: Window -> X WindowState -getWindowState w = do - ws <- gets $ (M.lookup w) . windowState - case ws of - Just s -> return s - Nothing -> emptyWindowState - -getsWindowState :: (WindowState -> a) -> Window -> X a -getsWindowState f w = f <$> getWindowState w - -setWindowState :: Window -> WindowState -> X () -setWindowState w ws = do - emptyState <- emptyWindowState - let f | ws == emptyState = M.delete w - | otherwise = M.insert w ws - modify $ \s -> s { windowState = f (windowState s) } - -modifyWindowState :: (WindowState -> WindowState) -> Window -> X () -modifyWindowState f w = getWindowState w >>= return . f >>= setWindowState w - --- | Common non-predefined atoms -atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_STATE, atom_WM_TAKE_FOCUS :: X Atom -atom_WM_PROTOCOLS = getAtom "WM_PROTOCOLS" -atom_WM_DELETE_WINDOW = getAtom "WM_DELETE_WINDOW" -atom_WM_STATE = getAtom "WM_STATE" -atom_WM_TAKE_FOCUS = getAtom "WM_TAKE_FOCUS" - ------------------------------------------------------------------------- --- 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] - --- | Every layout must be an instance of 'LayoutClass', which defines --- the basic layout operations along with a sensible default for each. --- --- Minimal complete definition: --- --- * 'runLayout' || (('doLayout' || 'pureLayout') && 'emptyLayout'), and --- --- * 'handleMessage' || 'pureMessage' --- --- You should also strongly consider implementing 'description', --- although it is not required. --- --- Note that any code which /uses/ 'LayoutClass' methods should only --- ever call 'runLayout', 'handleMessage', and 'description'! In --- other words, the only calls to 'doLayout', 'pureMessage', and other --- such methods should be from the default implementations of --- 'runLayout', 'handleMessage', and so on. This ensures that the --- proper methods will be used, regardless of the particular methods --- that any 'LayoutClass' instance chooses to define. -class Show (layout a) => LayoutClass layout a where - - -- | By default, 'runLayout' calls 'doLayout' if there are any - -- windows to be laid out, and 'emptyLayout' otherwise. Most - -- instances of 'LayoutClass' probably do not need to implement - -- 'runLayout'; it is only useful for layouts which wish to make - -- use of more of the 'Workspace' information (for example, - -- "XMonad.Layout.PerWorkspace"). - runLayout :: Workspace WorkspaceId (layout a) a - -> Rectangle - -> X ([(a, Rectangle)], Maybe (layout a)) - runLayout (Workspace _ l ms) r = maybe (emptyLayout l r) (doLayout l r) ms - - -- | Given a 'Rectangle' in which to place the windows, and a 'Stack' - -- of windows, return a list of windows and their corresponding - -- Rectangles. If an element is not given a Rectangle by - -- 'doLayout', then it is not shown on screen. The order of - -- windows in this list should be the desired stacking order. - -- - -- Also possibly return a modified layout (by returning @Just - -- newLayout@), if this layout needs to be modified (e.g. if it - -- keeps track of some sort of state). Return @Nothing@ if the - -- layout does not need to be modified. - -- - -- Layouts which do not need access to the 'X' monad ('IO', window - -- manager state, or configuration) and do not keep track of their - -- own state should implement 'pureLayout' instead of 'doLayout'. - 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 lay out - -- the windows, and we don't need to modify the layout itself. - pureLayout :: layout a -> Rectangle -> Stack a -> [(a, Rectangle)] - pureLayout _ r s = [(focus s, r)] - - -- | 'emptyLayout' is called when there are no windows. - emptyLayout :: layout a -> Rectangle -> X ([(a, Rectangle)], Maybe (layout a)) - emptyLayout _ _ = return ([], Nothing) - - -- | 'handleMessage' performs message handling. If - -- 'handleMessage' returns @Nothing@, then the layout did not - -- respond to the message and the screen is not refreshed. - -- Otherwise, 'handleMessage' returns an updated layout and the - -- screen is refreshed. - -- - -- Layouts which do not need access to the 'X' monad to decide how - -- to handle messages should implement 'pureMessage' instead of - -- 'handleMessage' (this restricts the risk of error, and makes - -- testing much easier). - 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. The default implementation is - -- 'show', which is in some cases a poor default. - description :: layout a -> String - description = show - -instance LayoutClass Layout Window where - runLayout (Workspace i (Layout l) ms) r = fmap (fmap Layout) `fmap` runLayout (Workspace i l ms) r - doLayout (Layout l) r s = fmap (fmap Layout) `fmap` doLayout l r s - emptyLayout (Layout l) r = fmap (fmap Layout) `fmap` emptyLayout l r - handleMessage (Layout l) = fmap (fmap Layout) . handleMessage l - description (Layout l) = description l - -instance Show (Layout a) where show (Layout l) = show l - --- | 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 - --- --------------------------------------------------------------------- --- Extensible state --- - --- | Every module must make the data it wants to store --- an instance of this class. --- --- Minimal complete definition: initialValue -class Typeable a => ExtensionClass a where - -- | Defines an initial value for the state extension - initialValue :: a - -- | Specifies whether the state extension should be - -- persistent. Setting this method to 'PersistentExtension' - -- will make the stored data survive restarts, but - -- requires a to be an instance of Read and Show. - -- - -- It defaults to 'StateExtension', i.e. no persistence. - extensionType :: a -> StateExtension - extensionType = StateExtension - --- | Existential type to store a state extension. -data StateExtension = - forall a. ExtensionClass a => StateExtension a - -- ^ Non-persistent state extension - | forall a. (Read a, Show a, ExtensionClass a) => PersistentExtension a - -- ^ Persistent extension - --- --------------------------------------------------------------------- --- | General utilities --- --- Lift an 'IO' action into the 'X' monad -io :: MonadIO m => IO a -> m 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 :: MonadIO m => IO () -> m () -catchIO f = io (f `catch` \(SomeException e) -> hPrint stderr e >> hFlush stderr) - --- | spawn. Launch an external application. Specifically, it double-forks and --- runs the 'String' you pass as a command to \/bin\/sh. --- --- Note this function assumes your locale uses utf8. -spawn :: MonadIO m => String -> m () -spawn x = spawnPID x >> return () - --- | Like 'spawn', but returns the 'ProcessID' of the launched application -spawnPID :: MonadIO m => String -> m ProcessID -spawnPID x = xfork $ executeFile "/bin/sh" False ["-c", encodeString x] Nothing - --- | A replacement for 'forkProcess' which resets default signal handlers. -xfork :: MonadIO m => IO () -> m ProcessID -xfork x = io . forkProcess . finally nullStdin $ do - uninstallSignalHandlers - createSession - x - where - nullStdin = do - fd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags - dupTo fd stdInput - closeFd fd - --- | This is basically a map function, running a function in the 'X' monad on --- each workspace with the output of that function being the modified workspace. -runOnWorkspaces :: (WindowSpace -> X WindowSpace) -> X () -runOnWorkspaces job = do - ws <- gets windowset - c:v <- mapM runOnScreen $ current ws : visible ws - modify $ \s -> s { windowset = ws { current = c, visible = v } } - where - runOnScreen scr@Screen { screenWorkspace = w, screenHidden = ws } = do - w':ws' <- mapM job (w:ws) - return scr { screenWorkspace = w', screenHidden = ws' } - --- | Return the path to @~\/.xmonad@. -getXMonadDir :: MonadIO m => m String -getXMonadDir = io $ getAppUserDataDirectory "xmonad" - --- | 'recompile force', recompile @~\/.xmonad\/xmonad.hs@ when any of the --- following apply: --- --- * force is 'True' --- --- * the xmonad executable does not exist --- --- * the xmonad executable is older than xmonad.hs or any file in --- ~\/.xmonad\/lib --- --- The -i flag is used to restrict recompilation to the xmonad.hs file only, --- and any files in the ~\/.xmonad\/lib directory. --- --- Compilation errors (if any) are logged to ~\/.xmonad\/xmonad.errors. If --- GHC indicates failure with a non-zero exit code, an xmessage displaying --- that file is spawned. --- --- 'False' is returned if there are compilation errors. --- -recompile :: MonadIO m => Bool -> m Bool -recompile force = io $ do - dir <- getXMonadDir - let binn = "xmonad-"++arch++"-"++os - bin = dir </> binn - base = dir </> "xmonad" - err = base ++ ".errors" - src = base ++ ".hs" - lib = dir </> "lib" - libTs <- mapM getModTime . Prelude.filter isSource =<< allFiles lib - srcT <- getModTime src - binT <- getModTime bin - if force || any (binT <) (srcT : libTs) - then do - -- temporarily disable SIGCHLD ignoring: - uninstallSignalHandlers - status <- bracket (openFile err WriteMode) hClose $ \h -> - waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-ilib", "-fforce-recomp", "-main-is", "main", "-v0", "-o",binn] (Just dir) - Nothing Nothing Nothing (Just h) - - -- re-enable SIGCHLD: - installSignalHandlers - - -- now, if it fails, run xmessage to let the user know: - when (status /= ExitSuccess) $ do - ghcErr <- readFile err - let msg = unlines $ - ["Error detected while loading xmonad configuration file: " ++ src] - ++ lines (if null ghcErr then show status else ghcErr) - ++ ["","Please check the file for errors."] - -- nb, the ordering of printing, then forking, is crucial due to - -- lazy evaluation - hPutStrLn stderr msg - forkProcess $ executeFile "xmessage" True ["-default", "okay", msg] Nothing - return () - return (status == ExitSuccess) - else return True - where getModTime f = catch (Just <$> getModificationTime f) (\(SomeException _) -> return Nothing) - isSource = flip elem [".hs",".lhs",".hsc"] . takeExtension - allFiles t = do - let prep = map (t</>) . Prelude.filter (`notElem` [".",".."]) - cs <- prep <$> catch (getDirectoryContents t) (\(SomeException _) -> return []) - ds <- filterM doesDirectoryExist cs - concat . ((cs \\ ds):) <$> mapM allFiles ds - --- | Conditionally run an action, using a @Maybe a@ to decide. -whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () -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 :: MonadIO m => String -> m () -trace = io . hPutStrLn stderr - --- | Ignore SIGPIPE to avoid termination when a pipe is full, and SIGCHLD to --- avoid zombie processes, and clean up any extant zombie processes. -installSignalHandlers :: MonadIO m => m () -installSignalHandlers = io $ do - installHandler openEndedPipe Ignore Nothing - installHandler sigCHLD Ignore Nothing - (try :: IO a -> IO (Either SomeException a)) - $ fix $ \more -> do - x <- getAnyProcessStatus False False - when (isJust x) more - return () - -uninstallSignalHandlers :: MonadIO m => m () -uninstallSignalHandlers = io $ do - installHandler openEndedPipe Default Nothing - installHandler sigCHLD Default Nothing - return () |