module XMonad.Core (
X, WindowSet, WindowSpace, WorkspaceId,
ScreenId(..), ScreenDetail(..), XState(..),
XConf(..), XConfig(..), LayoutClass(..),
Layout(..), readsLayout, Typeable, Message,
SomeMessage(..), fromMessage, LayoutMessages(..),
runX, catchX, userCode, userCodeDef, io, catchIO, installSignalHandlers, uninstallSignalHandlers,
withDisplay, withWindowSet, modifyPosStore, isRoot, runOnWorkspaces,
getAtom, spawn, spawnPID, getXMonadDir, recompile, trace, whenJust, whenX,
atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, ManageHook, Query(..), runQuery
) where
import XMonad.StackSet hiding (modify)
import XMonad.PositionStore
import Prelude hiding ( catch )
import Control.Exception (catch, try, bracket, throw, finally, Exception(ExitException))
import Control.Applicative
import Control.Monad.State
import Control.Monad.Reader
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
import Graphics.X11.Xlib.Extras (Event)
import Data.Typeable
import Data.List ((\\))
import Data.Maybe (isJust)
import Data.Monoid
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import qualified Data.Set as S
data XState = XState
{ windowset :: !WindowSet
, positionStore :: !(PositionStore Window)
, 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 ()))
, mouseFocused :: !Bool
, mousePosition :: !(Maybe (Position, Position))
}
data XConfig l = XConfig
{ normalBorderColor :: !String
, focusedBorderColor :: !String
, terminal :: !String
, layoutHook :: !(l Window)
, manageHook :: !ManageHook
, handleEventHook :: !(Event -> X All)
, workspaces :: ![String]
, 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 ())
, startupHook :: !(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 } deriving (Eq,Show, Read)
newtype X a = X (ReaderT XConf (StateT XState IO) a)
#ifndef __HADDOCK__
deriving (Functor, Monad, MonadIO, MonadState XState, MonadReader XConf, Typeable)
#endif
instance Applicative X where
pure = return
(<*>) = ap
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
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
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 a -> X (Maybe a)
userCode a = catchX (Just `liftM` a) (return Nothing)
userCodeDef :: a -> X a -> X a
userCodeDef def a = fromMaybe def `liftM` userCode a
withDisplay :: (Display -> X a) -> X a
withDisplay f = asks display >>= f
withWindowSet :: (WindowSet -> X a) -> X a
withWindowSet f = gets windowset >>= f
modifyPosStore :: (PositionStore Window -> PositionStore Window) -> X ()
modifyPosStore f = do
XState { positionStore = posStore } <- get
modify (\s -> s { positionStore = f posStore } )
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
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
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)]
emptyLayout :: layout a -> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
emptyLayout _ _ = return ([], Nothing)
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
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
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 :: MonadIO m => IO () -> m ()
catchIO f = io (f `catch` \e -> hPrint stderr e >> hFlush stderr)
spawn :: MonadIO m => String -> m ()
spawn x = spawnPID x >> return ()
spawnPID :: MonadIO m => String -> m ProcessID
spawnPID x = io . forkProcess . finally nullStdin $ do
uninstallSignalHandlers
createSession
executeFile "/bin/sh" False ["-c", x] Nothing
where
nullStdin = do
fd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
dupTo fd stdInput
closeFd fd
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 } }
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"
lib = dir </> "lib"
libTs <- mapM getModTime . Prelude.filter isSource =<< allFiles lib
srcT <- getModTime src
binT <- getModTime bin
if (force || srcT > binT || any (binT<) libTs)
then do
uninstallSignalHandlers
status <- bracket (openFile err WriteMode) hClose $ \h -> do
waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-ilib", "-fforce-recomp", "-v0", "-o",binn] (Just dir)
Nothing Nothing Nothing (Just h)
installSignalHandlers
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."]
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) (const $ return Nothing)
isSource = flip elem [".hs",".lhs",".hsc"]
allFiles t = do
let prep = map (t</>) . Prelude.filter (`notElem` [".",".."])
cs <- prep <$> catch (getDirectoryContents t) (\_ -> return [])
ds <- filterM doesDirectoryExist cs
concat . ((cs \\ ds):) <$> mapM allFiles ds
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
installSignalHandlers :: MonadIO m => m ()
installSignalHandlers = io $ do
installHandler openEndedPipe Ignore Nothing
installHandler sigCHLD Ignore Nothing
try $ fix $ \more -> do
x <- getAnyProcessStatus False False
when (isJust x) more
return ()
uninstallSignalHandlers :: MonadIO m => m ()
uninstallSignalHandlers = io $ do
installHandler sigCHLD Default Nothing
return ()