From eb5addb90f58ed0aa7e6f504fa2c960dd8228b1e Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Wed, 11 Sep 2013 19:14:25 +0200 Subject: Rename XMonad to MetaTile --- MetaTile/Core.hs | 574 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 574 insertions(+) create mode 100644 MetaTile/Core.hs (limited to 'MetaTile/Core.hs') 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 () -- cgit v1.2.3