diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -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)) ] diff --git a/Config.hs-boot b/Config.hs-boot --- a/Config.hs-boot +++ b/Config.hs-boot @@ -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] diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/Operations.hs b/Operations.hs --- a/Operations.hs +++ b/Operations.hs @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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 ------------------------------------------------------------------------ diff --git a/StackSet.hs b/StackSet.hs --- a/StackSet.hs +++ b/StackSet.hs @@ -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)) diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -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. diff --git a/XMonad.hs b/XMonad.hs --- a/XMonad.hs +++ b/XMonad.hs @@ -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 diff --git a/man/xmonad.1 b/man/xmonad.1 --- a/man/xmonad.1 +++ b/man/xmonad.1 @@ -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 diff --git a/man/xmonad.1.in b/man/xmonad.1.in --- a/man/xmonad.1.in +++ b/man/xmonad.1.in @@ -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 diff --git a/man/xmonad.html b/man/xmonad.html --- a/man/xmonad.html +++ b/man/xmonad.html @@ -3,8 +3,8 @@ Manpage of xmonad

xmonad

-Section: xmonad manual (1)
Updated: 29 April 07
Index -Return to Main Contents
+Section: xmonad manual (1)
Updated: 18 April 07
Index +Return to Main Contents
 

NAME

@@ -108,6 +108,9 @@
 mod-l Expand the master area
+
 mod-t +Push window back into tiling +

 mod-comma Increment the number of windows in the master area
@@ -134,6 +137,15 @@

 mod-shift-{w,e,r} Move client to screen 1, 2, or 3 +
+
 mod-button1 +Set the window to floating mode and move by dragging +
+
 mod-button2 +Raise the window to the top of the stack +
+
 mod-button3 +Set the window to floating mode and resize by dragging

  @@ -141,7 +153,7 @@ To use xmonad as your window manager add:

-exec xmonad +xmonad
to your ~/.xinitrc file @@ -172,6 +184,6 @@ This document was created by man2html, using the manual pages.
-Time: 06:12:01 GMT, May 29, 2007 +Time: 04:55:21 GMT, August 24, 2007 diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -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 diff --git a/tests/loc.hs b/tests/loc.hs --- a/tests/loc.hs +++ b/tests/loc.hs @@ -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 diff --git a/xmonad.cabal b/xmonad.cabal --- a/xmonad.cabal +++ b/xmonad.cabal @@ -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