Rename XMonad to MetaTile

1 files changed, 574 insertions, 0 deletions

diff --git a/MetaTile/Core.hs b/MetaTile/Core.hs
new file mode 100644
index 0000000..14c4211
--- /dev/null
+++ b/MetaTile/Core.hs
@@ -0,0 +1,574 @@
+{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, PatternGuards,
+             MultiParamTypeClasses, TypeSynonymInstances, CPP, DeriveDataTypeable #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  MetaTile.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 MetaTile.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, getMetaTileDir, recompile, trace, whenJust, whenX,
+    atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_TAKE_FOCUS, ManageHook, Query(..), runQuery
+  ) where
+
+import MetaTile.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 "MetaTile.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,
+    --   "MetaTile.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 @~\/.metatile@.
+getMetaTileDir :: MonadIO m => m String
+getMetaTileDir = io $ getAppUserDataDirectory "metatile"
+
+-- | 'recompile force', recompile @~\/.metatile\/metatile.hs@ when any of the
+-- following apply:
+--
+--      * force is 'True'
+--
+--      * the metatile executable does not exist
+--
+--      * the metatile executable is older than metatile.hs or any file in
+--        ~\/.metatile\/lib
+--
+-- The -i flag is used to restrict recompilation to the metatile.hs file only,
+-- and any files in the ~\/.metatile\/lib directory.
+--
+-- Compilation errors (if any) are logged to ~\/.metatile\/metatile.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 <- getMetaTileDir
+    let binn = "metatile-"++arch++"-"++os
+        bin  = dir </> binn
+        base = dir </> "metatile"
+        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", "metatile.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 metatile 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 ()