From 8b8380e18b70352c5e233635d34139b17539b001 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Thu, 1 Nov 2007 19:08:46 +0100 Subject: Hierarchify darcs-hash:20071101180846-a5988-25ba1c9ce37a35c1533e4075cc9494c6f7dd5ade --- DefaultConfig.hs | 258 ---------------------- EventLoop.hs | 268 ----------------------- Layouts.hs | 175 --------------- Main.hs | 4 +- Operations.hs | 505 ------------------------------------------- StackSet.hs | 565 ------------------------------------------------ XMonad.hs | 2 +- XMonad/DefaultConfig.hs | 257 ++++++++++++++++++++++ XMonad/EventLoop.hs | 268 +++++++++++++++++++++++ XMonad/Layouts.hs | 175 +++++++++++++++ XMonad/Operations.hs | 505 +++++++++++++++++++++++++++++++++++++++++++ XMonad/StackSet.hs | 565 ++++++++++++++++++++++++++++++++++++++++++++++++ tests/Properties.hs | 4 +- xmonad.cabal | 4 +- 14 files changed, 1777 insertions(+), 1778 deletions(-) delete mode 100644 DefaultConfig.hs delete mode 100644 EventLoop.hs delete mode 100644 Layouts.hs delete mode 100644 Operations.hs delete mode 100644 StackSet.hs create mode 100644 XMonad/DefaultConfig.hs create mode 100644 XMonad/EventLoop.hs create mode 100644 XMonad/Layouts.hs create mode 100644 XMonad/Operations.hs create mode 100644 XMonad/StackSet.hs diff --git a/DefaultConfig.hs b/DefaultConfig.hs deleted file mode 100644 index 58abac8..0000000 --- a/DefaultConfig.hs +++ /dev/null @@ -1,258 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Config.hs --- Copyright : (c) Spencer Janssen 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : dons@galois.com --- Stability : stable --- Portability : portable --- --- This module specifies configurable defaults for xmonad. If you change --- values here, be sure to recompile and restart (mod-q) xmonad, --- for the changes to take effect. --- ------------------------------------------------------------------------- - -module DefaultConfig (defaultConfig) where - --- --- Useful imports --- -import Control.Monad.Reader ( asks ) -import XMonad hiding (workspaces, manageHook, numlockMask) -import qualified XMonad (workspaces, manageHook, numlockMask) -import Layouts -import Operations -import qualified StackSet as W -import Data.Ratio -import Data.Bits ((.|.)) -import qualified Data.Map as M -import System.Exit -import Graphics.X11.Xlib -import EventLoop - --- % Extension-provided imports - --- | 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. --- -modMask :: KeyMask -modMask = mod1Mask - --- | The mask for the numlock key. Numlock status is "masked" from the --- current modifier status, so the keybindings will work with numlock on or --- off. You may need to change this on some systems. --- --- You can find the numlock modifier by running "xmodmap" and looking for a --- modifier with Num_Lock bound to it: --- --- > $ xmodmap | grep Num --- > mod2 Num_Lock (0x4d) --- --- Set numlockMask = 0 if you don't have a numlock key, or want to treat --- numlock status separately. --- -numlockMask :: KeyMask -numlockMask = mod2Mask - --- | Default offset of drawable screen boundaries from each physical --- screen. Anything non-zero here will leave a gap of that many pixels --- on the given edge, on the that screen. A useful gap at top of screen --- for a menu bar (e.g. 15) --- --- An example, to set a top gap on monitor 1, and a gap on the bottom of --- monitor 2, you'd use a list of geometries like so: --- --- > defaultGaps = [(18,0,0,0),(0,18,0,0)] -- 2 gaps on 2 monitors --- --- Fields are: top, bottom, left, right. --- ---defaultGaps :: [(Int,Int,Int,Int)] - - ------------------------------------------------------------------------- --- 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 :: Window -- ^ the new window to manage - -> String -- ^ window title - -> String -- ^ window resource name - -> String -- ^ window resource class - -> X (WindowSet -> WindowSet) - --- Always float various programs: -manageHook w _ _ c | c `elem` floats = fmap (W.float w . snd) (floatLocation w) - where floats = ["MPlayer", "Gimp"] - --- Desktop panels and dock apps should be ignored by xmonad: -manageHook w _ n _ | n `elem` ignore = reveal w >> return (W.delete w) - where ignore = ["gnome-panel", "desktop_window", "kicker", "kdesktop"] - --- Automatically send Firefox windows to the "web" workspace: --- If a workspace named "web" doesn't exist, the window will appear on the --- current workspace. -manageHook _ _ "Gecko" _ = return $ W.shift "web" - --- The default rule: return the WindowSet unmodified. You typically do not --- want to modify this line. -manageHook _ _ _ _ = return id - ------------------------------------------------------------------------- --- 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 - -- Add extra layouts you want to use here: - -- % Extension-provided layouts - 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 - ------------------------------------------------------------------------- --- Key bindings: - --- | The xmonad key bindings. Add, modify or remove key bindings here. --- --- (The comment formatting character is used when generating the manpage) --- -keys :: M.Map (KeyMask, KeySym) (X ()) -keys = M.fromList $ - -- launching and killing programs - [ ((modMask .|. shiftMask, xK_Return), asks (terminal . config) >>= spawn) -- %! Launch terminal - , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") -- %! 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 $ Layout layout) -- %! 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, 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 - - -- floating layer support - , ((modMask, xK_t ), withFocused $ windows . W.sink) -- %! Push window back into tiling - - -- 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 - - -- toggle the status bar gap - , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps defaultConfig ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap - - -- quit, or restart - , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- %! Quit xmonad - , ((modMask , xK_q ), broadcastMessage ReleaseResources >> restart Nothing True) -- %! Restart xmonad - - -- % Extension-provided key bindings - ] - ++ - -- 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 workspaces [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)]] - - -- % Extension-provided key bindings lists - --- | Mouse bindings: default actions bound to mouse events --- -mouseBindings :: M.Map (KeyMask, Button) (Window -> X ()) -mouseBindings = M.fromList $ - -- mod-button1 %! Set the window to floating mode and move by dragging - [ ((modMask, button1), (\w -> focus w >> mouseMoveWindow w)) - -- mod-button2 %! Raise the window to the top of the stack - , ((modMask, button2), (\w -> focus w >> windows W.swapMaster)) - -- mod-button3 %! Set the window to floating mode and resize by dragging - , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) - -- you may also bind events to the mouse scroll wheel (button4 and button5) - - -- % Extension-provided mouse bindings - ] - --- % Extension-provided definitions - -defaultConfig :: XConfig -defaultConfig = XConfig { borderWidth = 1 -- Width of the window border in pixels. - , XMonad.workspaces = workspaces - , defaultGaps = [(0,0,0,0)] -- 15 for default dzen font - -- | The top level layout switcher. Most users will not need to modify this binding. - -- - -- By default, we simply switch between the layouts listed in `layouts' - -- above, but you may program your own selection behaviour here. Layout - -- transformers, for example, would be hooked in here. - -- - , layoutHook = Layout layout - , terminal = "xterm" -- The preferred terminal program. - , normalBorderColor = "#dddddd" -- Border color for unfocused windows. - , focusedBorderColor = "#ff0000" -- Border color for focused windows. - , XMonad.numlockMask = numlockMask - , XMonad.keys = DefaultConfig.keys - , XMonad.mouseBindings = DefaultConfig.mouseBindings - -- | 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 = return () - , XMonad.manageHook = manageHook - } diff --git a/EventLoop.hs b/EventLoop.hs deleted file mode 100644 index ce29264..0000000 --- a/EventLoop.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- | --- Module : EventLoop.hs --- Copyright : (c) Spencer Janssen 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : sjanssen@cse.unl.edu --- Stability : unstable --- Portability : not portable, uses mtl, X11, posix --- --- xmonad, a minimalist, tiling window manager for X11 --- ------------------------------------------------------------------------------ - -module EventLoop (makeMain) where - -import Data.Bits -import qualified Data.Map as M -import qualified Data.Set as S -import Control.Monad.Reader -import Control.Monad.State -import Data.Maybe (fromMaybe) - -import System.Environment (getArgs) - -import Graphics.X11.Xlib hiding (refreshKeyboardMapping) -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xinerama (getScreenInfo) - -import XMonad -import StackSet (new, floating, member) -import qualified StackSet as W -import Operations - -import System.IO - --- | --- The main entry point --- -makeMain :: XConfig -> IO () -makeMain xmc = do - dpy <- openDisplay "" - let dflt = defaultScreen dpy - - rootw <- rootWindow dpy dflt - xinesc <- getScreenInfo dpy - nbc <- initColor dpy $ normalBorderColor xmc - fbc <- initColor dpy $ focusedBorderColor xmc - hSetBuffering stdout NoBuffering - args <- getArgs - - let layout = layoutHook xmc - lreads = readsLayout layout - initialWinset = new layout (workspaces xmc) $ zipWith SD xinesc gaps - - 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.ensureTags layout (workspaces xmc) - $ W.mapLayout (fromMaybe layout . maybeRead lreads) ws - - gaps = take (length xinesc) $ defaultGaps xmc ++ repeat (0,0,0,0) - - cf = XConf - { display = dpy - , config = xmc - , theRoot = rootw - , normalBorder = nbc - , focusedBorder = fbc } - st = XState - { windowset = initialWinset - , mapped = S.empty - , waitingUnmap = M.empty - , dragging = Nothing } - - xSetErrorHandler -- in C, I'm too lazy to write the binding: dons - - -- setup initial X environment - sync dpy False - selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask - .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask - - allocaXEvent $ \e -> - runX cf st $ do - - grabKeys xmc - grabButtons xmc - - io $ sync dpy False - - -- bootstrap the windowset, Operations.windows will identify all - -- the windows in winset as new and set initial properties for - -- those windows - windows (const winset) - - -- scan for all top-level windows, add the unmanaged ones to the - -- windowset - ws <- io $ scan dpy rootw - mapM_ manage ws - - -- main loop, for all you HOF/recursion fans out there. - forever_ $ handle =<< io (nextEvent dpy e >> getEvent e) - - return () - where forever_ a = a >> forever_ a - - -- --------------------------------------------------------------------- - -- | 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 - userCode $ whenJust (M.lookup (mClean, s) (keys xmc)) 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 manage w - - -- window destroyed, unmanage it - -- window gone, unmanage it - handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w - - -- 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}) = whenX (isClient w) $ do - e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap) - if (synthetic || e == 0) - then unmanage w - else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) }) - - -- set keyboard mapping - handle e@(MappingNotifyEvent {}) = do - io $ refreshKeyboardMapping e - when (ev_request e == mappingKeyboard) (grabKeys xmc) - - -- 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. - isr <- isRoot w - m <- cleanMask $ ev_state e - if isr then userCode $ whenJust (M.lookup (m, b) $ mouseBindings xmc) ($ ev_subwindow e) - else focus w - sendMessage e -- Always send button events. - - -- entered a normal window, makes this focused. - handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) - | t == enterNotify && ev_mode e == notifyNormal - && ev_detail e /= notifyInferior = 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 - wa <- io $ getWindowAttributes dpy w - - if M.member w (floating ws) - || 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 = fromIntegral (borderWidth xmc) - , wc_sibling = ev_above e - , wc_stack_mode = ev_detail e } - when (member w ws) (float w) - else io $ allocaXEvent $ \ev -> do - setEventType ev configureNotify - setConfigureEvent ev w w - (wa_x wa) (wa_y wa) (wa_width wa) - (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) - sendEvent dpy w False 0 ev - 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 PropertyEvent { ev_event_type = t, ev_atom = a } - | t == propertyNotify && a == wM_NAME = userCode $ logHook xmc - - handle e = broadcastMessage e -- trace (eventName e) -- ignoring - - --- --------------------------------------------------------------------- --- 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) - --- | Grab the keys back -grabKeys :: XConfig -> X () -grabKeys xmc = do - XConf { display = dpy, theRoot = rootw } <- ask - let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync - io $ ungrabKey dpy anyKey anyModifier rootw - forM_ (M.keys $ keys xmc) $ \(mask,sym) -> do - kc <- io $ keysymToKeycode dpy sym - -- "If the specified KeySym is not defined for any KeyCode, - -- XKeysymToKeycode() returns zero." - when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) =<< extraModifiers - --- | XXX comment me -grabButtons :: XConfig -> X () -grabButtons xmc = 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 - mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ mouseBindings xmc) diff --git a/Layouts.hs b/Layouts.hs deleted file mode 100644 index 30c70ea..0000000 --- a/Layouts.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} - --- -------------------------------------------------------------------------- --- | --- Module : Layouts.hs --- Copyright : (c) Spencer Janssen 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : sjanssen@cse.unl.edu --- Stability : unstable --- Portability : not portable, Typeable deriving, mtl, posix --- --- The collection of core layouts. --- ------------------------------------------------------------------------------ - -module Layouts (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..), - Full(..), Tall(..), Mirror(..), mirrorRect, splitVertically, - splitHorizontally, splitHorizontallyBy, splitVerticallyBy) where - -import XMonad - -import Graphics.X11 (Rectangle(..)) -import qualified StackSet as W -import Control.Arrow ((***), second) -import Control.Monad -import Data.Maybe (fromMaybe) - - ------------------------------------------------------------------------- --- LayoutClass selection manager - --- | A layout that allows users to switch between various layout options. - --- | 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 -(|||) = flip SLeft -infixr 5 ||| - -data Choose l r a = SLeft (r a) (l a) - | SRight (l a) (r a) deriving (Read, Show) - -data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable) -instance Message NextNoWrap - --- This has lots of pseudo duplicated code, we must find a better way -instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where - doLayout (SLeft r l) = (fmap (second . fmap $ SLeft r) .) . doLayout l - doLayout (SRight l r) = (fmap (second . fmap $ SRight l) .) . doLayout r - - description (SLeft _ l) = description l - description (SRight _ r) = description r - - handleMessage lr m | Just FirstLayout <- fromMessage m = case lr of - SLeft {} -> return Nothing - SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) - $ handleMessage r (SomeMessage Hide) - - handleMessage lr m | Just NextLayout <- fromMessage m = do - mlr <- handleMessage lr $ SomeMessage NextNoWrap - maybe (handleMessage lr $ SomeMessage FirstLayout) (return . Just) mlr - - handleMessage (SLeft r l) m | Just NextNoWrap <- fromMessage m = do - handleMessage l (SomeMessage Hide) - mr <- handleMessage r (SomeMessage FirstLayout) - return . Just . SRight l $ fromMaybe r mr - - handleMessage lr m | Just ReleaseResources <- fromMessage m = - liftM2 ((Just .) . cons) - (fmap (fromMaybe l) $ handleMessage l m) - (fmap (fromMaybe r) $ handleMessage r m) - where (cons, l, r) = case lr of - (SLeft r l) -> (flip SLeft, l, r) - (SRight l r) -> (SRight, l, r) - - -- The default cases for left and right: - handleMessage (SLeft r l) m = fmap (fmap $ SLeft r) $ handleMessage l m - handleMessage (SRight l r) m = fmap (fmap $ SRight l) $ handleMessage r m - --- --- | Builtin layout algorithms: --- --- > fullscreen mode --- > tall mode --- --- The latter algorithms support the following operations: --- --- > Shrink --- > Expand --- -data Resize = Shrink | Expand deriving Typeable - --- | You can also increase the number of clients in the master pane -data IncMasterN = IncMasterN Int deriving Typeable - -instance Message Resize -instance Message IncMasterN - --- | Simple fullscreen mode, just render all windows fullscreen. -data Full a = Full deriving (Show, Read) - -instance LayoutClass Full a - --- | The inbuilt tiling mode of xmonad, and its operations. -data Tall a = Tall Int Rational Rational deriving (Show, Read) - -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" - --- | Mirror a rectangle -mirrorRect :: Rectangle -> Rectangle -mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) - --- | Mirror a layout, compute its 90 degree rotated form. -data Mirror l a = Mirror (l a) deriving (Show, Read) - -instance LayoutClass l a => LayoutClass (Mirror l) a where - doLayout (Mirror l) r s = (map (second mirrorRect) *** fmap Mirror) - `fmap` doLayout l (mirrorRect r) s - handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l - description (Mirror l) = "Mirror "++ description l - --- | tile. Compute the positions for windows using the default 2 pane tiling algorithm. --- --- The screen is divided (currently) 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 (by default, 1). --- the variable `nmaster' controls how many windows are rendered in the --- master pane. --- --- `delta' specifies the ratio of the screen to resize by. --- --- 'frac' specifies what proportion of the screen to devote to the --- master area. --- -tile :: Rational -> Rectangle -> Int -> Int -> [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. - -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 - -splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect diff --git a/Main.hs b/Main.hs index d8610db..d41823e 100644 --- a/Main.hs +++ b/Main.hs @@ -14,8 +14,8 @@ module Main (main) where -import EventLoop (makeMain) -import DefaultConfig (defaultConfig) +import XMonad.EventLoop (makeMain) +import XMonad.DefaultConfig (defaultConfig) import Control.Exception (handle) import System.IO diff --git a/Operations.hs b/Operations.hs deleted file mode 100644 index b911cf5..0000000 --- a/Operations.hs +++ /dev/null @@ -1,505 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} - --- -------------------------------------------------------------------------- --- | --- Module : Operations.hs --- 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 Operations where - -import XMonad -import Layouts (Full(..)) -import qualified StackSet as W - -import Data.Maybe -import Data.List (nub, (\\), find) -import Data.Bits ((.|.), (.&.), complement) -import Data.Ratio -import qualified Data.Map as M -import qualified Data.Set as S - -import Control.Monad.State -import Control.Monad.Reader - -import System.IO -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 (fmap not $ isClient w) $ withDisplay $ \d -> do - sh <- io $ getWMNormalHints d w - - let isFixedSize = sh_min_size sh /= Nothing && sh_min_size sh == sh_max_size sh - isTransient <- isJust `liftM` io (getTransientForHint d w) - - (sc, rr) <- floatLocation w - -- ensure that float windows don't go over the edge of the screen - let adjust (W.RationalRect x y wid h) | x + wid > 1 || y + h > 1 || x < 0 || y < 0 - = W.RationalRect (0.5 - wid/2) (0.5 - h/2) wid h - adjust r = r - - f ws | isFixedSize || isTransient = W.float w (adjust rr) . W.insertUp w . W.view i $ ws - | otherwise = W.insertUp w ws - where i = fromMaybe (W.tag . W.workspace . W.current $ ws) $ W.lookupWorkspace sc ws - - n <- fmap (fromMaybe "") $ io $ fetchName d w - (ClassHint rn rc) <- io $ getClassHint d w - mh <- asks (manageHook . config) - g <- mh w n rn rc `catchX` return id - windows (g . f) - --- | unmanage. A window no longer exists, remove it from the window --- list, on whatever workspace it is. --- --- should also unmap? --- -unmanage :: Window -> X () -unmanage w = do - windows (W.delete w) - setWMState w withdrawnState - modify (\s -> s {mapped = S.delete w (mapped s), waitingUnmap = M.delete w (waitingUnmap s)}) - --- | Modify the size of the status gap at the top of the current screen --- Taking a function giving the current screen, and current geometry. -modifyGap :: (Int -> (Int,Int,Int,Int) -> (Int,Int,Int,Int)) -> X () -modifyGap f = do - windows $ \ws@(W.StackSet { W.current = c@(W.Screen { W.screenDetail = sd }) }) -> - let n = fromIntegral . W.screen $ c - g = f n . statusGap $ sd - in ws { W.current = c { W.screenDetail = sd { statusGap = g } } } - --- | Kill the currently focused client. 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) --- -kill :: X () -kill = withDisplay $ \d -> withFocused $ \w -> 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 () - --- --------------------------------------------------------------------- --- 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.workspace) $ W.current old : W.visible old - ws = f old - XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask - mapM_ setInitialProperties (W.allWindows ws \\ W.allWindows old) - whenJust (W.peek old) $ \otherw -> io $ setWindowBorder d otherw nbc - modify (\s -> s { windowset = ws }) - - -- notify non visibility - let tags_oldvisible = map (W.tag . W.workspace) $ W.current old : W.visible old - gottenhidden = filter (`elem` tags_oldvisible) $ map W.tag $ W.hidden ws - sendMessageToWorkspaces Hide gottenhidden - - -- for each workspace, layout the currently visible workspaces - let allscreens = W.screens ws - summed_visible = scanl (++) [] $ map (W.integrate' . W.stack . W.workspace) allscreens - visible <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do - let n = W.tag (W.workspace w) - this = W.view n ws - l = W.layout (W.workspace w) - flt = filter (flip M.member (W.floating ws)) (W.index this) - tiled = (W.stack . W.workspace . W.current $ this) - >>= W.filter (`M.notMember` W.floating ws) - >>= W.filter (`notElem` vis) - (SD (Rectangle sx sy sw sh) - (gt,gb,gl,gr)) = W.screenDetail w - viewrect = Rectangle (sx + fromIntegral gl) (sy + fromIntegral gt) - (sw - fromIntegral (gl + gr)) (sh - fromIntegral (gt + gb)) - - -- just the tiled windows: - -- now tile the windows on this workspace, modified by the gap - (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout (Layout Full) viewrect tiled - mapM_ (uncurry tileWindow) rs - whenJust ml' $ \l' -> runOnWorkspaces (\ww -> if W.tag ww == n - then return $ ww { W.layout = l'} - else return ww) - - -- now the floating windows: - -- move/resize the floating windows, if there are any - forM_ flt $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ - \(W.RationalRect rx ry rw rh) -> do - tileWindow fw $ Rectangle - (sx + floor (toRational sw*rx)) (sy + floor (toRational sh*ry)) - (floor (toRational sw*rw)) (floor (toRational sh*rh)) - - let vs = flt ++ map fst rs - io $ restackWindows d vs - -- return the visible windows for this workspace: - return vs - - whenJust (W.peek ws) $ \w -> io $ setWindowBorder d w fbc - setTopFocus - asks (logHook . config) >>= userCode - -- io performGC -- really helps, but seems to trigger GC bugs? - - -- hide every window that was potentially visible before, but is not - -- given a position by a layout now. - mapM_ hide (nub oldvisible \\ visible) - - clearEvents enterWindowMask - --- | 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 (gets (S.member w . mapped)) $ withDisplay $ \d -> do - io $ do selectInput d w (clientMask .&. complement structureNotifyMask) - unmapWindow d w - selectInput d w clientMask - setWMState w iconicState - -- this part is key: we increment the waitingUnmap counter to distinguish - -- between client and xmonad initiated unmaps. - modify (\s -> s { waitingUnmap = M.insertWith (+) w 1 (waitingUnmap s) - , mapped = S.delete w (mapped s) }) - --- | 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 - modify (\s -> s { mapped = S.insert w (mapped s) }) - --- | The client events that xmonad is interested in -clientMask :: EventMask -clientMask = structureNotifyMask .|. enterWindowMask .|. propertyChangeMask - --- | Set some properties when we initially gain control of a window -setInitialProperties :: Window -> X () -setInitialProperties w = asks normalBorder >>= \nb -> withDisplay $ \d -> do - setWMState w iconicState - io $ selectInput d w $ clientMask - bw <- asks (borderWidth . config) - io $ setWindowBorderWidth d w bw - -- we must initially set the color of new windows, to maintain invariants - -- required by the border setting in 'windows' - io $ setWindowBorder d w nb - --- | 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 - bw <- (fromIntegral . wa_border_width) `fmap` io (getWindowAttributes d w) - -- give all windows at least 1x1 pixels - let least x | x <= bw*2 = 1 - | otherwise = x - bw*2 - io $ moveResizeWindow d w (rect_x r) (rect_y r) - (least $ rect_width r) (least $ rect_height r) - reveal w - --- --------------------------------------------------------------------- - --- | 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 (io . getScreenInfo) - - windows $ \ws@(W.StackSet { W.current = v, W.visible = vs, W.hidden = hs }) -> - let (xs, ys) = splitAt (length xinesc) $ map W.workspace (v:vs) ++ hs - (a:as) = zipWith3 W.Screen xs [0..] $ zipWith SD xinesc gs - sgs = map (statusGap . W.screenDetail) (v:vs) - gs = take (length xinesc) (sgs ++ repeat (0,0,0,0)) - in ws { W.current = a - , W.visible = as - , W.hidden = ys } - --- --------------------------------------------------------------------- - --- | setButtonGrab. Tell whether or not to intercept clicks on a given window -setButtonGrab :: Bool -> Window -> X () -setButtonGrab grab w = withDisplay $ \d -> io $ - if grab - then forM_ [button1, button2, button3] $ \b -> - grabButton d b anyModifier w False buttonPressMask - grabModeAsync 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 = withWindowSet $ \s -> do - if W.member w s then when (W.peek s /= Just w) $ windows (W.focusWindow w) - else whenX (isRoot w) $ setFocusX w - --- | 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.current ws : W.visible ws) $ \wk -> do - forM_ (W.index (W.view (W.tag (W.workspace wk)) ws)) $ \otherw -> do - setButtonGrab True otherw - - -- If we ungrab buttons on the root window, we lose our mouse bindings. - whenX (not `liftM` isRoot w) $ setButtonGrab False w - io $ do setInputFocus dpy w revertToPointerRoot 0 - -- raiseWindow dpy w - ------------------------------------------------------------------------- --- 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.workspace . W.current) `fmap` gets windowset - ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - whenJust ml' $ \l' -> do - windows $ \ws -> ws { W.current = (W.current ws) - { W.workspace = (W.workspace $ W.current ws) - { W.layout = l' }}} - --- | Send a message to a list of workspaces' layouts, without necessarily refreshing. -sendMessageToWorkspaces :: Message a => a -> [WorkspaceId] -> X () -sendMessageToWorkspaces a l = runOnWorkspaces $ \w -> - if W.tag w `elem` l - then do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - return $ w { W.layout = maybe (W.layout w) id ml' } - else return w - --- | Send a message to all visible layouts, without necessarily refreshing. --- This is how we implement the hooks, such as UnDoLayout. -broadcastMessage :: Message a => a -> X () -broadcastMessage a = runOnWorkspaces $ \w -> do - ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - return $ w { W.layout = maybe (W.layout w) id ml' } - --- | 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 - h <- mapM job $ W.hidden ws - c:v <- mapM (\s -> fmap (\w -> s { W.workspace = w}) $ job (W.workspace s)) - $ W.current ws : W.visible ws - modify $ \s -> s { windowset = ws { W.current = c, W.visible = v, W.hidden = h } } - --- | Set the layout of the currently viewed workspace -setLayout :: Layout Window -> X () -setLayout l = do - ss@(W.StackSet { W.current = c@(W.Screen { W.workspace = ws })}) <- gets windowset - handleMessage (W.layout ws) (SomeMessage ReleaseResources) - windows $ const $ ss {W.current = c { W.workspace = 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 <- asks (numlockMask . config) - return [0, nlm, lockMask, nlm .|. lockMask ] - --- | Strip numlock\/capslock from a mask -cleanMask :: KeyMask -> X KeyMask -cleanMask km = do - nlm <- asks (numlockMask . config) - return (complement (nlm .|. lockMask) .&. km) - --- | Get the Pixel value for a named color -initColor :: Display -> String -> IO Pixel -initColor dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c - where colormap = defaultColormap dpy (defaultScreen dpy) - ------------------------------------------------------------------------- --- | 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 - bw <- fi `fmap` asks (borderWidth . config) - - -- XXX horrible - let sc = fromMaybe (W.current ws) $ find (pointWithin (fi $ wa_x wa) (fi $ wa_y wa) . screenRect . W.screenDetail) $ W.screens ws - 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 - pointWithin :: Integer -> Integer -> Rectangle -> Bool - pointWithin x y r = x >= fi (rect_x r) && - x < fi (rect_x r) + fi (rect_width r) && - y >= fi (rect_y r) && - y < fi (rect_y r) + fi (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` map (W.tag . W.workspace) (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 -> do - io $ resizeWindow d w `uncurry` - applySizeHints sh (ex - fromIntegral (wa_x wa), - ey - fromIntegral (wa_y wa))) - (float w) - --- --------------------------------------------------------------------- --- | Support for window size hints - -type D = (Dimension, Dimension) - --- | Reduce the dimensions if needed to comply to the given SizeHints. -applySizeHints :: Integral a => SizeHints -> (a,a) -> D -applySizeHints 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/StackSet.hs b/StackSet.hs deleted file mode 100644 index 807cb1b..0000000 --- a/StackSet.hs +++ /dev/null @@ -1,565 +0,0 @@ -{-# LANGUAGE PatternGuards #-} - ------------------------------------------------------------------------------ --- | --- Module : StackSet --- Copyright : (c) Don Stewart 2007 --- License : BSD3-style (see LICENSE) --- --- Maintainer : dons@galois.com --- Stability : experimental --- Portability : portable, Haskell 98 --- - -module StackSet ( - -- * Introduction - -- $intro - StackSet(..), Workspace(..), Screen(..), Stack(..), RationalRect(..), - -- * Construction - -- $construction - new, view, greedyView, - -- * Xinerama operations - -- $xinerama - lookupWorkspace, - screens, workspaces, allWindows, - -- * Operations on the current stack - -- $stackOperations - peek, index, integrate, integrate', differentiate, - focusUp, focusDown, focusMaster, focusWindow, - tagMember, renameTag, ensureTags, member, findTag, mapWorkspace, mapLayout, - -- * Modifying the stackset - -- $modifyStackset - insertUp, delete, delete', filter, - -- * Setting the master window - -- $settingMW - swapUp, swapDown, swapMaster, modify, modify', float, sink, -- needed by users - -- * Composite operations - -- $composite - shift, shiftWin, - - -- for testing - abort - ) where - -import Prelude hiding (filter) -import Data.Maybe (listToMaybe,fromJust) -import qualified Data.List as L (deleteBy,find,splitAt,filter,nub) -import Data.List ( (\\) ) -import qualified Data.Map as M (Map,insert,delete,empty) - --- $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 support: --- --- 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. --- --- Master and 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'. --- - --- | --- API changes from xmonad 0.1: --- StackSet constructor arguments changed. StackSet workspace window screen --- --- * new, -- was: empty --- --- * view, --- --- * index, --- --- * peek, -- was: peek\/peekStack --- --- * focusUp, focusDown, -- was: rotate --- --- * swapUp, swapDown --- --- * focus -- was: raiseFocus --- --- * insertUp, -- was: insert\/push --- --- * delete, --- --- * swapMaster, -- was: promote\/swap --- --- * member, --- --- * shift, --- --- * lookupWorkspace, -- was: workspace --- --- * visibleWorkspaces -- gone. --- ------------------------------------------------------------------------- --- | --- 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 - , hidden :: [Workspace i l a] -- ^ workspaces not visible anywhere - , floating :: M.Map a RationalRect -- ^ floating windows - } deriving (Show, Read, Eq) - --- | Visible workspaces, and their Xinerama screens. -data Screen i l a sid sd = Screen { workspace :: !(Workspace i l a) - , screen :: !sid - , screenDetail :: !sd } - deriving (Show, Read, Eq) - --- | --- A workspace is just a tag - its index - 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 (possibly empty) 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 = StackSet cur visi unseen M.empty - where (seen,unseen) = L.splitAt (length m) $ map (\i -> Workspace i l Nothing) wids - (cur:visi) = [ Screen i s sd | (i, s, sd) <- zip3 seen [0..] 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 - | not (i `tagMember` s) - || i == tag (workspace (current s)) = s -- out of bounds or current - - | Just x <- L.find ((i==).tag.workspace) (visible s) - -- if it is visible, it is just raised - = s { current = x, visible = current s : L.deleteBy (equating screen) x (visible s) } - - | Just x <- L.find ((i==).tag) (hidden s) -- must be hidden then - -- if it was hidden, it is raised on the xine screen currently used - = s { current = (current s) { workspace = x } - , hidden = workspace (current s) : L.deleteBy (equating tag) x (hidden s) } - - | otherwise = s -- can't happen: all workspaces are either invalid, current, visible, or hidden - - where equating f = \x y -> f x == f y - - -- '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 - --- --------------------------------------------------------------------- --- $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 . workspace . 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) - { workspace = (workspace (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' (reverseStack . focusUp' . reverseStack) - -swapUp = modify' swapUp' -swapDown = modify' (reverseStack . swapUp' . reverseStack) - -focusUp', swapUp' :: 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) - -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 = maybe s id $ 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 = workspace (current s) : map workspace (visible s) ++ hidden s - --- | 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 - --- | 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) - , hidden = map f (hidden s) } - where updScr scr = scr { workspace = f (workspace 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 hs m) = StackSet (fScreen v) (map fScreen vs) (map fWorkspace hs) m - where - fScreen (Screen ws s sd) = Screen (fWorkspace ws) 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 = maybe False (const True) (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. --- -delete :: (Ord a, Eq s) => a -> StackSet i l a s sd -> StackSet i l a s sd -delete w = sink w . delete' w - --- | 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 = s { current = removeFromScreen (current s) - , visible = map removeFromScreen (visible s) - , hidden = map removeFromWorkspace (hidden s) } - where removeFromWorkspace ws = ws { stack = stack ws >>= filter (/=w) } - removeFromScreen scr = scr { workspace = removeFromWorkspace (workspace scr) } - ------------------------------------------------------------------------- - --- | 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 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 | n `tagMember` s && n /= curtag = maybe s go (peek s) - | otherwise = s - where go w = view curtag . insertUp w . view n . delete' w $ s - curtag = tag (workspace (current 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. --- TODO how does this duplicate 'shift's behaviour? -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 | from == Nothing = s -- not found - | n `tagMember` s && (Just n) /= from = go - | otherwise = s - where from = findTag w s - - go = on n (insertUp w) . on (fromJust from) (delete' w) $ s - curtag = tag (workspace (current s)) - on i f = view curtag . f . view i - diff --git a/XMonad.hs b/XMonad.hs index 7428c2f..9039de2 100644 --- a/XMonad.hs +++ b/XMonad.hs @@ -21,7 +21,7 @@ module XMonad ( atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW ) where -import StackSet +import XMonad.StackSet import Prelude hiding ( catch ) import Control.Exception (catch, throw, Exception(ExitException)) diff --git a/XMonad/DefaultConfig.hs b/XMonad/DefaultConfig.hs new file mode 100644 index 0000000..6fc710f --- /dev/null +++ b/XMonad/DefaultConfig.hs @@ -0,0 +1,257 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DefaultConfig.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : dons@galois.com +-- Stability : stable +-- Portability : portable +-- +-- This module specifies configurable defaults for xmonad. If you change +-- values here, be sure to recompile and restart (mod-q) xmonad, +-- for the changes to take effect. +-- +------------------------------------------------------------------------ + +module XMonad.DefaultConfig (defaultConfig) where + +-- +-- Useful imports +-- +import Control.Monad.Reader ( asks ) +import XMonad hiding (workspaces, manageHook, numlockMask) +import qualified XMonad (workspaces, manageHook, numlockMask) +import XMonad.Layouts +import XMonad.Operations +import qualified XMonad.StackSet as W +import Data.Ratio +import Data.Bits ((.|.)) +import qualified Data.Map as M +import System.Exit +import Graphics.X11.Xlib + +-- % Extension-provided imports + +-- | 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. +-- +modMask :: KeyMask +modMask = mod1Mask + +-- | The mask for the numlock key. Numlock status is "masked" from the +-- current modifier status, so the keybindings will work with numlock on or +-- off. You may need to change this on some systems. +-- +-- You can find the numlock modifier by running "xmodmap" and looking for a +-- modifier with Num_Lock bound to it: +-- +-- > $ xmodmap | grep Num +-- > mod2 Num_Lock (0x4d) +-- +-- Set numlockMask = 0 if you don't have a numlock key, or want to treat +-- numlock status separately. +-- +numlockMask :: KeyMask +numlockMask = mod2Mask + +-- | Default offset of drawable screen boundaries from each physical +-- screen. Anything non-zero here will leave a gap of that many pixels +-- on the given edge, on the that screen. A useful gap at top of screen +-- for a menu bar (e.g. 15) +-- +-- An example, to set a top gap on monitor 1, and a gap on the bottom of +-- monitor 2, you'd use a list of geometries like so: +-- +-- > defaultGaps = [(18,0,0,0),(0,18,0,0)] -- 2 gaps on 2 monitors +-- +-- Fields are: top, bottom, left, right. +-- +--defaultGaps :: [(Int,Int,Int,Int)] + + +------------------------------------------------------------------------ +-- 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 :: Window -- ^ the new window to manage + -> String -- ^ window title + -> String -- ^ window resource name + -> String -- ^ window resource class + -> X (WindowSet -> WindowSet) + +-- Always float various programs: +manageHook w _ _ c | c `elem` floats = fmap (W.float w . snd) (floatLocation w) + where floats = ["MPlayer", "Gimp"] + +-- Desktop panels and dock apps should be ignored by xmonad: +manageHook w _ n _ | n `elem` ignore = reveal w >> return (W.delete w) + where ignore = ["gnome-panel", "desktop_window", "kicker", "kdesktop"] + +-- Automatically send Firefox windows to the "web" workspace: +-- If a workspace named "web" doesn't exist, the window will appear on the +-- current workspace. +manageHook _ _ "Gecko" _ = return $ W.shift "web" + +-- The default rule: return the WindowSet unmodified. You typically do not +-- want to modify this line. +manageHook _ _ _ _ = return id + +------------------------------------------------------------------------ +-- 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 + -- Add extra layouts you want to use here: + -- % Extension-provided layouts + 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 + +------------------------------------------------------------------------ +-- Key bindings: + +-- | The xmonad key bindings. Add, modify or remove key bindings here. +-- +-- (The comment formatting character is used when generating the manpage) +-- +keys :: M.Map (KeyMask, KeySym) (X ()) +keys = M.fromList $ + -- launching and killing programs + [ ((modMask .|. shiftMask, xK_Return), asks (terminal . config) >>= spawn) -- %! Launch terminal + , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") -- %! 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 $ Layout layout) -- %! 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, 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 + + -- floating layer support + , ((modMask, xK_t ), withFocused $ windows . W.sink) -- %! Push window back into tiling + + -- 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 + + -- toggle the status bar gap + , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps defaultConfig ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap + + -- quit, or restart + , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- %! Quit xmonad + , ((modMask , xK_q ), broadcastMessage ReleaseResources >> restart Nothing True) -- %! Restart xmonad + + -- % Extension-provided key bindings + ] + ++ + -- 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 workspaces [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)]] + + -- % Extension-provided key bindings lists + +-- | Mouse bindings: default actions bound to mouse events +-- +mouseBindings :: M.Map (KeyMask, Button) (Window -> X ()) +mouseBindings = M.fromList $ + -- mod-button1 %! Set the window to floating mode and move by dragging + [ ((modMask, button1), (\w -> focus w >> mouseMoveWindow w)) + -- mod-button2 %! Raise the window to the top of the stack + , ((modMask, button2), (\w -> focus w >> windows W.swapMaster)) + -- mod-button3 %! Set the window to floating mode and resize by dragging + , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) + -- you may also bind events to the mouse scroll wheel (button4 and button5) + + -- % Extension-provided mouse bindings + ] + +-- % Extension-provided definitions + +defaultConfig :: XConfig +defaultConfig = XConfig { borderWidth = 1 -- Width of the window border in pixels. + , XMonad.workspaces = workspaces + , defaultGaps = [(0,0,0,0)] -- 15 for default dzen font + -- | The top level layout switcher. Most users will not need to modify this binding. + -- + -- By default, we simply switch between the layouts listed in `layouts' + -- above, but you may program your own selection behaviour here. Layout + -- transformers, for example, would be hooked in here. + -- + , layoutHook = Layout layout + , terminal = "xterm" -- The preferred terminal program. + , normalBorderColor = "#dddddd" -- Border color for unfocused windows. + , focusedBorderColor = "#ff0000" -- Border color for focused windows. + , XMonad.numlockMask = numlockMask + , XMonad.keys = XMonad.DefaultConfig.keys + , XMonad.mouseBindings = XMonad.DefaultConfig.mouseBindings + -- | 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 = return () + , XMonad.manageHook = manageHook + } diff --git a/XMonad/EventLoop.hs b/XMonad/EventLoop.hs new file mode 100644 index 0000000..9bfb588 --- /dev/null +++ b/XMonad/EventLoop.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +---------------------------------------------------------------------------- +-- | +-- Module : EventLoop.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : sjanssen@cse.unl.edu +-- Stability : unstable +-- Portability : not portable, uses mtl, X11, posix +-- +-- xmonad, a minimalist, tiling window manager for X11 +-- +----------------------------------------------------------------------------- + +module XMonad.EventLoop (makeMain) where + +import Data.Bits +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Monad.Reader +import Control.Monad.State +import Data.Maybe (fromMaybe) + +import System.Environment (getArgs) + +import Graphics.X11.Xlib hiding (refreshKeyboardMapping) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xinerama (getScreenInfo) + +import XMonad +import XMonad.StackSet (new, floating, member) +import qualified XMonad.StackSet as W +import XMonad.Operations + +import System.IO + +-- | +-- The main entry point +-- +makeMain :: XConfig -> IO () +makeMain xmc = do + dpy <- openDisplay "" + let dflt = defaultScreen dpy + + rootw <- rootWindow dpy dflt + xinesc <- getScreenInfo dpy + nbc <- initColor dpy $ normalBorderColor xmc + fbc <- initColor dpy $ focusedBorderColor xmc + hSetBuffering stdout NoBuffering + args <- getArgs + + let layout = layoutHook xmc + lreads = readsLayout layout + initialWinset = new layout (workspaces xmc) $ zipWith SD xinesc gaps + + 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.ensureTags layout (workspaces xmc) + $ W.mapLayout (fromMaybe layout . maybeRead lreads) ws + + gaps = take (length xinesc) $ defaultGaps xmc ++ repeat (0,0,0,0) + + cf = XConf + { display = dpy + , config = xmc + , theRoot = rootw + , normalBorder = nbc + , focusedBorder = fbc } + st = XState + { windowset = initialWinset + , mapped = S.empty + , waitingUnmap = M.empty + , dragging = Nothing } + + xSetErrorHandler -- in C, I'm too lazy to write the binding: dons + + -- setup initial X environment + sync dpy False + selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask + .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask + + allocaXEvent $ \e -> + runX cf st $ do + + grabKeys xmc + grabButtons xmc + + io $ sync dpy False + + -- bootstrap the windowset, Operations.windows will identify all + -- the windows in winset as new and set initial properties for + -- those windows + windows (const winset) + + -- scan for all top-level windows, add the unmanaged ones to the + -- windowset + ws <- io $ scan dpy rootw + mapM_ manage ws + + -- main loop, for all you HOF/recursion fans out there. + forever_ $ handle =<< io (nextEvent dpy e >> getEvent e) + + return () + where forever_ a = a >> forever_ a + + -- --------------------------------------------------------------------- + -- | 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 + userCode $ whenJust (M.lookup (mClean, s) (keys xmc)) 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 manage w + + -- window destroyed, unmanage it + -- window gone, unmanage it + handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w + + -- 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}) = whenX (isClient w) $ do + e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap) + if (synthetic || e == 0) + then unmanage w + else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) }) + + -- set keyboard mapping + handle e@(MappingNotifyEvent {}) = do + io $ refreshKeyboardMapping e + when (ev_request e == mappingKeyboard) (grabKeys xmc) + + -- 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. + isr <- isRoot w + m <- cleanMask $ ev_state e + if isr then userCode $ whenJust (M.lookup (m, b) $ mouseBindings xmc) ($ ev_subwindow e) + else focus w + sendMessage e -- Always send button events. + + -- entered a normal window, makes this focused. + handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) + | t == enterNotify && ev_mode e == notifyNormal + && ev_detail e /= notifyInferior = 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 + wa <- io $ getWindowAttributes dpy w + + if M.member w (floating ws) + || 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 = fromIntegral (borderWidth xmc) + , wc_sibling = ev_above e + , wc_stack_mode = ev_detail e } + when (member w ws) (float w) + else io $ allocaXEvent $ \ev -> do + setEventType ev configureNotify + setConfigureEvent ev w w + (wa_x wa) (wa_y wa) (wa_width wa) + (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) + sendEvent dpy w False 0 ev + 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 PropertyEvent { ev_event_type = t, ev_atom = a } + | t == propertyNotify && a == wM_NAME = userCode $ logHook xmc + + handle e = broadcastMessage e -- trace (eventName e) -- ignoring + + +-- --------------------------------------------------------------------- +-- 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) + +-- | Grab the keys back +grabKeys :: XConfig -> X () +grabKeys xmc = do + XConf { display = dpy, theRoot = rootw } <- ask + let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync + io $ ungrabKey dpy anyKey anyModifier rootw + forM_ (M.keys $ keys xmc) $ \(mask,sym) -> do + kc <- io $ keysymToKeycode dpy sym + -- "If the specified KeySym is not defined for any KeyCode, + -- XKeysymToKeycode() returns zero." + when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) =<< extraModifiers + +-- | XXX comment me +grabButtons :: XConfig -> X () +grabButtons xmc = 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 + mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ mouseBindings xmc) diff --git a/XMonad/Layouts.hs b/XMonad/Layouts.hs new file mode 100644 index 0000000..862b70c --- /dev/null +++ b/XMonad/Layouts.hs @@ -0,0 +1,175 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} + +-- -------------------------------------------------------------------------- +-- | +-- Module : Layouts.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : sjanssen@cse.unl.edu +-- Stability : unstable +-- Portability : not portable, Typeable deriving, mtl, posix +-- +-- The collection of core layouts. +-- +----------------------------------------------------------------------------- + +module XMonad.Layouts (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..), + Full(..), Tall(..), Mirror(..), mirrorRect, splitVertically, + splitHorizontally, splitHorizontallyBy, splitVerticallyBy) where + +import XMonad + +import Graphics.X11 (Rectangle(..)) +import qualified XMonad.StackSet as W +import Control.Arrow ((***), second) +import Control.Monad +import Data.Maybe (fromMaybe) + + +------------------------------------------------------------------------ +-- LayoutClass selection manager + +-- | A layout that allows users to switch between various layout options. + +-- | 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 +(|||) = flip SLeft +infixr 5 ||| + +data Choose l r a = SLeft (r a) (l a) + | SRight (l a) (r a) deriving (Read, Show) + +data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable) +instance Message NextNoWrap + +-- This has lots of pseudo duplicated code, we must find a better way +instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where + doLayout (SLeft r l) = (fmap (second . fmap $ SLeft r) .) . doLayout l + doLayout (SRight l r) = (fmap (second . fmap $ SRight l) .) . doLayout r + + description (SLeft _ l) = description l + description (SRight _ r) = description r + + handleMessage lr m | Just FirstLayout <- fromMessage m = case lr of + SLeft {} -> return Nothing + SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) + $ handleMessage r (SomeMessage Hide) + + handleMessage lr m | Just NextLayout <- fromMessage m = do + mlr <- handleMessage lr $ SomeMessage NextNoWrap + maybe (handleMessage lr $ SomeMessage FirstLayout) (return . Just) mlr + + handleMessage (SLeft r l) m | Just NextNoWrap <- fromMessage m = do + handleMessage l (SomeMessage Hide) + mr <- handleMessage r (SomeMessage FirstLayout) + return . Just . SRight l $ fromMaybe r mr + + handleMessage lr m | Just ReleaseResources <- fromMessage m = + liftM2 ((Just .) . cons) + (fmap (fromMaybe l) $ handleMessage l m) + (fmap (fromMaybe r) $ handleMessage r m) + where (cons, l, r) = case lr of + (SLeft r l) -> (flip SLeft, l, r) + (SRight l r) -> (SRight, l, r) + + -- The default cases for left and right: + handleMessage (SLeft r l) m = fmap (fmap $ SLeft r) $ handleMessage l m + handleMessage (SRight l r) m = fmap (fmap $ SRight l) $ handleMessage r m + +-- +-- | Builtin layout algorithms: +-- +-- > fullscreen mode +-- > tall mode +-- +-- The latter algorithms support the following operations: +-- +-- > Shrink +-- > Expand +-- +data Resize = Shrink | Expand deriving Typeable + +-- | You can also increase the number of clients in the master pane +data IncMasterN = IncMasterN Int deriving Typeable + +instance Message Resize +instance Message IncMasterN + +-- | Simple fullscreen mode, just render all windows fullscreen. +data Full a = Full deriving (Show, Read) + +instance LayoutClass Full a + +-- | The inbuilt tiling mode of xmonad, and its operations. +data Tall a = Tall Int Rational Rational deriving (Show, Read) + +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" + +-- | Mirror a rectangle +mirrorRect :: Rectangle -> Rectangle +mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) + +-- | Mirror a layout, compute its 90 degree rotated form. +data Mirror l a = Mirror (l a) deriving (Show, Read) + +instance LayoutClass l a => LayoutClass (Mirror l) a where + doLayout (Mirror l) r s = (map (second mirrorRect) *** fmap Mirror) + `fmap` doLayout l (mirrorRect r) s + handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l + description (Mirror l) = "Mirror "++ description l + +-- | tile. Compute the positions for windows using the default 2 pane tiling algorithm. +-- +-- The screen is divided (currently) 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 (by default, 1). +-- the variable `nmaster' controls how many windows are rendered in the +-- master pane. +-- +-- `delta' specifies the ratio of the screen to resize by. +-- +-- 'frac' specifies what proportion of the screen to devote to the +-- master area. +-- +tile :: Rational -> Rectangle -> Int -> Int -> [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. + +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 + +splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect diff --git a/XMonad/Operations.hs b/XMonad/Operations.hs new file mode 100644 index 0000000..dc2d090 --- /dev/null +++ b/XMonad/Operations.hs @@ -0,0 +1,505 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} + +-- -------------------------------------------------------------------------- +-- | +-- Module : Operations.hs +-- 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 +import XMonad.Layouts (Full(..)) +import qualified XMonad.StackSet as W + +import Data.Maybe +import Data.List (nub, (\\), find) +import Data.Bits ((.|.), (.&.), complement) +import Data.Ratio +import qualified Data.Map as M +import qualified Data.Set as S + +import Control.Monad.State +import Control.Monad.Reader + +import System.IO +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 (fmap not $ isClient w) $ withDisplay $ \d -> do + sh <- io $ getWMNormalHints d w + + let isFixedSize = sh_min_size sh /= Nothing && sh_min_size sh == sh_max_size sh + isTransient <- isJust `liftM` io (getTransientForHint d w) + + (sc, rr) <- floatLocation w + -- ensure that float windows don't go over the edge of the screen + let adjust (W.RationalRect x y wid h) | x + wid > 1 || y + h > 1 || x < 0 || y < 0 + = W.RationalRect (0.5 - wid/2) (0.5 - h/2) wid h + adjust r = r + + f ws | isFixedSize || isTransient = W.float w (adjust rr) . W.insertUp w . W.view i $ ws + | otherwise = W.insertUp w ws + where i = fromMaybe (W.tag . W.workspace . W.current $ ws) $ W.lookupWorkspace sc ws + + n <- fmap (fromMaybe "") $ io $ fetchName d w + (ClassHint rn rc) <- io $ getClassHint d w + mh <- asks (manageHook . config) + g <- mh w n rn rc `catchX` return id + windows (g . f) + +-- | unmanage. A window no longer exists, remove it from the window +-- list, on whatever workspace it is. +-- +-- should also unmap? +-- +unmanage :: Window -> X () +unmanage w = do + windows (W.delete w) + setWMState w withdrawnState + modify (\s -> s {mapped = S.delete w (mapped s), waitingUnmap = M.delete w (waitingUnmap s)}) + +-- | Modify the size of the status gap at the top of the current screen +-- Taking a function giving the current screen, and current geometry. +modifyGap :: (Int -> (Int,Int,Int,Int) -> (Int,Int,Int,Int)) -> X () +modifyGap f = do + windows $ \ws@(W.StackSet { W.current = c@(W.Screen { W.screenDetail = sd }) }) -> + let n = fromIntegral . W.screen $ c + g = f n . statusGap $ sd + in ws { W.current = c { W.screenDetail = sd { statusGap = g } } } + +-- | Kill the currently focused client. 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) +-- +kill :: X () +kill = withDisplay $ \d -> withFocused $ \w -> 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 () + +-- --------------------------------------------------------------------- +-- 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.workspace) $ W.current old : W.visible old + ws = f old + XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask + mapM_ setInitialProperties (W.allWindows ws \\ W.allWindows old) + whenJust (W.peek old) $ \otherw -> io $ setWindowBorder d otherw nbc + modify (\s -> s { windowset = ws }) + + -- notify non visibility + let tags_oldvisible = map (W.tag . W.workspace) $ W.current old : W.visible old + gottenhidden = filter (`elem` tags_oldvisible) $ map W.tag $ W.hidden ws + sendMessageToWorkspaces Hide gottenhidden + + -- for each workspace, layout the currently visible workspaces + let allscreens = W.screens ws + summed_visible = scanl (++) [] $ map (W.integrate' . W.stack . W.workspace) allscreens + visible <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do + let n = W.tag (W.workspace w) + this = W.view n ws + l = W.layout (W.workspace w) + flt = filter (flip M.member (W.floating ws)) (W.index this) + tiled = (W.stack . W.workspace . W.current $ this) + >>= W.filter (`M.notMember` W.floating ws) + >>= W.filter (`notElem` vis) + (SD (Rectangle sx sy sw sh) + (gt,gb,gl,gr)) = W.screenDetail w + viewrect = Rectangle (sx + fromIntegral gl) (sy + fromIntegral gt) + (sw - fromIntegral (gl + gr)) (sh - fromIntegral (gt + gb)) + + -- just the tiled windows: + -- now tile the windows on this workspace, modified by the gap + (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout (Layout Full) viewrect tiled + mapM_ (uncurry tileWindow) rs + whenJust ml' $ \l' -> runOnWorkspaces (\ww -> if W.tag ww == n + then return $ ww { W.layout = l'} + else return ww) + + -- now the floating windows: + -- move/resize the floating windows, if there are any + forM_ flt $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ + \(W.RationalRect rx ry rw rh) -> do + tileWindow fw $ Rectangle + (sx + floor (toRational sw*rx)) (sy + floor (toRational sh*ry)) + (floor (toRational sw*rw)) (floor (toRational sh*rh)) + + let vs = flt ++ map fst rs + io $ restackWindows d vs + -- return the visible windows for this workspace: + return vs + + whenJust (W.peek ws) $ \w -> io $ setWindowBorder d w fbc + setTopFocus + asks (logHook . config) >>= userCode + -- io performGC -- really helps, but seems to trigger GC bugs? + + -- hide every window that was potentially visible before, but is not + -- given a position by a layout now. + mapM_ hide (nub oldvisible \\ visible) + + clearEvents enterWindowMask + +-- | 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 (gets (S.member w . mapped)) $ withDisplay $ \d -> do + io $ do selectInput d w (clientMask .&. complement structureNotifyMask) + unmapWindow d w + selectInput d w clientMask + setWMState w iconicState + -- this part is key: we increment the waitingUnmap counter to distinguish + -- between client and xmonad initiated unmaps. + modify (\s -> s { waitingUnmap = M.insertWith (+) w 1 (waitingUnmap s) + , mapped = S.delete w (mapped s) }) + +-- | 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 + modify (\s -> s { mapped = S.insert w (mapped s) }) + +-- | The client events that xmonad is interested in +clientMask :: EventMask +clientMask = structureNotifyMask .|. enterWindowMask .|. propertyChangeMask + +-- | Set some properties when we initially gain control of a window +setInitialProperties :: Window -> X () +setInitialProperties w = asks normalBorder >>= \nb -> withDisplay $ \d -> do + setWMState w iconicState + io $ selectInput d w $ clientMask + bw <- asks (borderWidth . config) + io $ setWindowBorderWidth d w bw + -- we must initially set the color of new windows, to maintain invariants + -- required by the border setting in 'windows' + io $ setWindowBorder d w nb + +-- | 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 + bw <- (fromIntegral . wa_border_width) `fmap` io (getWindowAttributes d w) + -- give all windows at least 1x1 pixels + let least x | x <= bw*2 = 1 + | otherwise = x - bw*2 + io $ moveResizeWindow d w (rect_x r) (rect_y r) + (least $ rect_width r) (least $ rect_height r) + reveal w + +-- --------------------------------------------------------------------- + +-- | 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 (io . getScreenInfo) + + windows $ \ws@(W.StackSet { W.current = v, W.visible = vs, W.hidden = hs }) -> + let (xs, ys) = splitAt (length xinesc) $ map W.workspace (v:vs) ++ hs + (a:as) = zipWith3 W.Screen xs [0..] $ zipWith SD xinesc gs + sgs = map (statusGap . W.screenDetail) (v:vs) + gs = take (length xinesc) (sgs ++ repeat (0,0,0,0)) + in ws { W.current = a + , W.visible = as + , W.hidden = ys } + +-- --------------------------------------------------------------------- + +-- | setButtonGrab. Tell whether or not to intercept clicks on a given window +setButtonGrab :: Bool -> Window -> X () +setButtonGrab grab w = withDisplay $ \d -> io $ + if grab + then forM_ [button1, button2, button3] $ \b -> + grabButton d b anyModifier w False buttonPressMask + grabModeAsync 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 = withWindowSet $ \s -> do + if W.member w s then when (W.peek s /= Just w) $ windows (W.focusWindow w) + else whenX (isRoot w) $ setFocusX w + +-- | 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.current ws : W.visible ws) $ \wk -> do + forM_ (W.index (W.view (W.tag (W.workspace wk)) ws)) $ \otherw -> do + setButtonGrab True otherw + + -- If we ungrab buttons on the root window, we lose our mouse bindings. + whenX (not `liftM` isRoot w) $ setButtonGrab False w + io $ do setInputFocus dpy w revertToPointerRoot 0 + -- raiseWindow dpy w + +------------------------------------------------------------------------ +-- 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.workspace . W.current) `fmap` gets windowset + ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing + whenJust ml' $ \l' -> do + windows $ \ws -> ws { W.current = (W.current ws) + { W.workspace = (W.workspace $ W.current ws) + { W.layout = l' }}} + +-- | Send a message to a list of workspaces' layouts, without necessarily refreshing. +sendMessageToWorkspaces :: Message a => a -> [WorkspaceId] -> X () +sendMessageToWorkspaces a l = runOnWorkspaces $ \w -> + if W.tag w `elem` l + then do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing + return $ w { W.layout = maybe (W.layout w) id ml' } + else return w + +-- | Send a message to all visible layouts, without necessarily refreshing. +-- This is how we implement the hooks, such as UnDoLayout. +broadcastMessage :: Message a => a -> X () +broadcastMessage a = runOnWorkspaces $ \w -> do + ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing + return $ w { W.layout = maybe (W.layout w) id ml' } + +-- | 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 + h <- mapM job $ W.hidden ws + c:v <- mapM (\s -> fmap (\w -> s { W.workspace = w}) $ job (W.workspace s)) + $ W.current ws : W.visible ws + modify $ \s -> s { windowset = ws { W.current = c, W.visible = v, W.hidden = h } } + +-- | Set the layout of the currently viewed workspace +setLayout :: Layout Window -> X () +setLayout l = do + ss@(W.StackSet { W.current = c@(W.Screen { W.workspace = ws })}) <- gets windowset + handleMessage (W.layout ws) (SomeMessage ReleaseResources) + windows $ const $ ss {W.current = c { W.workspace = 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 <- asks (numlockMask . config) + return [0, nlm, lockMask, nlm .|. lockMask ] + +-- | Strip numlock\/capslock from a mask +cleanMask :: KeyMask -> X KeyMask +cleanMask km = do + nlm <- asks (numlockMask . config) + return (complement (nlm .|. lockMask) .&. km) + +-- | Get the Pixel value for a named color +initColor :: Display -> String -> IO Pixel +initColor dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c + where colormap = defaultColormap dpy (defaultScreen dpy) + +------------------------------------------------------------------------ +-- | 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 + bw <- fi `fmap` asks (borderWidth . config) + + -- XXX horrible + let sc = fromMaybe (W.current ws) $ find (pointWithin (fi $ wa_x wa) (fi $ wa_y wa) . screenRect . W.screenDetail) $ W.screens ws + 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 + pointWithin :: Integer -> Integer -> Rectangle -> Bool + pointWithin x y r = x >= fi (rect_x r) && + x < fi (rect_x r) + fi (rect_width r) && + y >= fi (rect_y r) && + y < fi (rect_y r) + fi (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` map (W.tag . W.workspace) (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 -> do + io $ resizeWindow d w `uncurry` + applySizeHints sh (ex - fromIntegral (wa_x wa), + ey - fromIntegral (wa_y wa))) + (float w) + +-- --------------------------------------------------------------------- +-- | Support for window size hints + +type D = (Dimension, Dimension) + +-- | Reduce the dimensions if needed to comply to the given SizeHints. +applySizeHints :: Integral a => SizeHints -> (a,a) -> D +applySizeHints 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 new file mode 100644 index 0000000..cb19746 --- /dev/null +++ b/XMonad/StackSet.hs @@ -0,0 +1,565 @@ +{-# LANGUAGE PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : 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 + StackSet(..), Workspace(..), Screen(..), Stack(..), RationalRect(..), + -- * Construction + -- $construction + new, view, greedyView, + -- * Xinerama operations + -- $xinerama + lookupWorkspace, + screens, workspaces, allWindows, + -- * Operations on the current stack + -- $stackOperations + peek, index, integrate, integrate', differentiate, + focusUp, focusDown, focusMaster, focusWindow, + tagMember, renameTag, ensureTags, member, findTag, mapWorkspace, mapLayout, + -- * Modifying the stackset + -- $modifyStackset + insertUp, delete, delete', filter, + -- * Setting the master window + -- $settingMW + swapUp, swapDown, swapMaster, modify, modify', float, sink, -- needed by users + -- * Composite operations + -- $composite + shift, shiftWin, + + -- for testing + abort + ) where + +import Prelude hiding (filter) +import Data.Maybe (listToMaybe,fromJust) +import qualified Data.List as L (deleteBy,find,splitAt,filter,nub) +import Data.List ( (\\) ) +import qualified Data.Map as M (Map,insert,delete,empty) + +-- $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 support: +-- +-- 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. +-- +-- Master and 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'. +-- + +-- | +-- API changes from xmonad 0.1: +-- StackSet constructor arguments changed. StackSet workspace window screen +-- +-- * new, -- was: empty +-- +-- * view, +-- +-- * index, +-- +-- * peek, -- was: peek\/peekStack +-- +-- * focusUp, focusDown, -- was: rotate +-- +-- * swapUp, swapDown +-- +-- * focus -- was: raiseFocus +-- +-- * insertUp, -- was: insert\/push +-- +-- * delete, +-- +-- * swapMaster, -- was: promote\/swap +-- +-- * member, +-- +-- * shift, +-- +-- * lookupWorkspace, -- was: workspace +-- +-- * visibleWorkspaces -- gone. +-- +------------------------------------------------------------------------ +-- | +-- 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 + , hidden :: [Workspace i l a] -- ^ workspaces not visible anywhere + , floating :: M.Map a RationalRect -- ^ floating windows + } deriving (Show, Read, Eq) + +-- | Visible workspaces, and their Xinerama screens. +data Screen i l a sid sd = Screen { workspace :: !(Workspace i l a) + , screen :: !sid + , screenDetail :: !sd } + deriving (Show, Read, Eq) + +-- | +-- A workspace is just a tag - its index - 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 (possibly empty) 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 = StackSet cur visi unseen M.empty + where (seen,unseen) = L.splitAt (length m) $ map (\i -> Workspace i l Nothing) wids + (cur:visi) = [ Screen i s sd | (i, s, sd) <- zip3 seen [0..] 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 + | not (i `tagMember` s) + || i == tag (workspace (current s)) = s -- out of bounds or current + + | Just x <- L.find ((i==).tag.workspace) (visible s) + -- if it is visible, it is just raised + = s { current = x, visible = current s : L.deleteBy (equating screen) x (visible s) } + + | Just x <- L.find ((i==).tag) (hidden s) -- must be hidden then + -- if it was hidden, it is raised on the xine screen currently used + = s { current = (current s) { workspace = x } + , hidden = workspace (current s) : L.deleteBy (equating tag) x (hidden s) } + + | otherwise = s -- can't happen: all workspaces are either invalid, current, visible, or hidden + + where equating f = \x y -> f x == f y + + -- '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 + +-- --------------------------------------------------------------------- +-- $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 . workspace . 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) + { workspace = (workspace (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' (reverseStack . focusUp' . reverseStack) + +swapUp = modify' swapUp' +swapDown = modify' (reverseStack . swapUp' . reverseStack) + +focusUp', swapUp' :: 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) + +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 = maybe s id $ 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 = workspace (current s) : map workspace (visible s) ++ hidden s + +-- | 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 + +-- | 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) + , hidden = map f (hidden s) } + where updScr scr = scr { workspace = f (workspace 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 hs m) = StackSet (fScreen v) (map fScreen vs) (map fWorkspace hs) m + where + fScreen (Screen ws s sd) = Screen (fWorkspace ws) 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 = maybe False (const True) (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. +-- +delete :: (Ord a, Eq s) => a -> StackSet i l a s sd -> StackSet i l a s sd +delete w = sink w . delete' w + +-- | 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 = s { current = removeFromScreen (current s) + , visible = map removeFromScreen (visible s) + , hidden = map removeFromWorkspace (hidden s) } + where removeFromWorkspace ws = ws { stack = stack ws >>= filter (/=w) } + removeFromScreen scr = scr { workspace = removeFromWorkspace (workspace scr) } + +------------------------------------------------------------------------ + +-- | 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 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 | n `tagMember` s && n /= curtag = maybe s go (peek s) + | otherwise = s + where go w = view curtag . insertUp w . view n . delete' w $ s + curtag = tag (workspace (current 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. +-- TODO how does this duplicate 'shift's behaviour? +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 | from == Nothing = s -- not found + | n `tagMember` s && (Just n) /= from = go + | otherwise = s + where from = findTag w s + + go = on n (insertUp w) . on (fromJust from) (delete' w) $ s + curtag = tag (workspace (current s)) + on i f = view curtag . f . view i + diff --git a/tests/Properties.hs b/tests/Properties.hs index 0b3e728..4f69f76 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,8 +1,8 @@ {-# OPTIONS -fglasgow-exts #-} module Properties where -import StackSet hiding (filter) -import qualified StackSet as S (filter) +import XMonad.StackSet hiding (filter) +import qualified XMonad.StackSet as S (filter) import Debug.Trace import Data.Word diff --git a/xmonad.cabal b/xmonad.cabal index 0663f24..baa5a8c 100644 --- a/xmonad.cabal +++ b/xmonad.cabal @@ -19,11 +19,11 @@ author: Spencer Janssen maintainer: sjanssen@cse.unl.edu build-depends: base>=2.0, mtl, unix, X11==1.3.0 extra-source-files: README TODO tests/loc.hs tests/Properties.hs man/xmonad.1.in - Config.hs-boot util/GenerateManpage.hs man/xmonad.1 man/xmonad.html + util/GenerateManpage.hs man/xmonad.1 man/xmonad.html executable: xmonad main-is: Main.hs -other-modules: EventLoop Layouts Operations StackSet XMonad +other-modules: XMonad.EventLoop XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s ghc-prof-options: -prof -auto-all extensions: GeneralizedNewtypeDeriving -- cgit v1.2.3