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, getXMonadDir, recompile, trace, whenJust, whenX,
atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, ManageHook, Query(..), runManageHook
) where
import XMonad.StackSet
import Prelude hiding ( catch )
import Control.Exception (catch, bracket, throw, Exception(ExitException))
import Control.Applicative
import Control.Monad.State
import Control.Monad.Reader
import System.IO
import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession)
import System.Process
import System.Directory
import System.Exit
import System.Environment
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras (Event)
import Data.Typeable
import Data.Monoid
import qualified Data.Map as M
import qualified Data.Set as S
data XState = XState
{ windowset :: !WindowSet
, mapped :: !(S.Set Window)
, waitingUnmap :: !(M.Map Window Int)
, dragging :: !(Maybe (Position -> Position -> X (), X ())) }
data XConf = XConf
{ display :: Display
, config :: !(XConfig Layout)
, theRoot :: !Window
, normalBorder :: !Pixel
, focusedBorder :: !Pixel
, keyActions :: !(M.Map (KeyMask, KeySym) (X ()))
, buttonActions :: !(M.Map (KeyMask, Button) (Window -> X ()))
}
data XConfig l = XConfig
{ normalBorderColor :: !String
, focusedBorderColor :: !String
, terminal :: !String
, layoutHook :: !(l Window)
, manageHook :: !ManageHook
, workspaces :: [String]
, defaultGaps :: [(Int,Int,Int,Int)]
, numlockMask :: !KeyMask
, modMask :: !KeyMask
, keys :: XConfig Layout -> M.Map (ButtonMask,KeySym) (X ())
, mouseBindings :: XConfig Layout -> 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
type WorkspaceId = String
newtype ScreenId = S Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real)
data ScreenDetail = SD { screenRect :: !Rectangle
, statusGap :: !(Int,Int,Int,Int)
} deriving (Eq,Show, Read)
newtype X a = X (ReaderT XConf (StateT XState IO) a)
#ifndef __HADDOCK__
deriving (Functor, Monad, MonadIO, MonadState XState, MonadReader XConf)
#endif
instance (Monoid a) => Monoid (X a) where
mempty = return mempty
mappend = liftM2 mappend
type ManageHook = Query (Endo WindowSet)
newtype Query a = Query (ReaderT Window X a)
#ifndef __HADDOCK__
deriving (Functor, Monad, MonadReader Window, MonadIO)
#endif
runManageHook :: ManageHook -> Window -> X (WindowSet -> WindowSet)
runManageHook (Query m) w = appEndo <$> runReaderT m w
instance Monoid a => Monoid (Query a) where
mempty = return mempty
mappend = liftM2 mappend
runX :: XConf -> XState -> X a -> IO (a, XState)
runX c st (X a) = runStateT (runReaderT a c) st
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
userCode :: X () -> X ()
userCode a = catchX (a >> return ()) (return ())
withDisplay :: (Display -> X a) -> X a
withDisplay f = asks display >>= f
withWindowSet :: (WindowSet -> X a) -> X a
withWindowSet f = gets windowset >>= f
isRoot :: Window -> X Bool
isRoot w = (w==) <$> asks theRoot
getAtom :: String -> X Atom
getAtom str = withDisplay $ \dpy -> io $ internAtom dpy str False
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"
data Layout a = forall l. (LayoutClass l a, Read (l a)) => Layout (l a)
readsLayout :: Layout a -> String -> [(Layout a, String)]
readsLayout (Layout l) s = [(Layout (asTypeOf x l), rs) | (x, rs) <- reads s]
class Show (layout a) => LayoutClass layout a where
doLayout :: layout a -> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (layout a))
doLayout l r s = return (pureLayout l r s, Nothing)
pureLayout :: layout a -> Rectangle -> Stack a -> [(a, Rectangle)]
pureLayout _ r s = [(focus s, r)]
handleMessage :: layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l = return . pureMessage l
pureMessage :: layout a -> SomeMessage -> Maybe (layout a)
pureMessage _ _ = Nothing
description :: layout a -> String
description = show
instance LayoutClass Layout Window where
doLayout (Layout l) r s = fmap (fmap Layout) `fmap` 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
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)
class Typeable a => Message a
data SomeMessage = forall a. Message a => SomeMessage a
fromMessage :: Message m => SomeMessage -> Maybe m
fromMessage (SomeMessage m) = cast m
instance Message Event
data LayoutMessages = Hide
| ReleaseResources
deriving (Typeable, Eq)
instance Message LayoutMessages
io :: MonadIO m => IO a -> m a
io = liftIO
catchIO :: IO () -> X ()
catchIO f = io (f `catch` \e -> hPrint stderr e >> hFlush stderr)
spawn :: MonadIO m => String -> m ()
spawn x = doubleFork $ executeFile "/bin/sh" False ["-c", x] Nothing
doubleFork :: MonadIO m => IO () -> m ()
doubleFork m = io $ do
pid <- forkProcess $ do
forkProcess (createSession >> m)
exitWith ExitSuccess
getProcessStatus True False pid
return ()
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
getXMonadDir :: MonadIO m => m String
getXMonadDir = io $ getAppUserDataDirectory "xmonad"
recompile :: MonadIO m => Bool -> m ()
recompile force = io $ do
dir <- getXMonadDir
let bin = dir ++ "/" ++ "xmonad"
err = bin ++ ".errors"
src = bin ++ ".hs"
srcT <- getModTime src
binT <- getModTime bin
when (force || srcT > binT) $ do
status <- bracket (openFile err WriteMode) hClose $ \h -> do
waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-no-recomp", "-v0"] (Just dir)
Nothing Nothing Nothing (Just h)
when (status /= ExitSuccess) $ do
ghcErr <- readFile err
let msg = unlines $
["Error detected while loading xmonad configuration file: " ++ src]
++ lines ghcErr ++ ["","Please check the file for errors."]
doubleFork $ executeFile "xmessage" True [msg] Nothing
where getModTime f = catch (Just <$> getModificationTime f) (const $ return Nothing)
whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust mg f = maybe (return ()) f mg
whenX :: X Bool -> X () -> X ()
whenX a f = a >>= \b -> when b f
trace :: MonadIO m => String -> m ()
trace = io . hPutStrLn stderr