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 --- Main.hs | 32 +-- MetaTile.hs | 47 ++++ MetaTile/Config.hs | 321 +++++++++++++++++++++++++++ MetaTile/Core.hs | 574 +++++++++++++++++++++++++++++++++++++++++++++++ MetaTile/Layout.hs | 210 ++++++++++++++++++ MetaTile/Main.hsc | 433 ++++++++++++++++++++++++++++++++++++ MetaTile/ManageHook.hs | 115 ++++++++++ MetaTile/Operations.hs | 588 +++++++++++++++++++++++++++++++++++++++++++++++++ MetaTile/StackSet.hs | 549 +++++++++++++++++++++++++++++++++++++++++++++ XMonad.hs | 47 ---- XMonad/Config.hs | 321 --------------------------- XMonad/Core.hs | 574 ----------------------------------------------- XMonad/Layout.hs | 210 ------------------ XMonad/Main.hsc | 433 ------------------------------------ XMonad/ManageHook.hs | 115 ---------- XMonad/Operations.hs | 588 ------------------------------------------------- XMonad/StackSet.hs | 549 --------------------------------------------- metatile.cabal | 93 ++++++++ xmonad.cabal | 102 --------- 19 files changed, 2946 insertions(+), 2955 deletions(-) create mode 100644 MetaTile.hs create mode 100644 MetaTile/Config.hs create mode 100644 MetaTile/Core.hs create mode 100644 MetaTile/Layout.hs create mode 100644 MetaTile/Main.hsc create mode 100644 MetaTile/ManageHook.hs create mode 100644 MetaTile/Operations.hs create mode 100644 MetaTile/StackSet.hs delete mode 100644 XMonad.hs delete mode 100644 XMonad/Config.hs delete mode 100644 XMonad/Core.hs delete mode 100644 XMonad/Layout.hs delete mode 100644 XMonad/Main.hsc delete mode 100644 XMonad/ManageHook.hs delete mode 100644 XMonad/Operations.hs delete mode 100644 XMonad/StackSet.hs create mode 100644 metatile.cabal delete mode 100644 xmonad.cabal diff --git a/Main.hs b/Main.hs index 1e634d1..6aba89f 100644 --- a/Main.hs +++ b/Main.hs @@ -8,13 +8,13 @@ -- Stability : unstable -- Portability : not portable, uses mtl, X11, posix -- --- xmonad, a minimalist, tiling window manager for X11 +-- metatile, a minimalist, tiling window manager for X11 -- ----------------------------------------------------------------------------- module Main (main) where -import XMonad +import MetaTile import Control.Monad (unless) import System.Info @@ -22,7 +22,7 @@ import System.Environment import System.Posix.Process (executeFile) import System.Exit (exitFailure) -import Paths_xmonad (version) +import Paths_metatile (version) import Data.Version (showVersion) import Graphics.X11.Xinerama (compiledWithXinerama) @@ -31,13 +31,13 @@ import Graphics.X11.Xinerama (compiledWithXinerama) import qualified Properties #endif --- | The entry point into xmonad. Attempts to compile any custom main --- for xmonad, and if it doesn't find one, just launches the default. +-- | The entry point into metatile. Attempts to compile any custom main +-- for metatile, and if it doesn't find one, just launches the default. main :: IO () main = do installSignalHandlers -- important to ignore SIGCHLD to avoid zombies args <- getArgs - let launch = xmonad def + let launch = metatile def case args of [] -> launch ("--resume":_) -> launch @@ -52,7 +52,7 @@ main = do #endif _ -> fail "unrecognized flags" where - shortVersion = ["xmonad", showVersion version] + shortVersion = ["metatile", showVersion version] longVersion = [ "compiled by", compilerName, showVersion compilerVersion , "for", arch ++ "-" ++ os , "\nXinerama:", show compiledWithXinerama ] @@ -65,36 +65,36 @@ usage = do "Options:" : " --help Print this message" : " --version Print the version number" : - " --recompile Recompile your ~/.xmonad/xmonad.hs" : - " --replace Replace the running window manager with xmonad" : - " --restart Request a running xmonad process to restart" : + " --recompile Recompile your ~/.metatile/metatile.hs" : + " --replace Replace the running window manager with metatile" : + " --restart Request a running metatile process to restart" : #ifdef TESTING " --run-tests Run the test suite" : #endif [] --- | Build "~\/.xmonad\/xmonad.hs" with ghc, then execute it. If there are no +-- | Build "~\/.metatile\/metatile.hs" with ghc, then execute it. If there are no -- errors, this function does not return. An exception is raised in any of -- these cases: -- -- * ghc missing -- --- * both "~\/.xmonad\/xmonad.hs" and "~\/.xmonad\/xmonad-$arch-$os" missing +-- * both "~\/.metatile\/metatile.hs" and "~\/.metatile\/metatile-$arch-$os" missing -- --- * xmonad.hs fails to compile +-- * metatile.hs fails to compile -- -- ** wrong ghc in path (fails to compile) -- -- ** type error, syntax error, .. -- --- * Missing XMonad\/XMonadContrib modules due to ghc upgrade +-- * Missing MetaTile\/MetaTileContrib modules due to ghc upgrade -- buildLaunch :: IO () buildLaunch = do recompile False - dir <- getXMonadDir + dir <- getMetaTileDir args <- getArgs - executeFile (dir ++ "/xmonad-"++arch++"-"++os) False args Nothing + executeFile (dir ++ "/metatile-"++arch++"-"++os) False args Nothing return () sendRestart :: IO () diff --git a/MetaTile.hs b/MetaTile.hs new file mode 100644 index 0000000..9da613e --- /dev/null +++ b/MetaTile.hs @@ -0,0 +1,47 @@ +-------------------------------------------------------------------- +-- | +-- Module : MetaTile +-- Copyright : (c) Don Stewart +-- License : BSD3 +-- +-- Maintainer: Don Stewart +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- +-- +-- Useful exports for configuration files. + +module MetaTile ( + + module MetaTile.Main, + module MetaTile.Core, + module MetaTile.Config, + module MetaTile.Layout, + module MetaTile.ManageHook, + module MetaTile.Operations, + module Graphics.X11, + module Graphics.X11.Xlib.Extras, + (.|.), + MonadState(..), gets, modify, + MonadReader(..), asks, + MonadIO(..) + + ) where + +-- core modules +import MetaTile.Main +import MetaTile.Core +import MetaTile.Config +import MetaTile.Layout +import MetaTile.ManageHook +import MetaTile.Operations +-- import MetaTile.StackSet -- conflicts with 'workspaces' defined in MetaTile.hs + +-- modules needed to get basic configuration working +import Data.Bits +import Graphics.X11 hiding (refreshKeyboardMapping) +import Graphics.X11.Xlib.Extras + +import Control.Monad.State +import Control.Monad.Reader diff --git a/MetaTile/Config.hs b/MetaTile/Config.hs new file mode 100644 index 0000000..71706d8 --- /dev/null +++ b/MetaTile/Config.hs @@ -0,0 +1,321 @@ +{-# OPTIONS -fno-warn-missing-signatures -fno-warn-orphans #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : MetaTile.Config +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : dons@galois.com +-- Stability : stable +-- Portability : portable +-- +-- This module specifies the default configuration values for xmonad. +-- +-- DO NOT MODIFY THIS FILE! It won't work. You may configure xmonad +-- by providing your own @~\/.metatile\/metatile.hs@ that overrides +-- specific fields in the default config, 'def'. For a starting point, you can +-- copy the @metatile.hs@ found in the @man@ directory, or look at +-- examples on the xmonad wiki. +-- +------------------------------------------------------------------------ + +module MetaTile.Config (defaultConfig, Default(..)) where + +-- +-- Useful imports +-- +import MetaTile.Core as MetaTile hiding + (workspaces,manageHook,keys,logHook,startupHook,mouseBindings + ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,defaultBorderWidth,focusFollowsMouse + ,handleEventHook,clickJustFocuses,rootMask,frameMask,clientMask) +import qualified MetaTile.Core as MetaTile + (workspaces,manageHook,keys,logHook,startupHook,mouseBindings + ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,defaultBorderWidth,focusFollowsMouse + ,handleEventHook,clickJustFocuses,rootMask,frameMask,clientMask) + +import MetaTile.Layout +import MetaTile.Operations +import qualified MetaTile.StackSet as W +import Data.Bits ((.|.)) +import Data.Default +import Data.Monoid +import qualified Data.Map as M +import System.Exit +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +-- | The default number of workspaces (virtual screens) and their names. +-- By default we use numeric strings, but any string may be used as a +-- workspace name. The number of workspaces is determined by the length +-- of this list. +-- +-- A tagging example: +-- +-- > workspaces = ["web", "irc", "code" ] ++ map show [4..9] +-- +workspaces :: [WorkspaceId] +workspaces = map show [1 .. 9 :: Int] + +-- | modMask lets you specify which modkey you want to use. The default +-- is mod1Mask ("left alt"). You may also consider using mod3Mask +-- ("right alt"), which does not conflict with emacs keybindings. The +-- "windows key" is usually mod4Mask. +-- +defaultModMask :: KeyMask +defaultModMask = mod1Mask + +-- | Border colors for unfocused and focused windows, respectively. +-- +normalBorderColor, focusedBorderColor :: String +normalBorderColor = "gray" -- "#dddddd" +focusedBorderColor = "red" -- "#ff0000" don't use hex, not <24 bit safe + +defaultBorderWidth :: BorderWidth +defaultBorderWidth = BorderWidth 1 1 1 1 + +------------------------------------------------------------------------ +-- Window rules + +-- | Execute arbitrary actions and WindowSet manipulations when managing +-- a new window. You can use this to, for example, always float a +-- particular program, or have a client always appear on a particular +-- workspace. +-- +-- To find the property name associated with a program, use +-- xprop | grep WM_CLASS +-- and click on the client you're interested in. +-- +manageHook :: ManageHook +manageHook = mempty + +------------------------------------------------------------------------ +-- Logging + +-- | Perform an arbitrary action on each internal state change or X event. +-- Examples include: +-- +-- * do nothing +-- +-- * log the state to stdout +-- +-- See the 'DynamicLog' extension for examples. +-- +logHook :: X () +logHook = return () + +------------------------------------------------------------------------ +-- Event handling + +-- | Defines a custom handler function for X Events. The function should +-- return (All True) if the default handler is to be run afterwards. +-- To combine event hooks, use mappend or mconcat from Data.Monoid. +handleEventHook :: Event -> X All +handleEventHook _ = return (All True) + +-- | Perform an arbitrary action at xmonad startup. +startupHook :: X () +startupHook = return () + +------------------------------------------------------------------------ +-- Extensible layouts +-- +-- You can specify and transform your layouts by modifying these values. +-- If you change layout bindings be sure to use 'mod-shift-space' after +-- restarting (with 'mod-q') to reset your layout state to the new +-- defaults, as xmonad preserves your old layout settings by default. +-- + +-- | The available layouts. Note that each layout is separated by |||, which +-- denotes layout choice. +layout = tiled ||| Mirror tiled ||| Full + where + -- default tiling algorithm partitions the screen into two panes + tiled = Tall nmaster delta ratio + + -- The default number of windows in the master pane + nmaster = 1 + + -- Default proportion of screen occupied by master pane + ratio = 1/2 + + -- Percent of screen to increment by when resizing panes + delta = 3/100 + +------------------------------------------------------------------------ +-- Event Masks: + +-- | The client events that xmonad is interested in +clientMask :: EventMask +clientMask = structureNotifyMask .|. enterWindowMask .|. propertyChangeMask + +-- | The frame events that xmonad is interested in +frameMask :: EventMask +frameMask = substructureRedirectMask .|. substructureNotifyMask + +-- | The root events that xmonad is interested in +rootMask :: EventMask +rootMask = substructureRedirectMask .|. substructureNotifyMask + .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask + .|. buttonPressMask + +------------------------------------------------------------------------ +-- Key bindings: + +-- | The preferred terminal program, which is used in a binding below and by +-- certain contrib modules. +terminal :: String +terminal = "xterm" + +-- | Whether focus follows the mouse pointer. +focusFollowsMouse :: Bool +focusFollowsMouse = True + +-- | Whether a mouse click select the focus or is just passed to the window +clickJustFocuses :: Bool +clickJustFocuses = True + + +-- | The xmonad key bindings. Add, modify or remove key bindings here. +-- +-- (The comment formatting character is used when generating the manpage) +-- +keys :: XConfig Layout -> M.Map (KeyMask, KeySym) (X ()) +keys conf@(XConfig {MetaTile.modMask = modMask}) = M.fromList $ + -- launching and killing programs + [ ((modMask .|. shiftMask, xK_Return), spawn $ MetaTile.terminal conf) -- %! Launch terminal + , ((modMask, xK_p ), spawn "dmenu_run") -- %! Launch dmenu + , ((modMask .|. shiftMask, xK_p ), spawn "gmrun") -- %! Launch gmrun + , ((modMask .|. shiftMask, xK_c ), kill) -- %! Close the focused window + + , ((modMask, xK_space ), sendMessage NextLayout) -- %! Rotate through the available layout algorithms + , ((modMask .|. shiftMask, xK_space ), setLayout $ MetaTile.layoutHook conf) -- %! Reset the layouts on the current workspace to default + + , ((modMask, xK_n ), refresh) -- %! Resize viewed windows to the correct size + + -- move focus up or down the window stack + , ((modMask, xK_Tab ), windows W.focusDown) -- %! Move focus to the next window + , ((modMask .|. shiftMask, xK_Tab ), windows W.focusUp ) -- %! Move focus to the previous window + , ((modMask, xK_j ), windows W.focusDown) -- %! Move focus to the next window + , ((modMask, xK_k ), windows W.focusUp ) -- %! Move focus to the previous window + , ((modMask, xK_m ), windows W.focusMaster ) -- %! Move focus to the master window + + -- modifying the window order + , ((modMask, xK_Return), windows W.swapMaster) -- %! Swap the focused window and the master window + , ((modMask .|. shiftMask, xK_j ), windows W.swapDown ) -- %! Swap the focused window with the next window + , ((modMask .|. shiftMask, xK_k ), windows W.swapUp ) -- %! Swap the focused window with the previous window + + -- resizing the master/slave ratio + , ((modMask, xK_h ), sendMessage Shrink) -- %! Shrink the master area + , ((modMask, xK_l ), sendMessage Expand) -- %! Expand the master area + + -- increase or decrease number of windows in the master area + , ((modMask , xK_comma ), sendMessage (IncMasterN 1)) -- %! Increment the number of windows in the master area + , ((modMask , xK_period), sendMessage (IncMasterN (-1))) -- %! Deincrement the number of windows in the master area + + -- quit, or restart + , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- %! Quit metatile + , ((modMask , xK_q ), spawn "if type metatile; then metatile --recompile && metatile --restart; else xmessage metatile not in \\$PATH: \"$PATH\"; fi") -- %! Restart metatile + + , ((modMask .|. shiftMask, xK_slash ), spawn ("echo \"" ++ help ++ "\" | xmessage -file -")) -- %! Run xmessage with a summary of the default keybindings (useful for beginners) + -- repeat the binding for non-American layout keyboards + , ((modMask , xK_question), spawn ("echo \"" ++ help ++ "\" | xmessage -file -")) + ] + ++ + -- mod-[1..9] %! Switch to workspace N + -- mod-shift-[1..9] %! Move client to workspace N + [((m .|. modMask, k), windows $ f i) + | (i, k) <- zip (MetaTile.workspaces conf) [xK_1 .. xK_9] + , (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]] + ++ + -- mod-{w,e,r} %! Switch to physical/Xinerama screens 1, 2, or 3 + -- mod-shift-{w,e,r} %! Move client to screen 1, 2, or 3 + [((m .|. modMask, key), screenWorkspace sc >>= flip whenJust (windows . f)) + | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..] + , (f, m) <- [(W.view, 0), (W.shift, shiftMask)]] + +-- | Mouse bindings: default actions bound to mouse events +mouseBindings :: XConfig Layout -> M.Map (KeyMask, Button) (Window -> X ()) +mouseBindings (XConfig {MetaTile.modMask = modMask}) = M.fromList + -- mod-button2 %! Raise the window to the top of the stack + [ ((modMask, button2), windows . (W.shiftMaster .) . W.focusWindow) + -- you may also bind events to the mouse scroll wheel (button4 and button5) + ] + +instance (a ~ Choose Tall (Choose (Mirror Tall) Full)) => Default (XConfig a) where + def = XConfig + { MetaTile.workspaces = workspaces + , MetaTile.layoutHook = layout + , MetaTile.terminal = terminal + , MetaTile.normalBorderColor = normalBorderColor + , MetaTile.focusedBorderColor = focusedBorderColor + , MetaTile.defaultBorderWidth = defaultBorderWidth + , MetaTile.modMask = defaultModMask + , MetaTile.keys = keys + , MetaTile.logHook = logHook + , MetaTile.startupHook = startupHook + , MetaTile.mouseBindings = mouseBindings + , MetaTile.manageHook = manageHook + , MetaTile.handleEventHook = handleEventHook + , MetaTile.focusFollowsMouse = focusFollowsMouse + , MetaTile.clickJustFocuses = clickJustFocuses + , MetaTile.clientMask = clientMask + , MetaTile.frameMask = frameMask + , MetaTile.rootMask = rootMask + } + +-- | The default set of configuration values itself +{-# DEPRECATED defaultConfig "Use def (from Data.Default, and re-exported by MetaTile and MetaTile.Config) instead." #-} +defaultConfig :: XConfig (Choose Tall (Choose (Mirror Tall) Full)) +defaultConfig = def + +-- | Finally, a copy of the default bindings in simple textual tabular format. +help :: String +help = unlines ["The default modifier key is 'alt'. Default keybindings:", + "", + "-- launching and killing programs", + "mod-Shift-Enter Launch xterminal", + "mod-p Launch dmenu", + "mod-Shift-p Launch gmrun", + "mod-Shift-c Close/kill the focused window", + "mod-Space Rotate through the available layout algorithms", + "mod-Shift-Space Reset the layouts on the current workSpace to default", + "mod-n Resize/refresh viewed windows to the correct size", + "", + "-- move focus up or down the window stack", + "mod-Tab Move focus to the next window", + "mod-Shift-Tab Move focus to the previous window", + "mod-j Move focus to the next window", + "mod-k Move focus to the previous window", + "mod-m Move focus to the master window", + "", + "-- modifying the window order", + "mod-Return Swap the focused window and the master window", + "mod-Shift-j Swap the focused window with the next window", + "mod-Shift-k Swap the focused window with the previous window", + "", + "-- resizing the master/slave ratio", + "mod-h Shrink the master area", + "mod-l Expand the master area", + "", + "-- floating layer support", + "mod-t Push window back into tiling; unfloat and re-tile it", + "", + "-- increase or decrease number of windows in the master area", + "mod-comma (mod-,) Increment the number of windows in the master area", + "mod-period (mod-.) Deincrement the number of windows in the master area", + "", + "-- quit, or restart", + "mod-Shift-q Quit metatile", + "mod-q Restart metatile", + "mod-[1..9] Switch to workSpace N", + "", + "-- Workspaces & screens", + "mod-Shift-[1..9] Move client to workspace N", + "mod-{w,e,r} Switch to physical/Xinerama screens 1, 2, or 3", + "mod-Shift-{w,e,r} Move client to screen 1, 2, or 3", + "", + "-- Mouse bindings: default actions bound to mouse events", + "mod-button1 Set the window to floating mode and move by dragging", + "mod-button2 Raise the window to the top of the stack", + "mod-button3 Set the window to floating mode and resize by dragging"] 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 () diff --git a/MetaTile/Layout.hs b/MetaTile/Layout.hs new file mode 100644 index 0000000..47fd4f9 --- /dev/null +++ b/MetaTile/Layout.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances, DeriveDataTypeable #-} + +-- -------------------------------------------------------------------------- +-- | +-- Module : MetaTile.Layout +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : spencerjanssen@gmail.com +-- Stability : unstable +-- Portability : not portable, Typeable deriving, mtl, posix +-- +-- The collection of core layouts. +-- +----------------------------------------------------------------------------- + +module MetaTile.Layout ( + Full(..), Tall(..), Mirror(..), + Resize(..), IncMasterN(..), Choose, (|||), ChangeLayout(..), + mirrorRect, splitVertically, + splitHorizontally, splitHorizontallyBy, splitVerticallyBy, + + tile + + ) where + +import MetaTile.Core + +import Graphics.X11 (Rectangle(..)) +import qualified MetaTile.StackSet as W +import Control.Arrow ((***), second) +import Control.Monad +import Data.Maybe (fromMaybe) + +------------------------------------------------------------------------ + +-- | Change the size of the master pane. +data Resize = Shrink | Expand deriving Typeable + +-- | Increase the number of clients in the master pane. +data IncMasterN = IncMasterN !Int deriving Typeable + +instance Message Resize +instance Message IncMasterN + +-- | Simple fullscreen mode. Renders the focused window fullscreen. +data Full a = Full deriving (Show, Read) + +instance LayoutClass Full a + +-- | The builtin tiling mode of xmonad. Supports 'Shrink', 'Expand' and +-- 'IncMasterN'. +data Tall a = Tall { tallNMaster :: !Int -- ^ The default number of windows in the master pane (default: 1) + , tallRatioIncrement :: !Rational -- ^ Percent of screen to increment by when resizing panes (default: 3/100) + , tallRatio :: !Rational -- ^ Default proportion of screen occupied by master pane (default: 1/2) + } + deriving (Show, Read) + -- TODO should be capped [0..1] .. + +-- a nice pure layout, lots of properties for the layout, and its messages, in Properties.hs +instance LayoutClass Tall a where + pureLayout (Tall nmaster _ frac) r s = zip ws rs + where ws = W.integrate s + rs = tile frac r nmaster (length ws) + + pureMessage (Tall nmaster delta frac) m = + msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] + + where resize Shrink = Tall nmaster delta (max 0 $ frac-delta) + resize Expand = Tall nmaster delta (min 1 $ frac+delta) + incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac + + description _ = "Tall" + +-- | Compute the positions for windows using the default two-pane tiling +-- algorithm. +-- +-- The screen is divided into two panes. All clients are +-- then partioned between these two panes. One pane, the master, by +-- convention has the least number of windows in it. +tile + :: Rational -- ^ @frac@, what proportion of the screen to devote to the master area + -> Rectangle -- ^ @r@, the rectangle representing the screen + -> Int -- ^ @nmaster@, the number of windows in the master pane + -> Int -- ^ @n@, the total number of windows to tile + -> [Rectangle] +tile f r nmaster n = if n <= nmaster || nmaster == 0 + then splitVertically n r + else splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns + where (r1,r2) = splitHorizontallyBy f r + +-- +-- Divide the screen vertically into n subrectangles +-- +splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle] +splitVertically n r | n < 2 = [r] +splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh : + splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) + where smallh = sh `div` fromIntegral n --hmm, this is a fold or map. + +-- Not used in the core, but exported +splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect + +-- Divide the screen into two rectangles, using a rational to specify the ratio +splitHorizontallyBy, splitVerticallyBy :: RealFrac r => r -> Rectangle -> (Rectangle, Rectangle) +splitHorizontallyBy f (Rectangle sx sy sw sh) = + ( Rectangle sx sy leftw sh + , Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh) + where leftw = floor $ fromIntegral sw * f + +-- Not used in the core, but exported +splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect + +------------------------------------------------------------------------ + +-- | Mirror a layout, compute its 90 degree rotated form. +newtype Mirror l a = Mirror (l a) deriving (Show, Read) + +instance LayoutClass l a => LayoutClass (Mirror l) a where + runLayout (W.Workspace i (Mirror l) ms) r = (map (second mirrorRect) *** fmap Mirror) + `fmap` runLayout (W.Workspace i l ms) (mirrorRect r) + handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l + description (Mirror l) = "Mirror "++ description l + +-- | Mirror a rectangle. +mirrorRect :: Rectangle -> Rectangle +mirrorRect (Rectangle rx ry rw rh) = Rectangle ry rx rh rw + +------------------------------------------------------------------------ +-- LayoutClass selection manager +-- Layouts that transition between other layouts + +-- | Messages to change the current layout. +data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable) + +instance Message ChangeLayout + +-- | The layout choice combinator +(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a +(|||) = Choose L +infixr 5 ||| + +-- | A layout that allows users to switch between various layout options. +data Choose l r a = Choose LR (l a) (r a) deriving (Read, Show) + +-- | Are we on the left or right sub-layout? +data LR = L | R deriving (Read, Show, Eq) + +data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable) +instance Message NextNoWrap + +-- | A small wrapper around handleMessage, as it is tedious to write +-- SomeMessage repeatedly. +handle :: (LayoutClass l a, Message m) => l a -> m -> X (Maybe (l a)) +handle l m = handleMessage l (SomeMessage m) + +-- | A smart constructor that takes some potential modifications, returns a +-- new structure if any fields have changed, and performs any necessary cleanup +-- on newly non-visible layouts. +choose :: (LayoutClass l a, LayoutClass r a) + => Choose l r a-> LR -> Maybe (l a) -> Maybe (r a) -> X (Maybe (Choose l r a)) +choose (Choose d _ _) d' Nothing Nothing | d == d' = return Nothing +choose (Choose d l r) d' ml mr = f lr + where + (l', r') = (fromMaybe l ml, fromMaybe r mr) + lr = case (d, d') of + (L, R) -> (hide l' , return r') + (R, L) -> (return l', hide r' ) + (_, _) -> (return l', return r') + f (x,y) = fmap Just $ liftM2 (Choose d') x y + hide x = fmap (fromMaybe x) $ handle x Hide + +instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where + runLayout (W.Workspace i (Choose L l r) ms) = + fmap (second . fmap $ flip (Choose L) r) . runLayout (W.Workspace i l ms) + runLayout (W.Workspace i (Choose R l r) ms) = + fmap (second . fmap $ Choose R l) . runLayout (W.Workspace i r ms) + + description (Choose L l _) = description l + description (Choose R _ r) = description r + + handleMessage lr m | Just NextLayout <- fromMessage m = do + mlr' <- handle lr NextNoWrap + maybe (handle lr FirstLayout) (return . Just) mlr' + + handleMessage c@(Choose d l r) m | Just NextNoWrap <- fromMessage m = + case d of + L -> do + ml <- handle l NextNoWrap + case ml of + Just _ -> choose c L ml Nothing + Nothing -> choose c R Nothing =<< handle r FirstLayout + + R -> choose c R Nothing =<< handle r NextNoWrap + + handleMessage c@(Choose _ l _) m | Just FirstLayout <- fromMessage m = + flip (choose c L) Nothing =<< handle l FirstLayout + + handleMessage c@(Choose d l r) m | Just ReleaseResources <- fromMessage m = + join $ liftM2 (choose c d) (handle l ReleaseResources) (handle r ReleaseResources) + + handleMessage c@(Choose d l r) m = do + ml' <- case d of + L -> handleMessage l m + R -> return Nothing + mr' <- case d of + L -> return Nothing + R -> handleMessage r m + choose c d ml' mr' diff --git a/MetaTile/Main.hsc b/MetaTile/Main.hsc new file mode 100644 index 0000000..abdb75c --- /dev/null +++ b/MetaTile/Main.hsc @@ -0,0 +1,433 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, ForeignFunctionInterface #-} +---------------------------------------------------------------------------- +-- | +-- Module : MetaTile.Main +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : spencerjanssen@gmail.com +-- Stability : unstable +-- Portability : not portable, uses mtl, X11, posix +-- +-- metatile, a minimalist, tiling window manager for X11 +-- +----------------------------------------------------------------------------- + +module MetaTile.Main (metatile) where + +import Control.Arrow (second) +import Data.Bits +import Data.List ((\\)) +import Data.Function +import qualified Data.Map as M +import Control.Monad.Reader +import Control.Monad.State +import Data.Maybe (fromMaybe) +import Data.Monoid (getAll) + +import Foreign.C +import Foreign.Ptr + +import System.Environment (getArgs) + +import Graphics.X11.Xlib hiding (refreshKeyboardMapping) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xlib.Types (Visual(..)) + +import MetaTile.Core +import qualified MetaTile.Config as Default +import MetaTile.StackSet (new, member) +import qualified MetaTile.StackSet as W +import MetaTile.Operations + +import System.IO + +------------------------------------------------------------------------ +-- Locale support + +#include + +foreign import ccall unsafe "locale.h setlocale" + c_setlocale :: CInt -> Ptr CChar -> IO (Ptr CChar) + +------------------------------------------------------------------------ + +-- | +-- The main entry point +-- +metatile :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO () +metatile initxmc = do + -- setup locale information from environment + withCString "" $ c_setlocale (#const LC_ALL) + -- ignore SIGPIPE and SIGCHLD + installSignalHandlers + -- First, wrap the layout in an existential, to keep things pretty: + let xmc = initxmc { layoutHook = Layout $ layoutHook initxmc } + dpy <- openDisplay "" + let dflt = defaultScreen dpy + + rootw <- rootWindow dpy dflt + + args <- getArgs + + when ("--replace" `elem` args) $ replace dpy dflt rootw + + -- If another WM is running, a BadAccess error will be returned. The + -- default error handler will write the exception to stderr and exit with + -- an error. + selectInput dpy rootw $ rootMask initxmc + + sync dpy False -- sync to ensure all outstanding errors are delivered + + -- turn off the default handler in favor of one that ignores all errors + -- (ugly, I know) + xSetErrorHandler -- in C, I'm too lazy to write the binding: dons + + xinesc <- getCleanedScreenInfo dpy + nbc <- do v <- initColor dpy $ normalBorderColor xmc + ~(Just nbc_) <- initColor dpy $ normalBorderColor Default.def + return (fromMaybe nbc_ v) + + fbc <- do v <- initColor dpy $ focusedBorderColor xmc + ~(Just fbc_) <- initColor dpy $ focusedBorderColor Default.def + return (fromMaybe fbc_ v) + + hSetBuffering stdout NoBuffering + + let layout = layoutHook xmc + lreads = readsLayout layout + initialWinset = new layout (workspaces xmc) $ map SD xinesc + maybeRead reads' s = case reads' s of + [(x, "")] -> Just x + _ -> Nothing + + winset = fromMaybe initialWinset $ do + ("--resume" : s : _) <- return args + ws <- maybeRead reads s + return $ W.mapLayout (fromMaybe layout . maybeRead lreads) ws + extState = fromMaybe M.empty $ do + ("--resume" : _ : dyns : _) <- return args + vals <- maybeRead reads dyns + return . M.fromList . map (second Left) $ vals + + cf = XConf + { display = dpy + , config = xmc + , theRoot = rootw + , normalBorder = nbc + , focusedBorder = fbc + , keyActions = keys xmc xmc + , buttonActions = mouseBindings xmc xmc + , mouseFocused = False + , mousePosition = Nothing + , currentEvent = Nothing } + + st = XState + { windowset = initialWinset + , numberlockMask = 0 + , windowState = M.empty + , dragging = Nothing + , extensibleState = extState + } + allocaXEvent $ \e -> + runX cf st $ do + + setNumlockMask + grabKeys + grabButtons + + io $ sync dpy False + + ws <- io $ scan dpy rootw + + -- bootstrap the windowset, Operations.windows will identify all + -- the windows in winset as new and set initial properties for + -- those windows. Remove all windows that are no longer top-level + -- children of the root, they may have disappeared since + -- restarting. + windows . const . foldr W.delete winset $ W.allWindows winset \\ ws + + -- manage the as-yet-unmanaged windows + mapM_ (\w -> reparent w >> manage w) (ws \\ W.allWindows winset) + + userCode $ startupHook initxmc + + -- main loop, for all you HOF/recursion fans out there. + forever $ prehandle =<< io (nextEvent dpy e >> getEvent e) + + return () + where + -- if the event gives us the position of the pointer, set mousePosition + prehandle e = let mouse = do guard (ev_event_type e `elem` evs) + return (fromIntegral (ev_x_root e) + ,fromIntegral (ev_y_root e)) + in local (\c -> c { mousePosition = mouse, currentEvent = Just e }) (handleWithHook e) + evs = [ keyPress, keyRelease, enterNotify, leaveNotify + , buttonPress, buttonRelease] + + +-- | Runs handleEventHook from the configuration and runs the default handler +-- function if it returned True. +handleWithHook :: Event -> X () +handleWithHook e = do + evHook <- asks (handleEventHook . config) + whenX (userCodeDef True $ getAll `fmap` evHook e) (handle e) + +-- --------------------------------------------------------------------- +-- | Event handler. Map X events onto calls into Operations.hs, which +-- modify our internal model of the window manager state. +-- +-- Events dwm handles that we don't: +-- +-- [ButtonPress] = buttonpress, +-- [Expose] = expose, +-- [PropertyNotify] = propertynotify, +-- +handle :: Event -> X () + +-- run window manager command +handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) + | t == keyPress = withDisplay $ \dpy -> do + s <- io $ keycodeToKeysym dpy code 0 + mClean <- cleanMask m + ks <- asks keyActions + userCodeDef () $ whenJust (M.lookup (mClean, s) ks) id + +-- manage a new window +handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do + wa <- io $ getWindowAttributes dpy w -- ignore override windows + -- need to ignore mapping requests by managed windows not on the current workspace + managed <- isClient w + when (not (wa_override_redirect wa) && not managed) $ do + reparent w + manage w + +-- window destroyed, unmanage it +-- window gone, unmanage it +handle (DestroyWindowEvent {ev_window = w}) = do + whenX (isClient w) $ + unmanage w + unparent w + modify (\s -> s { windowState = M.delete w (windowState s)}) + +-- We track expected unmap events in waitingUnmap. We ignore this event unless +-- it is synthetic or we are not expecting an unmap notification from a window. +handle UnmapEvent {ev_window = w, ev_send_event = synthetic, ev_event = we} = whenX (isClient w) $ do + rootw <- asks theRoot + e <- getsWindowState wsWaitingUnmap w + if (synthetic || (e == 0 && we /= rootw)) + then unmanage w >> hideParent w + else when (e > 0) $ modifyWindowState (\ws -> ws { wsWaitingUnmap = e - 1 }) w + +-- set keyboard mapping +handle e@(MappingNotifyEvent {}) = do + io $ refreshKeyboardMapping e + when (ev_request e `elem` [mappingKeyboard, mappingModifier]) $ do + setNumlockMask + grabKeys + +-- handle button release, which may finish dragging. +handle e@(ButtonEvent {ev_event_type = t}) + | t == buttonRelease = do + drag <- gets dragging + case drag of + -- we're done dragging and have released the mouse: + Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f + Nothing -> broadcastMessage e + +-- handle motionNotify event, which may mean we are dragging. +handle e@(MotionEvent {ev_event_type = _t, ev_x = x, ev_y = y}) = do + drag <- gets dragging + case drag of + Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging + Nothing -> broadcastMessage e + +-- click on an unfocused window, makes it focused on this workspace +handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b }) + | t == buttonPress = do + -- If it's the root window, then it's something we + -- grabbed in grabButtons. Otherwise, it's click-to-focus. + dpy <- asks display + isr <- isRoot w + m <- cleanMask $ ev_state e + mact <- asks (M.lookup (m, b) . buttonActions) + case mact of + Just act | isr -> act $ ev_subwindow e + _ -> do + focus w + ctf <- asks (clickJustFocuses . config) + unless ctf $ io (allowEvents dpy replayPointer currentTime) + broadcastMessage e -- Always send button events. + +-- entered a normal window: focus it if focusFollowsMouse is set to +-- True in the user's config. +handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) + | t == enterNotify && ev_mode e == notifyNormal + = whenX (asks $ focusFollowsMouse . config) (focus w) + +-- left a window, check if we need to focus root +handle e@(CrossingEvent {ev_event_type = t}) + | t == leaveNotify + = do rootw <- asks theRoot + when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw + +-- configure a window +handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do + ws <- gets windowset + + if not (member w ws) + then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges + { wc_x = ev_x e + , wc_y = ev_y e + , wc_width = ev_width e + , wc_height = ev_height e + , wc_border_width = 0 + , wc_sibling = ev_above e + , wc_stack_mode = ev_detail e } + else configureClientWindow w + io $ sync dpy False + +-- configuration changes in the root may mean display settings have changed +handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen + +-- property notify +handle event@(PropertyEvent { ev_event_type = t, ev_atom = a }) + | t == propertyNotify && a == wM_NAME = asks (logHook . config) >>= userCodeDef () >> + broadcastMessage event + +handle e@ClientMessageEvent { ev_message_type = mt } = do + a <- getAtom "XMONAD_RESTART" + if (mt == a) + then restart "metatile" True + else broadcastMessage e + +handle e = broadcastMessage e -- trace (eventName e) -- ignoring + + +reparent :: Window -> X () +reparent w = withDisplay $ \dpy -> do + rootw <- asks theRoot + p <- asks normalBorder + fMask <- asks (frameMask . config) + noFrame <- getsWindowState ((==none) . wsFrame) w + when noFrame $ do + trace $ "reparent: " ++ show w + frame <- io $ allocaSetWindowAttributes $ \swa -> do + set_background_pixel swa p + set_border_pixel swa p + set_event_mask swa fMask + set_override_redirect swa True + createWindow dpy rootw (-1) (-1) 1 1 0 copyFromParent inputOutput (Visual nullPtr) (cWBackPixel.|.cWBorderPixel.|.cWEventMask.|.cWOverrideRedirect) swa + io $ do + unmapWindow dpy w + addToSaveSet dpy w + reparentWindow dpy w frame 0 0 + modifyWindowState (\ws -> ws { wsFrame = frame }) w + +hideParent :: Window -> X () +hideParent w = withDisplay $ \dpy -> do + frame <- getsWindowState wsFrame w + when (frame /= none) $ io $ unmapWindow dpy frame + +unparent :: Window -> X () +unparent w = withDisplay $ \dpy -> do + frame <- getsWindowState wsFrame w + when (frame /= none) $ do + trace $ "unparent: " ++ show w + io $ destroyWindow dpy frame + modifyWindowState (\ws -> ws { wsFrame = none }) w + +-- --------------------------------------------------------------------- +-- IO stuff. Doesn't require any X state +-- Most of these things run only on startup (bar grabkeys) + +-- | scan for any new windows to manage. If they're already managed, +-- this should be idempotent. +scan :: Display -> Window -> IO [Window] +scan dpy rootw = do + (_, _, ws) <- queryTree dpy rootw + filterM ok ws + -- TODO: scan for windows that are either 'IsViewable' or where WM_STATE == + -- Iconic + where ok w = do wa <- getWindowAttributes dpy w + a <- internAtom dpy "WM_STATE" False + p <- getWindowProperty32 dpy a w + let ic = case p of + Just (3:_) -> True -- 3 for iconified + _ -> False + return $ not (wa_override_redirect wa) + && (wa_map_state wa == waIsViewable || ic) + +setNumlockMask :: X () +setNumlockMask = do + dpy <- asks display + ms <- io $ getModifierMapping dpy + xs <- sequence [ do + ks <- io $ keycodeToKeysym dpy kc 0 + if ks == xK_Num_Lock + then return (setBit 0 (fromIntegral m)) + else return (0 :: KeyMask) + | (m, kcs) <- ms, kc <- kcs, kc /= 0] + modify (\s -> s { numberlockMask = foldr (.|.) 0 xs }) + +-- | Grab the keys back +grabKeys :: X () +grabKeys = do + XConf { display = dpy, theRoot = rootw } <- ask + let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync + (minCode, maxCode) = displayKeycodes dpy + allCodes = [fromIntegral minCode .. fromIntegral maxCode] + io $ ungrabKey dpy anyKey anyModifier rootw + ks <- asks keyActions + -- build a map from keysyms to lists of keysyms (doing what + -- XGetKeyboardMapping would do if the X11 package bound it) + syms <- forM allCodes $ \code -> io (keycodeToKeysym dpy code 0) + let keysymMap = M.fromListWith (++) (zip syms [[code] | code <- allCodes]) + keysymToKeycodes sym = M.findWithDefault [] sym keysymMap + forM_ (M.keys ks) $ \(mask,sym) -> + forM_ (keysymToKeycodes sym) $ \kc -> + mapM_ (grab kc . (mask .|.)) =<< extraModifiers + +-- | XXX comment me +grabButtons :: X () +grabButtons = do + XConf { display = dpy, theRoot = rootw } <- ask + let grab button mask = io $ grabButton dpy button mask rootw False buttonPressMask + grabModeAsync grabModeSync none none + io $ ungrabButton dpy anyButton anyModifier rootw + ems <- extraModifiers + ba <- asks buttonActions + mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ ba) + +-- | @replace@ to signals compliant window managers to exit. +replace :: Display -> ScreenNumber -> Window -> IO () +replace dpy dflt rootw = do + -- check for other WM + wmSnAtom <- internAtom dpy ("WM_S" ++ show dflt) False + currentWmSnOwner <- xGetSelectionOwner dpy wmSnAtom + when (currentWmSnOwner /= 0) $ do + -- prepare to receive destroyNotify for old WM + selectInput dpy currentWmSnOwner structureNotifyMask + + -- create off-screen window + netWmSnOwner <- allocaSetWindowAttributes $ \attributes -> do + set_override_redirect attributes True + set_event_mask attributes propertyChangeMask + let screen = defaultScreenOfDisplay dpy + visual = defaultVisualOfScreen screen + attrmask = cWOverrideRedirect .|. cWEventMask + createWindow dpy rootw (-100) (-100) 1 1 0 copyFromParent copyFromParent visual attrmask attributes + + -- try to acquire wmSnAtom, this should signal the old WM to terminate + xSetSelectionOwner dpy wmSnAtom netWmSnOwner currentTime + + -- SKIPPED: check if we acquired the selection + -- SKIPPED: send client message indicating that we are now the WM + + -- wait for old WM to go away + fix $ \again -> do + evt <- allocaXEvent $ \event -> do + windowEvent dpy currentWmSnOwner structureNotifyMask event + get_EventType event + + when (evt /= destroyNotify) again diff --git a/MetaTile/ManageHook.hs b/MetaTile/ManageHook.hs new file mode 100644 index 0000000..f2daf9c --- /dev/null +++ b/MetaTile/ManageHook.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : MetaTile.ManageHook +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : spencerjanssen@gmail.com +-- Stability : unstable +-- Portability : not portable, uses cunning newtype deriving +-- +-- An EDSL for ManageHooks +-- +----------------------------------------------------------------------------- + +-- XXX examples required + +module MetaTile.ManageHook where + +import Prelude hiding (catch) +import MetaTile.Core +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xlib (Display, Window, internAtom, wM_NAME) +import Control.Exception.Extensible (bracket, catch, SomeException(..)) +import Control.Monad.Reader +import Data.Maybe +import Data.Monoid +import qualified MetaTile.StackSet as W +import MetaTile.Operations (reveal) + +-- | Lift an 'X' action to a 'Query'. +liftX :: X a -> Query a +liftX = Query . lift + +-- | The identity hook that returns the WindowSet unchanged. +idHook :: Monoid m => m +idHook = mempty + +-- | Infix 'mappend'. Compose two 'ManageHook' from right to left. +(<+>) :: Monoid m => m -> m -> m +(<+>) = mappend + +-- | Compose the list of 'ManageHook's. +composeAll :: Monoid m => [m] -> m +composeAll = mconcat + +infix 0 --> + +-- | @p --> x@. If @p@ returns 'True', execute the 'ManageHook'. +-- +-- > (-->) :: Monoid m => Query Bool -> Query m -> Query m -- a simpler type +(-->) :: (Monad m, Monoid a) => m Bool -> m a -> m a +p --> f = p >>= \b -> if b then f else return mempty + +-- | @q =? x@. if the result of @q@ equals @x@, return 'True'. +(=?) :: Eq a => Query a -> a -> Query Bool +q =? x = fmap (== x) q + +infixr 3 <&&>, <||> + +-- | '&&' lifted to a 'Monad'. +(<&&>) :: Monad m => m Bool -> m Bool -> m Bool +(<&&>) = liftM2 (&&) + +-- | '||' lifted to a 'Monad'. +(<||>) :: Monad m => m Bool -> m Bool -> m Bool +(<||>) = liftM2 (||) + +-- | Return the window title. +title :: Query String +title = ask >>= \w -> liftX $ do + d <- asks display + let + getProp = + (internAtom d "_NET_WM_NAME" False >>= getTextProperty d w) + `catch` \(SomeException _) -> getTextProperty d w wM_NAME + extract prop = do l <- wcTextPropertyToTextList d prop + return $ if null l then "" else head l + io $ bracket getProp (xFree . tp_value) extract `catch` \(SomeException _) -> return "" + +-- | Return the application name. +appName :: Query String +appName = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resName $ io $ getClassHint d w) + +-- | Backwards compatible alias for 'appName'. +resource :: Query String +resource = appName + +-- | Return the resource class. +className :: Query String +className = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resClass $ io $ getClassHint d w) + +-- | A query that can return an arbitrary X property of type 'String', +-- identified by name. +stringProperty :: String -> Query String +stringProperty p = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ getStringProperty d w p) + +getStringProperty :: Display -> Window -> String -> X (Maybe String) +getStringProperty d w p = do + a <- getAtom p + md <- io $ getWindowProperty8 d a w + return $ fmap (map (toEnum . fromIntegral)) md + +-- | Modify the 'WindowSet' with a pure function. +doF :: (s -> s) -> Query (Endo s) +doF = return . Endo + +-- | Map the window and remove it from the 'WindowSet'. +doIgnore :: ManageHook +doIgnore = ask >>= \w -> liftX (reveal w) >> doF (W.delete w) + +-- | Move the window to a given workspace +doShift :: WorkspaceId -> ManageHook +doShift i = doF . W.shiftWin i =<< ask diff --git a/MetaTile/Operations.hs b/MetaTile/Operations.hs new file mode 100644 index 0000000..1a2fd11 --- /dev/null +++ b/MetaTile/Operations.hs @@ -0,0 +1,588 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} + +-- -------------------------------------------------------------------------- +-- | +-- Module : MetaTile.Operations +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : unstable +-- Portability : not portable, Typeable deriving, mtl, posix +-- +-- Operations. +-- +----------------------------------------------------------------------------- + +module MetaTile.Operations where + +import MetaTile.Core +import MetaTile.Layout (Full(..)) +import qualified MetaTile.StackSet as W + +import Data.Maybe +import Data.Monoid (Endo(..)) +import Data.List (nub, (\\), find) +import Data.Bits ((.|.), (.&.), complement, testBit) +import Data.Ratio +import qualified Data.Map as M + +import Control.Applicative +import Control.Arrow ((&&&)) +import Control.Monad.Reader +import Control.Monad.State +import qualified Control.Exception.Extensible as C + +import System.Posix.Process (executeFile) +import Graphics.X11.Xlib +import Graphics.X11.Xinerama (getScreenInfo) +import Graphics.X11.Xlib.Extras + +-- --------------------------------------------------------------------- +-- | +-- Window manager operations +-- manage. Add a new window to be managed in the current workspace. +-- Bring it into focus. +-- +-- Whether the window is already managed, or not, it is mapped, has its +-- border set, and its event mask set. +-- +manage :: Window -> X () +manage w = whenX (not <$> isClient w) $ do + mh <- asks (manageHook . config) + g <- appEndo <$> userCodeDef (Endo id) (runQuery mh w) + windows (g . W.insertUp w) + +-- | unmanage. A window no longer exists, remove it from the window +-- list, on whatever workspace it is. +-- +unmanage :: Window -> X () +unmanage = windows . W.delete + +-- | Kill the specified window. If we do kill it, we'll get a +-- delete notify back from X. +-- +-- There are two ways to delete a window. Either just kill it, or if it +-- supports the delete protocol, send a delete event (e.g. firefox) +-- +killWindow :: Window -> X () +killWindow w = withDisplay $ \d -> do + wmdelt <- atom_WM_DELETE_WINDOW ; wmprot <- atom_WM_PROTOCOLS + + protocols <- io $ getWMProtocols d w + io $ if wmdelt `elem` protocols + then allocaXEvent $ \ev -> do + setEventType ev clientMessage + setClientMessageEvent ev w wmprot 32 wmdelt 0 + sendEvent d w False noEventMask ev + else killClient d w >> return () + +-- | Kill the currently focused client. +kill :: X () +kill = withFocused killWindow + +-- --------------------------------------------------------------------- +-- Managing windows + +-- | windows. Modify the current window list with a pure function, and refresh +windows :: (WindowSet -> WindowSet) -> X () +windows f = do + XState { windowset = old } <- get + let oldvisible = concatMap (W.integrate' . W.stack . W.screenWorkspace) $ W.screens old + newwindows = W.allWindows ws \\ W.allWindows old + ws = f old + XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask + + mapM_ setInitialProperties newwindows + + whenJust (W.peek old) $ \otherw -> setFrameBackground d otherw nbc + modify (\s -> s { windowset = ws }) + + -- notify non visibility + let tags_oldvisible = map (W.tag . W.screenWorkspace) $ W.screens old + gottenhidden = filter (flip elem tags_oldvisible . W.tag) $ W.hidden ws + mapM_ (sendMessageWithNoRefresh Hide) gottenhidden + + -- for each workspace, layout the currently visible workspaces + let allscreens = W.screens ws + summed_visible = scanl (++) [] $ map (W.integrate' . W.stack . W.screenWorkspace) allscreens + rects <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do + let wsp = W.screenWorkspace w + this = W.view n ws + n = W.tag wsp + tiled = (W.stack . W.screenWorkspace . W.current $ this) + >>= W.filter (`notElem` vis) + viewrect = screenRect $ W.screenDetail w + + -- just the tiled windows: + -- now tile the windows on this workspace, modified by the gap + (rs, ml') <- runLayout wsp { W.stack = tiled } viewrect `catchX` + runLayout wsp { W.stack = tiled, W.layout = Layout Full } viewrect + updateLayout n ml' + + io $ restackWindows d (map fst rs) + -- return the visible windows for this workspace: + return rs + + let visible = map fst rects + + mapM_ (uncurry tileWindow) rects + + whenJust (W.peek ws) $ \w -> setFrameBackground d w fbc + + mapM_ reveal visible + setTopFocus + + -- hide every window that was potentially visible before, but is not + -- given a position by a layout now. + mapM_ hide (nub (oldvisible ++ newwindows) \\ visible) + + -- all windows that are no longer in the windowset are marked as + -- withdrawn, it is important to do this after the above, otherwise 'hide' + -- will overwrite withdrawnState with iconicState + mapM_ (flip setWMState withdrawnState) (W.allWindows old \\ W.allWindows ws) + + isMouseFocused <- asks mouseFocused + unless isMouseFocused $ clearEvents enterWindowMask + asks (logHook . config) >>= userCodeDef () + where + setFrameBackground :: Display -> Window -> Pixel -> X () + setFrameBackground d w p = do + frame <- getsWindowState wsFrame w + io $ do + setWindowBackground d frame p + clearWindow d frame + +-- | Produce the actual rectangle from a screen and a ratio on that screen. +scaleRationalRect :: Rectangle -> W.RationalRect -> Rectangle +scaleRationalRect (Rectangle sx sy sw sh) (W.RationalRect rx ry rw rh) + = Rectangle (sx + scale sw rx) (sy + scale sh ry) (scale sw rw) (scale sh rh) + where scale s r = floor (toRational s * r) + +-- | setWMState. set the WM_STATE property +setWMState :: Window -> Int -> X () +setWMState w v = withDisplay $ \dpy -> do + a <- atom_WM_STATE + io $ changeProperty32 dpy w a a propModeReplace [fromIntegral v, fromIntegral none] + +-- | hide. Hide a window by unmapping it, and setting Iconified. +hide :: Window -> X () +hide w = whenX (getsWindowState wsMapped w) $ withDisplay $ \d -> do + (cMask,fMask) <- asks $ (clientMask &&& frameMask) . config + frame <- getsWindowState wsFrame w + io $ do selectInput d w (cMask .&. complement structureNotifyMask) + selectInput d frame (fMask .&. complement structureNotifyMask) + unmapWindow d frame + selectInput d frame fMask + selectInput d w cMask + setWMState w iconicState + -- this part is key: we increment the waitingUnmap counter to distinguish + -- between client and xmonad initiated unmaps. + modifyWindowState (\ws -> ws { wsMapped = False + , wsWaitingUnmap = (wsWaitingUnmap ws) + 1 }) w + +configureClientWindow :: Window -> X () +configureClientWindow w = withDisplay $ \d -> do + (frame, bw) <- getsWindowState (wsFrame &&& wsBorderWidth) w + (_, x, y, width, height, _, _) <- io $ getGeometry d frame + let least1 n = max 1 n + x' = x + (fi $ bwLeft bw) + y' = y + (fi $ bwTop bw) + width' = least1 (width - bwLeft bw - bwRight bw) + height' = least1 (height - bwTop bw - bwBottom bw) + io $ do + moveResizeWindow d w (fi $ bwLeft bw) (fi $ bwTop bw) width' height' + -- send absolute ConfigureNotify + allocaXEvent $ \event -> do + setEventType event configureNotify + setConfigureEvent event w w (fi x') (fi y') (fi width') (fi height') 0 none False + sendEvent d w False 0 event + where + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral + +-- | reveal. Show a window by mapping it and setting Normal +-- this is harmless if the window was already visible +reveal :: Window -> X () +reveal w = withDisplay $ \d -> do + setWMState w normalState + io $ mapWindow d w + whenX (isClient w) $ do + configureClientWindow w + getsWindowState wsFrame w >>= io . mapWindow d + modifyWindowState (\ws -> ws { wsMapped = True }) w + +-- | Set some properties when we initially gain control of a window +setInitialProperties :: Window -> X () +setInitialProperties w = withDisplay $ \d -> do + setWMState w iconicState + asks (clientMask . config) >>= io . selectInput d w + io $ setWindowBorderWidth d w 0 + +-- | refresh. Render the currently visible workspaces, as determined by +-- the 'StackSet'. Also, set focus to the focused window. +-- +-- This is our 'view' operation (MVC), in that it pretty prints our model +-- with X calls. +-- +refresh :: X () +refresh = windows id + +-- | clearEvents. Remove all events of a given type from the event queue. +clearEvents :: EventMask -> X () +clearEvents mask = withDisplay $ \d -> io $ do + sync d False + allocaXEvent $ \p -> fix $ \again -> do + more <- checkMaskEvent d mask p + when more again -- beautiful + +-- | tileWindow. Moves and resizes w such that it fits inside the given +-- rectangle, including its border. +tileWindow :: Window -> Rectangle -> X () +tileWindow w r = withDisplay $ \d -> do + -- give all windows at least 1x1 pixels + let least x | x <= 0 = 1 + | otherwise = x + frame <- getsWindowState wsFrame w + io $ moveResizeWindow d frame (rect_x r) (rect_y r) (least $ rect_width r) (least $ rect_height r) + +-- --------------------------------------------------------------------- + +-- | Returns 'True' if the first rectangle is contained within, but not equal +-- to the second. +containedIn :: Rectangle -> Rectangle -> Bool +containedIn r1@(Rectangle x1 y1 w1 h1) r2@(Rectangle x2 y2 w2 h2) + = and [ r1 /= r2 + , x1 >= x2 + , y1 >= y2 + , fromIntegral x1 + w1 <= fromIntegral x2 + w2 + , fromIntegral y1 + h1 <= fromIntegral y2 + h2 ] + +-- | Given a list of screens, remove all duplicated screens and screens that +-- are entirely contained within another. +nubScreens :: [Rectangle] -> [Rectangle] +nubScreens xs = nub . filter (\x -> not $ any (x `containedIn`) xs) $ xs + +-- | Cleans the list of screens according to the rules documented for +-- nubScreens. +getCleanedScreenInfo :: MonadIO m => Display -> m [Rectangle] +getCleanedScreenInfo = io . fmap nubScreens . getScreenInfo + +-- | rescreen. The screen configuration may have changed (due to +-- xrandr), update the state and refresh the screen, and reset the gap. +rescreen :: X () +rescreen = do + xinesc <- withDisplay getCleanedScreenInfo + + windows $ \ws -> + let (xs, ys) = splitAt (length xinesc) $ W.workspaces ws + (a:as) = zipWith3 (flip W.Screen []) xs [0..] $ map SD xinesc + in ws { W.current = a { W.screenHidden = ys } + , W.visible = as } + +-- --------------------------------------------------------------------- + +-- | setButtonGrab. Tell whether or not to intercept clicks on a given window +setButtonGrab :: Bool -> Window -> X () +setButtonGrab grab w = do + pointerMode <- asks $ \c -> if clickJustFocuses (config c) + then grabModeAsync + else grabModeSync + withDisplay $ \d -> io $ if grab + then forM_ [button1, button2, button3] $ \b -> + grabButton d b anyModifier w False buttonPressMask + pointerMode grabModeSync none none + else ungrabButton d anyButton anyModifier w + +-- --------------------------------------------------------------------- +-- Setting keyboard focus + +-- | Set the focus to the window on top of the stack, or root +setTopFocus :: X () +setTopFocus = withWindowSet $ maybe (setFocusX =<< asks theRoot) setFocusX . W.peek + +-- | Set focus explicitly to window 'w' if it is managed by us, or root. +-- This happens if X notices we've moved the mouse (and perhaps moved +-- the mouse to a new screen). +focus :: Window -> X () +focus w = local (\c -> c { mouseFocused = True }) $ withWindowSet $ \s -> do + let stag = W.tag . W.screenWorkspace + curr = stag $ W.current s + mnew <- maybe (return Nothing) (fmap (fmap stag) . uncurry pointScreen) + =<< asks mousePosition + root <- asks theRoot + case () of + _ | W.member w s && W.peek s /= Just w -> windows (W.focusWindow w) + | Just new <- mnew, w == root && curr /= new + -> windows (W.view new) + | otherwise -> return () + +-- | Call X to set the keyboard focus details. +setFocusX :: Window -> X () +setFocusX w = withWindowSet $ \ws -> do + dpy <- asks display + + -- clear mouse button grab and border on other windows + forM_ (W.screens ws) $ \wk -> + forM_ (W.index (W.view (W.tag (W.screenWorkspace wk)) ws)) $ \otherw -> + setButtonGrab True otherw + + -- If we ungrab buttons on the root window, we lose our mouse bindings. + whenX (not <$> isRoot w) $ setButtonGrab False w + + hints <- io $ getWMHints dpy w + protocols <- io $ getWMProtocols dpy w + wmprot <- atom_WM_PROTOCOLS + wmtf <- atom_WM_TAKE_FOCUS + currevt <- asks currentEvent + let inputHintSet = wmh_flags hints `testBit` inputHintBit + + when ((inputHintSet && wmh_input hints) || (not inputHintSet)) $ + io $ do setInputFocus dpy w revertToPointerRoot 0 + when (wmtf `elem` protocols) $ + io $ allocaXEvent $ \ev -> do + setEventType ev clientMessage + setClientMessageEvent ev w wmprot 32 wmtf $ maybe currentTime event_time currevt + sendEvent dpy w False noEventMask ev + where event_time ev = + if (ev_event_type ev) `elem` timedEvents then + ev_time ev + else + currentTime + timedEvents = [ keyPress, keyRelease, buttonPress, buttonRelease, enterNotify, leaveNotify, selectionRequest ] + +------------------------------------------------------------------------ +-- Message handling + +-- | Throw a message to the current 'LayoutClass' possibly modifying how we +-- layout the windows, then refresh. +sendMessage :: Message a => a -> X () +sendMessage a = do + w <- W.screenWorkspace . W.current <$> gets windowset + ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing + whenJust ml' $ \l' -> + windows $ \ws -> ws { W.current = (W.current ws) + { W.screenWorkspace = (W.screenWorkspace $ W.current ws) + { W.layout = l' }}} + +-- | Send a message to all layouts, without refreshing. +broadcastMessage :: Message a => a -> X () +broadcastMessage a = withWindowSet $ \ws -> + mapM_ (sendMessageWithNoRefresh a) (W.workspaces ws) + +-- | Send a message to a layout, without refreshing. +sendMessageWithNoRefresh :: Message a => a -> W.Workspace WorkspaceId (Layout Window) Window -> X () +sendMessageWithNoRefresh a w = + handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing >>= + updateLayout (W.tag w) + +-- | Update the layout field of a workspace +updateLayout :: WorkspaceId -> Maybe (Layout Window) -> X () +updateLayout i ml = whenJust ml $ \l -> + runOnWorkspaces $ \ww -> return $ if W.tag ww == i then ww { W.layout = l} else ww + +-- | Set the layout of the currently viewed workspace +setLayout :: Layout Window -> X () +setLayout l = do + ss@(W.StackSet { W.current = c@(W.Screen { W.screenWorkspace = ws })}) <- gets windowset + handleMessage (W.layout ws) (SomeMessage ReleaseResources) + windows $ const $ ss {W.current = c { W.screenWorkspace = ws { W.layout = l } } } + +------------------------------------------------------------------------ +-- Utilities + +-- | Return workspace visible on screen 'sc', or 'Nothing'. +screenWorkspace :: ScreenId -> X (Maybe WorkspaceId) +screenWorkspace sc = withWindowSet $ return . W.lookupWorkspace sc + +-- | Apply an 'X' operation to the currently focused window, if there is one. +withFocused :: (Window -> X ()) -> X () +withFocused f = withWindowSet $ \w -> whenJust (W.peek w) f + +-- | 'True' if window is under management by us +isClient :: Window -> X Bool +isClient w = withWindowSet $ return . W.member w + +-- | Combinations of extra modifier masks we need to grab keys\/buttons for. +-- (numlock and capslock) +extraModifiers :: X [KeyMask] +extraModifiers = do + nlm <- gets numberlockMask + return [0, nlm, lockMask, nlm .|. lockMask ] + +-- | Strip numlock\/capslock from a mask +cleanMask :: KeyMask -> X KeyMask +cleanMask km = do + nlm <- gets numberlockMask + return (complement (nlm .|. lockMask) .&. km) + +-- | Get the 'Pixel' value for a named color +initColor :: Display -> String -> IO (Maybe Pixel) +initColor dpy c = C.handle (\(C.SomeException _) -> return Nothing) $ + (Just . color_pixel . fst) <$> allocNamedColor dpy colormap c + where colormap = defaultColormap dpy (defaultScreen dpy) + +------------------------------------------------------------------------ + +-- | @restart name resume@. Attempt to restart xmonad by executing the program +-- @name@. If @resume@ is 'True', restart with the current window state. +-- When executing another window manager, @resume@ should be 'False'. +restart :: String -> Bool -> X () +restart prog resume = do + broadcastMessage ReleaseResources + io . flush =<< asks display + let wsData = show . W.mapLayout show . windowset + maybeShow (t, Right (PersistentExtension ext)) = Just (t, show ext) + maybeShow (t, Left str) = Just (t, str) + maybeShow _ = Nothing + extState = return . show . catMaybes . map maybeShow . M.toList . extensibleState + args <- if resume then gets (\s -> "--resume":wsData s:extState s) else return [] + catchIO (executeFile prog True args Nothing) + +------------------------------------------------------------------------ +-- | Floating layer support + +-- | Given a window, find the screen it is located on, and compute +-- the geometry of that window wrt. that screen. +floatLocation :: Window -> X (ScreenId, W.RationalRect) +floatLocation w = withDisplay $ \d -> do + ws <- gets windowset + wa <- io $ getWindowAttributes d w + let bw = (fromIntegral . wa_border_width) wa + sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa) + + let sr = screenRect . W.screenDetail $ sc + rr = W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr)) + ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr)) + (fi (wa_width wa + bw*2) % fi (rect_width sr)) + (fi (wa_height wa + bw*2) % fi (rect_height sr)) + + return (W.screen sc, rr) + where fi x = fromIntegral x + +-- | Given a point, determine the screen (if any) that contains it. +pointScreen :: Position -> Position + -> X (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)) +pointScreen x y = withWindowSet $ return . find p . W.screens + where p = pointWithin x y . screenRect . W.screenDetail + +-- | @pointWithin x y r@ returns 'True' if the @(x, y)@ co-ordinate is within +-- @r@. +pointWithin :: Position -> Position -> Rectangle -> Bool +pointWithin x y r = x >= rect_x r && + x < rect_x r + fromIntegral (rect_width r) && + y >= rect_y r && + y < rect_y r + fromIntegral (rect_height r) + +-- | Make a tiled window floating, using its suggested rectangle +{-float :: Window -> X () +float w = do + (sc, rr) <- floatLocation w + windows $ \ws -> W.float w rr . fromMaybe ws $ do + i <- W.findTag w ws + guard $ i `elem` concatMap (map W.tag . W.screenWorkspaces) (W.screens ws) + f <- W.peek ws + sw <- W.lookupWorkspace sc ws + return (W.focusWindow f . W.shiftWin sw w $ ws)-} + +-- --------------------------------------------------------------------- +-- Mouse handling + +-- | Accumulate mouse motion events +mouseDrag :: (Position -> Position -> X ()) -> X () -> X () +mouseDrag f done = do + drag <- gets dragging + case drag of + Just _ -> return () -- error case? we're already dragging + Nothing -> do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) + grabModeAsync grabModeAsync none none currentTime + modify $ \s -> s { dragging = Just (motion, cleanup) } + where + cleanup = do + withDisplay $ io . flip ungrabPointer currentTime + modify $ \s -> s { dragging = Nothing } + done + motion x y = do z <- f x y + clearEvents pointerMotionMask + return z + +-- | XXX comment me +{-mouseMoveWindow :: Window -> X () +mouseMoveWindow w = whenX (isClient w) $ withDisplay $ \d -> do + io $ raiseWindow d w + wa <- io $ getWindowAttributes d w + (_, _, _, ox', oy', _, _, _) <- io $ queryPointer d w + let ox = fromIntegral ox' + oy = fromIntegral oy' + mouseDrag (\ex ey -> io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) + (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))) + (float w) + +-- | XXX comment me +mouseResizeWindow :: Window -> X () +mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do + io $ raiseWindow d w + wa <- io $ getWindowAttributes d w + sh <- io $ getWMNormalHints d w + io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa)) + mouseDrag (\ex ey -> + io $ resizeWindow d w `uncurry` + applySizeHintsContents sh (ex - fromIntegral (wa_x wa), + ey - fromIntegral (wa_y wa))) + (float w)-} + +-- --------------------------------------------------------------------- +-- | Support for window size hints + +type D = (Dimension, Dimension) + +-- | Given a window, build an adjuster function that will reduce the given +-- dimensions according to the window's border width and size hints. +mkAdjust :: Window -> X (D -> D) +mkAdjust w = withDisplay $ \d -> liftIO $ do + sh <- getWMNormalHints d w + bw <- fmap (fromIntegral . wa_border_width) $ getWindowAttributes d w + return $ applySizeHints bw sh + +-- | Reduce the dimensions if needed to comply to the given SizeHints, taking +-- window borders into account. +applySizeHints :: Integral a => Dimension -> SizeHints -> (a, a) -> D +applySizeHints bw sh = + tmap (+ 2 * bw) . applySizeHintsContents sh . tmap (subtract $ 2 * fromIntegral bw) + where + tmap f (x, y) = (f x, f y) + +-- | Reduce the dimensions if needed to comply to the given SizeHints. +applySizeHintsContents :: Integral a => SizeHints -> (a, a) -> D +applySizeHintsContents sh (w, h) = + applySizeHints' sh (fromIntegral $ max 1 w, fromIntegral $ max 1 h) + +-- | XXX comment me +applySizeHints' :: SizeHints -> D -> D +applySizeHints' sh = + maybe id applyMaxSizeHint (sh_max_size sh) + . maybe id (\(bw, bh) (w, h) -> (w+bw, h+bh)) (sh_base_size sh) + . maybe id applyResizeIncHint (sh_resize_inc sh) + . maybe id applyAspectHint (sh_aspect sh) + . maybe id (\(bw,bh) (w,h) -> (w-bw, h-bh)) (sh_base_size sh) + +-- | Reduce the dimensions so their aspect ratio falls between the two given aspect ratios. +applyAspectHint :: (D, D) -> D -> D +applyAspectHint ((minx, miny), (maxx, maxy)) x@(w,h) + | or [minx < 1, miny < 1, maxx < 1, maxy < 1] = x + | w * maxy > h * maxx = (h * maxx `div` maxy, h) + | w * miny < h * minx = (w, w * miny `div` minx) + | otherwise = x + +-- | Reduce the dimensions so they are a multiple of the size increments. +applyResizeIncHint :: D -> D -> D +applyResizeIncHint (iw,ih) x@(w,h) = + if iw > 0 && ih > 0 then (w - w `mod` iw, h - h `mod` ih) else x + +-- | Reduce the dimensions if they exceed the given maximum dimensions. +applyMaxSizeHint :: D -> D -> D +applyMaxSizeHint (mw,mh) x@(w,h) = + if mw > 0 && mh > 0 then (min w mw,min h mh) else x diff --git a/MetaTile/StackSet.hs b/MetaTile/StackSet.hs new file mode 100644 index 0000000..907840c --- /dev/null +++ b/MetaTile/StackSet.hs @@ -0,0 +1,549 @@ +{-# LANGUAGE PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : MetaTile.StackSet +-- Copyright : (c) Don Stewart 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : dons@galois.com +-- Stability : experimental +-- Portability : portable, Haskell 98 +-- + +module MetaTile.StackSet ( + -- * Introduction + -- $intro + + -- ** The Zipper + -- $zipper + + -- ** Xinerama support + -- $xinerama + + -- ** Master and Focus + -- $focus + + StackSet(..), Workspace(..), Screen(..), Stack(..), RationalRect(..), + -- * Construction + -- $construction + new, view, greedyView, + -- * Xinerama operations + -- $xinerama + lookupWorkspace, + screens, screenWorkspaces, workspaces, hidden, allWindows, currentTag, + -- * Operations on the current stack + -- $stackOperations + peek, index, integrate, integrate', differentiate, + focusUp, focusDown, focusUp', focusDown', focusMaster, focusWindow, + tagMember, renameTag, member, findTag, mapWorkspace, mapLayout, + -- * Modifying the stackset + -- $modifyStackset + insertUp, delete, filter, + -- * Setting the master window + -- $settingMW + swapUp, swapDown, swapMaster, shiftMaster, modify, modify', -- needed by users + -- * Composite operations + -- $composite + shift, shiftWin, + + -- for testing + abort + ) where + +import Prelude hiding (filter) +import Data.Function (on) +import Data.Maybe (listToMaybe,isJust,fromMaybe) +import qualified Data.List as L (deleteBy,find,splitAt,filter,nub) + +-- $intro +-- +-- The 'StackSet' data type encodes a window manager abstraction. The +-- window manager is a set of virtual workspaces. On each workspace is a +-- stack of windows. A given workspace is always current, and a given +-- window on each workspace has focus. The focused window on the current +-- workspace is the one which will take user input. It can be visualised +-- as follows: +-- +-- > Workspace { 0*} { 1 } { 2 } { 3 } { 4 } +-- > +-- > Windows [1 [] [3* [6*] [] +-- > ,2*] ,4 +-- > ,5] +-- +-- Note that workspaces are indexed from 0, windows are numbered +-- uniquely. A '*' indicates the window on each workspace that has +-- focus, and which workspace is current. + +-- $zipper +-- +-- We encode all the focus tracking directly in the data structure, with a 'zipper': +-- +-- A Zipper is essentially an `updateable' and yet pure functional +-- cursor into a data structure. Zipper is also a delimited +-- continuation reified as a data structure. +-- +-- The Zipper lets us replace an item deep in a complex data +-- structure, e.g., a tree or a term, without an mutation. The +-- resulting data structure will share as much of its components with +-- the old structure as possible. +-- +-- Oleg Kiselyov, 27 Apr 2005, haskell\@, "Zipper as a delimited continuation" +-- +-- We use the zipper to keep track of the focused workspace and the +-- focused window on each workspace, allowing us to have correct focus +-- by construction. We closely follow Huet's original implementation: +-- +-- G. Huet, /Functional Pearl: The Zipper/, +-- 1997, J. Functional Programming 75(5):549-554. +-- and: +-- R. Hinze and J. Jeuring, /Functional Pearl: The Web/. +-- +-- and Conor McBride's zipper differentiation paper. +-- Another good reference is: +-- +-- The Zipper, Haskell wikibook + +-- $xinerama +-- Xinerama in X11 lets us view multiple virtual workspaces +-- simultaneously. While only one will ever be in focus (i.e. will +-- receive keyboard events), other workspaces may be passively +-- viewable. We thus need to track which virtual workspaces are +-- associated (viewed) on which physical screens. To keep track of +-- this, 'StackSet' keeps separate lists of visible but non-focused +-- workspaces, and non-visible workspaces. + +-- $focus +-- +-- Each stack tracks a focused item, and for tiling purposes also tracks +-- a 'master' position. The connection between 'master' and 'focus' +-- needs to be well defined, particularly in relation to 'insert' and +-- 'delete'. +-- + +------------------------------------------------------------------------ +-- | +-- A cursor into a non-empty list of workspaces. +-- +-- We puncture the workspace list, producing a hole in the structure +-- used to track the currently focused workspace. The two other lists +-- that are produced are used to track those workspaces visible as +-- Xinerama screens, and those workspaces not visible anywhere. + +data StackSet i l a sid sd = + StackSet { current :: !(Screen i l a sid sd) -- ^ currently focused workspace + , visible :: [Screen i l a sid sd] -- ^ non-focused workspaces, visible in xinerama + } deriving (Show, Read, Eq) + +-- | Visible workspaces, and their Xinerama screens. +data Screen i l a sid sd = Screen { screenWorkspace :: !(Workspace i l a) + , screenHidden :: [Workspace i l a] + , screen :: !sid + , screenDetail :: !sd } + deriving (Show, Read, Eq) + +-- | +-- A workspace is just a tag, a layout, and a stack. +-- +data Workspace i l a = Workspace { tag :: !i, layout :: l, stack :: Maybe (Stack a) } + deriving (Show, Read, Eq) + +-- | A structure for window geometries +data RationalRect = RationalRect Rational Rational Rational Rational + deriving (Show, Read, Eq) + +-- | +-- A stack is a cursor onto a window list. +-- The data structure tracks focus by construction, and +-- the master window is by convention the top-most item. +-- Focus operations will not reorder the list that results from +-- flattening the cursor. The structure can be envisaged as: +-- +-- > +-- master: < '7' > +-- > up | [ '2' ] +-- > +--------- [ '3' ] +-- > focus: < '4' > +-- > dn +----------- [ '8' ] +-- +-- A 'Stack' can be viewed as a list with a hole punched in it to make +-- the focused position. Under the zipper\/calculus view of such +-- structures, it is the differentiation of a [a], and integrating it +-- back has a natural implementation used in 'index'. +-- +data Stack a = Stack { focus :: !a -- focused thing in this set + , up :: [a] -- clowns to the left + , down :: [a] } -- jokers to the right + deriving (Show, Read, Eq) + + +-- | this function indicates to catch that an error is expected +abort :: String -> a +abort x = error $ "metatile: StackSet: " ++ x + +-- --------------------------------------------------------------------- +-- $construction + +-- | /O(n)/. Create a new stackset, of empty stacks, with given tags, +-- with physical screens whose descriptions are given by 'm'. The +-- number of physical screens (@length 'm'@) should be less than or +-- equal to the number of workspace tags. The first workspace in the +-- list will be current. +-- +-- Xinerama: Virtual workspaces are assigned to physical screens, starting at 0. +-- +new :: (Integral s) => l -> [i] -> [sd] -> StackSet i l a s sd +new l wids m | not (null wids) && length m <= length wids && not (null m) + = StackSet cur visi + where (seen,unseen) = L.splitAt (length m) $ map (\i -> Workspace i l Nothing) wids + cur = Screen (head seen) unseen 0 (head m) + visi = [ Screen i [] s sd | (i, s, sd) <- zip3 (tail seen) [1..] (tail m) ] + -- now zip up visibles with their screen id +new _ _ _ = abort "non-positive argument to StackSet.new" + +-- | +-- /O(w)/. Set focus to the workspace with index \'i\'. +-- If the index is out of range, return the original 'StackSet'. +-- +-- Xinerama: If the workspace is not visible on any Xinerama screen, it +-- becomes the current screen. If it is in the visible list, it becomes +-- current. + +view :: (Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd +view i s = s { current = head s', visible = tail s' } + where + s' = map makeVisible (current s : visible s) + + makeVisible scr + | Just x <- L.find ((i==) . tag) (screenHidden scr) = scr { screenWorkspace = x, screenHidden = (screenWorkspace scr) : L.deleteBy ((==) `on` tag) x (screenHidden scr)} + | otherwise = scr + + -- 'Catch'ing this might be hard. Relies on monotonically increasing + -- workspace tags defined in 'new' + -- + -- and now tags are not monotonic, what happens here? + +-- | +-- Set focus to the given workspace. If that workspace does not exist +-- in the stackset, the original workspace is returned. If that workspace is +-- 'hidden', then display that workspace on the current screen, and move the +-- current workspace to 'hidden'. If that workspace is 'visible' on another +-- screen, the workspaces of the current screen and the other screen are +-- swapped. + +greedyView :: (Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd +{-greedyView w ws + | any wTag (hidden ws) = view w ws + | (Just s) <- L.find (wTag . workspace) (visible ws) + = ws { current = (current ws) { workspace = workspace s } + , visible = s { workspace = workspace (current ws) } + : L.filter (not . wTag . workspace) (visible ws) } + | otherwise = ws + where wTag = (w == ) . tag-} +greedyView = view + +-- --------------------------------------------------------------------- +-- $xinerama + +-- | Find the tag of the workspace visible on Xinerama screen 'sc'. +-- 'Nothing' if screen is out of bounds. +lookupWorkspace :: Eq s => s -> StackSet i l a s sd -> Maybe i +lookupWorkspace sc w = listToMaybe [ tag i | Screen i _ s _ <- current w : visible w, s == sc ] + +-- --------------------------------------------------------------------- +-- $stackOperations + +-- | +-- The 'with' function takes a default value, a function, and a +-- StackSet. If the current stack is Nothing, 'with' returns the +-- default value. Otherwise, it applies the function to the stack, +-- returning the result. It is like 'maybe' for the focused workspace. +-- +with :: b -> (Stack a -> b) -> StackSet i l a s sd -> b +with dflt f = maybe dflt f . stack . screenWorkspace . current + +-- | +-- Apply a function, and a default value for 'Nothing', to modify the current stack. +-- +modify :: Maybe (Stack a) -> (Stack a -> Maybe (Stack a)) -> StackSet i l a s sd -> StackSet i l a s sd +modify d f s = s { current = (current s) + { screenWorkspace = (screenWorkspace (current s)) { stack = with d f s }}} + +-- | +-- Apply a function to modify the current stack if it isn't empty, and we don't +-- want to empty it. +-- +modify' :: (Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd +modify' f = modify Nothing (Just . f) + +-- | +-- /O(1)/. Extract the focused element of the current stack. +-- Return 'Just' that element, or 'Nothing' for an empty stack. +-- +peek :: StackSet i l a s sd -> Maybe a +peek = with Nothing (return . focus) + +-- | +-- /O(n)/. Flatten a 'Stack' into a list. +-- +integrate :: Stack a -> [a] +integrate (Stack x l r) = reverse l ++ x : r + +-- | +-- /O(n)/ Flatten a possibly empty stack into a list. +integrate' :: Maybe (Stack a) -> [a] +integrate' = maybe [] integrate + +-- | +-- /O(n)/. Turn a list into a possibly empty stack (i.e., a zipper): +-- the first element of the list is current, and the rest of the list +-- is down. +differentiate :: [a] -> Maybe (Stack a) +differentiate [] = Nothing +differentiate (x:xs) = Just $ Stack x [] xs + +-- | +-- /O(n)/. 'filter p s' returns the elements of 's' such that 'p' evaluates to +-- 'True'. Order is preserved, and focus moves as described for 'delete'. +-- +filter :: (a -> Bool) -> Stack a -> Maybe (Stack a) +filter p (Stack f ls rs) = case L.filter p (f:rs) of + f':rs' -> Just $ Stack f' (L.filter p ls) rs' -- maybe move focus down + [] -> case L.filter p ls of -- filter back up + f':ls' -> Just $ Stack f' ls' [] -- else up + [] -> Nothing + +-- | +-- /O(s)/. Extract the stack on the current workspace, as a list. +-- The order of the stack is determined by the master window -- it will be +-- the head of the list. The implementation is given by the natural +-- integration of a one-hole list cursor, back to a list. +-- +index :: StackSet i l a s sd -> [a] +index = with [] integrate + +-- | +-- /O(1), O(w) on the wrapping case/. +-- +-- focusUp, focusDown. Move the window focus up or down the stack, +-- wrapping if we reach the end. The wrapping should model a 'cycle' +-- on the current stack. The 'master' window, and window order, +-- are unaffected by movement of focus. +-- +-- swapUp, swapDown, swap the neighbour in the stack ordering, wrapping +-- if we reach the end. Again the wrapping model should 'cycle' on +-- the current stack. +-- +focusUp, focusDown, swapUp, swapDown :: StackSet i l a s sd -> StackSet i l a s sd +focusUp = modify' focusUp' +focusDown = modify' focusDown' + +swapUp = modify' swapUp' +swapDown = modify' (reverseStack . swapUp' . reverseStack) + +-- | Variants of 'focusUp' and 'focusDown' that work on a +-- 'Stack' rather than an entire 'StackSet'. +focusUp', focusDown' :: Stack a -> Stack a +focusUp' (Stack t (l:ls) rs) = Stack l ls (t:rs) +focusUp' (Stack t [] rs) = Stack x xs [] where (x:xs) = reverse (t:rs) +focusDown' = reverseStack . focusUp' . reverseStack + +swapUp' :: Stack a -> Stack a +swapUp' (Stack t (l:ls) rs) = Stack t ls (l:rs) +swapUp' (Stack t [] rs) = Stack t (reverse rs) [] + +-- | reverse a stack: up becomes down and down becomes up. +reverseStack :: Stack a -> Stack a +reverseStack (Stack t ls rs) = Stack t rs ls + +-- +-- | /O(1) on current window, O(n) in general/. Focus the window 'w', +-- and set its workspace as current. +-- +focusWindow :: (Eq s, Eq a, Eq i) => a -> StackSet i l a s sd -> StackSet i l a s sd +focusWindow w s | Just w == peek s = s + | otherwise = fromMaybe s $ do + n <- findTag w s + return $ until ((Just w ==) . peek) focusUp (view n s) + +-- | Get a list of all screens in the 'StackSet'. +screens :: StackSet i l a s sd -> [Screen i l a s sd] +screens s = current s : visible s + +-- | Get a list of all workspaces in the 'StackSet'. +workspaces :: StackSet i l a s sd -> [Workspace i l a] +workspaces s = concatMap screenWorkspaces $ (current s) : (visible s) + +screenWorkspaces :: Screen i l a sid sd -> [Workspace i l a] +screenWorkspaces scr = screenWorkspace scr : screenHidden scr + +hidden :: StackSet i l a s sd -> [Workspace i l a] +hidden = concatMap screenHidden . screens + +-- | Get a list of all windows in the 'StackSet' in no particular order +allWindows :: Eq a => StackSet i l a s sd -> [a] +allWindows = L.nub . concatMap (integrate' . stack) . workspaces + +-- | Get the tag of the currently focused workspace. +currentTag :: StackSet i l a s sd -> i +currentTag = tag . screenWorkspace . current + +-- | Is the given tag present in the 'StackSet'? +tagMember :: Eq i => i -> StackSet i l a s sd -> Bool +tagMember t = elem t . map tag . workspaces + +-- | Rename a given tag if present in the 'StackSet'. +renameTag :: Eq i => i -> i -> StackSet i l a s sd -> StackSet i l a s sd +renameTag o n = mapWorkspace rename + where rename w = if tag w == o then w { tag = n } else w + +-- | Ensure that a given set of workspace tags is present by renaming +-- existing workspaces and\/or creating new hidden workspaces as +-- necessary. +{-ensureTags :: Eq i => l -> [i] -> StackSet i l a s sd -> StackSet i l a s sd +ensureTags l allt st = et allt (map tag (workspaces st) \\ allt) st + where et [] _ s = s + et (i:is) rn s | i `tagMember` s = et is rn s + et (i:is) [] s = et is [] (s { hidden = Workspace i l Nothing : hidden s }) + et (i:is) (r:rs) s = et is rs $ renameTag r i s-} + +-- | Map a function on all the workspaces in the 'StackSet'. +mapWorkspace :: (Workspace i l a -> Workspace i l a) -> StackSet i l a s sd -> StackSet i l a s sd +mapWorkspace f s = s { current = updScr (current s) + , visible = map updScr (visible s) } + where updScr scr = scr { screenWorkspace = f (screenWorkspace scr), screenHidden = map f (screenHidden scr) } + +-- | Map a function on all the layouts in the 'StackSet'. +mapLayout :: (l -> l') -> StackSet i l a s sd -> StackSet i l' a s sd +mapLayout f (StackSet v vs) = StackSet (fScreen v) (map fScreen vs) + where + fScreen (Screen ws hd s sd) = Screen (fWorkspace ws) (map fWorkspace hd) s sd + fWorkspace (Workspace t l s) = Workspace t (f l) s + +-- | /O(n)/. Is a window in the 'StackSet'? +member :: Eq a => a -> StackSet i l a s sd -> Bool +member a s = isJust (findTag a s) + +-- | /O(1) on current window, O(n) in general/. +-- Return 'Just' the workspace tag of the given window, or 'Nothing' +-- if the window is not in the 'StackSet'. +findTag :: Eq a => a -> StackSet i l a s sd -> Maybe i +findTag a s = listToMaybe + [ tag w | w <- workspaces s, has a (stack w) ] + where has _ Nothing = False + has x (Just (Stack t l r)) = x `elem` (t : l ++ r) + +-- --------------------------------------------------------------------- +-- $modifyStackset + +-- | +-- /O(n)/. (Complexity due to duplicate check). Insert a new element +-- into the stack, above the currently focused element. The new +-- element is given focus; the previously focused element is moved +-- down. +-- +-- If the element is already in the stackset, the original stackset is +-- returned unmodified. +-- +-- Semantics in Huet's paper is that insert doesn't move the cursor. +-- However, we choose to insert above, and move the focus. +-- +insertUp :: Eq a => a -> StackSet i l a s sd -> StackSet i l a s sd +insertUp a s = if member a s then s else insert + where insert = modify (Just $ Stack a [] []) (\(Stack t l r) -> Just $ Stack a l (t:r)) s + +-- insertDown :: a -> StackSet i l a s sd -> StackSet i l a s sd +-- insertDown a = modify (Stack a [] []) $ \(Stack t l r) -> Stack a (t:l) r +-- Old semantics, from Huet. +-- > w { down = a : down w } + +-- | +-- /O(1) on current window, O(n) in general/. Delete window 'w' if it exists. +-- There are 4 cases to consider: +-- +-- * delete on an 'Nothing' workspace leaves it Nothing +-- +-- * otherwise, try to move focus to the down +-- +-- * otherwise, try to move focus to the up +-- +-- * otherwise, you've got an empty workspace, becomes 'Nothing' +-- +-- Behaviour with respect to the master: +-- +-- * deleting the master window resets it to the newly focused window +-- +-- * otherwise, delete doesn't affect the master. +-- +-- | Only temporarily remove the window from the stack, thereby not destroying special +-- information saved in the 'Stackset' +delete :: (Eq a, Eq s) => a -> StackSet i l a s sd -> StackSet i l a s sd +delete w s = mapWorkspace removeFromWorkspace s + where removeFromWorkspace ws = ws { stack = stack ws >>= filter (/=w) } + +------------------------------------------------------------------------ + +-- | Given a window, and its preferred rectangle, set it as floating +-- A floating window should already be managed by the 'StackSet'. +--float :: Ord a => a -> RationalRect -> StackSet i l a s sd -> StackSet i l a s sd +--float w r s = s { floating = M.insert w r (floating s) } + +-- | Clear the floating status of a window +--sink :: Ord a => a -> StackSet i l a s sd -> StackSet i l a s sd +--sink w s = s { floating = M.delete w (floating s) } + +------------------------------------------------------------------------ +-- $settingMW + +-- | /O(s)/. Set the master window to the focused window. +-- The old master window is swapped in the tiling order with the focused window. +-- Focus stays with the item moved. +swapMaster :: StackSet i l a s sd -> StackSet i l a s sd +swapMaster = modify' $ \c -> case c of + Stack _ [] _ -> c -- already master. + Stack t ls rs -> Stack t [] (xs ++ x : rs) where (x:xs) = reverse ls + +-- natural! keep focus, move current to the top, move top to current. + +-- | /O(s)/. Set the master window to the focused window. +-- The other windows are kept in order and shifted down on the stack, as if you +-- just hit mod-shift-k a bunch of times. +-- Focus stays with the item moved. +shiftMaster :: StackSet i l a s sd -> StackSet i l a s sd +shiftMaster = modify' $ \c -> case c of + Stack _ [] _ -> c -- already master. + Stack t ls rs -> Stack t [] (reverse ls ++ rs) + +-- | /O(s)/. Set focus to the master window. +focusMaster :: StackSet i l a s sd -> StackSet i l a s sd +focusMaster = modify' $ \c -> case c of + Stack _ [] _ -> c + Stack t ls rs -> Stack x [] (xs ++ t : rs) where (x:xs) = reverse ls + +-- +-- --------------------------------------------------------------------- +-- $composite + +-- | /O(w)/. shift. Move the focused element of the current stack to stack +-- 'n', leaving it as the focused element on that stack. The item is +-- inserted above the currently focused element on that workspace. +-- The actual focused workspace doesn't change. If there is no +-- element on the current stack, the original stackSet is returned. +-- +shift :: (Ord a, Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd +shift n s = maybe s (\w -> shiftWin n w s) (peek s) + +-- | /O(n)/. shiftWin. Searches for the specified window 'w' on all workspaces +-- of the stackSet and moves it to stack 'n', leaving it as the focused +-- element on that stack. The item is inserted above the currently +-- focused element on that workspace. +-- The actual focused workspace doesn't change. If the window is not +-- found in the stackSet, the original stackSet is returned. +shiftWin :: (Ord a, Eq a, Eq s, Eq i) => i -> a -> StackSet i l a s sd -> StackSet i l a s sd +shiftWin n w s = case findTag w s of + Just from | n `tagMember` s && n /= from -> go from s + _ -> s + where go from = onWorkspace n (insertUp w) . onWorkspace from (delete w) + +onWorkspace :: (Eq i, Eq s) => i -> (StackSet i l a s sd -> StackSet i l a s sd) + -> (StackSet i l a s sd -> StackSet i l a s sd) +onWorkspace n f s = view (currentTag s) . f . view n $ s diff --git a/XMonad.hs b/XMonad.hs deleted file mode 100644 index c1fc5dc..0000000 --- a/XMonad.hs +++ /dev/null @@ -1,47 +0,0 @@ --------------------------------------------------------------------- --- | --- Module : XMonad --- Copyright : (c) Don Stewart --- License : BSD3 --- --- Maintainer: Don Stewart --- Stability : provisional --- Portability: --- --------------------------------------------------------------------- --- --- Useful exports for configuration files. - -module XMonad ( - - module XMonad.Main, - module XMonad.Core, - module XMonad.Config, - module XMonad.Layout, - module XMonad.ManageHook, - module XMonad.Operations, - module Graphics.X11, - module Graphics.X11.Xlib.Extras, - (.|.), - MonadState(..), gets, modify, - MonadReader(..), asks, - MonadIO(..) - - ) where - --- core modules -import XMonad.Main -import XMonad.Core -import XMonad.Config -import XMonad.Layout -import XMonad.ManageHook -import XMonad.Operations --- import XMonad.StackSet -- conflicts with 'workspaces' defined in XMonad.hs - --- modules needed to get basic configuration working -import Data.Bits -import Graphics.X11 hiding (refreshKeyboardMapping) -import Graphics.X11.Xlib.Extras - -import Control.Monad.State -import Control.Monad.Reader diff --git a/XMonad/Config.hs b/XMonad/Config.hs deleted file mode 100644 index 1405fd1..0000000 --- a/XMonad/Config.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# OPTIONS -fno-warn-missing-signatures -fno-warn-orphans #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : XMonad.Config --- Copyright : (c) Spencer Janssen 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : dons@galois.com --- Stability : stable --- Portability : portable --- --- This module specifies the default configuration values for xmonad. --- --- DO NOT MODIFY THIS FILE! It won't work. You may configure xmonad --- by providing your own @~\/.xmonad\/xmonad.hs@ that overrides --- specific fields in the default config, 'def'. For a starting point, you can --- copy the @xmonad.hs@ found in the @man@ directory, or look at --- examples on the xmonad wiki. --- ------------------------------------------------------------------------- - -module XMonad.Config (defaultConfig, Default(..)) where - --- --- Useful imports --- -import XMonad.Core as XMonad hiding - (workspaces,manageHook,keys,logHook,startupHook,mouseBindings - ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,defaultBorderWidth,focusFollowsMouse - ,handleEventHook,clickJustFocuses,rootMask,frameMask,clientMask) -import qualified XMonad.Core as XMonad - (workspaces,manageHook,keys,logHook,startupHook,mouseBindings - ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,defaultBorderWidth,focusFollowsMouse - ,handleEventHook,clickJustFocuses,rootMask,frameMask,clientMask) - -import XMonad.Layout -import XMonad.Operations -import qualified XMonad.StackSet as W -import Data.Bits ((.|.)) -import Data.Default -import Data.Monoid -import qualified Data.Map as M -import System.Exit -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras - --- | The default number of workspaces (virtual screens) and their names. --- By default we use numeric strings, but any string may be used as a --- workspace name. The number of workspaces is determined by the length --- of this list. --- --- A tagging example: --- --- > workspaces = ["web", "irc", "code" ] ++ map show [4..9] --- -workspaces :: [WorkspaceId] -workspaces = map show [1 .. 9 :: Int] - --- | modMask lets you specify which modkey you want to use. The default --- is mod1Mask ("left alt"). You may also consider using mod3Mask --- ("right alt"), which does not conflict with emacs keybindings. The --- "windows key" is usually mod4Mask. --- -defaultModMask :: KeyMask -defaultModMask = mod1Mask - --- | Border colors for unfocused and focused windows, respectively. --- -normalBorderColor, focusedBorderColor :: String -normalBorderColor = "gray" -- "#dddddd" -focusedBorderColor = "red" -- "#ff0000" don't use hex, not <24 bit safe - -defaultBorderWidth :: BorderWidth -defaultBorderWidth = BorderWidth 1 1 1 1 - ------------------------------------------------------------------------- --- Window rules - --- | Execute arbitrary actions and WindowSet manipulations when managing --- a new window. You can use this to, for example, always float a --- particular program, or have a client always appear on a particular --- workspace. --- --- To find the property name associated with a program, use --- xprop | grep WM_CLASS --- and click on the client you're interested in. --- -manageHook :: ManageHook -manageHook = mempty - ------------------------------------------------------------------------- --- Logging - --- | Perform an arbitrary action on each internal state change or X event. --- Examples include: --- --- * do nothing --- --- * log the state to stdout --- --- See the 'DynamicLog' extension for examples. --- -logHook :: X () -logHook = return () - ------------------------------------------------------------------------- --- Event handling - --- | Defines a custom handler function for X Events. The function should --- return (All True) if the default handler is to be run afterwards. --- To combine event hooks, use mappend or mconcat from Data.Monoid. -handleEventHook :: Event -> X All -handleEventHook _ = return (All True) - --- | Perform an arbitrary action at xmonad startup. -startupHook :: X () -startupHook = return () - ------------------------------------------------------------------------- --- Extensible layouts --- --- You can specify and transform your layouts by modifying these values. --- If you change layout bindings be sure to use 'mod-shift-space' after --- restarting (with 'mod-q') to reset your layout state to the new --- defaults, as xmonad preserves your old layout settings by default. --- - --- | The available layouts. Note that each layout is separated by |||, which --- denotes layout choice. -layout = tiled ||| Mirror tiled ||| Full - where - -- default tiling algorithm partitions the screen into two panes - tiled = Tall nmaster delta ratio - - -- The default number of windows in the master pane - nmaster = 1 - - -- Default proportion of screen occupied by master pane - ratio = 1/2 - - -- Percent of screen to increment by when resizing panes - delta = 3/100 - ------------------------------------------------------------------------- --- Event Masks: - --- | The client events that xmonad is interested in -clientMask :: EventMask -clientMask = structureNotifyMask .|. enterWindowMask .|. propertyChangeMask - --- | The frame events that xmonad is interested in -frameMask :: EventMask -frameMask = substructureRedirectMask .|. substructureNotifyMask - --- | The root events that xmonad is interested in -rootMask :: EventMask -rootMask = substructureRedirectMask .|. substructureNotifyMask - .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask - .|. buttonPressMask - ------------------------------------------------------------------------- --- Key bindings: - --- | The preferred terminal program, which is used in a binding below and by --- certain contrib modules. -terminal :: String -terminal = "xterm" - --- | Whether focus follows the mouse pointer. -focusFollowsMouse :: Bool -focusFollowsMouse = True - --- | Whether a mouse click select the focus or is just passed to the window -clickJustFocuses :: Bool -clickJustFocuses = True - - --- | The xmonad key bindings. Add, modify or remove key bindings here. --- --- (The comment formatting character is used when generating the manpage) --- -keys :: XConfig Layout -> M.Map (KeyMask, KeySym) (X ()) -keys conf@(XConfig {XMonad.modMask = modMask}) = M.fromList $ - -- launching and killing programs - [ ((modMask .|. shiftMask, xK_Return), spawn $ XMonad.terminal conf) -- %! Launch terminal - , ((modMask, xK_p ), spawn "dmenu_run") -- %! Launch dmenu - , ((modMask .|. shiftMask, xK_p ), spawn "gmrun") -- %! Launch gmrun - , ((modMask .|. shiftMask, xK_c ), kill) -- %! Close the focused window - - , ((modMask, xK_space ), sendMessage NextLayout) -- %! Rotate through the available layout algorithms - , ((modMask .|. shiftMask, xK_space ), setLayout $ XMonad.layoutHook conf) -- %! Reset the layouts on the current workspace to default - - , ((modMask, xK_n ), refresh) -- %! Resize viewed windows to the correct size - - -- move focus up or down the window stack - , ((modMask, xK_Tab ), windows W.focusDown) -- %! Move focus to the next window - , ((modMask .|. shiftMask, xK_Tab ), windows W.focusUp ) -- %! Move focus to the previous window - , ((modMask, xK_j ), windows W.focusDown) -- %! Move focus to the next window - , ((modMask, xK_k ), windows W.focusUp ) -- %! Move focus to the previous window - , ((modMask, xK_m ), windows W.focusMaster ) -- %! Move focus to the master window - - -- modifying the window order - , ((modMask, xK_Return), windows W.swapMaster) -- %! Swap the focused window and the master window - , ((modMask .|. shiftMask, xK_j ), windows W.swapDown ) -- %! Swap the focused window with the next window - , ((modMask .|. shiftMask, xK_k ), windows W.swapUp ) -- %! Swap the focused window with the previous window - - -- resizing the master/slave ratio - , ((modMask, xK_h ), sendMessage Shrink) -- %! Shrink the master area - , ((modMask, xK_l ), sendMessage Expand) -- %! Expand the master area - - -- increase or decrease number of windows in the master area - , ((modMask , xK_comma ), sendMessage (IncMasterN 1)) -- %! Increment the number of windows in the master area - , ((modMask , xK_period), sendMessage (IncMasterN (-1))) -- %! Deincrement the number of windows in the master area - - -- quit, or restart - , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- %! Quit xmonad - , ((modMask , xK_q ), spawn "if type xmonad; then xmonad --recompile && xmonad --restart; else xmessage xmonad not in \\$PATH: \"$PATH\"; fi") -- %! Restart xmonad - - , ((modMask .|. shiftMask, xK_slash ), spawn ("echo \"" ++ help ++ "\" | xmessage -file -")) -- %! Run xmessage with a summary of the default keybindings (useful for beginners) - -- repeat the binding for non-American layout keyboards - , ((modMask , xK_question), spawn ("echo \"" ++ help ++ "\" | xmessage -file -")) - ] - ++ - -- mod-[1..9] %! Switch to workspace N - -- mod-shift-[1..9] %! Move client to workspace N - [((m .|. modMask, k), windows $ f i) - | (i, k) <- zip (XMonad.workspaces conf) [xK_1 .. xK_9] - , (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]] - ++ - -- mod-{w,e,r} %! Switch to physical/Xinerama screens 1, 2, or 3 - -- mod-shift-{w,e,r} %! Move client to screen 1, 2, or 3 - [((m .|. modMask, key), screenWorkspace sc >>= flip whenJust (windows . f)) - | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..] - , (f, m) <- [(W.view, 0), (W.shift, shiftMask)]] - --- | Mouse bindings: default actions bound to mouse events -mouseBindings :: XConfig Layout -> M.Map (KeyMask, Button) (Window -> X ()) -mouseBindings (XConfig {XMonad.modMask = modMask}) = M.fromList - -- mod-button2 %! Raise the window to the top of the stack - [ ((modMask, button2), windows . (W.shiftMaster .) . W.focusWindow) - -- you may also bind events to the mouse scroll wheel (button4 and button5) - ] - -instance (a ~ Choose Tall (Choose (Mirror Tall) Full)) => Default (XConfig a) where - def = XConfig - { XMonad.workspaces = workspaces - , XMonad.layoutHook = layout - , XMonad.terminal = terminal - , XMonad.normalBorderColor = normalBorderColor - , XMonad.focusedBorderColor = focusedBorderColor - , XMonad.defaultBorderWidth = defaultBorderWidth - , XMonad.modMask = defaultModMask - , XMonad.keys = keys - , XMonad.logHook = logHook - , XMonad.startupHook = startupHook - , XMonad.mouseBindings = mouseBindings - , XMonad.manageHook = manageHook - , XMonad.handleEventHook = handleEventHook - , XMonad.focusFollowsMouse = focusFollowsMouse - , XMonad.clickJustFocuses = clickJustFocuses - , XMonad.clientMask = clientMask - , XMonad.frameMask = frameMask - , XMonad.rootMask = rootMask - } - --- | The default set of configuration values itself -{-# DEPRECATED defaultConfig "Use def (from Data.Default, and re-exported by XMonad and XMonad.Config) instead." #-} -defaultConfig :: XConfig (Choose Tall (Choose (Mirror Tall) Full)) -defaultConfig = def - --- | Finally, a copy of the default bindings in simple textual tabular format. -help :: String -help = unlines ["The default modifier key is 'alt'. Default keybindings:", - "", - "-- launching and killing programs", - "mod-Shift-Enter Launch xterminal", - "mod-p Launch dmenu", - "mod-Shift-p Launch gmrun", - "mod-Shift-c Close/kill the focused window", - "mod-Space Rotate through the available layout algorithms", - "mod-Shift-Space Reset the layouts on the current workSpace to default", - "mod-n Resize/refresh viewed windows to the correct size", - "", - "-- move focus up or down the window stack", - "mod-Tab Move focus to the next window", - "mod-Shift-Tab Move focus to the previous window", - "mod-j Move focus to the next window", - "mod-k Move focus to the previous window", - "mod-m Move focus to the master window", - "", - "-- modifying the window order", - "mod-Return Swap the focused window and the master window", - "mod-Shift-j Swap the focused window with the next window", - "mod-Shift-k Swap the focused window with the previous window", - "", - "-- resizing the master/slave ratio", - "mod-h Shrink the master area", - "mod-l Expand the master area", - "", - "-- floating layer support", - "mod-t Push window back into tiling; unfloat and re-tile it", - "", - "-- increase or decrease number of windows in the master area", - "mod-comma (mod-,) Increment the number of windows in the master area", - "mod-period (mod-.) Deincrement the number of windows in the master area", - "", - "-- quit, or restart", - "mod-Shift-q Quit xmonad", - "mod-q Restart xmonad", - "mod-[1..9] Switch to workSpace N", - "", - "-- Workspaces & screens", - "mod-Shift-[1..9] Move client to workspace N", - "mod-{w,e,r} Switch to physical/Xinerama screens 1, 2, or 3", - "mod-Shift-{w,e,r} Move client to screen 1, 2, or 3", - "", - "-- Mouse bindings: default actions bound to mouse events", - "mod-button1 Set the window to floating mode and move by dragging", - "mod-button2 Raise the window to the top of the stack", - "mod-button3 Set the window to floating mode and resize by dragging"] diff --git a/XMonad/Core.hs b/XMonad/Core.hs deleted file mode 100644 index 18ca213..0000000 --- a/XMonad/Core.hs +++ /dev/null @@ -1,574 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, PatternGuards, - MultiParamTypeClasses, TypeSynonymInstances, CPP, DeriveDataTypeable #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonad.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 XMonad.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, getXMonadDir, recompile, trace, whenJust, whenX, - atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_TAKE_FOCUS, ManageHook, Query(..), runQuery - ) where - -import XMonad.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 "XMonad.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, - -- "XMonad.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 @~\/.xmonad@. -getXMonadDir :: MonadIO m => m String -getXMonadDir = io $ getAppUserDataDirectory "xmonad" - --- | 'recompile force', recompile @~\/.xmonad\/xmonad.hs@ when any of the --- following apply: --- --- * force is 'True' --- --- * the xmonad executable does not exist --- --- * the xmonad executable is older than xmonad.hs or any file in --- ~\/.xmonad\/lib --- --- The -i flag is used to restrict recompilation to the xmonad.hs file only, --- and any files in the ~\/.xmonad\/lib directory. --- --- Compilation errors (if any) are logged to ~\/.xmonad\/xmonad.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 <- 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 || any (binT <) (srcT : libTs) - then do - -- temporarily disable SIGCHLD ignoring: - uninstallSignalHandlers - status <- bracket (openFile err WriteMode) hClose $ \h -> - waitForProcess =<< runProcess "ghc" ["--make", "xmonad.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 xmonad 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 () diff --git a/XMonad/Layout.hs b/XMonad/Layout.hs deleted file mode 100644 index 8eff488..0000000 --- a/XMonad/Layout.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances, DeriveDataTypeable #-} - --- -------------------------------------------------------------------------- --- | --- Module : XMonad.Layout --- Copyright : (c) Spencer Janssen 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : spencerjanssen@gmail.com --- Stability : unstable --- Portability : not portable, Typeable deriving, mtl, posix --- --- The collection of core layouts. --- ------------------------------------------------------------------------------ - -module XMonad.Layout ( - Full(..), Tall(..), Mirror(..), - Resize(..), IncMasterN(..), Choose, (|||), ChangeLayout(..), - mirrorRect, splitVertically, - splitHorizontally, splitHorizontallyBy, splitVerticallyBy, - - tile - - ) where - -import XMonad.Core - -import Graphics.X11 (Rectangle(..)) -import qualified XMonad.StackSet as W -import Control.Arrow ((***), second) -import Control.Monad -import Data.Maybe (fromMaybe) - ------------------------------------------------------------------------- - --- | Change the size of the master pane. -data Resize = Shrink | Expand deriving Typeable - --- | Increase the number of clients in the master pane. -data IncMasterN = IncMasterN !Int deriving Typeable - -instance Message Resize -instance Message IncMasterN - --- | Simple fullscreen mode. Renders the focused window fullscreen. -data Full a = Full deriving (Show, Read) - -instance LayoutClass Full a - --- | The builtin tiling mode of xmonad. Supports 'Shrink', 'Expand' and --- 'IncMasterN'. -data Tall a = Tall { tallNMaster :: !Int -- ^ The default number of windows in the master pane (default: 1) - , tallRatioIncrement :: !Rational -- ^ Percent of screen to increment by when resizing panes (default: 3/100) - , tallRatio :: !Rational -- ^ Default proportion of screen occupied by master pane (default: 1/2) - } - deriving (Show, Read) - -- TODO should be capped [0..1] .. - --- a nice pure layout, lots of properties for the layout, and its messages, in Properties.hs -instance LayoutClass Tall a where - pureLayout (Tall nmaster _ frac) r s = zip ws rs - where ws = W.integrate s - rs = tile frac r nmaster (length ws) - - pureMessage (Tall nmaster delta frac) m = - msum [fmap resize (fromMessage m) - ,fmap incmastern (fromMessage m)] - - where resize Shrink = Tall nmaster delta (max 0 $ frac-delta) - resize Expand = Tall nmaster delta (min 1 $ frac+delta) - incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac - - description _ = "Tall" - --- | Compute the positions for windows using the default two-pane tiling --- algorithm. --- --- The screen is divided into two panes. All clients are --- then partioned between these two panes. One pane, the master, by --- convention has the least number of windows in it. -tile - :: Rational -- ^ @frac@, what proportion of the screen to devote to the master area - -> Rectangle -- ^ @r@, the rectangle representing the screen - -> Int -- ^ @nmaster@, the number of windows in the master pane - -> Int -- ^ @n@, the total number of windows to tile - -> [Rectangle] -tile f r nmaster n = if n <= nmaster || nmaster == 0 - then splitVertically n r - else splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns - where (r1,r2) = splitHorizontallyBy f r - --- --- Divide the screen vertically into n subrectangles --- -splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle] -splitVertically n r | n < 2 = [r] -splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh : - splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) - where smallh = sh `div` fromIntegral n --hmm, this is a fold or map. - --- Not used in the core, but exported -splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect - --- Divide the screen into two rectangles, using a rational to specify the ratio -splitHorizontallyBy, splitVerticallyBy :: RealFrac r => r -> Rectangle -> (Rectangle, Rectangle) -splitHorizontallyBy f (Rectangle sx sy sw sh) = - ( Rectangle sx sy leftw sh - , Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh) - where leftw = floor $ fromIntegral sw * f - --- Not used in the core, but exported -splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect - ------------------------------------------------------------------------- - --- | Mirror a layout, compute its 90 degree rotated form. -newtype Mirror l a = Mirror (l a) deriving (Show, Read) - -instance LayoutClass l a => LayoutClass (Mirror l) a where - runLayout (W.Workspace i (Mirror l) ms) r = (map (second mirrorRect) *** fmap Mirror) - `fmap` runLayout (W.Workspace i l ms) (mirrorRect r) - handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l - description (Mirror l) = "Mirror "++ description l - --- | Mirror a rectangle. -mirrorRect :: Rectangle -> Rectangle -mirrorRect (Rectangle rx ry rw rh) = Rectangle ry rx rh rw - ------------------------------------------------------------------------- --- LayoutClass selection manager --- Layouts that transition between other layouts - --- | Messages to change the current layout. -data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable) - -instance Message ChangeLayout - --- | The layout choice combinator -(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a -(|||) = Choose L -infixr 5 ||| - --- | A layout that allows users to switch between various layout options. -data Choose l r a = Choose LR (l a) (r a) deriving (Read, Show) - --- | Are we on the left or right sub-layout? -data LR = L | R deriving (Read, Show, Eq) - -data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable) -instance Message NextNoWrap - --- | A small wrapper around handleMessage, as it is tedious to write --- SomeMessage repeatedly. -handle :: (LayoutClass l a, Message m) => l a -> m -> X (Maybe (l a)) -handle l m = handleMessage l (SomeMessage m) - --- | A smart constructor that takes some potential modifications, returns a --- new structure if any fields have changed, and performs any necessary cleanup --- on newly non-visible layouts. -choose :: (LayoutClass l a, LayoutClass r a) - => Choose l r a-> LR -> Maybe (l a) -> Maybe (r a) -> X (Maybe (Choose l r a)) -choose (Choose d _ _) d' Nothing Nothing | d == d' = return Nothing -choose (Choose d l r) d' ml mr = f lr - where - (l', r') = (fromMaybe l ml, fromMaybe r mr) - lr = case (d, d') of - (L, R) -> (hide l' , return r') - (R, L) -> (return l', hide r' ) - (_, _) -> (return l', return r') - f (x,y) = fmap Just $ liftM2 (Choose d') x y - hide x = fmap (fromMaybe x) $ handle x Hide - -instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where - runLayout (W.Workspace i (Choose L l r) ms) = - fmap (second . fmap $ flip (Choose L) r) . runLayout (W.Workspace i l ms) - runLayout (W.Workspace i (Choose R l r) ms) = - fmap (second . fmap $ Choose R l) . runLayout (W.Workspace i r ms) - - description (Choose L l _) = description l - description (Choose R _ r) = description r - - handleMessage lr m | Just NextLayout <- fromMessage m = do - mlr' <- handle lr NextNoWrap - maybe (handle lr FirstLayout) (return . Just) mlr' - - handleMessage c@(Choose d l r) m | Just NextNoWrap <- fromMessage m = - case d of - L -> do - ml <- handle l NextNoWrap - case ml of - Just _ -> choose c L ml Nothing - Nothing -> choose c R Nothing =<< handle r FirstLayout - - R -> choose c R Nothing =<< handle r NextNoWrap - - handleMessage c@(Choose _ l _) m | Just FirstLayout <- fromMessage m = - flip (choose c L) Nothing =<< handle l FirstLayout - - handleMessage c@(Choose d l r) m | Just ReleaseResources <- fromMessage m = - join $ liftM2 (choose c d) (handle l ReleaseResources) (handle r ReleaseResources) - - handleMessage c@(Choose d l r) m = do - ml' <- case d of - L -> handleMessage l m - R -> return Nothing - mr' <- case d of - L -> return Nothing - R -> handleMessage r m - choose c d ml' mr' diff --git a/XMonad/Main.hsc b/XMonad/Main.hsc deleted file mode 100644 index 224631c..0000000 --- a/XMonad/Main.hsc +++ /dev/null @@ -1,433 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, ForeignFunctionInterface #-} ----------------------------------------------------------------------------- --- | --- Module : XMonad.Main --- Copyright : (c) Spencer Janssen 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : spencerjanssen@gmail.com --- Stability : unstable --- Portability : not portable, uses mtl, X11, posix --- --- xmonad, a minimalist, tiling window manager for X11 --- ------------------------------------------------------------------------------ - -module XMonad.Main (xmonad) where - -import Control.Arrow (second) -import Data.Bits -import Data.List ((\\)) -import Data.Function -import qualified Data.Map as M -import Control.Monad.Reader -import Control.Monad.State -import Data.Maybe (fromMaybe) -import Data.Monoid (getAll) - -import Foreign.C -import Foreign.Ptr - -import System.Environment (getArgs) - -import Graphics.X11.Xlib hiding (refreshKeyboardMapping) -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xlib.Types (Visual(..)) - -import XMonad.Core -import qualified XMonad.Config as Default -import XMonad.StackSet (new, member) -import qualified XMonad.StackSet as W -import XMonad.Operations - -import System.IO - ------------------------------------------------------------------------- --- Locale support - -#include - -foreign import ccall unsafe "locale.h setlocale" - c_setlocale :: CInt -> Ptr CChar -> IO (Ptr CChar) - ------------------------------------------------------------------------- - --- | --- The main entry point --- -xmonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO () -xmonad initxmc = do - -- setup locale information from environment - withCString "" $ c_setlocale (#const LC_ALL) - -- ignore SIGPIPE and SIGCHLD - installSignalHandlers - -- First, wrap the layout in an existential, to keep things pretty: - let xmc = initxmc { layoutHook = Layout $ layoutHook initxmc } - dpy <- openDisplay "" - let dflt = defaultScreen dpy - - rootw <- rootWindow dpy dflt - - args <- getArgs - - when ("--replace" `elem` args) $ replace dpy dflt rootw - - -- If another WM is running, a BadAccess error will be returned. The - -- default error handler will write the exception to stderr and exit with - -- an error. - selectInput dpy rootw $ rootMask initxmc - - sync dpy False -- sync to ensure all outstanding errors are delivered - - -- turn off the default handler in favor of one that ignores all errors - -- (ugly, I know) - xSetErrorHandler -- in C, I'm too lazy to write the binding: dons - - xinesc <- getCleanedScreenInfo dpy - nbc <- do v <- initColor dpy $ normalBorderColor xmc - ~(Just nbc_) <- initColor dpy $ normalBorderColor Default.def - return (fromMaybe nbc_ v) - - fbc <- do v <- initColor dpy $ focusedBorderColor xmc - ~(Just fbc_) <- initColor dpy $ focusedBorderColor Default.def - return (fromMaybe fbc_ v) - - hSetBuffering stdout NoBuffering - - let layout = layoutHook xmc - lreads = readsLayout layout - initialWinset = new layout (workspaces xmc) $ map SD xinesc - maybeRead reads' s = case reads' s of - [(x, "")] -> Just x - _ -> Nothing - - winset = fromMaybe initialWinset $ do - ("--resume" : s : _) <- return args - ws <- maybeRead reads s - return $ W.mapLayout (fromMaybe layout . maybeRead lreads) ws - extState = fromMaybe M.empty $ do - ("--resume" : _ : dyns : _) <- return args - vals <- maybeRead reads dyns - return . M.fromList . map (second Left) $ vals - - cf = XConf - { display = dpy - , config = xmc - , theRoot = rootw - , normalBorder = nbc - , focusedBorder = fbc - , keyActions = keys xmc xmc - , buttonActions = mouseBindings xmc xmc - , mouseFocused = False - , mousePosition = Nothing - , currentEvent = Nothing } - - st = XState - { windowset = initialWinset - , numberlockMask = 0 - , windowState = M.empty - , dragging = Nothing - , extensibleState = extState - } - allocaXEvent $ \e -> - runX cf st $ do - - setNumlockMask - grabKeys - grabButtons - - io $ sync dpy False - - ws <- io $ scan dpy rootw - - -- bootstrap the windowset, Operations.windows will identify all - -- the windows in winset as new and set initial properties for - -- those windows. Remove all windows that are no longer top-level - -- children of the root, they may have disappeared since - -- restarting. - windows . const . foldr W.delete winset $ W.allWindows winset \\ ws - - -- manage the as-yet-unmanaged windows - mapM_ (\w -> reparent w >> manage w) (ws \\ W.allWindows winset) - - userCode $ startupHook initxmc - - -- main loop, for all you HOF/recursion fans out there. - forever $ prehandle =<< io (nextEvent dpy e >> getEvent e) - - return () - where - -- if the event gives us the position of the pointer, set mousePosition - prehandle e = let mouse = do guard (ev_event_type e `elem` evs) - return (fromIntegral (ev_x_root e) - ,fromIntegral (ev_y_root e)) - in local (\c -> c { mousePosition = mouse, currentEvent = Just e }) (handleWithHook e) - evs = [ keyPress, keyRelease, enterNotify, leaveNotify - , buttonPress, buttonRelease] - - --- | Runs handleEventHook from the configuration and runs the default handler --- function if it returned True. -handleWithHook :: Event -> X () -handleWithHook e = do - evHook <- asks (handleEventHook . config) - whenX (userCodeDef True $ getAll `fmap` evHook e) (handle e) - --- --------------------------------------------------------------------- --- | Event handler. Map X events onto calls into Operations.hs, which --- modify our internal model of the window manager state. --- --- Events dwm handles that we don't: --- --- [ButtonPress] = buttonpress, --- [Expose] = expose, --- [PropertyNotify] = propertynotify, --- -handle :: Event -> X () - --- run window manager command -handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) - | t == keyPress = withDisplay $ \dpy -> do - s <- io $ keycodeToKeysym dpy code 0 - mClean <- cleanMask m - ks <- asks keyActions - userCodeDef () $ whenJust (M.lookup (mClean, s) ks) id - --- manage a new window -handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do - wa <- io $ getWindowAttributes dpy w -- ignore override windows - -- need to ignore mapping requests by managed windows not on the current workspace - managed <- isClient w - when (not (wa_override_redirect wa) && not managed) $ do - reparent w - manage w - --- window destroyed, unmanage it --- window gone, unmanage it -handle (DestroyWindowEvent {ev_window = w}) = do - whenX (isClient w) $ - unmanage w - unparent w - modify (\s -> s { windowState = M.delete w (windowState s)}) - --- We track expected unmap events in waitingUnmap. We ignore this event unless --- it is synthetic or we are not expecting an unmap notification from a window. -handle UnmapEvent {ev_window = w, ev_send_event = synthetic, ev_event = we} = whenX (isClient w) $ do - rootw <- asks theRoot - e <- getsWindowState wsWaitingUnmap w - if (synthetic || (e == 0 && we /= rootw)) - then unmanage w >> hideParent w - else when (e > 0) $ modifyWindowState (\ws -> ws { wsWaitingUnmap = e - 1 }) w - --- set keyboard mapping -handle e@(MappingNotifyEvent {}) = do - io $ refreshKeyboardMapping e - when (ev_request e `elem` [mappingKeyboard, mappingModifier]) $ do - setNumlockMask - grabKeys - --- handle button release, which may finish dragging. -handle e@(ButtonEvent {ev_event_type = t}) - | t == buttonRelease = do - drag <- gets dragging - case drag of - -- we're done dragging and have released the mouse: - Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f - Nothing -> broadcastMessage e - --- handle motionNotify event, which may mean we are dragging. -handle e@(MotionEvent {ev_event_type = _t, ev_x = x, ev_y = y}) = do - drag <- gets dragging - case drag of - Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging - Nothing -> broadcastMessage e - --- click on an unfocused window, makes it focused on this workspace -handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b }) - | t == buttonPress = do - -- If it's the root window, then it's something we - -- grabbed in grabButtons. Otherwise, it's click-to-focus. - dpy <- asks display - isr <- isRoot w - m <- cleanMask $ ev_state e - mact <- asks (M.lookup (m, b) . buttonActions) - case mact of - Just act | isr -> act $ ev_subwindow e - _ -> do - focus w - ctf <- asks (clickJustFocuses . config) - unless ctf $ io (allowEvents dpy replayPointer currentTime) - broadcastMessage e -- Always send button events. - --- entered a normal window: focus it if focusFollowsMouse is set to --- True in the user's config. -handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) - | t == enterNotify && ev_mode e == notifyNormal - = whenX (asks $ focusFollowsMouse . config) (focus w) - --- left a window, check if we need to focus root -handle e@(CrossingEvent {ev_event_type = t}) - | t == leaveNotify - = do rootw <- asks theRoot - when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw - --- configure a window -handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do - ws <- gets windowset - - if not (member w ws) - then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges - { wc_x = ev_x e - , wc_y = ev_y e - , wc_width = ev_width e - , wc_height = ev_height e - , wc_border_width = 0 - , wc_sibling = ev_above e - , wc_stack_mode = ev_detail e } - else configureClientWindow w - io $ sync dpy False - --- configuration changes in the root may mean display settings have changed -handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen - --- property notify -handle event@(PropertyEvent { ev_event_type = t, ev_atom = a }) - | t == propertyNotify && a == wM_NAME = asks (logHook . config) >>= userCodeDef () >> - broadcastMessage event - -handle e@ClientMessageEvent { ev_message_type = mt } = do - a <- getAtom "XMONAD_RESTART" - if (mt == a) - then restart "xmonad" True - else broadcastMessage e - -handle e = broadcastMessage e -- trace (eventName e) -- ignoring - - -reparent :: Window -> X () -reparent w = withDisplay $ \dpy -> do - rootw <- asks theRoot - p <- asks normalBorder - fMask <- asks (frameMask . config) - noFrame <- getsWindowState ((==none) . wsFrame) w - when noFrame $ do - trace $ "reparent: " ++ show w - frame <- io $ allocaSetWindowAttributes $ \swa -> do - set_background_pixel swa p - set_border_pixel swa p - set_event_mask swa fMask - set_override_redirect swa True - createWindow dpy rootw (-1) (-1) 1 1 0 copyFromParent inputOutput (Visual nullPtr) (cWBackPixel.|.cWBorderPixel.|.cWEventMask.|.cWOverrideRedirect) swa - io $ do - unmapWindow dpy w - addToSaveSet dpy w - reparentWindow dpy w frame 0 0 - modifyWindowState (\ws -> ws { wsFrame = frame }) w - -hideParent :: Window -> X () -hideParent w = withDisplay $ \dpy -> do - frame <- getsWindowState wsFrame w - when (frame /= none) $ io $ unmapWindow dpy frame - -unparent :: Window -> X () -unparent w = withDisplay $ \dpy -> do - frame <- getsWindowState wsFrame w - when (frame /= none) $ do - trace $ "unparent: " ++ show w - io $ destroyWindow dpy frame - modifyWindowState (\ws -> ws { wsFrame = none }) w - --- --------------------------------------------------------------------- --- IO stuff. Doesn't require any X state --- Most of these things run only on startup (bar grabkeys) - --- | scan for any new windows to manage. If they're already managed, --- this should be idempotent. -scan :: Display -> Window -> IO [Window] -scan dpy rootw = do - (_, _, ws) <- queryTree dpy rootw - filterM ok ws - -- TODO: scan for windows that are either 'IsViewable' or where WM_STATE == - -- Iconic - where ok w = do wa <- getWindowAttributes dpy w - a <- internAtom dpy "WM_STATE" False - p <- getWindowProperty32 dpy a w - let ic = case p of - Just (3:_) -> True -- 3 for iconified - _ -> False - return $ not (wa_override_redirect wa) - && (wa_map_state wa == waIsViewable || ic) - -setNumlockMask :: X () -setNumlockMask = do - dpy <- asks display - ms <- io $ getModifierMapping dpy - xs <- sequence [ do - ks <- io $ keycodeToKeysym dpy kc 0 - if ks == xK_Num_Lock - then return (setBit 0 (fromIntegral m)) - else return (0 :: KeyMask) - | (m, kcs) <- ms, kc <- kcs, kc /= 0] - modify (\s -> s { numberlockMask = foldr (.|.) 0 xs }) - --- | Grab the keys back -grabKeys :: X () -grabKeys = do - XConf { display = dpy, theRoot = rootw } <- ask - let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync - (minCode, maxCode) = displayKeycodes dpy - allCodes = [fromIntegral minCode .. fromIntegral maxCode] - io $ ungrabKey dpy anyKey anyModifier rootw - ks <- asks keyActions - -- build a map from keysyms to lists of keysyms (doing what - -- XGetKeyboardMapping would do if the X11 package bound it) - syms <- forM allCodes $ \code -> io (keycodeToKeysym dpy code 0) - let keysymMap = M.fromListWith (++) (zip syms [[code] | code <- allCodes]) - keysymToKeycodes sym = M.findWithDefault [] sym keysymMap - forM_ (M.keys ks) $ \(mask,sym) -> - forM_ (keysymToKeycodes sym) $ \kc -> - mapM_ (grab kc . (mask .|.)) =<< extraModifiers - --- | XXX comment me -grabButtons :: X () -grabButtons = do - XConf { display = dpy, theRoot = rootw } <- ask - let grab button mask = io $ grabButton dpy button mask rootw False buttonPressMask - grabModeAsync grabModeSync none none - io $ ungrabButton dpy anyButton anyModifier rootw - ems <- extraModifiers - ba <- asks buttonActions - mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ ba) - --- | @replace@ to signals compliant window managers to exit. -replace :: Display -> ScreenNumber -> Window -> IO () -replace dpy dflt rootw = do - -- check for other WM - wmSnAtom <- internAtom dpy ("WM_S" ++ show dflt) False - currentWmSnOwner <- xGetSelectionOwner dpy wmSnAtom - when (currentWmSnOwner /= 0) $ do - -- prepare to receive destroyNotify for old WM - selectInput dpy currentWmSnOwner structureNotifyMask - - -- create off-screen window - netWmSnOwner <- allocaSetWindowAttributes $ \attributes -> do - set_override_redirect attributes True - set_event_mask attributes propertyChangeMask - let screen = defaultScreenOfDisplay dpy - visual = defaultVisualOfScreen screen - attrmask = cWOverrideRedirect .|. cWEventMask - createWindow dpy rootw (-100) (-100) 1 1 0 copyFromParent copyFromParent visual attrmask attributes - - -- try to acquire wmSnAtom, this should signal the old WM to terminate - xSetSelectionOwner dpy wmSnAtom netWmSnOwner currentTime - - -- SKIPPED: check if we acquired the selection - -- SKIPPED: send client message indicating that we are now the WM - - -- wait for old WM to go away - fix $ \again -> do - evt <- allocaXEvent $ \event -> do - windowEvent dpy currentWmSnOwner structureNotifyMask event - get_EventType event - - when (evt /= destroyNotify) again diff --git a/XMonad/ManageHook.hs b/XMonad/ManageHook.hs deleted file mode 100644 index 64f9fe6..0000000 --- a/XMonad/ManageHook.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonad.ManageHook --- Copyright : (c) Spencer Janssen 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : spencerjanssen@gmail.com --- Stability : unstable --- Portability : not portable, uses cunning newtype deriving --- --- An EDSL for ManageHooks --- ------------------------------------------------------------------------------ - --- XXX examples required - -module XMonad.ManageHook where - -import Prelude hiding (catch) -import XMonad.Core -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xlib (Display, Window, internAtom, wM_NAME) -import Control.Exception.Extensible (bracket, catch, SomeException(..)) -import Control.Monad.Reader -import Data.Maybe -import Data.Monoid -import qualified XMonad.StackSet as W -import XMonad.Operations (reveal) - --- | Lift an 'X' action to a 'Query'. -liftX :: X a -> Query a -liftX = Query . lift - --- | The identity hook that returns the WindowSet unchanged. -idHook :: Monoid m => m -idHook = mempty - --- | Infix 'mappend'. Compose two 'ManageHook' from right to left. -(<+>) :: Monoid m => m -> m -> m -(<+>) = mappend - --- | Compose the list of 'ManageHook's. -composeAll :: Monoid m => [m] -> m -composeAll = mconcat - -infix 0 --> - --- | @p --> x@. If @p@ returns 'True', execute the 'ManageHook'. --- --- > (-->) :: Monoid m => Query Bool -> Query m -> Query m -- a simpler type -(-->) :: (Monad m, Monoid a) => m Bool -> m a -> m a -p --> f = p >>= \b -> if b then f else return mempty - --- | @q =? x@. if the result of @q@ equals @x@, return 'True'. -(=?) :: Eq a => Query a -> a -> Query Bool -q =? x = fmap (== x) q - -infixr 3 <&&>, <||> - --- | '&&' lifted to a 'Monad'. -(<&&>) :: Monad m => m Bool -> m Bool -> m Bool -(<&&>) = liftM2 (&&) - --- | '||' lifted to a 'Monad'. -(<||>) :: Monad m => m Bool -> m Bool -> m Bool -(<||>) = liftM2 (||) - --- | Return the window title. -title :: Query String -title = ask >>= \w -> liftX $ do - d <- asks display - let - getProp = - (internAtom d "_NET_WM_NAME" False >>= getTextProperty d w) - `catch` \(SomeException _) -> getTextProperty d w wM_NAME - extract prop = do l <- wcTextPropertyToTextList d prop - return $ if null l then "" else head l - io $ bracket getProp (xFree . tp_value) extract `catch` \(SomeException _) -> return "" - --- | Return the application name. -appName :: Query String -appName = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resName $ io $ getClassHint d w) - --- | Backwards compatible alias for 'appName'. -resource :: Query String -resource = appName - --- | Return the resource class. -className :: Query String -className = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resClass $ io $ getClassHint d w) - --- | A query that can return an arbitrary X property of type 'String', --- identified by name. -stringProperty :: String -> Query String -stringProperty p = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ getStringProperty d w p) - -getStringProperty :: Display -> Window -> String -> X (Maybe String) -getStringProperty d w p = do - a <- getAtom p - md <- io $ getWindowProperty8 d a w - return $ fmap (map (toEnum . fromIntegral)) md - --- | Modify the 'WindowSet' with a pure function. -doF :: (s -> s) -> Query (Endo s) -doF = return . Endo - --- | Map the window and remove it from the 'WindowSet'. -doIgnore :: ManageHook -doIgnore = ask >>= \w -> liftX (reveal w) >> doF (W.delete w) - --- | Move the window to a given workspace -doShift :: WorkspaceId -> ManageHook -doShift i = doF . W.shiftWin i =<< ask diff --git a/XMonad/Operations.hs b/XMonad/Operations.hs deleted file mode 100644 index 294d4a8..0000000 --- a/XMonad/Operations.hs +++ /dev/null @@ -1,588 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} - --- -------------------------------------------------------------------------- --- | --- Module : XMonad.Operations --- Copyright : (c) Spencer Janssen 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : dons@cse.unsw.edu.au --- Stability : unstable --- Portability : not portable, Typeable deriving, mtl, posix --- --- Operations. --- ------------------------------------------------------------------------------ - -module XMonad.Operations where - -import XMonad.Core -import XMonad.Layout (Full(..)) -import qualified XMonad.StackSet as W - -import Data.Maybe -import Data.Monoid (Endo(..)) -import Data.List (nub, (\\), find) -import Data.Bits ((.|.), (.&.), complement, testBit) -import Data.Ratio -import qualified Data.Map as M - -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Monad.Reader -import Control.Monad.State -import qualified Control.Exception.Extensible as C - -import System.Posix.Process (executeFile) -import Graphics.X11.Xlib -import Graphics.X11.Xinerama (getScreenInfo) -import Graphics.X11.Xlib.Extras - --- --------------------------------------------------------------------- --- | --- Window manager operations --- manage. Add a new window to be managed in the current workspace. --- Bring it into focus. --- --- Whether the window is already managed, or not, it is mapped, has its --- border set, and its event mask set. --- -manage :: Window -> X () -manage w = whenX (not <$> isClient w) $ do - mh <- asks (manageHook . config) - g <- appEndo <$> userCodeDef (Endo id) (runQuery mh w) - windows (g . W.insertUp w) - --- | unmanage. A window no longer exists, remove it from the window --- list, on whatever workspace it is. --- -unmanage :: Window -> X () -unmanage = windows . W.delete - --- | Kill the specified window. If we do kill it, we'll get a --- delete notify back from X. --- --- There are two ways to delete a window. Either just kill it, or if it --- supports the delete protocol, send a delete event (e.g. firefox) --- -killWindow :: Window -> X () -killWindow w = withDisplay $ \d -> do - wmdelt <- atom_WM_DELETE_WINDOW ; wmprot <- atom_WM_PROTOCOLS - - protocols <- io $ getWMProtocols d w - io $ if wmdelt `elem` protocols - then allocaXEvent $ \ev -> do - setEventType ev clientMessage - setClientMessageEvent ev w wmprot 32 wmdelt 0 - sendEvent d w False noEventMask ev - else killClient d w >> return () - --- | Kill the currently focused client. -kill :: X () -kill = withFocused killWindow - --- --------------------------------------------------------------------- --- Managing windows - --- | windows. Modify the current window list with a pure function, and refresh -windows :: (WindowSet -> WindowSet) -> X () -windows f = do - XState { windowset = old } <- get - let oldvisible = concatMap (W.integrate' . W.stack . W.screenWorkspace) $ W.screens old - newwindows = W.allWindows ws \\ W.allWindows old - ws = f old - XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask - - mapM_ setInitialProperties newwindows - - whenJust (W.peek old) $ \otherw -> setFrameBackground d otherw nbc - modify (\s -> s { windowset = ws }) - - -- notify non visibility - let tags_oldvisible = map (W.tag . W.screenWorkspace) $ W.screens old - gottenhidden = filter (flip elem tags_oldvisible . W.tag) $ W.hidden ws - mapM_ (sendMessageWithNoRefresh Hide) gottenhidden - - -- for each workspace, layout the currently visible workspaces - let allscreens = W.screens ws - summed_visible = scanl (++) [] $ map (W.integrate' . W.stack . W.screenWorkspace) allscreens - rects <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do - let wsp = W.screenWorkspace w - this = W.view n ws - n = W.tag wsp - tiled = (W.stack . W.screenWorkspace . W.current $ this) - >>= W.filter (`notElem` vis) - viewrect = screenRect $ W.screenDetail w - - -- just the tiled windows: - -- now tile the windows on this workspace, modified by the gap - (rs, ml') <- runLayout wsp { W.stack = tiled } viewrect `catchX` - runLayout wsp { W.stack = tiled, W.layout = Layout Full } viewrect - updateLayout n ml' - - io $ restackWindows d (map fst rs) - -- return the visible windows for this workspace: - return rs - - let visible = map fst rects - - mapM_ (uncurry tileWindow) rects - - whenJust (W.peek ws) $ \w -> setFrameBackground d w fbc - - mapM_ reveal visible - setTopFocus - - -- hide every window that was potentially visible before, but is not - -- given a position by a layout now. - mapM_ hide (nub (oldvisible ++ newwindows) \\ visible) - - -- all windows that are no longer in the windowset are marked as - -- withdrawn, it is important to do this after the above, otherwise 'hide' - -- will overwrite withdrawnState with iconicState - mapM_ (flip setWMState withdrawnState) (W.allWindows old \\ W.allWindows ws) - - isMouseFocused <- asks mouseFocused - unless isMouseFocused $ clearEvents enterWindowMask - asks (logHook . config) >>= userCodeDef () - where - setFrameBackground :: Display -> Window -> Pixel -> X () - setFrameBackground d w p = do - frame <- getsWindowState wsFrame w - io $ do - setWindowBackground d frame p - clearWindow d frame - --- | Produce the actual rectangle from a screen and a ratio on that screen. -scaleRationalRect :: Rectangle -> W.RationalRect -> Rectangle -scaleRationalRect (Rectangle sx sy sw sh) (W.RationalRect rx ry rw rh) - = Rectangle (sx + scale sw rx) (sy + scale sh ry) (scale sw rw) (scale sh rh) - where scale s r = floor (toRational s * r) - --- | setWMState. set the WM_STATE property -setWMState :: Window -> Int -> X () -setWMState w v = withDisplay $ \dpy -> do - a <- atom_WM_STATE - io $ changeProperty32 dpy w a a propModeReplace [fromIntegral v, fromIntegral none] - --- | hide. Hide a window by unmapping it, and setting Iconified. -hide :: Window -> X () -hide w = whenX (getsWindowState wsMapped w) $ withDisplay $ \d -> do - (cMask,fMask) <- asks $ (clientMask &&& frameMask) . config - frame <- getsWindowState wsFrame w - io $ do selectInput d w (cMask .&. complement structureNotifyMask) - selectInput d frame (fMask .&. complement structureNotifyMask) - unmapWindow d frame - selectInput d frame fMask - selectInput d w cMask - setWMState w iconicState - -- this part is key: we increment the waitingUnmap counter to distinguish - -- between client and xmonad initiated unmaps. - modifyWindowState (\ws -> ws { wsMapped = False - , wsWaitingUnmap = (wsWaitingUnmap ws) + 1 }) w - -configureClientWindow :: Window -> X () -configureClientWindow w = withDisplay $ \d -> do - (frame, bw) <- getsWindowState (wsFrame &&& wsBorderWidth) w - (_, x, y, width, height, _, _) <- io $ getGeometry d frame - let least1 n = max 1 n - x' = x + (fi $ bwLeft bw) - y' = y + (fi $ bwTop bw) - width' = least1 (width - bwLeft bw - bwRight bw) - height' = least1 (height - bwTop bw - bwBottom bw) - io $ do - moveResizeWindow d w (fi $ bwLeft bw) (fi $ bwTop bw) width' height' - -- send absolute ConfigureNotify - allocaXEvent $ \event -> do - setEventType event configureNotify - setConfigureEvent event w w (fi x') (fi y') (fi width') (fi height') 0 none False - sendEvent d w False 0 event - where - fi :: (Integral a, Num b) => a -> b - fi = fromIntegral - --- | reveal. Show a window by mapping it and setting Normal --- this is harmless if the window was already visible -reveal :: Window -> X () -reveal w = withDisplay $ \d -> do - setWMState w normalState - io $ mapWindow d w - whenX (isClient w) $ do - configureClientWindow w - getsWindowState wsFrame w >>= io . mapWindow d - modifyWindowState (\ws -> ws { wsMapped = True }) w - --- | Set some properties when we initially gain control of a window -setInitialProperties :: Window -> X () -setInitialProperties w = withDisplay $ \d -> do - setWMState w iconicState - asks (clientMask . config) >>= io . selectInput d w - io $ setWindowBorderWidth d w 0 - --- | refresh. Render the currently visible workspaces, as determined by --- the 'StackSet'. Also, set focus to the focused window. --- --- This is our 'view' operation (MVC), in that it pretty prints our model --- with X calls. --- -refresh :: X () -refresh = windows id - --- | clearEvents. Remove all events of a given type from the event queue. -clearEvents :: EventMask -> X () -clearEvents mask = withDisplay $ \d -> io $ do - sync d False - allocaXEvent $ \p -> fix $ \again -> do - more <- checkMaskEvent d mask p - when more again -- beautiful - --- | tileWindow. Moves and resizes w such that it fits inside the given --- rectangle, including its border. -tileWindow :: Window -> Rectangle -> X () -tileWindow w r = withDisplay $ \d -> do - -- give all windows at least 1x1 pixels - let least x | x <= 0 = 1 - | otherwise = x - frame <- getsWindowState wsFrame w - io $ moveResizeWindow d frame (rect_x r) (rect_y r) (least $ rect_width r) (least $ rect_height r) - --- --------------------------------------------------------------------- - --- | Returns 'True' if the first rectangle is contained within, but not equal --- to the second. -containedIn :: Rectangle -> Rectangle -> Bool -containedIn r1@(Rectangle x1 y1 w1 h1) r2@(Rectangle x2 y2 w2 h2) - = and [ r1 /= r2 - , x1 >= x2 - , y1 >= y2 - , fromIntegral x1 + w1 <= fromIntegral x2 + w2 - , fromIntegral y1 + h1 <= fromIntegral y2 + h2 ] - --- | Given a list of screens, remove all duplicated screens and screens that --- are entirely contained within another. -nubScreens :: [Rectangle] -> [Rectangle] -nubScreens xs = nub . filter (\x -> not $ any (x `containedIn`) xs) $ xs - --- | Cleans the list of screens according to the rules documented for --- nubScreens. -getCleanedScreenInfo :: MonadIO m => Display -> m [Rectangle] -getCleanedScreenInfo = io . fmap nubScreens . getScreenInfo - --- | rescreen. The screen configuration may have changed (due to --- xrandr), update the state and refresh the screen, and reset the gap. -rescreen :: X () -rescreen = do - xinesc <- withDisplay getCleanedScreenInfo - - windows $ \ws -> - let (xs, ys) = splitAt (length xinesc) $ W.workspaces ws - (a:as) = zipWith3 (flip W.Screen []) xs [0..] $ map SD xinesc - in ws { W.current = a { W.screenHidden = ys } - , W.visible = as } - --- --------------------------------------------------------------------- - --- | setButtonGrab. Tell whether or not to intercept clicks on a given window -setButtonGrab :: Bool -> Window -> X () -setButtonGrab grab w = do - pointerMode <- asks $ \c -> if clickJustFocuses (config c) - then grabModeAsync - else grabModeSync - withDisplay $ \d -> io $ if grab - then forM_ [button1, button2, button3] $ \b -> - grabButton d b anyModifier w False buttonPressMask - pointerMode grabModeSync none none - else ungrabButton d anyButton anyModifier w - --- --------------------------------------------------------------------- --- Setting keyboard focus - --- | Set the focus to the window on top of the stack, or root -setTopFocus :: X () -setTopFocus = withWindowSet $ maybe (setFocusX =<< asks theRoot) setFocusX . W.peek - --- | Set focus explicitly to window 'w' if it is managed by us, or root. --- This happens if X notices we've moved the mouse (and perhaps moved --- the mouse to a new screen). -focus :: Window -> X () -focus w = local (\c -> c { mouseFocused = True }) $ withWindowSet $ \s -> do - let stag = W.tag . W.screenWorkspace - curr = stag $ W.current s - mnew <- maybe (return Nothing) (fmap (fmap stag) . uncurry pointScreen) - =<< asks mousePosition - root <- asks theRoot - case () of - _ | W.member w s && W.peek s /= Just w -> windows (W.focusWindow w) - | Just new <- mnew, w == root && curr /= new - -> windows (W.view new) - | otherwise -> return () - --- | Call X to set the keyboard focus details. -setFocusX :: Window -> X () -setFocusX w = withWindowSet $ \ws -> do - dpy <- asks display - - -- clear mouse button grab and border on other windows - forM_ (W.screens ws) $ \wk -> - forM_ (W.index (W.view (W.tag (W.screenWorkspace wk)) ws)) $ \otherw -> - setButtonGrab True otherw - - -- If we ungrab buttons on the root window, we lose our mouse bindings. - whenX (not <$> isRoot w) $ setButtonGrab False w - - hints <- io $ getWMHints dpy w - protocols <- io $ getWMProtocols dpy w - wmprot <- atom_WM_PROTOCOLS - wmtf <- atom_WM_TAKE_FOCUS - currevt <- asks currentEvent - let inputHintSet = wmh_flags hints `testBit` inputHintBit - - when ((inputHintSet && wmh_input hints) || (not inputHintSet)) $ - io $ do setInputFocus dpy w revertToPointerRoot 0 - when (wmtf `elem` protocols) $ - io $ allocaXEvent $ \ev -> do - setEventType ev clientMessage - setClientMessageEvent ev w wmprot 32 wmtf $ maybe currentTime event_time currevt - sendEvent dpy w False noEventMask ev - where event_time ev = - if (ev_event_type ev) `elem` timedEvents then - ev_time ev - else - currentTime - timedEvents = [ keyPress, keyRelease, buttonPress, buttonRelease, enterNotify, leaveNotify, selectionRequest ] - ------------------------------------------------------------------------- --- Message handling - --- | Throw a message to the current 'LayoutClass' possibly modifying how we --- layout the windows, then refresh. -sendMessage :: Message a => a -> X () -sendMessage a = do - w <- W.screenWorkspace . W.current <$> gets windowset - ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - whenJust ml' $ \l' -> - windows $ \ws -> ws { W.current = (W.current ws) - { W.screenWorkspace = (W.screenWorkspace $ W.current ws) - { W.layout = l' }}} - --- | Send a message to all layouts, without refreshing. -broadcastMessage :: Message a => a -> X () -broadcastMessage a = withWindowSet $ \ws -> - mapM_ (sendMessageWithNoRefresh a) (W.workspaces ws) - --- | Send a message to a layout, without refreshing. -sendMessageWithNoRefresh :: Message a => a -> W.Workspace WorkspaceId (Layout Window) Window -> X () -sendMessageWithNoRefresh a w = - handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing >>= - updateLayout (W.tag w) - --- | Update the layout field of a workspace -updateLayout :: WorkspaceId -> Maybe (Layout Window) -> X () -updateLayout i ml = whenJust ml $ \l -> - runOnWorkspaces $ \ww -> return $ if W.tag ww == i then ww { W.layout = l} else ww - --- | Set the layout of the currently viewed workspace -setLayout :: Layout Window -> X () -setLayout l = do - ss@(W.StackSet { W.current = c@(W.Screen { W.screenWorkspace = ws })}) <- gets windowset - handleMessage (W.layout ws) (SomeMessage ReleaseResources) - windows $ const $ ss {W.current = c { W.screenWorkspace = ws { W.layout = l } } } - ------------------------------------------------------------------------- --- Utilities - --- | Return workspace visible on screen 'sc', or 'Nothing'. -screenWorkspace :: ScreenId -> X (Maybe WorkspaceId) -screenWorkspace sc = withWindowSet $ return . W.lookupWorkspace sc - --- | Apply an 'X' operation to the currently focused window, if there is one. -withFocused :: (Window -> X ()) -> X () -withFocused f = withWindowSet $ \w -> whenJust (W.peek w) f - --- | 'True' if window is under management by us -isClient :: Window -> X Bool -isClient w = withWindowSet $ return . W.member w - --- | Combinations of extra modifier masks we need to grab keys\/buttons for. --- (numlock and capslock) -extraModifiers :: X [KeyMask] -extraModifiers = do - nlm <- gets numberlockMask - return [0, nlm, lockMask, nlm .|. lockMask ] - --- | Strip numlock\/capslock from a mask -cleanMask :: KeyMask -> X KeyMask -cleanMask km = do - nlm <- gets numberlockMask - return (complement (nlm .|. lockMask) .&. km) - --- | Get the 'Pixel' value for a named color -initColor :: Display -> String -> IO (Maybe Pixel) -initColor dpy c = C.handle (\(C.SomeException _) -> return Nothing) $ - (Just . color_pixel . fst) <$> allocNamedColor dpy colormap c - where colormap = defaultColormap dpy (defaultScreen dpy) - ------------------------------------------------------------------------- - --- | @restart name resume@. Attempt to restart xmonad by executing the program --- @name@. If @resume@ is 'True', restart with the current window state. --- When executing another window manager, @resume@ should be 'False'. -restart :: String -> Bool -> X () -restart prog resume = do - broadcastMessage ReleaseResources - io . flush =<< asks display - let wsData = show . W.mapLayout show . windowset - maybeShow (t, Right (PersistentExtension ext)) = Just (t, show ext) - maybeShow (t, Left str) = Just (t, str) - maybeShow _ = Nothing - extState = return . show . catMaybes . map maybeShow . M.toList . extensibleState - args <- if resume then gets (\s -> "--resume":wsData s:extState s) else return [] - catchIO (executeFile prog True args Nothing) - ------------------------------------------------------------------------- --- | Floating layer support - --- | Given a window, find the screen it is located on, and compute --- the geometry of that window wrt. that screen. -floatLocation :: Window -> X (ScreenId, W.RationalRect) -floatLocation w = withDisplay $ \d -> do - ws <- gets windowset - wa <- io $ getWindowAttributes d w - let bw = (fromIntegral . wa_border_width) wa - sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa) - - let sr = screenRect . W.screenDetail $ sc - rr = W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr)) - ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr)) - (fi (wa_width wa + bw*2) % fi (rect_width sr)) - (fi (wa_height wa + bw*2) % fi (rect_height sr)) - - return (W.screen sc, rr) - where fi x = fromIntegral x - --- | Given a point, determine the screen (if any) that contains it. -pointScreen :: Position -> Position - -> X (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)) -pointScreen x y = withWindowSet $ return . find p . W.screens - where p = pointWithin x y . screenRect . W.screenDetail - --- | @pointWithin x y r@ returns 'True' if the @(x, y)@ co-ordinate is within --- @r@. -pointWithin :: Position -> Position -> Rectangle -> Bool -pointWithin x y r = x >= rect_x r && - x < rect_x r + fromIntegral (rect_width r) && - y >= rect_y r && - y < rect_y r + fromIntegral (rect_height r) - --- | Make a tiled window floating, using its suggested rectangle -{-float :: Window -> X () -float w = do - (sc, rr) <- floatLocation w - windows $ \ws -> W.float w rr . fromMaybe ws $ do - i <- W.findTag w ws - guard $ i `elem` concatMap (map W.tag . W.screenWorkspaces) (W.screens ws) - f <- W.peek ws - sw <- W.lookupWorkspace sc ws - return (W.focusWindow f . W.shiftWin sw w $ ws)-} - --- --------------------------------------------------------------------- --- Mouse handling - --- | Accumulate mouse motion events -mouseDrag :: (Position -> Position -> X ()) -> X () -> X () -mouseDrag f done = do - drag <- gets dragging - case drag of - Just _ -> return () -- error case? we're already dragging - Nothing -> do - XConf { theRoot = root, display = d } <- ask - io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) - grabModeAsync grabModeAsync none none currentTime - modify $ \s -> s { dragging = Just (motion, cleanup) } - where - cleanup = do - withDisplay $ io . flip ungrabPointer currentTime - modify $ \s -> s { dragging = Nothing } - done - motion x y = do z <- f x y - clearEvents pointerMotionMask - return z - --- | XXX comment me -{-mouseMoveWindow :: Window -> X () -mouseMoveWindow w = whenX (isClient w) $ withDisplay $ \d -> do - io $ raiseWindow d w - wa <- io $ getWindowAttributes d w - (_, _, _, ox', oy', _, _, _) <- io $ queryPointer d w - let ox = fromIntegral ox' - oy = fromIntegral oy' - mouseDrag (\ex ey -> io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) - (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))) - (float w) - --- | XXX comment me -mouseResizeWindow :: Window -> X () -mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do - io $ raiseWindow d w - wa <- io $ getWindowAttributes d w - sh <- io $ getWMNormalHints d w - io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa)) - mouseDrag (\ex ey -> - io $ resizeWindow d w `uncurry` - applySizeHintsContents sh (ex - fromIntegral (wa_x wa), - ey - fromIntegral (wa_y wa))) - (float w)-} - --- --------------------------------------------------------------------- --- | Support for window size hints - -type D = (Dimension, Dimension) - --- | Given a window, build an adjuster function that will reduce the given --- dimensions according to the window's border width and size hints. -mkAdjust :: Window -> X (D -> D) -mkAdjust w = withDisplay $ \d -> liftIO $ do - sh <- getWMNormalHints d w - bw <- fmap (fromIntegral . wa_border_width) $ getWindowAttributes d w - return $ applySizeHints bw sh - --- | Reduce the dimensions if needed to comply to the given SizeHints, taking --- window borders into account. -applySizeHints :: Integral a => Dimension -> SizeHints -> (a, a) -> D -applySizeHints bw sh = - tmap (+ 2 * bw) . applySizeHintsContents sh . tmap (subtract $ 2 * fromIntegral bw) - where - tmap f (x, y) = (f x, f y) - --- | Reduce the dimensions if needed to comply to the given SizeHints. -applySizeHintsContents :: Integral a => SizeHints -> (a, a) -> D -applySizeHintsContents sh (w, h) = - applySizeHints' sh (fromIntegral $ max 1 w, fromIntegral $ max 1 h) - --- | XXX comment me -applySizeHints' :: SizeHints -> D -> D -applySizeHints' sh = - maybe id applyMaxSizeHint (sh_max_size sh) - . maybe id (\(bw, bh) (w, h) -> (w+bw, h+bh)) (sh_base_size sh) - . maybe id applyResizeIncHint (sh_resize_inc sh) - . maybe id applyAspectHint (sh_aspect sh) - . maybe id (\(bw,bh) (w,h) -> (w-bw, h-bh)) (sh_base_size sh) - --- | Reduce the dimensions so their aspect ratio falls between the two given aspect ratios. -applyAspectHint :: (D, D) -> D -> D -applyAspectHint ((minx, miny), (maxx, maxy)) x@(w,h) - | or [minx < 1, miny < 1, maxx < 1, maxy < 1] = x - | w * maxy > h * maxx = (h * maxx `div` maxy, h) - | w * miny < h * minx = (w, w * miny `div` minx) - | otherwise = x - --- | Reduce the dimensions so they are a multiple of the size increments. -applyResizeIncHint :: D -> D -> D -applyResizeIncHint (iw,ih) x@(w,h) = - if iw > 0 && ih > 0 then (w - w `mod` iw, h - h `mod` ih) else x - --- | Reduce the dimensions if they exceed the given maximum dimensions. -applyMaxSizeHint :: D -> D -> D -applyMaxSizeHint (mw,mh) x@(w,h) = - if mw > 0 && mh > 0 then (min w mw,min h mh) else x diff --git a/XMonad/StackSet.hs b/XMonad/StackSet.hs deleted file mode 100644 index 958b94b..0000000 --- a/XMonad/StackSet.hs +++ /dev/null @@ -1,549 +0,0 @@ -{-# LANGUAGE PatternGuards #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonad.StackSet --- Copyright : (c) Don Stewart 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : dons@galois.com --- Stability : experimental --- Portability : portable, Haskell 98 --- - -module XMonad.StackSet ( - -- * Introduction - -- $intro - - -- ** The Zipper - -- $zipper - - -- ** Xinerama support - -- $xinerama - - -- ** Master and Focus - -- $focus - - StackSet(..), Workspace(..), Screen(..), Stack(..), RationalRect(..), - -- * Construction - -- $construction - new, view, greedyView, - -- * Xinerama operations - -- $xinerama - lookupWorkspace, - screens, screenWorkspaces, workspaces, hidden, allWindows, currentTag, - -- * Operations on the current stack - -- $stackOperations - peek, index, integrate, integrate', differentiate, - focusUp, focusDown, focusUp', focusDown', focusMaster, focusWindow, - tagMember, renameTag, member, findTag, mapWorkspace, mapLayout, - -- * Modifying the stackset - -- $modifyStackset - insertUp, delete, filter, - -- * Setting the master window - -- $settingMW - swapUp, swapDown, swapMaster, shiftMaster, modify, modify', -- needed by users - -- * Composite operations - -- $composite - shift, shiftWin, - - -- for testing - abort - ) where - -import Prelude hiding (filter) -import Data.Function (on) -import Data.Maybe (listToMaybe,isJust,fromMaybe) -import qualified Data.List as L (deleteBy,find,splitAt,filter,nub) - --- $intro --- --- The 'StackSet' data type encodes a window manager abstraction. The --- window manager is a set of virtual workspaces. On each workspace is a --- stack of windows. A given workspace is always current, and a given --- window on each workspace has focus. The focused window on the current --- workspace is the one which will take user input. It can be visualised --- as follows: --- --- > Workspace { 0*} { 1 } { 2 } { 3 } { 4 } --- > --- > Windows [1 [] [3* [6*] [] --- > ,2*] ,4 --- > ,5] --- --- Note that workspaces are indexed from 0, windows are numbered --- uniquely. A '*' indicates the window on each workspace that has --- focus, and which workspace is current. - --- $zipper --- --- We encode all the focus tracking directly in the data structure, with a 'zipper': --- --- A Zipper is essentially an `updateable' and yet pure functional --- cursor into a data structure. Zipper is also a delimited --- continuation reified as a data structure. --- --- The Zipper lets us replace an item deep in a complex data --- structure, e.g., a tree or a term, without an mutation. The --- resulting data structure will share as much of its components with --- the old structure as possible. --- --- Oleg Kiselyov, 27 Apr 2005, haskell\@, "Zipper as a delimited continuation" --- --- We use the zipper to keep track of the focused workspace and the --- focused window on each workspace, allowing us to have correct focus --- by construction. We closely follow Huet's original implementation: --- --- G. Huet, /Functional Pearl: The Zipper/, --- 1997, J. Functional Programming 75(5):549-554. --- and: --- R. Hinze and J. Jeuring, /Functional Pearl: The Web/. --- --- and Conor McBride's zipper differentiation paper. --- Another good reference is: --- --- The Zipper, Haskell wikibook - --- $xinerama --- Xinerama in X11 lets us view multiple virtual workspaces --- simultaneously. While only one will ever be in focus (i.e. will --- receive keyboard events), other workspaces may be passively --- viewable. We thus need to track which virtual workspaces are --- associated (viewed) on which physical screens. To keep track of --- this, 'StackSet' keeps separate lists of visible but non-focused --- workspaces, and non-visible workspaces. - --- $focus --- --- Each stack tracks a focused item, and for tiling purposes also tracks --- a 'master' position. The connection between 'master' and 'focus' --- needs to be well defined, particularly in relation to 'insert' and --- 'delete'. --- - ------------------------------------------------------------------------- --- | --- A cursor into a non-empty list of workspaces. --- --- We puncture the workspace list, producing a hole in the structure --- used to track the currently focused workspace. The two other lists --- that are produced are used to track those workspaces visible as --- Xinerama screens, and those workspaces not visible anywhere. - -data StackSet i l a sid sd = - StackSet { current :: !(Screen i l a sid sd) -- ^ currently focused workspace - , visible :: [Screen i l a sid sd] -- ^ non-focused workspaces, visible in xinerama - } deriving (Show, Read, Eq) - --- | Visible workspaces, and their Xinerama screens. -data Screen i l a sid sd = Screen { screenWorkspace :: !(Workspace i l a) - , screenHidden :: [Workspace i l a] - , screen :: !sid - , screenDetail :: !sd } - deriving (Show, Read, Eq) - --- | --- A workspace is just a tag, a layout, and a stack. --- -data Workspace i l a = Workspace { tag :: !i, layout :: l, stack :: Maybe (Stack a) } - deriving (Show, Read, Eq) - --- | A structure for window geometries -data RationalRect = RationalRect Rational Rational Rational Rational - deriving (Show, Read, Eq) - --- | --- A stack is a cursor onto a window list. --- The data structure tracks focus by construction, and --- the master window is by convention the top-most item. --- Focus operations will not reorder the list that results from --- flattening the cursor. The structure can be envisaged as: --- --- > +-- master: < '7' > --- > up | [ '2' ] --- > +--------- [ '3' ] --- > focus: < '4' > --- > dn +----------- [ '8' ] --- --- A 'Stack' can be viewed as a list with a hole punched in it to make --- the focused position. Under the zipper\/calculus view of such --- structures, it is the differentiation of a [a], and integrating it --- back has a natural implementation used in 'index'. --- -data Stack a = Stack { focus :: !a -- focused thing in this set - , up :: [a] -- clowns to the left - , down :: [a] } -- jokers to the right - deriving (Show, Read, Eq) - - --- | this function indicates to catch that an error is expected -abort :: String -> a -abort x = error $ "xmonad: StackSet: " ++ x - --- --------------------------------------------------------------------- --- $construction - --- | /O(n)/. Create a new stackset, of empty stacks, with given tags, --- with physical screens whose descriptions are given by 'm'. The --- number of physical screens (@length 'm'@) should be less than or --- equal to the number of workspace tags. The first workspace in the --- list will be current. --- --- Xinerama: Virtual workspaces are assigned to physical screens, starting at 0. --- -new :: (Integral s) => l -> [i] -> [sd] -> StackSet i l a s sd -new l wids m | not (null wids) && length m <= length wids && not (null m) - = StackSet cur visi - where (seen,unseen) = L.splitAt (length m) $ map (\i -> Workspace i l Nothing) wids - cur = Screen (head seen) unseen 0 (head m) - visi = [ Screen i [] s sd | (i, s, sd) <- zip3 (tail seen) [1..] (tail m) ] - -- now zip up visibles with their screen id -new _ _ _ = abort "non-positive argument to StackSet.new" - --- | --- /O(w)/. Set focus to the workspace with index \'i\'. --- If the index is out of range, return the original 'StackSet'. --- --- Xinerama: If the workspace is not visible on any Xinerama screen, it --- becomes the current screen. If it is in the visible list, it becomes --- current. - -view :: (Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd -view i s = s { current = head s', visible = tail s' } - where - s' = map makeVisible (current s : visible s) - - makeVisible scr - | Just x <- L.find ((i==) . tag) (screenHidden scr) = scr { screenWorkspace = x, screenHidden = (screenWorkspace scr) : L.deleteBy ((==) `on` tag) x (screenHidden scr)} - | otherwise = scr - - -- 'Catch'ing this might be hard. Relies on monotonically increasing - -- workspace tags defined in 'new' - -- - -- and now tags are not monotonic, what happens here? - --- | --- Set focus to the given workspace. If that workspace does not exist --- in the stackset, the original workspace is returned. If that workspace is --- 'hidden', then display that workspace on the current screen, and move the --- current workspace to 'hidden'. If that workspace is 'visible' on another --- screen, the workspaces of the current screen and the other screen are --- swapped. - -greedyView :: (Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd -{-greedyView w ws - | any wTag (hidden ws) = view w ws - | (Just s) <- L.find (wTag . workspace) (visible ws) - = ws { current = (current ws) { workspace = workspace s } - , visible = s { workspace = workspace (current ws) } - : L.filter (not . wTag . workspace) (visible ws) } - | otherwise = ws - where wTag = (w == ) . tag-} -greedyView = view - --- --------------------------------------------------------------------- --- $xinerama - --- | Find the tag of the workspace visible on Xinerama screen 'sc'. --- 'Nothing' if screen is out of bounds. -lookupWorkspace :: Eq s => s -> StackSet i l a s sd -> Maybe i -lookupWorkspace sc w = listToMaybe [ tag i | Screen i _ s _ <- current w : visible w, s == sc ] - --- --------------------------------------------------------------------- --- $stackOperations - --- | --- The 'with' function takes a default value, a function, and a --- StackSet. If the current stack is Nothing, 'with' returns the --- default value. Otherwise, it applies the function to the stack, --- returning the result. It is like 'maybe' for the focused workspace. --- -with :: b -> (Stack a -> b) -> StackSet i l a s sd -> b -with dflt f = maybe dflt f . stack . screenWorkspace . current - --- | --- Apply a function, and a default value for 'Nothing', to modify the current stack. --- -modify :: Maybe (Stack a) -> (Stack a -> Maybe (Stack a)) -> StackSet i l a s sd -> StackSet i l a s sd -modify d f s = s { current = (current s) - { screenWorkspace = (screenWorkspace (current s)) { stack = with d f s }}} - --- | --- Apply a function to modify the current stack if it isn't empty, and we don't --- want to empty it. --- -modify' :: (Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd -modify' f = modify Nothing (Just . f) - --- | --- /O(1)/. Extract the focused element of the current stack. --- Return 'Just' that element, or 'Nothing' for an empty stack. --- -peek :: StackSet i l a s sd -> Maybe a -peek = with Nothing (return . focus) - --- | --- /O(n)/. Flatten a 'Stack' into a list. --- -integrate :: Stack a -> [a] -integrate (Stack x l r) = reverse l ++ x : r - --- | --- /O(n)/ Flatten a possibly empty stack into a list. -integrate' :: Maybe (Stack a) -> [a] -integrate' = maybe [] integrate - --- | --- /O(n)/. Turn a list into a possibly empty stack (i.e., a zipper): --- the first element of the list is current, and the rest of the list --- is down. -differentiate :: [a] -> Maybe (Stack a) -differentiate [] = Nothing -differentiate (x:xs) = Just $ Stack x [] xs - --- | --- /O(n)/. 'filter p s' returns the elements of 's' such that 'p' evaluates to --- 'True'. Order is preserved, and focus moves as described for 'delete'. --- -filter :: (a -> Bool) -> Stack a -> Maybe (Stack a) -filter p (Stack f ls rs) = case L.filter p (f:rs) of - f':rs' -> Just $ Stack f' (L.filter p ls) rs' -- maybe move focus down - [] -> case L.filter p ls of -- filter back up - f':ls' -> Just $ Stack f' ls' [] -- else up - [] -> Nothing - --- | --- /O(s)/. Extract the stack on the current workspace, as a list. --- The order of the stack is determined by the master window -- it will be --- the head of the list. The implementation is given by the natural --- integration of a one-hole list cursor, back to a list. --- -index :: StackSet i l a s sd -> [a] -index = with [] integrate - --- | --- /O(1), O(w) on the wrapping case/. --- --- focusUp, focusDown. Move the window focus up or down the stack, --- wrapping if we reach the end. The wrapping should model a 'cycle' --- on the current stack. The 'master' window, and window order, --- are unaffected by movement of focus. --- --- swapUp, swapDown, swap the neighbour in the stack ordering, wrapping --- if we reach the end. Again the wrapping model should 'cycle' on --- the current stack. --- -focusUp, focusDown, swapUp, swapDown :: StackSet i l a s sd -> StackSet i l a s sd -focusUp = modify' focusUp' -focusDown = modify' focusDown' - -swapUp = modify' swapUp' -swapDown = modify' (reverseStack . swapUp' . reverseStack) - --- | Variants of 'focusUp' and 'focusDown' that work on a --- 'Stack' rather than an entire 'StackSet'. -focusUp', focusDown' :: Stack a -> Stack a -focusUp' (Stack t (l:ls) rs) = Stack l ls (t:rs) -focusUp' (Stack t [] rs) = Stack x xs [] where (x:xs) = reverse (t:rs) -focusDown' = reverseStack . focusUp' . reverseStack - -swapUp' :: Stack a -> Stack a -swapUp' (Stack t (l:ls) rs) = Stack t ls (l:rs) -swapUp' (Stack t [] rs) = Stack t (reverse rs) [] - --- | reverse a stack: up becomes down and down becomes up. -reverseStack :: Stack a -> Stack a -reverseStack (Stack t ls rs) = Stack t rs ls - --- --- | /O(1) on current window, O(n) in general/. Focus the window 'w', --- and set its workspace as current. --- -focusWindow :: (Eq s, Eq a, Eq i) => a -> StackSet i l a s sd -> StackSet i l a s sd -focusWindow w s | Just w == peek s = s - | otherwise = fromMaybe s $ do - n <- findTag w s - return $ until ((Just w ==) . peek) focusUp (view n s) - --- | Get a list of all screens in the 'StackSet'. -screens :: StackSet i l a s sd -> [Screen i l a s sd] -screens s = current s : visible s - --- | Get a list of all workspaces in the 'StackSet'. -workspaces :: StackSet i l a s sd -> [Workspace i l a] -workspaces s = concatMap screenWorkspaces $ (current s) : (visible s) - -screenWorkspaces :: Screen i l a sid sd -> [Workspace i l a] -screenWorkspaces scr = screenWorkspace scr : screenHidden scr - -hidden :: StackSet i l a s sd -> [Workspace i l a] -hidden = concatMap screenHidden . screens - --- | Get a list of all windows in the 'StackSet' in no particular order -allWindows :: Eq a => StackSet i l a s sd -> [a] -allWindows = L.nub . concatMap (integrate' . stack) . workspaces - --- | Get the tag of the currently focused workspace. -currentTag :: StackSet i l a s sd -> i -currentTag = tag . screenWorkspace . current - --- | Is the given tag present in the 'StackSet'? -tagMember :: Eq i => i -> StackSet i l a s sd -> Bool -tagMember t = elem t . map tag . workspaces - --- | Rename a given tag if present in the 'StackSet'. -renameTag :: Eq i => i -> i -> StackSet i l a s sd -> StackSet i l a s sd -renameTag o n = mapWorkspace rename - where rename w = if tag w == o then w { tag = n } else w - --- | Ensure that a given set of workspace tags is present by renaming --- existing workspaces and\/or creating new hidden workspaces as --- necessary. -{-ensureTags :: Eq i => l -> [i] -> StackSet i l a s sd -> StackSet i l a s sd -ensureTags l allt st = et allt (map tag (workspaces st) \\ allt) st - where et [] _ s = s - et (i:is) rn s | i `tagMember` s = et is rn s - et (i:is) [] s = et is [] (s { hidden = Workspace i l Nothing : hidden s }) - et (i:is) (r:rs) s = et is rs $ renameTag r i s-} - --- | Map a function on all the workspaces in the 'StackSet'. -mapWorkspace :: (Workspace i l a -> Workspace i l a) -> StackSet i l a s sd -> StackSet i l a s sd -mapWorkspace f s = s { current = updScr (current s) - , visible = map updScr (visible s) } - where updScr scr = scr { screenWorkspace = f (screenWorkspace scr), screenHidden = map f (screenHidden scr) } - --- | Map a function on all the layouts in the 'StackSet'. -mapLayout :: (l -> l') -> StackSet i l a s sd -> StackSet i l' a s sd -mapLayout f (StackSet v vs) = StackSet (fScreen v) (map fScreen vs) - where - fScreen (Screen ws hd s sd) = Screen (fWorkspace ws) (map fWorkspace hd) s sd - fWorkspace (Workspace t l s) = Workspace t (f l) s - --- | /O(n)/. Is a window in the 'StackSet'? -member :: Eq a => a -> StackSet i l a s sd -> Bool -member a s = isJust (findTag a s) - --- | /O(1) on current window, O(n) in general/. --- Return 'Just' the workspace tag of the given window, or 'Nothing' --- if the window is not in the 'StackSet'. -findTag :: Eq a => a -> StackSet i l a s sd -> Maybe i -findTag a s = listToMaybe - [ tag w | w <- workspaces s, has a (stack w) ] - where has _ Nothing = False - has x (Just (Stack t l r)) = x `elem` (t : l ++ r) - --- --------------------------------------------------------------------- --- $modifyStackset - --- | --- /O(n)/. (Complexity due to duplicate check). Insert a new element --- into the stack, above the currently focused element. The new --- element is given focus; the previously focused element is moved --- down. --- --- If the element is already in the stackset, the original stackset is --- returned unmodified. --- --- Semantics in Huet's paper is that insert doesn't move the cursor. --- However, we choose to insert above, and move the focus. --- -insertUp :: Eq a => a -> StackSet i l a s sd -> StackSet i l a s sd -insertUp a s = if member a s then s else insert - where insert = modify (Just $ Stack a [] []) (\(Stack t l r) -> Just $ Stack a l (t:r)) s - --- insertDown :: a -> StackSet i l a s sd -> StackSet i l a s sd --- insertDown a = modify (Stack a [] []) $ \(Stack t l r) -> Stack a (t:l) r --- Old semantics, from Huet. --- > w { down = a : down w } - --- | --- /O(1) on current window, O(n) in general/. Delete window 'w' if it exists. --- There are 4 cases to consider: --- --- * delete on an 'Nothing' workspace leaves it Nothing --- --- * otherwise, try to move focus to the down --- --- * otherwise, try to move focus to the up --- --- * otherwise, you've got an empty workspace, becomes 'Nothing' --- --- Behaviour with respect to the master: --- --- * deleting the master window resets it to the newly focused window --- --- * otherwise, delete doesn't affect the master. --- --- | Only temporarily remove the window from the stack, thereby not destroying special --- information saved in the 'Stackset' -delete :: (Eq a, Eq s) => a -> StackSet i l a s sd -> StackSet i l a s sd -delete w s = mapWorkspace removeFromWorkspace s - where removeFromWorkspace ws = ws { stack = stack ws >>= filter (/=w) } - ------------------------------------------------------------------------- - --- | Given a window, and its preferred rectangle, set it as floating --- A floating window should already be managed by the 'StackSet'. ---float :: Ord a => a -> RationalRect -> StackSet i l a s sd -> StackSet i l a s sd ---float w r s = s { floating = M.insert w r (floating s) } - --- | Clear the floating status of a window ---sink :: Ord a => a -> StackSet i l a s sd -> StackSet i l a s sd ---sink w s = s { floating = M.delete w (floating s) } - ------------------------------------------------------------------------- --- $settingMW - --- | /O(s)/. Set the master window to the focused window. --- The old master window is swapped in the tiling order with the focused window. --- Focus stays with the item moved. -swapMaster :: StackSet i l a s sd -> StackSet i l a s sd -swapMaster = modify' $ \c -> case c of - Stack _ [] _ -> c -- already master. - Stack t ls rs -> Stack t [] (xs ++ x : rs) where (x:xs) = reverse ls - --- natural! keep focus, move current to the top, move top to current. - --- | /O(s)/. Set the master window to the focused window. --- The other windows are kept in order and shifted down on the stack, as if you --- just hit mod-shift-k a bunch of times. --- Focus stays with the item moved. -shiftMaster :: StackSet i l a s sd -> StackSet i l a s sd -shiftMaster = modify' $ \c -> case c of - Stack _ [] _ -> c -- already master. - Stack t ls rs -> Stack t [] (reverse ls ++ rs) - --- | /O(s)/. Set focus to the master window. -focusMaster :: StackSet i l a s sd -> StackSet i l a s sd -focusMaster = modify' $ \c -> case c of - Stack _ [] _ -> c - Stack t ls rs -> Stack x [] (xs ++ t : rs) where (x:xs) = reverse ls - --- --- --------------------------------------------------------------------- --- $composite - --- | /O(w)/. shift. Move the focused element of the current stack to stack --- 'n', leaving it as the focused element on that stack. The item is --- inserted above the currently focused element on that workspace. --- The actual focused workspace doesn't change. If there is no --- element on the current stack, the original stackSet is returned. --- -shift :: (Ord a, Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd -shift n s = maybe s (\w -> shiftWin n w s) (peek s) - --- | /O(n)/. shiftWin. Searches for the specified window 'w' on all workspaces --- of the stackSet and moves it to stack 'n', leaving it as the focused --- element on that stack. The item is inserted above the currently --- focused element on that workspace. --- The actual focused workspace doesn't change. If the window is not --- found in the stackSet, the original stackSet is returned. -shiftWin :: (Ord a, Eq a, Eq s, Eq i) => i -> a -> StackSet i l a s sd -> StackSet i l a s sd -shiftWin n w s = case findTag w s of - Just from | n `tagMember` s && n /= from -> go from s - _ -> s - where go from = onWorkspace n (insertUp w) . onWorkspace from (delete w) - -onWorkspace :: (Eq i, Eq s) => i -> (StackSet i l a s sd -> StackSet i l a s sd) - -> (StackSet i l a s sd -> StackSet i l a s sd) -onWorkspace n f s = view (currentTag s) . f . view n $ s diff --git a/metatile.cabal b/metatile.cabal new file mode 100644 index 0000000..d5327da --- /dev/null +++ b/metatile.cabal @@ -0,0 +1,93 @@ +name: metatile +version: 0.12 +synopsis: A tiling window manager +description: + metatile is a tiling window manager for X. Windows are arranged + automatically to tile the screen without gaps or overlap, maximising + screen use. All features of the window manager are accessible from + the keyboard: a mouse is strictly optional. xmonad is written and + extensible in Haskell. Custom layout algorithms, and other + extensions, may be written by the user in config files. Layouts are + applied dynamically, and different layouts may be used on each + workspace. Xinerama is fully supported, allowing windows to be tiled + on several screens. +category: System +license: BSD3 +license-file: LICENSE +author: Spencer Janssen +maintainer: xmonad@haskell.org +extra-source-files: README TODO CONFIG STYLE tests/loc.hs tests/Properties.hs + man/xmonad.1.markdown man/xmonad.1 man/xmonad.1.html + util/GenerateManpage.hs +cabal-version: >= 1.6 +bug-reports: http://code.google.com/p/xmonad/issues/list +build-type: Simple + +tested-with: GHC==7.6.3 + +data-files: man/xmonad.hs, man/xmonad.1, man/xmonad.1.html + +flag small_base + description: Choose the new smaller, split-up base package. + +flag testing + description: Testing mode, only build minimal components + default: False + +library + exposed-modules: MetaTile + MetaTile.Main + MetaTile.Core + MetaTile.Config + MetaTile.Layout + MetaTile.ManageHook + MetaTile.Operations + MetaTile.StackSet + + if flag(small_base) + build-depends: base < 5 && >=3, containers, directory, process, filepath, extensible-exceptions + else + build-depends: base < 3 + build-depends: X11>=1.5 && < 1.7, mtl, unix, + utf8-string >= 0.3 && < 0.4, + data-default + + if true + ghc-options: -funbox-strict-fields -Wall + + if impl(ghc >= 6.12.1) + ghc-options: -fno-warn-unused-do-bind + + ghc-prof-options: -prof -auto-all + extensions: CPP + + if flag(testing) + buildable: False + +executable metatile + main-is: Main.hs + other-modules: MetaTile + MetaTile.Main + MetaTile.Core + MetaTile.Config + MetaTile.Layout + MetaTile.ManageHook + MetaTile.Operations + MetaTile.StackSet + + if true + ghc-options: -funbox-strict-fields -Wall + + if impl(ghc >= 6.12.1) + ghc-options: -fno-warn-unused-do-bind + + ghc-prof-options: -prof -auto-all + extensions: CPP + + if flag(testing) + cpp-options: -DTESTING + hs-source-dirs: . tests/ + build-depends: QuickCheck < 2 + ghc-options: -Werror + if flag(testing) && flag(small_base) + build-depends: filepath, process, directory, mtl, unix, X11, base, containers, random, extensible-exceptions diff --git a/xmonad.cabal b/xmonad.cabal deleted file mode 100644 index 627361c..0000000 --- a/xmonad.cabal +++ /dev/null @@ -1,102 +0,0 @@ -name: xmonad -version: 0.12 -homepage: http://xmonad.org -synopsis: A tiling window manager -description: - xmonad is a tiling window manager for X. Windows are arranged - automatically to tile the screen without gaps or overlap, maximising - screen use. All features of the window manager are accessible from - the keyboard: a mouse is strictly optional. xmonad is written and - extensible in Haskell. Custom layout algorithms, and other - extensions, may be written by the user in config files. Layouts are - applied dynamically, and different layouts may be used on each - workspace. Xinerama is fully supported, allowing windows to be tiled - on several screens. -category: System -license: BSD3 -license-file: LICENSE -author: Spencer Janssen -maintainer: xmonad@haskell.org -extra-source-files: README TODO CONFIG STYLE tests/loc.hs tests/Properties.hs - man/xmonad.1.markdown man/xmonad.1 man/xmonad.1.html - util/GenerateManpage.hs -cabal-version: >= 1.6 -bug-reports: http://code.google.com/p/xmonad/issues/list -build-type: Simple - -tested-with: GHC==7.6.1, - GHC==7.4.1, - GHC==7.2.1, - GHC==6.12.3, - GHC==6.10.4 - -data-files: man/xmonad.hs, man/xmonad.1, man/xmonad.1.html - -source-repository head - type: darcs - location: http://code.haskell.org/xmonad - -flag small_base - description: Choose the new smaller, split-up base package. - -flag testing - description: Testing mode, only build minimal components - default: False - -library - exposed-modules: XMonad - XMonad.Main - XMonad.Core - XMonad.Config - XMonad.Layout - XMonad.ManageHook - XMonad.Operations - XMonad.StackSet - - if flag(small_base) - build-depends: base < 5 && >=3, containers, directory, process, filepath, extensible-exceptions - else - build-depends: base < 3 - build-depends: X11>=1.5 && < 1.7, mtl, unix, - utf8-string >= 0.3 && < 0.4, - data-default - - if true - ghc-options: -funbox-strict-fields -Wall - - if impl(ghc >= 6.12.1) - ghc-options: -fno-warn-unused-do-bind - - ghc-prof-options: -prof -auto-all - extensions: CPP - - if flag(testing) - buildable: False - -executable xmonad - main-is: Main.hs - other-modules: XMonad - XMonad.Main - XMonad.Core - XMonad.Config - XMonad.Layout - XMonad.ManageHook - XMonad.Operations - XMonad.StackSet - - if true - ghc-options: -funbox-strict-fields -Wall - - if impl(ghc >= 6.12.1) - ghc-options: -fno-warn-unused-do-bind - - ghc-prof-options: -prof -auto-all - extensions: CPP - - if flag(testing) - cpp-options: -DTESTING - hs-source-dirs: . tests/ - build-depends: QuickCheck < 2 - ghc-options: -Werror - if flag(testing) && flag(small_base) - build-depends: filepath, process, directory, mtl, unix, X11, base, containers, random, extensible-exceptions -- cgit v1.2.3