summaryrefslogtreecommitdiffstats
path: root/XMonad
diff options
context:
space:
mode:
Diffstat (limited to 'XMonad')
-rw-r--r--XMonad/Config.hs321
-rw-r--r--XMonad/Core.hs574
-rw-r--r--XMonad/Layout.hs210
-rw-r--r--XMonad/Main.hsc433
-rw-r--r--XMonad/ManageHook.hs115
-rw-r--r--XMonad/Operations.hs588
-rw-r--r--XMonad/StackSet.hs549
7 files changed, 0 insertions, 2790 deletions
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 <locale.h>
-
-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