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, doubleFork,
withDisplay, withWindowSet, isRoot, runOnWorkspaces, broadcastMessage,
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 hiding (modify)
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.Info
import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession)
import System.Process
import System.Directory
import System.Exit
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 ())
, focusFollowsMouse :: !Bool
}
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 ()
broadcastMessage :: Message a => a -> X ()
broadcastMessage a = runOnWorkspaces $ \w -> do
ml' <- handleMessage (layout w) (SomeMessage a) `catchX` return Nothing
return $ w { layout = maybe (layout w) id ml' }
runOnWorkspaces :: (WindowSpace -> X WindowSpace) -> X ()
runOnWorkspaces job = do
ws <- gets windowset
h <- mapM job $ hidden ws
c:v <- mapM (\s -> (\w -> s { workspace = w}) <$> job (workspace s))
$ current ws : visible ws
modify $ \s -> s { windowset = ws { current = c, visible = v, hidden = h } }
restart :: String -> Bool -> X ()
restart prog resume = do
broadcastMessage ReleaseResources
io . flush =<< asks display
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 Bool
recompile force = io $ do
dir <- getXMonadDir
let binn = "xmonad-"++arch++"-"++os
bin = dir ++ "/" ++ binn
base = dir ++ "/" ++ "xmonad"
err = base ++ ".errors"
src = base ++ ".hs"
srcT <- getModTime src
binT <- getModTime bin
if (force || srcT > binT)
then do
status <- bracket (openFile err WriteMode) hClose $ \h -> do
waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-no-recomp", "-v0", "-o",binn] (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
return (status == ExitSuccess)
else return True
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