xmonad 0.2 → 0.3
raw patch · 14 files changed
+1131/−536 lines, 14 filesdep ~X11-extrasdep ~basenew-uploader
Dependency ranges changed: X11-extras, base
Files
- Config.hs +76/−31
- Config.hs-boot +5/−0
- Main.hs +122/−47
- Operations.hs +388/−169
- README +28/−9
- StackSet.hs +265/−164
- TODO +9/−0
- XMonad.hs +77/−38
- man/xmonad.1 +13/−1
- man/xmonad.1.in +1/−1
- man/xmonad.html +16/−4
- tests/Properties.hs +127/−68
- tests/loc.hs +0/−1
- xmonad.cabal +4/−3
Config.hs view
@@ -7,13 +7,13 @@ -- Maintainer : dons@cse.unsw.edu.au -- Stability : stable -- Portability : portable----------------------------------------------------------------------------+-- -- -- This module specifies configurable defaults for xmonad. If you change--- values here, be sure to recompile and restart (mod-shift-ctrl-q) xmonad,+-- values here, be sure to recompile and restart (mod-q) xmonad, -- for the changes to take effect.---+-- +------------------------------------------------------------------------ module Config where @@ -22,42 +22,45 @@ -- import XMonad 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 --- The number of workspaces (virtual screens)-workspaces :: Int-workspaces = 9+--+-- The number of workspaces (virtual screens, or window groups)+--+workspaces :: [WorkspaceId]+workspaces = [0..8] --- 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 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 --- When resizing a window, this ratio specifies by what percent to--- resize in a single step-defaultDelta :: Rational-defaultDelta = 3%100---- The default number of windows in the master area-defaultWindowsInMaster :: Int-defaultWindowsInMaster = 1-+-- | -- 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)+-- 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)] defaultGaps = [(0,0,0,0)] -- 15 for default dzen +-- | -- numlock handling: -- -- The mask for the numlock key. You may need to change this on some systems.@@ -71,29 +74,57 @@ numlockMask :: KeyMask numlockMask = mod2Mask +-- | -- Border colors for unfocused and focused windows, respectively.+-- normalBorderColor, focusedBorderColor :: String normalBorderColor = "#dddddd" focusedBorderColor = "#ff0000" +-- | -- Width of the window border in pixels+-- borderWidth :: Dimension borderWidth = 1 --- The default set of Layouts:-defaultLayouts :: [Layout]-defaultLayouts = [ tall defaultWindowsInMaster defaultDelta (1%2)- , wide defaultWindowsInMaster defaultDelta (1%2)- , full ]+-- |+-- The default set of tiling algorithms+--+defaultLayouts :: [Layout Window]+defaultLayouts = [ tiled , mirror tiled , full ]+ where+ -- default tiling algorithm partitions the screen into two panes+ tiled = tall nmaster delta ratio + -- The default number of windows in the master pane+ nmaster = 1++ -- Default proportion of screen occupied by master pane+ ratio = 1%2++ -- Percent of screen to increment by when resizing panes+ delta = 3%100++-- |+-- Perform an arbitrary action on each state change.+-- Examples include:+-- * do nothing+-- * log the state to stdout --+logHook :: X ()+logHook = return ()++-- | -- The key bindings list.+-- +-- The unusual comment format is used to generate the documentation+-- automatically. -- keys :: M.Map (KeyMask, KeySym) (X ()) keys = M.fromList $ -- launching and killing programs [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") -- @@ Launch an xterm- , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && exec $exe") -- @@ Launch dmenu+ , ((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 @@ -115,6 +146,8 @@ , ((modMask, xK_h ), sendMessage Shrink) -- @@ Shrink the master area , ((modMask, xK_l ), sendMessage Expand) -- @@ Expand the master area + , ((modMask, xK_t ), withFocused 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@@ -123,19 +156,31 @@ , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps ++ 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 .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- @@ Quit xmonad , ((modMask , xK_q ), restart Nothing True) -- @@ Restart xmonad ] ++ -- mod-[1..9] @@ Switch to workspace N -- mod-shift-[1..9] @@ Move client to workspace N [((m .|. modMask, k), f i)- | (i, k) <- zip [0 .. fromIntegral workspaces - 1] [xK_1 ..]+ | (i, k) <- zip workspaces [xK_1 ..] , (f, m) <- [(view, 0), (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 >>= f)+ [((m .|. modMask, key), screenWorkspace sc >>= flip whenJust f) | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..]- , (f, m) <- [(view, 0), (shift, shiftMask)]]+ , (f, m) <- [(windows . W.view, 0), (shift, shiftMask)]]++-- |+-- 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 >> swapMaster))+ -- mod-button3 @@ Set the window to floating mode and resize by dragging+ , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) ]
Config.hs-boot view
@@ -1,3 +1,8 @@ module Config where import Graphics.X11.Xlib.Types (Dimension)+import Graphics.X11.Xlib (KeyMask)+import XMonad borderWidth :: Dimension+logHook :: X ()+numlockMask :: KeyMask+workspaces :: [WorkspaceId]
Main.hs view
@@ -8,14 +8,18 @@ -- Stability : unstable -- Portability : not portable, uses mtl, X11, posix ----------------------------------------------------------------------------------- -- xmonad, a minimalist, tiling window manager for X11---+-- +----------------------------------------------------------------------------- +module Main 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) @@ -25,46 +29,44 @@ import XMonad import Config-import StackSet (new)-import Operations (manage, unmanage, focus, setFocusX, full, isClient, rescreen)+import StackSet (new, floating, member, findIndex, workspace, tag, current, visible)+import qualified StackSet as W+import Operations ---+import System.IO++-- | -- The main entry point -- main :: IO () main = do dpy <- openDisplay "" let dflt = defaultScreen dpy- initcolor c = fst `liftM` allocNamedColor dpy (defaultColormap dpy dflt) c rootw <- rootWindow dpy dflt- wmdelt <- internAtom dpy "WM_DELETE_WINDOW" False- wmprot <- internAtom dpy "WM_PROTOCOLS" False xinesc <- getScreenInfo dpy- nbc <- initcolor normalBorderColor- fbc <- initcolor focusedBorderColor+ nbc <- initColor dpy normalBorderColor+ fbc <- initColor dpy focusedBorderColor+ hSetBuffering stdout NoBuffering args <- getArgs let winset | ("--resume" : s : _) <- args , [(x, "")] <- reads s = x- | otherwise = new (fromIntegral workspaces) (fromIntegral $ length xinesc)- safeLayouts = case defaultLayouts of [] -> (full, []); (x:xs) -> (x, xs)+ | otherwise = new workspaces $ zipWith SD xinesc gaps+ gaps = take (length xinesc) $ defaultGaps ++ repeat (0,0,0,0)++ safeLayouts = case defaultLayouts of [] -> (full, []); (x:xs) -> (x,xs) cf = XConf { display = dpy , theRoot = rootw- , wmdelete = wmdelt- , wmprotocols = wmprot- -- fromIntegral needed for X11 versions that use Int instead of CInt. , normalBorder = nbc- , focusedBorder = fbc- }+ , focusedBorder = fbc } st = XState { windowset = winset- , layouts = M.fromList [(w, safeLayouts) | w <- [0 .. W workspaces - 1]]- , statusGaps = take (length xinesc) $ defaultGaps ++ repeat (0,0,0,0)- , xineScreens = xinesc- , dimensions = (fromIntegral (displayWidth dpy dflt),- fromIntegral (displayHeight dpy dflt)) }+ , layouts = M.fromList [(w, safeLayouts) | w <- workspaces]+ , mapped = S.empty+ , waitingUnmap = M.empty+ , dragging = Nothing } xSetErrorHandler -- in C, I'm too lazy to write the binding: dons @@ -73,12 +75,27 @@ selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask grabKeys dpy rootw+ grabButtons dpy rootw+ sync dpy False - ws <- scan dpy rootw+ ws <- scan dpy rootw -- on the resume case, will pick up new windows allocaXEvent $ \e -> runX cf st $ do- mapM_ manage ws++ -- walk workspace, resetting X states/mask for windows+ -- TODO, general iterators for these lists.+ sequence_ [ setInitialProperties w >> reveal w+ | wk <- map W.workspace (W.current winset : W.visible winset)+ , w <- W.integrate' (W.stack wk) ]++ sequence_ [ setInitialProperties w >> hide w+ | wk <- W.hidden winset+ , w <- W.integrate' (W.stack wk) ]++ mapM_ manage ws -- find new windows+ refresh+ -- main loop, for all you HOF/recursion fans out there. forever $ handle =<< io (nextEvent dpy e >> getEvent e) @@ -88,29 +105,42 @@ -- IO stuff. Doesn't require any X state -- Most of these things run only on startup (bar grabkeys) --- | scan for any initial windows to manage+-- | 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+ && (wa_map_state wa == waIsViewable || ic) -- | Grab the keys back grabKeys :: Display -> Window -> IO () grabKeys dpy rootw = do ungrabKey dpy anyKey anyModifier rootw- flip mapM_ (M.keys keys) $ \(mask,sym) -> do+ forM_ (M.keys keys) $ \(mask,sym) -> do kc <- keysymToKeycode dpy sym -- "If the specified KeySym is not defined for any KeyCode, -- XKeysymToKeycode() returns zero."- when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) $- [0, numlockMask, lockMask, numlockMask .|. lockMask]+ when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) extraModifiers where grab kc m = grabKey dpy kc m rootw True grabModeAsync grabModeAsync +grabButtons :: Display -> Window -> IO ()+grabButtons dpy rootw = do+ ungrabButton dpy anyButton anyModifier rootw+ mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) extraModifiers) (M.keys mouseBindings)+ where grab button mask = grabButton dpy button mask rootw False buttonPressMask+ grabModeAsync grabModeSync none none+ -- --------------------------------------------------------------------- -- | Event handler. Map X events onto calls into Operations.hs, which -- modify our internal model of the window manager state.@@ -128,25 +158,57 @@ handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) | t == keyPress = withDisplay $ \dpy -> do s <- io $ keycodeToKeysym dpy code 0- whenJust (M.lookup (complement (numlockMask .|. lockMask) .&. m,s) keys) id+ whenJust (M.lookup (cleanMask m,s) keys) id -- manage a new window handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do wa <- io $ getWindowAttributes dpy w -- ignore override windows- when (not (wa_override_redirect wa)) $ manage w+ -- 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-handle (UnmapEvent {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 {ev_window = w}) = do io $ refreshKeyboardMapping e when (ev_request e == mappingKeyboard) $ withDisplay $ io . flip grabKeys w +-- 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 (ButtonEvent {ev_window = w, ev_event_type = t}) | t == buttonPress = focus w+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+ if isr then whenJust (M.lookup (cleanMask (ev_state e), b) mouseBindings) ($ 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})@@ -160,20 +222,33 @@ when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw -- configure a window-handle e@(ConfigureRequestEvent {}) = withDisplay $ \dpy -> do- io $ configureWindow dpy (ev_window e) (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 = ev_border_width e- , wc_sibling = ev_above e- -- this fromIntegral is only necessary with the old X11 version that uses- -- Int instead of CInt. TODO delete it when there is a new release of X11- , wc_stack_mode = fromIntegral $ ev_detail e }+handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do+ ws <- gets windowset+ wa <- io $ getWindowAttributes dpy w++ -- TODO temporary workaround for some bugs in float. Don't call 'float' on+ -- windows that aren't visible, because it changes the focused screen+ let vis = any ((== findIndex w ws) . Just . tag . workspace) (current ws : visible ws)+ if (M.member w (floating ws) && vis)+ || 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+ , 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 -- the root may have configured handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen -handle _ = return () -- trace (eventName e) -- ignoring+handle e = broadcastMessage e -- trace (eventName e) -- ignoring
Operations.hs view
@@ -1,5 +1,6 @@-{-# OPTIONS -fglasgow-exts #-}------------------------------------------------------------------------------+{-# OPTIONS -fno-warn-orphans -fglasgow-exts #-}+-- \^^ deriving Typeable+-- -------------------------------------------------------------------------- -- | -- Module : Operations.hs -- Copyright : (c) Spencer Janssen 2007@@ -7,48 +8,75 @@ -- -- Maintainer : dons@cse.unsw.edu.au -- Stability : unstable--- Portability : not portable, mtl, posix+-- Portability : not portable, Typeable deriving, mtl, posix --+-- Operations.+-- ----------------------------------------------------------------------------- module Operations where import XMonad import qualified StackSet as W-import {-# SOURCE #-} Config (borderWidth)+import {-# SOURCE #-} Config (borderWidth,logHook,numlockMask) import Data.Maybe-import Data.List (genericIndex, intersectBy)-import Data.Bits ((.|.))+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 System.Mem (performGC) import Control.Monad.State import Control.Monad.Reader-import Control.Arrow+import Control.Arrow ((***), first, second) +import System.IO import Graphics.X11.Xlib import Graphics.X11.Xinerama (getScreenInfo) import Graphics.X11.Xlib.Extras +import qualified Data.Traversable as T+ -- ---------------------------------------------------------------------+-- | -- Window manager operations---- | manage. Add a new window to be managed in the current workspace.--- Bring it into focus. If the window is already managed, nothing happens.+-- 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 = do- withDisplay $ \d -> io $ do- selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask- mapWindow d w- setWindowBorderWidth d w borderWidth- windows $ W.insertUp w+manage w = whenX (fmap not $ isClient w) $ withDisplay $ \d -> do+ setInitialProperties w >> reveal w + -- FIXME: This is pretty awkward. We can't can't let "refresh" happen+ -- before the call to float, because that will resize the window and+ -- lose the default sizing.++ 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)+ if isFixedSize || isTransient+ then do modify $ \s -> s { windowset = W.insertUp w (windowset s) }+ float w -- \^^ now go the refresh.+ else windows $ W.insertUp w+ -- | unmanage. A window no longer exists, remove it from the window -- list, on whatever workspace it is.+--+-- FIXME: clearFloating should be taken care of in W.delete, but if we do it+-- there, floating status is lost when moving windows between workspaces,+-- because W.shift calls W.delete.+--+-- should also unmap?+-- unmanage :: Window -> X ()-unmanage = windows . W.delete+unmanage w = do+ windows (W.sink w . W.delete w)+ setWMState w 0 {-withdrawn-}+ modify (\s -> s {mapped = S.delete w (mapped s), waitingUnmap = M.delete w (waitingUnmap s)}) -- | focus. focus window up or down. or swap various windows. focusUp, focusDown, swapUp, swapDown, swapMaster :: X ()@@ -60,22 +88,20 @@ -- | shift. Move a window to a new workspace, 0 indexed. shift :: WorkspaceId -> X ()-shift n = withFocused hide >> windows (W.shift n)- -- refresh will raise it if we didn't need to move it.+shift n = windows (W.shift n) -- | view. Change the current workspace to workspace at offset n (0 indexed). view :: WorkspaceId -> X ()-view = windows . W.view+view = windows . W.greedyView -- | 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- XState { windowset = ws, statusGaps = gaps } <- get- let n = fromIntegral $ W.screen (W.current ws)- (a,i:b) = splitAt n gaps- modify $ \s -> s { statusGaps = a ++ f n i : b }- refresh+ 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.@@ -85,7 +111,8 @@ -- kill :: X () kill = withDisplay $ \d -> withFocused $ \w -> do- XConf {wmdelete = wmdelt, wmprotocols = wmprot} <- ask+ wmdelt <- atom_WM_DELETE_WINDOW ; wmprot <- atom_WM_PROTOCOLS+ protocols <- io $ getWMProtocols d w io $ if wmdelt `elem` protocols then allocaXEvent $ \ev -> do@@ -97,34 +124,104 @@ -- --------------------------------------------------------------------- -- Managing windows +data UnDoLayout = UnDoLayout deriving ( Typeable, Eq )+instance Message UnDoLayout+ -- | windows. Modify the current window list with a pure function, and refresh windows :: (WindowSet -> WindowSet) -> X () windows f = do- old <- gets windowset- let new = f old- modify (\s -> s { windowset = new })- refresh+ -- Notify visible layouts to remove decorations etc+ -- We cannot use sendMessage because this must not call refresh ever,+ -- and must be called on all visible workspaces.+ broadcastMessage UnDoLayout+ XState { windowset = old, layouts = fls } <- get+ let oldvisible = concatMap (W.integrate' . W.stack . W.workspace) $ W.current old : W.visible old+ ws = f old+ modify (\s -> s { windowset = ws })+ d <- asks display - -- We now go to some effort to compute the minimal set of windows to hide.- -- The minimal set being only those windows which weren't previously hidden,- -- which is the intersection of previously visible windows with those now hidden- mapM_ hide . concatMap (integrate . W.stack) $- intersectBy (\w x -> W.tag w == W.tag x)- (map W.workspace $ W.current old : W.visible old)- (W.hidden new)+ -- for each workspace, layout the currently visible workspaces+ let allscreens = W.current ws : W.visible 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+ Just l = fmap fst $ M.lookup n fls+ flt = filter (flip M.member (W.floating ws)) (W.index this)+ tiled = (W.stack . W.workspace . W.current $ this)+ >>= W.filter (not . flip M.member (W.floating ws))+ >>= W.filter (not . (`elem` 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)) - clearEnterEvents+ -- just the tiled windows:+ -- now tile the windows on this workspace, modified by the gap+ (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout full viewrect tiled+ mapM_ (uncurry tileWindow) rs+ whenJust ml' $ \l' -> modify $ \ss ->+ ss { layouts = M.adjust (first (const l')) n (layouts ss) } - -- TODO: move this into StackSet. This isn't exactly the usual integrate.- where integrate W.Empty = []- integrate (W.Node x l r) = x : l ++ r+ -- 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)) --- | hide. Hide a window by moving it off screen.+ let vs = flt ++ map fst rs+ io $ restackWindows d vs+ -- return the visible windows for this workspace:+ return vs++ setTopFocus+ logHook+ -- 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 = withDisplay $ \d -> do- (sw,sh) <- gets dimensions- io $ moveWindow d w sw sh+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 3 --iconic+ -- 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 1 --normal+ 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 = withDisplay $ \d -> io $ do+ selectInput d w $ clientMask+ setWindowBorderWidth d w borderWidth+ -- | refresh. Render the currently visible workspaces, as determined by -- the StackSet. Also, set focus to the focused window. --@@ -132,47 +229,27 @@ -- with X calls. -- refresh :: X ()-refresh = do- XState { windowset = ws, layouts = fls, xineScreens = xinesc, statusGaps = gaps } <- get- d <- asks display-- -- for each workspace, layout the currently visible workspaces- (`mapM_` (W.current ws : W.visible ws)) $ \w -> do- let n = W.tag (W.workspace w)- this = W.view n ws- Just l = fmap fst $ M.lookup n fls- (Rectangle sx sy sw sh) = genericIndex xinesc (W.screen w)- (gt,gb,gl,gr) = genericIndex gaps (W.screen w)-- -- now tile the windows on this workspace, modified by the gap- rs <- doLayout l (Rectangle (sx + fromIntegral gl)- (sy + fromIntegral gt)- (sw - fromIntegral (gl + gr))- (sh - fromIntegral (gt + gb))) (W.index this)- mapM_ (\(win,rect) -> io (tileWindow d win rect)) rs-- -- and raise the focused window if there is one.- whenJust (W.peek this) $ io . raiseWindow d-- setTopFocus- clearEnterEvents--- io performGC -- really helps +refresh = windows id --- | clearEnterEvents. Remove all window entry events from the event queue.-clearEnterEvents :: X ()-clearEnterEvents = withDisplay $ \d -> io $ do+-- | 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 enterWindowMask p+ 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 :: Display -> Window -> Rectangle -> IO ()-tileWindow d w r = do- bw <- (fromIntegral . wa_border_width) `liftM` getWindowAttributes d w- moveResizeWindow d w (rect_x r) (rect_y r)- (rect_width r - bw*2) (rect_height r - bw*2)+tileWindow :: Window -> Rectangle -> X ()+tileWindow w r = withDisplay $ \d -> do+ bw <- (fromIntegral . wa_border_width) `liftM` 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 -- --------------------------------------------------------------------- @@ -182,67 +259,57 @@ rescreen = do xinesc <- withDisplay (io . getScreenInfo) - -- TODO: This stuff is necessary because Xlib apparently caches screen- -- width/height. Find a better solution later. I hate Xlib.- let sx = maximum $ map (\r -> rect_x r + fromIntegral (rect_width r)) xinesc- sy = maximum $ map (\r -> rect_y r + fromIntegral (rect_height r)) xinesc-- modify (\s -> s { xineScreens = xinesc , dimensions = (sx, sy)- , statusGaps = take (length xinesc) $ (statusGaps s) ++ repeat (0,0,0,0) })- windows $ \ws@(W.StackSet { W.current = v, W.visible = vs, W.hidden = hs }) ->- let (x:xs, ys) = splitAt (length xinesc) $ map W.workspace (v:vs) ++ hs- in ws { W.current = W.Screen x 0- , W.visible = zipWith W.Screen xs [1 ..]+ 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 } -- --------------------------------------------------------------------- -buttonsToGrab :: [Button]-buttonsToGrab = [button1, button2, button3]- -- | setButtonGrab. Tell whether or not to intercept clicks on a given window setButtonGrab :: Bool -> Window -> X ()-setButtonGrab grab w = withDisplay $ \d -> io $ (`mapM_` buttonsToGrab) $ \b ->- if grab then grabButton d b anyModifier w False (buttonPressMask .|. buttonReleaseMask)- grabModeAsync grabModeSync none none- else ungrabButton d b anyModifier w+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 = withWorkspace $ maybe (setFocusX =<< asks theRoot) setFocusX . W.peek+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 = withWorkspace $ \s -> do- if W.member w s then modify (\st -> st { windowset = W.focusWindow w s }) >> setFocusX w -- >> refresh- else whenX (isRoot w) $ setFocusX w -- we could refresh here, moving gap too.- -- XXX a focus change could be caused by switching workspaces in xinerama.- -- if so, and the gap is in use, the gap should probably follow the- -- cursor to the new screen. - --- -- to get the gap though, you need to trigger a refresh.+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 = withWorkspace $ \ws -> do+setFocusX w = withWindowSet $ \ws -> do XConf { display = dpy , normalBorder = nbc, focusedBorder = fbc } <- ask -- clear mouse button grab and border on other windows- (`mapM_` (W.current ws : W.visible ws)) $ \wk -> do- (`mapM_` (W.index (W.view (W.tag (W.workspace wk)) ws))) $ \otherw -> do+ 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- io $ setWindowBorder dpy otherw (color_pixel nbc)+ io $ setWindowBorder dpy otherw nbc + -- 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- setButtonGrab False w- io $ setWindowBorder dpy w (color_pixel fbc)+ io $ setWindowBorder dpy w fbc -- --------------------------------------------------------------------- -- Managing layout@@ -254,23 +321,42 @@ -- becomes a master. When switching back , the focused window is -- uppermost. --+-- Note that the new layout's deconstructor will be called, so it should be+-- idempotent. switchLayout :: X ()-switchLayout = layout (\(x, xs) -> let xs' = xs ++ [x] in (head xs', tail xs'))+switchLayout = do+ broadcastMessage UnDoLayout -- calling refresh now would defeat the point of deconstruction+ n <- gets (W.tag . W.workspace . W.current . windowset)+ modify $ \s -> s { layouts = M.adjust switch n (layouts s) }+ refresh+ where switch (x, xs) = let xs' = xs ++ [x] in (head xs', tail xs') --- | Throw an (extensible) message value to the current Layout scheme,--- possibly modifying how we layout the windows, then refresh.------ TODO, this will refresh on Nothing.+-- | Throw a message to the current Layout possibly modifying how we+-- layout the windows, then refresh. -- sendMessage :: Message a => a -> X ()-sendMessage a = layout $ \x@(l, ls) -> maybe x (flip (,) ls) (modifyLayout l (SomeMessage a))+sendMessage a = do n <- (W.tag . W.workspace . W.current) `fmap` gets windowset+ Just (l,ls) <- M.lookup n `fmap` gets layouts+ ml' <- modifyLayout l (SomeMessage a) `catchX` return (Just l)+ whenJust ml' $ \l' -> do modify $ \s -> s { layouts = M.insert n (l',ls) (layouts s) }+ refresh +-- | 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 = do+ ol <- gets layouts+ nl <- T.forM ol $ \ (l,ls) -> maybe (l,ls) (flip (,) ls) `fmap`+ (modifyLayout l (SomeMessage a) `catchX` return (Just l))+ modify $ \s -> s { layouts = nl }++instance Message Event+ -- -- Builtin layout algorithms: -- -- fullscreen mode -- tall mode--- wide mode -- -- The latter algorithms support the following operations: --@@ -278,85 +364,218 @@ -- Expand -- -data Resize = Shrink | Expand deriving Typeable+data Resize = Shrink | Expand deriving Typeable+data IncMasterN = IncMasterN Int deriving Typeable instance Message Resize--data IncMasterN = IncMasterN Int deriving Typeable instance Message IncMasterN -full :: Layout-full = Layout { doLayout = \sc ws -> return [ (w,sc) | w <- ws ]- , modifyLayout = const Nothing } -- no changes--tall, wide :: Int -> Rational -> Rational -> Layout-wide nmaster delta frac = mirrorLayout (tall nmaster delta frac)+-- simple fullscreen mode, just render all windows fullscreen.+-- a plea for tuple sections: map . (,sc)+full :: Layout a+full = Layout { doLayout = \sc (W.Stack f _ _) -> return ([(f, sc)],Nothing)+ , modifyLayout = const (return Nothing) } -- no changes +--+-- The tiling mode of xmonad, and its operations.+--+tall :: Int -> Rational -> Rational -> Layout a tall nmaster delta frac =- Layout { doLayout = \r -> return . ap zip (tile frac r nmaster . length)- , modifyLayout = \m -> fmap resize (fromMessage m) `mplus`- fmap incmastern (fromMessage m) }+ Layout { doLayout = \r -> return . (\x->(x,Nothing)) .+ ap zip (tile frac r nmaster . length) . W.integrate+ , modifyLayout = \m -> return $ msum [fmap resize (fromMessage m)+ ,fmap incmastern (fromMessage m)] } - where resize Shrink = tall nmaster delta (frac-delta)- resize Expand = tall nmaster delta (frac+delta)- incmastern (IncMasterN d) = tall (max 1 (nmaster+d)) delta frac+ 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 -- | Mirror a rectangle mirrorRect :: Rectangle -> Rectangle mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) --- | Mirror a layout-mirrorLayout :: Layout -> Layout-mirrorLayout (Layout { doLayout = dl, modifyLayout = ml }) =- Layout { doLayout = \sc w -> map (second mirrorRect) `fmap` dl (mirrorRect sc) w- , modifyLayout = fmap mirrorLayout . ml }+-- | Mirror a layout, compute its 90 degree rotated form.+mirror :: Layout a -> Layout a+mirror (Layout { doLayout = dl, modifyLayout = ml }) =+ Layout { doLayout = \sc w -> do (wrs, ml') <- dl (mirrorRect sc) w+ return (map (second mirrorRect) wrs, mirror `fmap` ml')+ , modifyLayout = fmap (fmap mirror) . ml } --- | tile. Compute the positions for windows in our default tiling modes--- Tiling algorithms in the core should satisify the constraint that+-- | tile. Compute the positions for windows using the default 2 pane tiling algorithm. ----- * no windows overlap--- * no gaps exist between windows.+-- 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 | n <= nmaster = splitVertically n r- | otherwise = splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2- where (r1,r2) = splitHorizontallyBy f r+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-splitHorizontally n r = map mirrorRect $ splitVertically n $ mirrorRect r+ where smallh = sh `div` fromIntegral n --hmm, this is a fold or map. -splitHorizontallyBy, splitVerticallyBy :: Rational -> 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 r = (\(a,b)->(mirrorRect a,mirrorRect b)) $ splitHorizontallyBy f $ mirrorRect r+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 --- | layout. Modify the current workspace's layout with a pure--- function and refresh.-layout :: ((Layout, [Layout]) -> (Layout, [Layout])) -> X ()-layout f = do- modify $ \s ->- let n = W.tag . W.workspace . W.current . windowset $ s- (Just fl) = M.lookup n $ layouts s- in s { layouts = M.insert n (f fl) (layouts s) }- refresh+splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect ------------------------------------------------------------------------ -- Utilities --- | Return workspace visible on screen 'sc', or 0.-screenWorkspace :: ScreenId -> X WorkspaceId-screenWorkspace sc = withWorkspace $ return . fromMaybe 0 . W.lookupWorkspace sc+-- | 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 = withWorkspace $ \w -> whenJust (W.peek w) f+withFocused f = withWindowSet $ \w -> whenJust (W.peek w) f -- | True if window is under management by us isClient :: Window -> X Bool-isClient w = withWorkspace $ return . W.member w+isClient w = withWindowSet $ return . W.member w++-- | Combinations of extra modifier masks we need to grab keys\/buttons for.+-- (numlock and capslock)+extraModifiers :: [KeyMask]+extraModifiers = [0, numlockMask, lockMask, numlockMask .|. lockMask ]++-- | Strip numlock\/capslock from a mask+cleanMask :: KeyMask -> KeyMask+cleanMask = (complement (numlockMask .|. lockMask) .&.)++-- | 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++-- | Make a floating window tiled+sink :: Window -> X ()+sink = windows . W.sink++-- | Make a tiled window floating, using its suggested rectangle+--+-- TODO: float changes the set of visible workspaces when we call it for an+-- invisible window -- this should not happen. See 'temporary workaround' in+-- the handler for ConfigureRequestEvent also.+float :: Window -> X ()+float w = withDisplay $ \d -> do+ ws <- gets windowset+ wa <- io $ getWindowAttributes d w++ let sc = fromMaybe (W.current ws) $ find (pointWithin (fi $ wa_x wa) (fi $ wa_y wa) . screenRect . W.screenDetail) $ W.current ws : W.visible ws+ sr = screenRect . W.screenDetail $ sc+ sw = W.tag . W.workspace $ sc+ bw = fi . wa_border_width $ wa++ windows $ maybe id W.focusWindow (W.peek ws) . W.shift sw . W.focusWindow w . W.float w+ (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)))+ 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)++-- ---------------------------------------------------------------------+-- 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++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)++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 ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))),+ (fromIntegral (max 1 (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 :: 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
README view
@@ -44,31 +44,50 @@ whether you've got a package run 'ghc-pkg list some_package_name' mtl http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl-1.0- (Included with GHC)- unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 - (Included with GHC)- X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.2.2- (Included with GHC)-- X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.2+ X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.3 And then build with Cabal: - runhaskell Setup.lhs configure --prefix=/home/dons+ runhaskell Setup.lhs configure --prefix=$HOME runhaskell Setup.lhs build runhaskell Setup.lhs install --user ------------------------------------------------------------------------ +Notes for using the darcs version++ If you're building the darcs version of xmonad, be sure to also+ use the darcs version of X11-extras, which is developed concurrently+ with xmonad.++ darcs get http://darcs.haskell.org/~sjanssen/X11-extras++ Not using X11-extras from darcs, is the most common reason for the+ darcs version of xmonad to fail to build.++------------------------------------------------------------------------+ Running xmonad: Add: - exec /home/dons/bin/xmonad+ $HOME/bin/xmonad to the last line of your .xsession or .xinitrc file.++------------------------------------------------------------------------++XMonadContrib++ There are various contributed modules that can be used with xmonad.+ Examples include an ion3-like tabbed layout, a prompt/program launcher,+ and various other useful modules. XMonadContrib is available at:++ 0.3 release: http://www.xmonad.org/XMonadContrib-0.3.tar.gz++ darcs version: darcs get http://darcs.haskell.org/~sjanssen/XMonadContrib ------------------------------------------------------------------------
StackSet.hs view
@@ -8,9 +8,39 @@ -- Stability : experimental -- Portability : portable, Haskell 98 -------------------------------------------------------------------------------------- ** Introduction++module StackSet (+ -- * Introduction+ -- $intro+ StackSet(..), Workspace(..), Screen(..), StackOrNot, Stack(..), RationalRect(..),+ -- * Construction+ -- $construction+ new, view, greedyView,+ -- * Xinerama operations+ -- $xinerama+ lookupWorkspace,+ -- * Operations on the current stack+ -- $stackOperations+ peek, index, integrate, integrate', differentiate,+ focusUp, focusDown,+ focusWindow, tagMember, member, findIndex,+ -- * Modifying the stackset+ -- $modifyStackset+ insertUp, delete, filter,+ -- * Setting the master window+ -- $settingMW+ swapMaster, swapUp, swapDown, modify, modify', float, sink, -- needed by users+ -- * Composite operations+ -- $composite+ shift+ ) where++import Prelude hiding (filter)+import Data.Maybe (listToMaybe)+import qualified Data.List as L (delete,deleteBy,find,splitAt,filter)+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@@ -18,18 +48,18 @@ -- 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]---+-- +-- > 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 +-- Zipper -- -- We encode all the focus tracking directly in the data structure, with a 'zipper': --@@ -42,7 +72,7 @@ -- 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"+-- 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@@ -58,7 +88,7 @@ -- -- The Zipper, Haskell wikibook -- --- ** Xinerama support:+-- Xinerama support: -- -- Xinerama in X11 lets us view multiple virtual workspaces -- simultaneously. While only one will ever be in focus (i.e. will@@ -67,89 +97,100 @@ -- (viewed) on which physical screens. We use a simple Map Workspace -- Screen for this. ----- ** Master and Focus+-- 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. Particular in relation to 'insert' and -- 'delete'. ---module StackSet (- StackSet(..), Workspace(..), Screen(..), Stack(..),- new, view, lookupWorkspace, peek, index, focusUp, focusDown,- focusWindow, member, findIndex, insertUp, delete, shift,- swapMaster, swapUp, swapDown, modify -- needed by users- ) where -import Data.Maybe (listToMaybe)-import qualified Data.List as L (delete,find,genericSplitAt)--+-- | -- 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.+-- 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 a sid =- StackSet { size :: !i -- number of workspaces- , current :: !(Screen i a sid) -- currently focused workspace- , visible :: [Screen i a sid] -- non-focused workspaces, visible in xinerama- , hidden :: [Workspace i a] -- workspaces not visible anywhere++data StackSet i a sid sd =+ StackSet { current :: !(Screen i a sid sd) -- ^ currently focused workspace+ , visible :: [Screen i a sid sd] -- ^ non-focused workspaces, visible in xinerama+ , hidden :: [Workspace i 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 a sid = Screen { workspace :: !(Workspace i a), screen :: !sid }+-- | Visible workspaces, and their Xinerama screens.+data Screen i a sid sd = Screen { workspace :: !(Workspace i a)+ , screen :: !sid+ , screenDetail :: !sd } deriving (Show, Read, Eq) --- +-- | -- A workspace is just a tag - its index - and a stack ---data Workspace i a = Workspace { tag :: !i, stack :: Stack a }+data Workspace i a = Workspace { tag :: !i, stack :: StackOrNot a } deriving (Show, Read, Eq) --- +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' ]+-- > +-- 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+-- 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 = Empty- | Node { focus :: !a -- focused thing in this set- , up :: [a] -- clowns to the left- , down :: [a] } -- jokers to the right+type StackOrNot a = Maybe (Stack a)++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) @@ -158,99 +199,152 @@ abort x = error $ "xmonad: StackSet: " ++ x -- ------------------------------------------------------------------------ Construction+-- $construction --- | /O(n)/. Create a new stackset, of empty stacks, of size 'n', with--- 'm' physical screens. 'm' should be less than or equal to 'n'.--- The workspace with index '0' will be current.+-- | /O(n)/. Create a new stackset, of empty stacks, with given tags, with+-- 'm' physical screens. '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 i, Integral s) => i -> s -> StackSet i a s-new n m | n > 0 && m > 0 = StackSet n cur visi unseen- | otherwise = abort "non-positive arguments to StackSet.new"-- where (seen,unseen) = L.genericSplitAt m $ Workspace 0 Empty : [ Workspace i Empty | i <- [1 ..n-1]]- (cur:visi) = [ Screen i s | (i,s) <- zip seen [0..] ]+new :: (Integral s) => [i] -> [sd] -> StackSet i a s sd+new wids m | not (null wids) && length m <= length wids = StackSet cur visi unseen M.empty+ where (seen,unseen) = L.splitAt (length m) $ map (flip Workspace 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'. +++-- |+-- /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. --- is raised to the current screen. If it is already visible, focus is--- just moved.----view :: (Eq i, Eq a, Eq s, Integral i) => i -> StackSet i a s -> StackSet i a s+view :: (Eq a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd view i s- | i < 0 && i >= size s || i == tag (workspace (current s)) = s -- out of bounds or current+ | 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.delete x (visible s) }+ = s { current = x, visible = current s : L.deleteBy screenEq x (visible s) } - | Just x <- L.find ((i==).tag) (hidden s)+ | Just x <- L.find ((i==).tag) (hidden s) -- if it was hidden, it is raised on the xine screen currently used- = s { current = Screen x (screen (current s))+ = s { current = (current s) { workspace = x } , hidden = workspace (current s) : L.delete x (hidden s) } - | otherwise = abort "Inconsistent StackSet: workspace not found"+ | otherwise = s+ where screenEq x y = screen x == screen y -- 'Catch'ing this might be hard. Relies on monotonically increasing -- workspace tags defined in 'new' +-- |+-- 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 a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i 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 operations+-- $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 a s -> Maybe i-lookupWorkspace sc w = listToMaybe [ tag i | Screen i s <- current w : visible w, s == sc ]+lookupWorkspace :: Eq s => s -> StackSet i a s sd -> Maybe i+lookupWorkspace sc w = listToMaybe [ tag i | Screen i s _ <- current w : visible w, s == sc ] -- ------------------------------------------------------------------------ Operations on the current stack+-- $stackOperations ---+-- | -- The 'with' function takes a default value, a function, and a--- StackSet. If the current stack is Empty, 'with' returns the+-- 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 a s -> b-with dflt f s = case stack (workspace (current s)) of Empty -> dflt; v -> f v- -- TODO: ndm: a 'catch' proof here that 'f' only gets Node- -- constructors, hence all 'f's are safe below?+with :: b -> (Stack a -> b) -> StackSet i a s sd -> b+with dflt f = maybe dflt f . stack . workspace . current ------ Apply a function, and a default value for Empty, to modify the current stack.+-- |+-- Apply a function, and a default value for Nothing, to modify the current stack. ---modify :: Stack a -> (Stack a -> Stack a) -> StackSet i a s -> StackSet i a s+modify :: StackOrNot a -> (Stack a -> StackOrNot a) -> StackSet i a s sd -> StackSet i 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 a s sd -> StackSet i 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 a s -> Maybe a+peek :: StackSet i 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' :: StackOrNot a -> [a]+integrate' = maybe [] integrate++-- |+-- /O(n)/. Texture a list.+--+differentiate :: [a] -> StackOrNot 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 -> StackOrNot 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 :: Eq a => StackSet i a s -> [a]-index = with [] $ \(Node t l r) -> reverse l ++ t : r+index :: StackSet i a s sd -> [a]+index = with [] integrate -- let is = t : r ++ reverse l in take (length is) (dropWhile (/= m) (cycle is)) ---+-- | -- /O(1), O(w) on the wrapping case/. -- -- focusUp, focusDown. Move the window focus up or down the stack,@@ -262,59 +356,66 @@ -- if we reach the end. Again the wrapping model should 'cycle' on -- the current stack. -- -focusUp, focusDown, swapUp, swapDown :: StackSet i a s -> StackSet i a s-focusUp = modify Empty $ \c -> case c of- Node _ [] [] -> c- Node t (l:ls) rs -> Node l ls (t:rs)- Node t [] rs -> Node x (xs ++ [t]) [] where (x:xs) = reverse rs+focusUp, focusDown, swapUp, swapDown :: StackSet i a s sd -> StackSet i a s sd+focusUp = modify' focusUp'+focusDown = modify' (reverseStack . focusUp' . reverseStack) -focusDown = modify Empty $ \c -> case c of- Node _ [] [] -> c- Node t ls (r:rs) -> Node r (t:ls) rs- Node t ls [] -> Node x [] (xs ++ [t]) where (x:xs) = reverse ls+swapUp = modify' swapUp'+swapDown = modify' (reverseStack . swapUp' . reverseStack) -swapUp = modify Empty $ \c -> case c of- Node _ [] [] -> c- Node t (l:ls) rs -> Node t ls (l:rs)- Node t [] rs -> Node t (reverse rs) []+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) -swapDown = modify Empty $ \c -> case c of- Node _ [] [] -> c- Node t ls (r:rs) -> Node t (r:ls) rs- Node t ls [] -> Node t [] (reverse ls)+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 :: (Integral i, Eq s, Eq a) => a -> StackSet i a s -> StackSet i a s+focusWindow :: (Eq s, Eq a, Eq i) => a -> StackSet i a s sd -> StackSet i a s sd focusWindow w s | Just w == peek s = s | otherwise = maybe s id $ do n <- findIndex w s return $ until ((Just w ==) . peek) focusUp (view n s) ---+++-- | Get a list of all workspaces in the StackSet.+workspaces :: StackSet i a s sd -> [Workspace i a]+workspaces s = workspace (current s) : map workspace (visible s) ++ hidden s++-- | Is the given tag present in the StackSet?+tagMember :: Eq i => i -> StackSet i a s sd -> Bool+tagMember t = elem t . map tag . workspaces++-- | -- Finding if a window is in the stackset is a little tedious. We could -- keep a cache :: Map a i, but with more bookkeeping. -- -- | /O(n)/. Is a window in the StackSet.-member :: Eq a => a -> StackSet i a s -> Bool+member :: Eq a => a -> StackSet i a s sd -> Bool member a s = maybe False (const True) (findIndex a s) -- | /O(1) on current window, O(n) in general/. -- Return Just the workspace index of the given window, or Nothing -- if the window is not in the StackSet.-findIndex :: Eq a => a -> StackSet i a s -> Maybe i+findIndex :: Eq a => a -> StackSet i a s sd -> Maybe i findIndex a s = listToMaybe- [ tag w | w <- workspace (current s) : map workspace (visible s) ++ hidden s, has a (stack w) ]- where has _ Empty = False- has x (Node t l r) = x `elem` (t : l ++ r)+ [ 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) -- ------------------------------------------------------------------------ Modifying the stackset+-- $modifyStackset ---+-- | -- /O(n)/. (Complexity due to duplicate check). Insert a new element into -- the stack, above the currently focused element. --@@ -328,71 +429,71 @@ -- 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 a s -> StackSet i a s+insertUp :: Eq a => a -> StackSet i a s sd -> StackSet i a s sd insertUp a s = if member a s then s else insert- where insert = modify (Node a [] []) (\(Node t l r) -> Node a l (t:r)) s+ where insert = modify (Just $ Stack a [] []) (\(Stack t l r) -> Just $ Stack a l (t:r)) s --- insertDown :: a -> StackSet i a s -> StackSet i a s--- insertDown a = modify (Node a [] []) $ \(Node t l r) -> Node a (t:l) r+-- insertDown :: a -> StackSet i a s sd -> StackSet i 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 Empty workspace leaves it Empty+-- * 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 Empty+-- * 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 :: (Integral i, Eq a, Eq s) => a -> StackSet i a s -> StackSet i a s-delete w s | Just w == peek s = remove s -- common case. - | otherwise = maybe s (removeWindow.tag.workspace.current $ s) (findIndex w s)- where- -- find and remove window script- removeWindow o n = foldr ($) s [view o,remove,view n]+delete :: (Ord a, Eq s) => a -> StackSet i a s sd -> StackSet i 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) } - -- actual removal logic, and focus/master logic:- remove = modify Empty $ \c ->- if focus c == w- then case c of- Node _ ls (r:rs) -> Node r ls rs -- try down first- Node _ (l:ls) [] -> Node l ls [] -- else up- Node _ [] [] -> Empty- else c { up = w `L.delete` up c, down = w `L.delete` down c }+------------------------------------------------------------------------ +-- | 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 a s sd -> StackSet i 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 a s sd -> StackSet i a s sd+sink w s = s { floating = M.delete w (floating s) }+ --------------------------------------------------------------------------- Setting the master window+-- $settingMW --- /O(s)/. Set the master window to the focused window.+-- | /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 a s -> StackSet i a s-swapMaster = modify Empty $ \c -> case c of- Node _ [] _ -> c -- already master.- Node t ls rs -> Node t [] (ys ++ x : rs) where (x:ys) = reverse ls-- -- natural! keep focus, move current to the top, move top to current.+swapMaster :: StackSet i a s sd -> StackSet i a s sd+swapMaster = modify' $ \c -> case c of+ Stack _ [] _ -> c -- already master.+ Stack t ls rs -> Stack t [] (ys ++ x : rs) where (x:ys) = reverse ls +-- natural! keep focus, move current to the top, move top to current.+-- -- ------------------------------------------------------------------------ Composite operations---+-- $composite --- /O(w)/. shift. Move the focused element of the current stack to stack+-- | /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 :: (Eq a, Eq s, Integral i) => i -> StackSet i a s -> StackSet i a s-shift n s = if and [n >= 0,n < size s,n /= tag (workspace (current s))]- then maybe s go (peek s) else s- where go w = foldr ($) s [view (tag (workspace (current s))),insertUp w,view n,delete w]- -- ^^ poor man's state monad :-)-+shift :: (Ord a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i 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))
TODO view
@@ -1,3 +1,12 @@+0.3 release:+ * stable contrib repo tarball+ * haddocks for core and contribs on xmonad.org+ * tag xmonad+ * tag X11-extras+ * tag X11+ * more QC tests++ - possibles: - use more constrained type in StackSet to avoid pattern match warnings - audit for events handled in dwm.
XMonad.hs view
@@ -9,19 +9,19 @@ -- Stability : unstable -- Portability : not portable, uses cunning newtype deriving ----------------------------------------------------------------------------------- -- The X monad, a state monad transformer over IO, for the window -- manager state, and support routines. --+----------------------------------------------------------------------------- module XMonad (- X, WindowSet, WorkspaceId(..), ScreenId(..), XState(..), XConf(..), Layout(..),- Typeable, Message, SomeMessage(..), fromMessage,- runX, io, withDisplay, withWorkspace, isRoot, spawn, restart, trace, whenJust, whenX+ X, WindowSet, WorkspaceId(..), ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..),+ Typeable, Message, SomeMessage(..), fromMessage, runLayout,+ runX, catchX, io, catchIO, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX,+ atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW ) where -import StackSet (StackSet)+import StackSet import Control.Monad.State import Control.Monad.Reader@@ -30,29 +30,29 @@ import System.Exit import System.Environment import Graphics.X11.Xlib+-- for Read instance+import Graphics.X11.Xlib.Extras () import Data.Typeable import qualified Data.Map as M+import qualified Data.Set as S -- | XState, the window manager state. -- Just the display, width, height and a window list data XState = XState- { windowset :: !WindowSet -- ^ workspace list- , xineScreens :: ![Rectangle] -- ^ dimensions of each screen- , dimensions :: !(Position,Position) -- ^ dimensions of the screen,- , statusGaps :: ![(Int,Int,Int,Int)] -- ^ width of status bar on each screen- , layouts :: !(M.Map WorkspaceId (Layout, [Layout])) }+ { windowset :: !WindowSet -- ^ workspace list+ , mapped :: !(S.Set Window) -- ^ the Set of mapped windows+ , waitingUnmap :: !(M.Map Window Int) -- ^ the number of expected UnmapEvents+ , layouts :: !(M.Map WorkspaceId (Layout Window, [Layout Window])) -- ^ mapping of workspaces to descriptions of their layouts-+ , dragging :: !(Maybe (Position -> Position -> X (), X ())) } data XConf = XConf { display :: Display -- ^ the X11 display , theRoot :: !Window -- ^ the root window- , wmdelete :: !Atom -- ^ window deletion atom- , wmprotocols :: !Atom -- ^ wm protocols atom- , normalBorder :: !Color -- ^ border color of unfocused windows- , focusedBorder :: !Color } -- ^ border color of the focused window+ , normalBorder :: !Pixel -- ^ border color of unfocused windows+ , focusedBorder :: !Pixel } -- ^ border color of the focused window -type WindowSet = StackSet WorkspaceId Window ScreenId+type WindowSet = StackSet WorkspaceId Window ScreenId ScreenDetail -- | Virtual workspace indicies newtype WorkspaceId = W Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real)@@ -60,6 +60,10 @@ -- | Physical screen indicies newtype ScreenId = S Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real) +data ScreenDetail = SD { screenRect :: !Rectangle+ , statusGap :: !(Int,Int,Int,Int) -- ^ width of status bar on the screen+ } deriving (Eq,Show, Read)+ ------------------------------------------------------------------------ -- | The X monad, a StateT transformer over IO encapsulating the window@@ -77,44 +81,75 @@ runX :: XConf -> XState -> X a -> IO () runX c st (X a) = runStateT (runReaderT a c) st >> return () +-- | Run in the X monad, and in case of exception, and catch it and log it+-- to stderr, and run the error case.+catchX :: X a -> X a -> X a+catchX (X job) (X errcase) = do+ st <- get+ c <- ask+ (a,s') <- io ((runStateT (runReaderT job c) st) `catch`+ \e -> (do hPutStrLn stderr (show e); runStateT (runReaderT errcase c) st))+ put s'+ return a+ -- --------------------------------------------------------------------- -- Convenient wrappers to state -- | Run a monad action with the current display settings withDisplay :: (Display -> X a) -> X a-withDisplay f = asks display >>= f+withDisplay f = asks display >>= f --- | Run a monadic action with the current workspace-withWorkspace :: (WindowSet -> X a) -> X a-withWorkspace f = gets windowset >>= f+-- | Run a monadic action with the current stack set+withWindowSet :: (WindowSet -> X a) -> X a+withWindowSet f = gets windowset >>= f -- | True if the given window is the root window isRoot :: Window -> X Bool isRoot w = liftM (w==) (asks theRoot) +-- | Wrapper for the common case of atom internment+getAtom :: String -> X Atom+getAtom str = withDisplay $ \dpy -> io $ internAtom dpy str False++-- | Common non-predefined atoms+atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_STATE :: X Atom+atom_WM_PROTOCOLS = getAtom "WM_PROTOCOLS"+atom_WM_DELETE_WINDOW = getAtom "WM_DELETE_WINDOW"+atom_WM_STATE = getAtom "WM_STATE"+ --------------------------------------------------------------------------- Layout handling+-- | Layout handling --- | The different layout modes--- 'doLayout', a pure function to layout a Window set 'modifyLayout', --- 'modifyLayout' can be considered a branch of an exception handler.+-- The different layout modes+-- 'doLayout': given a Rectangle and a Stack, layout the stack elements+-- inside the given Rectangle. If an element is not given a Rectangle+-- by 'doLayout', then it is not shown on screen. Windows are restacked+-- according to the order they are returned by 'doLayout'. ---data Layout = Layout { doLayout :: Rectangle -> [Window] -> X [(Window, Rectangle)]- , modifyLayout :: SomeMessage -> Maybe Layout }+-- 'modifyLayout' performs message handling for that layout. If+-- 'modifyLayout' returns Nothing, then the layout did not respond to+-- that message and the screen is not refreshed. Otherwise, 'modifyLayout'+-- returns an updated 'Layout' and the screen is refreshed.+--+data Layout a = Layout { doLayout :: Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (Layout a))+ , modifyLayout :: SomeMessage -> X (Maybe (Layout a)) } --- Based on ideas in /An Extensible Dynamically-Typed Hierarchy of Exceptions/,+runLayout :: Layout a -> Rectangle -> StackOrNot a -> X ([(a, Rectangle)], Maybe (Layout a))+runLayout l r = maybe (return ([], Nothing)) (doLayout l r)++-- | Based on ideas in /An Extensible Dynamically-Typed Hierarchy of Exceptions/, -- Simon Marlow, 2006. Use extensible messages to the modifyLayout handler. -- --- User-extensible messages must be a member of this class:+-- User-extensible messages must be a member of this class. -- class Typeable a => Message a ---+-- | -- A wrapped value of some type in the Message class. -- data SomeMessage = forall a. Message a => SomeMessage a ---+-- | -- And now, unwrap a given, unknown Message type, performing a (dynamic) -- type check on the result. --@@ -122,12 +157,17 @@ fromMessage (SomeMessage m) = cast m -- ------------------------------------------------------------------------ General utilities---- | Lift an IO action into the X monad+-- | General utilities+--+-- Lift an IO action into the X monad io :: IO a -> X a io = liftIO +-- | Lift an IO action into the X monad. If the action results in an IO+-- exception, log the exception to stderr and continue normal execution.+catchIO :: IO () -> X ()+catchIO f = liftIO (f `catch` \e -> do hPutStrLn stderr (show e); hFlush stderr)+ -- | spawn. Launch an external application spawn :: String -> X () spawn x = io $ do@@ -147,10 +187,9 @@ -- current window state. restart :: Maybe String -> Bool -> X () restart mprog resume = do- prog <- maybe (io $ getProgName) return mprog+ prog <- maybe (io getProgName) return mprog args <- if resume then gets (("--resume":) . return . show . windowset) else return []- io $ catch (executeFile prog True args Nothing)- (hPutStrLn stderr . show) -- print executable not found exception+ catchIO (executeFile prog True args Nothing) -- | Run a side effecting action with the current workspace. Like 'when' but whenJust :: Maybe a -> (a -> X ()) -> X ()@@ -160,7 +199,7 @@ whenX :: X Bool -> X () -> X () whenX a f = a >>= \b -> when b f --- | Grab the X server (lock it) from the X monad+-- Grab the X server (lock it) from the X monad -- withServerX :: X () -> X () -- withServerX f = withDisplay $ \dpy -> do -- io $ grabServer dpy
man/xmonad.1 view
@@ -79,6 +79,9 @@ \fBmod-l\fR Expand the master area .IP+ \fBmod-t\fR+Push window back into tiling+.IP \fBmod-comma\fR Increment the number of windows in the master area .IP@@ -105,11 +108,20 @@ .IP \fBmod-shift-{w,e,r}\fR Move client to screen 1, 2, or 3+.IP+ \fBmod-button1\fR+Set the window to floating mode and move by dragging+.IP+ \fBmod-button2\fR+Raise the window to the top of the stack+.IP+ \fBmod-button3\fR+Set the window to floating mode and resize by dragging .SH EXAMPLES To use \fBxmonad\fR as your window manager add: .RS-exec xmonad+xmonad .RE to your \fI~/.xinitrc\fR file .SH CUSTOMIZATION
man/xmonad.1.in view
@@ -40,7 +40,7 @@ .SH EXAMPLES To use \fBxmonad\fR as your window manager add: .RS-exec xmonad+xmonad .RE to your \fI~/.xinitrc\fR file .SH CUSTOMIZATION
man/xmonad.html view
@@ -3,8 +3,8 @@ <HTML><HEAD><TITLE>Manpage of xmonad</TITLE> </HEAD><BODY> <H1>xmonad</H1>-Section: xmonad manual (1)<BR>Updated: 29 April 07<BR><A HREF="#index">Index</A>-<A HREF="http://www.xmonad.org">Return to Main Contents</A><HR>+Section: xmonad manual (1)<BR>Updated: 18 April 07<BR><A HREF="#index">Index</A>+<A HREF="http://localhost/cgi-bin/man/man2html">Return to Main Contents</A><HR> <A NAME="lbAB"> </A> <H2>NAME</H2>@@ -108,6 +108,9 @@ <BR> <B>mod-l</B> Expand the master area <DT><DD>+<BR> <B>mod-t</B>+Push window back into tiling+<DT><DD> <BR> <B>mod-comma</B> Increment the number of windows in the master area <DT><DD>@@ -134,6 +137,15 @@ <DT><DD> <BR> <B>mod-shift-{w,e,r}</B> Move client to screen 1, 2, or 3+<DT><DD>+<BR> <B>mod-button1</B>+Set the window to floating mode and move by dragging+<DT><DD>+<BR> <B>mod-button2</B>+Raise the window to the top of the stack+<DT><DD>+<BR> <B>mod-button3</B>+Set the window to floating mode and resize by dragging <P> </DL> <A NAME="lbAF"> </A>@@ -141,7 +153,7 @@ To use <B>xmonad</B> as your window manager add: <DL COMPACT><DT><DD>-exec xmonad+xmonad </DL> to your <I>~/.xinitrc</I> file@@ -172,6 +184,6 @@ This document was created by <A HREF="http://localhost/cgi-bin/man/man2html">man2html</A>, using the manual pages.<BR>-Time: 06:12:01 GMT, May 29, 2007+Time: 04:55:21 GMT, August 24, 2007 </BODY> </HTML>
tests/Properties.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS -fglasgow-exts #-} -import StackSet+import StackSet hiding (filter)+import qualified StackSet as S (filter) import Operations (tile) import Debug.Trace@@ -33,11 +34,13 @@ -- -- The all important Arbitrary instance for StackSet. ---instance (Integral i, Integral s, Eq a, Arbitrary a) => Arbitrary (StackSet i a s) where+instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary sd)+ => Arbitrary (StackSet i a s sd) where arbitrary = do sz <- choose (1,10) -- number of workspaces n <- choose (0,sz-1) -- pick one to be in focus- sc <- choose (1,sz) -- a number of physical screens+ sc <- choose (1,sz) -- a number of physical screens+ sds <- replicateM sc arbitrary ls <- vector sz -- a vector of sz workspaces -- pick a random item in each stack to focus@@ -45,7 +48,7 @@ else liftM Just (choose ((-1),length s-1)) | s <- ls ] - return $ fromList (fromIntegral n, fromIntegral sc,fs,ls)+ return $ fromList (fromIntegral n, sds,fs,ls) coarbitrary = error "no coarbitrary for StackSet" @@ -59,19 +62,14 @@ -- 'fs' random focused window on each workspace -- 'xs' list of list of windows ---fromList :: (Integral i, Integral s, Eq a) => (i, s, [Maybe Int], [[a]]) -> StackSet i a s+fromList :: (Integral i, Integral s, Eq a) => (i, [sd], [Maybe Int], [[a]]) -> StackSet i a s sd fromList (_,_,_,[]) = error "Cannot build a StackSet from an empty list" -fromList (n,m,fs,xs) | n < 0 || n >= genericLength xs- = error $ "Cursor index is out of range: " ++ show (n, length xs)- | m < 1 || m > genericLength xs- = error $ "Can't have more screens than workspaces: " ++ show (m, length xs)- fromList (o,m,fs,xs) = let s = view o $ foldr (\(i,ys) s -> foldr insertUp (view i s) ys)- (new (genericLength xs) m) (zip [0..] xs)+ (new [0..genericLength xs-1] m) (zip [0..] xs) in foldr (\f t -> case f of Nothing -> t Just i -> foldr (const focusUp) t [0..i] ) s fs@@ -81,7 +79,7 @@ -- -- Just generate StackSets with Char elements. ---type T = StackSet Int Char Int+type T = StackSet (NonNegative Int) Char Int Int -- Useful operation, the non-local workspaces hidden_spaces x = map workspace (visible x) ++ hidden x@@ -103,7 +101,6 @@ invariant (s :: T) = and -- no duplicates [ noDuplicates- , accurateSize -- all this xinerama stuff says we don't have the right structure -- , validScreens@@ -114,10 +111,8 @@ where ws = concat [ focus t : up t ++ down t | w <- workspace (current s) : map workspace (visible s) ++ hidden s- , let t = stack w, t /= Empty ] :: [Char]+ , t <- maybeToList (stack w)] :: [Char] noDuplicates = nub ws == ws- calculatedSize = length (visible s) + length (hidden s) + 1 -- +1 is for current- accurateSize = calculatedSize == size s -- validScreens = monotonic . sort . M. . (W.current s : W.visible : W$ s @@ -134,12 +129,16 @@ prop_invariant = invariant -- and check other ops preserve invariants-prop_empty_I (n :: Positive Int) = forAll (choose (1,fromIntegral n)) $ \m ->- invariant $ new (fromIntegral n) m+prop_empty_I (n :: Positive Int) = forAll (choose (1,fromIntegral n)) $ \m ->+ forAll (vector m) $ \ms ->+ invariant $ new [0..fromIntegral n-1] ms prop_view_I (n :: NonNegative Int) (x :: T) =- fromIntegral n < size x ==> invariant $ view (fromIntegral n) x+ n `tagMember` x ==> invariant $ view (fromIntegral n) x +prop_greedyView_I (n :: NonNegative Int) (x :: T) =+ n `tagMember` x ==> invariant $ view (fromIntegral n) x+ prop_focusUp_I (n :: NonNegative Int) (x :: T) = invariant $ foldr (const focusUp) x [1..n] prop_focusDown_I (n :: NonNegative Int) (x :: T) =@@ -148,7 +147,7 @@ prop_focus_I (n :: NonNegative Int) (x :: T) = case peek x of Nothing -> True- Just _ -> let w = focus . stack . workspace . current $ foldr (const focusUp) x [1..n]+ Just _ -> let w = focus . fromJust . stack . workspace . current $ foldr (const focusUp) x [1..n] in invariant $ focusWindow w x prop_insertUp_I n (x :: T) = invariant $ insertUp n x@@ -166,41 +165,40 @@ invariant $ foldr (const swapDown) x [1..n] prop_shift_I (n :: NonNegative Int) (x :: T) =- fromIntegral n < size x ==> invariant $ shift (fromIntegral n) x+ n `tagMember` x ==> invariant $ shift (fromIntegral n) x -- --------------------------------------------------------------------- -- 'new' -- empty StackSets have no windows in them-prop_empty (n :: Positive Int)- (m :: Positive Int) =- all (== Empty) [ stack w | w <- workspace (current x)+prop_empty (EmptyStackSet x) = + all (== Nothing) [ stack w | w <- workspace (current x) : map workspace (visible x) ++ hidden x ] - where x = new (fromIntegral n) (fromIntegral m) :: T---- empty StackSets always have focus on workspace 0-prop_empty_current (n :: Positive Int)- (m :: Positive Int) = tag (workspace $ current x) == 0- where x = new (fromIntegral n) (fromIntegral m) :: T+-- empty StackSets always have focus on first workspace+prop_empty_current (NonEmptyNubList ns) (NonEmptyNubList sds) =+ -- TODO, this is ugly+ length sds <= length ns ==>+ tag (workspace $ current x) == head ns+ where x = new ns sds :: T -- no windows will be a member of an empty workspace-prop_member_empty i (n :: Positive Int) (m :: Positive Int)- = member i (new (fromIntegral n) (fromIntegral m) :: T) == False+prop_member_empty i (EmptyStackSet x)+ = member i x == False -- --------------------------------------------------------------------- -- viewing workspaces -- view sets the current workspace to 'n'-prop_view_current (x :: T) (n :: NonNegative Int) = i < size x ==>+prop_view_current (x :: T) (n :: NonNegative Int) = i `tagMember` x ==> tag (workspace $ current (view i x)) == i where i = fromIntegral n -- view *only* sets the current workspace, and touches Xinerama. -- no workspace contents will be changed.-prop_view_local (x :: T) (n :: NonNegative Int) = i < size x ==>+prop_view_local (x :: T) (n :: NonNegative Int) = i `tagMember` x ==> workspaces x == workspaces (view i x) where workspaces a = sortBy (\s t -> tag s `compare` tag t) $@@ -209,23 +207,46 @@ i = fromIntegral n -- view should result in a visible xinerama screen--- prop_view_xinerama (x :: T) (n :: NonNegative Int) = i < size x ==>+-- prop_view_xinerama (x :: T) (n :: NonNegative Int) = i `tagMember` x ==> -- M.member i (screens (view i x)) -- where -- i = fromIntegral n -- view is idempotent-prop_view_idem (x :: T) r =- let i = fromIntegral $ r `mod` sz- sz = size x- in view i (view i x) == (view i x)+prop_view_idem (x :: T) (i :: NonNegative Int) = i `tagMember` x ==> view i (view i x) == (view i x) -- view is reversible, though shuffles the order of hidden/visible-prop_view_reversible r (x :: T) = normal (view n (view i x)) == normal x+prop_view_reversible (i :: NonNegative Int) (x :: T) =+ i `tagMember` x ==> normal (view n (view i x)) == normal x where n = tag (workspace $ current x)- sz = size x- i = fromIntegral $ r `mod` sz +-- ---------------------------------------------------------------------+-- greedyViewing workspaces++-- greedyView sets the current workspace to 'n'+prop_greedyView_current (x :: T) (n :: NonNegative Int) = i `tagMember` x ==>+ tag (workspace $ current (greedyView i x)) == i+ where+ i = fromIntegral n++-- greedyView *only* sets the current workspace, and touches Xinerama. +-- no workspace contents will be changed.+prop_greedyView_local (x :: T) (n :: NonNegative Int) = i `tagMember` x ==>+ workspaces x == workspaces (greedyView i x)+ where+ workspaces a = sortBy (\s t -> tag s `compare` tag t) $+ workspace (current a)+ : map workspace (visible a) ++ hidden a+ i = fromIntegral n++-- greedyView is idempotent+prop_greedyView_idem (x :: T) (i :: NonNegative Int) = i `tagMember` x ==> greedyView i (greedyView i x) == (greedyView i x)++-- greedyView is reversible, though shuffles the order of hidden/visible+prop_greedyView_reversible (i :: NonNegative Int) (x :: T) =+ i `tagMember` x ==> normal (greedyView n (greedyView i x)) == normal x+ where n = tag (workspace $ current x)+ -- normalise workspace list normal s = s { hidden = sortBy g (hidden s), visible = sortBy f (visible s) } where@@ -257,12 +278,9 @@ -- the list returned by index should be the same length as the actual -- windows kept in the zipper prop_index_length (x :: T) =- case it of- Empty -> length (index x) == 0- Node {} -> length (index x) == length list- where- it = stack . workspace . current $ x- list = focus it : up it ++ down it+ case stack . workspace . current $ x of+ Nothing -> length (index x) == 0+ Just it -> length (index x) == length (focus it : up it ++ down it) -- --------------------------------------------------------------------- -- rotating focus@@ -293,7 +311,7 @@ Nothing -> True Just _ -> let s = index x i = fromIntegral n `mod` length s- in (focus . stack . workspace . current) (focusWindow (s !! i) x) == (s !! i)+ in (focus . fromJust . stack . workspace . current) (focusWindow (s !! i) x) == (s !! i) -- rotation through the height of a stack gets us back to the start prop_focus_all_l (x :: T) = (foldr (const focusUp) x [1..n]) == x@@ -324,17 +342,15 @@ prop_findIndex (x :: T) = and [ tag w == fromJust (findIndex i x) | w <- workspace (current x) : map workspace (visible x) ++ hidden x- , let t = stack w- , t /= Empty- , i <- focus (stack w) : up (stack w) ++ down (stack w)+ , t <- maybeToList (stack w)+ , i <- focus t : up t ++ down t ] -- --------------------------------------------------------------------- -- 'insert' -- inserting a item into an empty stackset means that item is now a member-prop_insert_empty i (n :: Positive Int) (m :: Positive Int) = member i (insertUp i x)- where x = new (fromIntegral n) (fromIntegral m) :: T+prop_insert_empty i (EmptyStackSet x)= member i (insertUp i x) -- insert should be idempotent prop_insert_idem i (x :: T) = insertUp i x == insertUp i (insertUp i x)@@ -347,10 +363,8 @@ -- Inserting a (unique) list of items into an empty stackset should -- result in the last inserted element having focus.-prop_insert_peek (n :: Positive Int) (m :: Positive Int) (NonEmptyNubList is) =+prop_insert_peek (EmptyStackSet x) (NonEmptyNubList is) = peek (foldr insertUp x is) == Just (head is)- where- x = new (fromIntegral n) (fromIntegral m) :: T -- insert >> delete is the identity, when i `notElem` . -- Except for the 'master', which is reset on insert and delete.@@ -361,11 +375,10 @@ -- otherwise, we don't have a rule for where master goes. -- inserting n elements increases current stack size by n-prop_size_insert is (n :: Positive Int) (m :: Positive Int) =+prop_size_insert is (EmptyStackSet x) = size (foldr insertUp x ws ) == (length ws) where ws = nub is- x = new (fromIntegral n) (fromIntegral m) :: T size = length . index @@ -390,7 +403,7 @@ y = swapMaster x -- delete should be local-prop_delete_local (x :: T) = +prop_delete_local (x :: T) = case peek x of Nothing -> True Just i -> hidden_spaces x == hidden_spaces (delete i x)@@ -398,7 +411,37 @@ -- delete should not affect focus unless the focused element is what is being deleted prop_delete_focus n (x :: T) = member n x && Just n /= peek x ==> peek (delete n x) == peek x +-- focus movement in the presence of delete:+-- when the last window in the stack set is focused, focus moves `up'.+-- usual case is that it moves 'down'.+prop_delete_focus_end (x :: T) =+ length (index x) > 1+ ==>+ peek (delete n y) == peek (focusUp y)+ where+ n = last (index x)+ y = focusWindow n x -- focus last window in stack++-- focus movement in the presence of delete:+-- when not in the last item in the stack, focus moves down+prop_delete_focus_not_end (x :: T) =+ length (index x) > 1 &&+ n /= last (index x)+ ==>+ peek (delete n x) == peek (focusDown x)+ where+ Just n = peek x+ -- ---------------------------------------------------------------------+-- filter++-- preserve order+prop_filter_order (x :: T) =+ case stack $ workspace $ current x of+ Nothing -> True+ Just s@(Stack i _ _) -> integrate' (S.filter (/= i) s) == filter (/= i) (integrate' (Just s))++-- --------------------------------------------------------------------- -- swapUp, swapDown, swapMaster: reordiring windows -- swap is trivially reversible@@ -442,15 +485,13 @@ -- shift is fully reversible on current window, when focus and master -- are the same. otherwise, master may move.-prop_shift_reversible (r :: Int) (x :: T) =- let i = fromIntegral $ r `mod` sz- sz = size y- n = tag (workspace $ current y)- in case peek y of- Nothing -> True- Just _ -> normal ((view n . shift n . view i . shift i) y) == normal y+prop_shift_reversible i (x :: T) =+ i `tagMember` x ==> case peek y of+ Nothing -> True+ Just _ -> normal ((view n . shift n . view i . shift i) y) == normal y where y = swapMaster x+ n = tag (workspace $ current y) ------------------------------------------------------------------------ -- some properties for layouts:@@ -507,6 +548,12 @@ -- ,("view / xinerama" , mytest prop_view_xinerama) ,("view is local" , mytest prop_view_local) + ,("greedyView : invariant" , mytest prop_greedyView_I)+ ,("greedyView sets current" , mytest prop_greedyView_current)+ ,("greedyView idempotent" , mytest prop_greedyView_idem)+ ,("greedyView reversible" , mytest prop_greedyView_reversible)+ ,("greedyView is local" , mytest prop_greedyView_local)+-- -- ,("valid workspace xinerama", mytest prop_lookupWorkspace) ,("peek/member " , mytest prop_member_peek)@@ -544,7 +591,11 @@ ,("delete is reversible", mytest prop_delete_insert) ,("delete is local" , mytest prop_delete_local) ,("delete/focus" , mytest prop_delete_focus)+ ,("delete last/focus up", mytest prop_delete_focus_end)+ ,("delete ~last/focus down", mytest prop_delete_focus_not_end) + ,("filter preserves order", mytest prop_filter_order)+ ,("swapMaster: invariant", mytest prop_swap_master_I) ,("swapUp: invariant" , mytest prop_swap_left_I) ,("swapDown: invariant", mytest prop_swap_right_I)@@ -704,7 +755,6 @@ arbitrary = NonEmptyNubList `fmap` ((liftM nub arbitrary) `suchThat` (not . null)) coarbitrary = undefined - type Positive a = NonZero (NonNegative a) newtype NonZero a = NonZero a@@ -724,6 +774,15 @@ , (1, return 0) ] coarbitrary = undefined++newtype EmptyStackSet = EmptyStackSet T deriving Show++instance Arbitrary EmptyStackSet where+ arbitrary = do+ (NonEmptyNubList ns) <- arbitrary+ (NonEmptyNubList sds) <- arbitrary+ -- there cannot be more screens than workspaces:+ return . EmptyStackSet . new ns $ take (min (length ns) (length sds)) sds -- | Generates a value that satisfies a predicate. suchThat :: Gen a -> (a -> Bool) -> Gen a
tests/loc.hs view
@@ -8,7 +8,6 @@ putStrLn $ show loc -- uncomment the following to check for mistakes in isntcomment -- putStr $ unlines $ actual_loc- when (loc > 550) $ fail "Too many lines of code!" isntcomment "" = False isntcomment ('-':'-':_) = False
xmonad.cabal view
@@ -1,5 +1,5 @@ name: xmonad-version: 0.2+version: 0.3 homepage: http://xmonad.org synopsis: A lightweight X11 window manager. description:@@ -18,13 +18,14 @@ license-file: LICENSE author: Spencer Janssen maintainer: sjanssen@cse.unl.edu-build-depends: base>=1.0, X11>=1.2.1, X11-extras>=0.2, mtl>=1.0, unix>=1.0+build-depends: base>=2.0, X11>=1.2.1, X11-extras>=0.3, mtl>=1.0, unix>=1.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 executable: xmonad main-is: Main.hs other-modules: Config Operations StackSet XMonad-ghc-options: -funbox-strict-fields -O -fasm -Wall -optl-Wl,-s+ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s ghc-prof-options: -prof -auto-all extensions: GeneralizedNewtypeDeriving+-- Also requires deriving Typeable