diff options
| -rw-r--r-- | Config.hs | 18 | ||||
| -rw-r--r-- | Config.hs-boot | 2 | ||||
| -rw-r--r-- | Main.hs | 92 | ||||
| -rw-r--r-- | Operations.hs | 356 | ||||
| -rw-r--r-- | StackSet.hs | 548 | ||||
| -rw-r--r-- | XMonad.hs | 35 | ||||
| -rw-r--r-- | tests/Properties.hs | 813 |
7 files changed, 1107 insertions, 757 deletions
@@ -86,13 +86,13 @@ module Config where -- -- Useful imports -- +import XMonad +import Operations import Data.Ratio -import Data.Bits +import Data.Bits ((.|.)) import qualified Data.Map as M import System.Exit import Graphics.X11.Xlib -import XMonad -import Operations -- The number of workspaces (virtual screens) workspaces :: Int @@ -156,9 +156,9 @@ keys = M.fromList $ -- 'nudge': resize viewed windows to the correct size. , ((modMask, xK_n ), refresh) - , ((modMask, xK_Tab ), raise GT) - , ((modMask, xK_j ), raise GT) - , ((modMask, xK_k ), raise LT) + , ((modMask, xK_Tab ), focusLeft) + , ((modMask, xK_j ), focusLeft) + , ((modMask, xK_k ), focusRight) , ((modMask, xK_h ), sendMessage Shrink) , ((modMask, xK_l ), sendMessage Expand) @@ -172,18 +172,18 @@ keys = M.fromList $ , ((modMask .|. shiftMask .|. controlMask, xK_q ), io restart) -- Cycle the current tiling order - , ((modMask, xK_Return), promote) + , ((modMask, xK_Return), swap) ] ++ -- Keybindings to get to each workspace: [((m .|. modMask, k), f i) | (i, k) <- zip [0 .. fromIntegral workspaces - 1] [xK_1 ..] - , (f, m) <- [(view, 0), (tag, shiftMask)]] + , (f, m) <- [(view, 0), (shift, shiftMask)]] -- Keybindings to each screen : -- mod-wer (underneath 123) switches to physical/Xinerama screens 1 2 and 3 ++ [((m .|. modMask, key), screenWorkspace sc >>= f) | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..] - , (f, m) <- [(view, 0), (tag, shiftMask)]] + , (f, m) <- [(view, 0), (shift, shiftMask)]] diff --git a/Config.hs-boot b/Config.hs-boot index 5a03488..2d66ae1 100644 --- a/Config.hs-boot +++ b/Config.hs-boot @@ -1,5 +1,3 @@ module Config where -import XMonad (Layout) import Graphics.X11.Xlib.Types (Dimension) -defaultLayouts :: [Layout] borderWidth :: Dimension @@ -10,24 +10,21 @@ -- ----------------------------------------------------------------------------- -- --- xmonad, a minimal window manager for X11 +-- xmonad, a minimalist, tiling window manager for X11 -- import Data.Bits import qualified Data.Map as M +import Control.Monad.Reader import Graphics.X11.Xlib hiding (refreshKeyboardMapping) import Graphics.X11.Xlib.Extras -import Graphics.X11.Xinerama - -import Control.Monad.State -import Control.Monad.Reader - -import qualified StackSet as W +import Graphics.X11.Xinerama (getScreenInfo) import XMonad -import Operations import Config +import StackSet (new) +import Operations (manage, unmanage, focus, setFocusX, full, isClient) -- -- The main entry point @@ -59,18 +56,15 @@ main = do , focusedBorder = fbc } st = XState - { workspace = W.empty workspaces (length xinesc) - , layouts = M.fromList [(w, safeLayouts) | w <- [0 .. W workspaces - 1]] - } + { workspace = new (fromIntegral workspaces) (fromIntegral $ length xinesc) + , layouts = M.fromList [(w, safeLayouts) | w <- [0 .. W workspaces - 1]] } - xSetErrorHandler -- in C, I'm too lazy to write the binding + xSetErrorHandler -- in C, I'm too lazy to write the binding: dons -- setup initial X environment sync dpy False - selectInput dpy rootw $ substructureRedirectMask - .|. substructureNotifyMask - .|. enterWindowMask - .|. leaveWindowMask + selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask + .|. enterWindowMask .|. leaveWindowMask grabKeys dpy rootw sync dpy False @@ -78,10 +72,9 @@ main = do allocaXEvent $ \e -> runX cf st $ do mapM_ manage ws - forever $ handle =<< xevent dpy e - where - xevent d e = io (nextEvent d e >> getEvent e) - forever a = a >> forever a + -- main loop, for all you HOF/recursion fans out there. + forever $ handle =<< io (nextEvent dpy e >> getEvent e) + where forever a = a >> forever a -- --------------------------------------------------------------------- -- IO stuff. Doesn't require any X state @@ -105,14 +98,14 @@ grabKeys dpy rootw = 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 .|.)) $ + [0, numlockMask, lockMask, numlockMask .|. lockMask] where grab kc m = grabKey dpy kc m rootw True grabModeAsync grabModeAsync -- --------------------------------------------------------------------- --- Event handler --- --- | handle. Handle X events +-- | Event handler. Map X events onto calls into Operations.hs, which +-- modify our internal model of the window manager state. -- -- Events dwm handles that we don't: -- @@ -120,25 +113,13 @@ grabKeys dpy rootw = do -- [Expose] = expose, -- [PropertyNotify] = propertynotify, -- --- Todo: seperate IO from X monad stuff. We want to be able to test the --- handler, and client functions, with dummy X interface ops, in QuickCheck --- --- Will require an abstract interpreter from Event -> X Action, which --- modifies the internal X state, and then produces an IO action to --- evaluate. --- --- XCreateWindowEvent(3X11) --- Window manager clients normally should ignore this window if the --- override_redirect member is True. --- handle :: Event -> X () -- run window manager command handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) - | t == keyPress - = withDisplay $ \dpy -> do - s <- io $ keycodeToKeysym dpy code 0 + | t == keyPress = withDisplay $ \dpy -> do + s <- io $ keycodeToKeysym dpy code 0 whenJust (M.lookup (complement (numlockMask .|. lockMask) .&. m,s) keys) id -- manage a new window @@ -147,40 +128,31 @@ handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do when (not (wa_override_redirect wa)) $ manage w -- window destroyed, unmanage it -handle (DestroyWindowEvent {ev_window = w}) = do b <- isClient w; when b $ unmanage w - --- window gone, unmanage it -handle (UnmapEvent {ev_window = w}) = do b <- isClient w; when b $ unmanage w +-- window gone, unmanage it +handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w +handle (UnmapEvent {ev_window = w}) = whenX (isClient w) $ unmanage w -- set keyboard mapping handle e@(MappingNotifyEvent {ev_window = w}) = do io $ refreshKeyboardMapping e when (ev_request e == mappingKeyboard) $ withDisplay $ io . flip grabKeys w --- click on an unfocussed window -handle (ButtonEvent {ev_window = w, ev_event_type = t}) - | t == buttonPress - = safeFocus w +-- click on an unfocused window, makes it focused on this workspace +handle (ButtonEvent {ev_window = w, ev_event_type = t}) | t == buttonPress = focus w --- entered a normal window +-- entered a normal window, makes this focused. handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) - | t == enterNotify && ev_mode e == notifyNormal && ev_detail e /= notifyInferior - = safeFocus w + | t == enterNotify && ev_mode e == notifyNormal + && ev_detail e /= notifyInferior = focus w -- left a window, check if we need to focus root handle e@(CrossingEvent {ev_event_type = t}) | t == leaveNotify = do rootw <- asks theRoot - when (ev_window e == rootw && not (ev_same_screen e)) $ setFocus rootw + when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw -- configure a window -handle e@(ConfigureRequestEvent {ev_window = w}) = do - dpy <- asks display - ws <- gets workspace - - when (W.member w ws) $ -- already managed, reconfigure (see client:configure() - trace ("Reconfigure already managed window: " ++ show w) - +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 @@ -190,9 +162,7 @@ handle e@(ConfigureRequestEvent {ev_window = w}) = do , 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 - } - + , wc_stack_mode = fromIntegral $ ev_detail e } io $ sync dpy False -handle e = trace (eventName e) -- ignoring +handle _ = return () -- trace (eventName e) -- ignoring diff --git a/Operations.hs b/Operations.hs index eb17c86..a67bbe1 100644 --- a/Operations.hs +++ b/Operations.hs @@ -6,65 +6,187 @@ -- License : BSD3-style (see LICENSE) -- -- Maintainer : dons@cse.unsw.edu.au --- Stability : stable --- Portability : portable +-- Stability : unstable +-- Portability : not portable, mtl, posix -- ----------------------------------------------------------------------------- module Operations where -import Data.List +import XMonad +import qualified StackSet as W +import {-# SOURCE #-} Config (borderWidth) + import Data.Maybe -import Data.Bits +import Data.List (genericIndex) +import Data.Bits ((.|.)) import qualified Data.Map as M +import System.Mem import Control.Monad.State import Control.Monad.Reader -import Control.Arrow (second) - -import System.Posix.Process -import System.Environment -import System.Directory +import Control.Arrow import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras -import XMonad -import {-# SOURCE #-} Config +-- --------------------------------------------------------------------- +-- Window manager operations -import qualified StackSet as W +-- | 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 :: Window -> X () +manage w = do + withDisplay $ \d -> io $ do + selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask + mapWindow d w + setWindowBorderWidth d w borderWidth + windows $ W.insertLeft w + +-- | unmanage. A window no longer exists, remove it from the window +-- list, on whatever workspace it is. +unmanage :: Window -> X () +unmanage = windows . W.delete + +-- | focus. focus window to the left or right. +focusLeft, focusRight :: X () +focusLeft = windows W.focusLeft +focusRight = windows W.focusRight + +-- | swap. Move the currently focused window into the master frame +swap :: X () +swap = windows W.swap + +-- | 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. + +-- | view. Change the current workspace to workspace at offset n (0 indexed). +view :: WorkspaceId -> X () +view n = withWorkspace $ \w -> when (n /= (W.tag (W.current w))) $ do + windows $ W.view n -- move in new workspace first, to avoid flicker + mapM_ hide (W.index w) -- now just hide the old workspace + clearEnterEvents -- better clear any events from the old workspace +-- | Kill the currently focused client. If we do kill it, we'll get a +-- delete notify back from X. +-- +-- There are two ways to delete a window. Either just kill it, or if it +-- supports the delete protocol, send a delete event (e.g. firefox) +-- +kill :: X () +kill = withDisplay $ \d -> withFocused $ \w -> do + XConf {wmdelete = wmdelt, wmprotocols = wmprot} <- ask + protocols <- io $ getWMProtocols d w + io $ if wmdelt `elem` protocols + then allocaXEvent $ \ev -> do + setEventType ev clientMessage + setClientMessageEvent ev w wmprot 32 wmdelt 0 + sendEvent d w False noEventMask ev + else killClient d w >> return () -- --------------------------------------------------------------------- -- Managing windows --- | refresh. Refresh the currently focused window. Resizes to full --- screen and raises the window. +-- | windows. Modify the current window list with a pure function, and refresh +windows :: (WindowSet -> WindowSet) -> X () +windows f = modify (\s -> s { workspace = f (workspace s) }) >> refresh + +-- | hide. Hide a window by moving it off screen. +hide :: Window -> X () +hide w = withDisplay $ \d -> do + (sw,sh) <- asks dimensions + io $ moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) + +-- | refresh. Render the currently visible workspaces, as determined by +-- the StackSet. Also, set focus to the focused window. +-- +-- This is our 'view' operation (MVC), in that it pretty prints our model +-- with X calls. +-- refresh :: X () refresh = do - XState { workspace = ws, layouts = fls } <- get - XConf { xineScreens = xinesc, display = d } <- ask -- neat, eh? - - flip mapM_ (M.assocs (W.screen2ws ws)) $ \(scn, n) -> do - let sc = genericIndex xinesc scn -- temporary coercion! - (Just l) = fmap fst $ M.lookup n fls - whenJust (W.index n ws) $ \winds -> - do wrects <- doLayout l sc winds :: X [(Window,Rectangle)] - mapM_ (\(w, rect) -> io $ moveWindowInside d w rect) wrects - whenJust (W.peekStack n ws) (io . raiseWindow d) - whenJust (W.peek ws) setFocus + XState { workspace = ws, layouts = fls } <- get + XConf { xineScreens = xinesc, display = d } <- ask + + -- for each workspace, layout the currently visible workspaces + flip mapM_ (M.assocs (W.screens ws)) $ \(n, scn) -> do + let this = W.view n ws + Just l = fmap fst $ M.lookup n fls + -- now tile the windows on this workspace + rs <- doLayout l (genericIndex xinesc scn) (W.index this) + mapM_ (\(w,rect) -> io (tileWindow d w rect)) rs + + -- and raise the focused window if there is one. + whenJust (W.peek this) $ io . raiseWindow d + + setTopFocus clearEnterEvents + io performGC -- really helps -- | clearEnterEvents. Remove all window entry events from the event queue. clearEnterEvents :: X () -clearEnterEvents = do - d <- asks display - io $ sync d False - io $ allocaXEvent $ \p -> fix $ \again -> do +clearEnterEvents = withDisplay $ \d -> io $ do + sync d False + allocaXEvent $ \p -> fix $ \again -> do more <- checkMaskEvent d enterWindowMask 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) + +-- --------------------------------------------------------------------- + +buttonsToGrab :: [Button] +buttonsToGrab = [button1, button2, button3] + +-- | setButtonGrab. Tell whether or not to intercept clicks on a given window +setButtonGrab :: Bool -> Window -> X () +setButtonGrab True w = withDisplay $ \d -> io $ flip mapM_ buttonsToGrab $ \b -> + grabButton d b anyModifier w False (buttonPressMask .|. buttonReleaseMask) + grabModeAsync grabModeSync none none + +setButtonGrab False w = withDisplay $ \d -> io $ flip mapM_ buttonsToGrab $ \b -> + ungrabButton d b anyModifier w + +-- --------------------------------------------------------------------- +-- Setting keyboard focus + +-- | Set the focus to the window on top of the stack, or root +setTopFocus :: X () +setTopFocus = withWorkspace $ \ws -> maybe (asks theRoot >>= setFocusX) setFocusX (W.peek ws) + +-- | Set focus explicitly to window 'w' if it is managed by us, or root. +focus :: Window -> X () +focus w = withWorkspace $ \s -> do + if W.member w s then do modify $ \st -> st { workspace = W.focusWindow w s } -- avoid 'refresh' + setFocusX w + else whenX (isRoot w) $ setFocusX w + +-- | Call X to set the keyboard focus details. +setFocusX :: Window -> X () +setFocusX w = withWorkspace $ \ws -> do + XConf { display = dpy , normalBorder = nbc, focusedBorder = fbc } <- ask + + -- clear mouse button grab and border on other windows + (`mapM_` (M.keys . W.screens $ ws)) $ \n -> do + (`mapM_` (W.index (W.view n ws))) $ \otherw -> do + setButtonGrab True otherw + io $ setWindowBorder dpy otherw (color_pixel nbc) + + withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0 + setButtonGrab False w + io $ setWindowBorder dpy w (color_pixel fbc) + +-- --------------------------------------------------------------------- +-- Managing layout -- | switchLayout. Switch to another layout scheme. Switches the -- layout of the current workspace. By convention, a window set as @@ -84,7 +206,6 @@ switchLayout = layout (\(x, xs) -> let xs' = xs ++ [x] in (head xs', tail xs')) sendMessage :: Message a => a -> X () sendMessage a = layout $ \x@(l, ls) -> maybe x (flip (,) ls) (modifyLayout l (SomeMessage a)) ------------------------------------------------------------------------- -- -- Builtin layout algorithms: -- @@ -159,175 +280,22 @@ splitVerticallyBy f r = (\(a,b)->(mirrorRect a,mirrorRect b)) $ splitHorizontall layout :: ((Layout, [Layout]) -> (Layout, [Layout])) -> X () layout f = do modify $ \s -> - let n = W.current . workspace $ s + let n = W.tag . W.current . workspace $ s (Just fl) = M.lookup n $ layouts s in s { layouts = M.insert n (f fl) (layouts s) } refresh --- | windows. Modify the current window list with a pure function, and refresh -windows :: (WindowSet -> WindowSet) -> X () -windows f = do - modify $ \s -> s { workspace = f (workspace s) } - refresh - -- gets workspace >>= trace . show -- log state changes to stderr - --- | hide. Hide a window by moving it offscreen. -hide :: Window -> X () -hide w = withDisplay $ \d -> do - (sw,sh) <- asks dimensions - io $ moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) - --- --------------------------------------------------------------------- --- Window operations - --- | setButtonGrab. Tell whether or not to intercept clicks on a given window -buttonsToGrab :: [Button] -buttonsToGrab = [button1, button2, button3] - -setButtonGrab :: Bool -> Window -> X () -setButtonGrab True w = withDisplay $ \d -> io $ - flip mapM_ buttonsToGrab $ \b -> - grabButton d b anyModifier w False - (buttonPressMask .|. buttonReleaseMask) - grabModeAsync grabModeSync none none - -setButtonGrab False w = withDisplay $ \d -> io $ - flip mapM_ buttonsToGrab $ \b -> - ungrabButton d b anyModifier w - --- | moveWindowInside. Moves and resizes w such that it fits inside the given --- rectangle, including its border. -moveWindowInside :: Display -> Window -> Rectangle -> IO () -moveWindowInside 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) - --- | manage. Add a new window to be managed in the current workspace. Bring it into focus. --- If the window is already under management, it is just raised. --- -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.push w - --- | unmanage. A window no longer exists, remove it from the window --- list, on whatever workspace it is. -unmanage :: Window -> X () -unmanage w = do - windows $ W.delete w - withServerX $ do - setTopFocus - withDisplay $ \d -> io (sync d False) - -- TODO, everything operates on the current display, so wrap it up. - --- | Grab the X server (lock it) from the X monad -withServerX :: X () -> X () -withServerX f = withDisplay $ \dpy -> do - io $ grabServer dpy - f - io $ ungrabServer dpy - -safeFocus :: Window -> X () -safeFocus w = do ws <- gets workspace - if W.member w ws - then setFocus w - else do b <- isRoot w - when b setTopFocus - --- | Explicitly set the keyboard focus to the given window -setFocus :: Window -> X () -setFocus w = do - ws <- gets workspace - XConf { display = dpy , normalBorder = nbc, focusedBorder = fbc } <- ask - - -- clear mouse button grab and border on other windows - flip mapM_ (W.visibleWorkspaces ws) $ \n -> do - flip mapM_ (fromMaybe [] $ W.index n ws) $ \otherw -> do - setButtonGrab True otherw - io $ setWindowBorder dpy otherw (color_pixel nbc) - - withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0 - setButtonGrab False w - io $ setWindowBorder dpy w (color_pixel fbc) - - -- This does not use 'windows' intentionally. 'windows' calls refresh, - -- which means infinite loops. - modify $ \s -> s { workspace = W.raiseFocus w (workspace s) } - --- | Set the focus to the window on top of the stack, or root -setTopFocus :: X () -setTopFocus = do - ws <- gets workspace - case W.peek ws of - Just new -> setFocus new - Nothing -> asks theRoot >>= setFocus - --- | raise. focus to window at offset 'n' in list. --- The currently focused window is always the head of the list -raise :: Ordering -> X () -raise = windows . W.rotate - --- | promote. Move the currently focused window into the master frame -promote :: X () -promote = windows W.promote - --- | Kill the currently focused client -kill :: X () -kill = withDisplay $ \d -> do - ws <- gets workspace - whenJust (W.peek ws) $ \w -> do - protocols <- io $ getWMProtocols d w - XConf {wmdelete = wmdelt, wmprotocols = wmprot} <- ask - if wmdelt `elem` protocols - then io $ allocaXEvent $ \ev -> do - setEventType ev clientMessage - setClientMessageEvent ev w wmprot 32 wmdelt 0 - sendEvent d w False noEventMask ev - else io (killClient d w) >> return () - --- | tag. Move a window to a new workspace, 0 indexed. -tag :: WorkspaceId -> X () -tag n = do - ws <- gets workspace - let m = W.current ws -- :: WorkspaceId - when (n /= m) $ - whenJust (W.peek ws) $ \w -> do - hide w - windows $ W.shift n - --- | view. Change the current workspace to workspace at offset n (0 indexed). -view :: WorkspaceId -> X () -view n = do - ws <- gets workspace - let m = W.current ws - windows $ W.view n - ws' <- gets workspace - -- If the old workspace isn't visible anymore, we have to hide the windows - -- in case we're switching to an empty workspace. - when (m `notElem` W.visibleWorkspaces ws') $ maybe (return ()) (mapM_ hide) $ W.index m ws - clearEnterEvents - setTopFocus +------------------------------------------------------------------------ +-- Utilities --- | 'screenWorkspace sc' returns the workspace number viewed by 'sc'. +-- | Return workspace visible on screen 'sc', or 0. screenWorkspace :: ScreenId -> X WorkspaceId -screenWorkspace sc = fmap (fromMaybe 0 . W.workspace sc) (gets workspace) +screenWorkspace sc = withWorkspace $ return . fromMaybe 0 . 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 -- | True if window is under management by us isClient :: Window -> X Bool -isClient w = liftM (W.member w) (gets workspace) - --- | Restart xmonad by exec()'ing self. This doesn't save state and xmonad has --- to be in PATH for this to work. -restart :: IO () -restart = do - prog <- getProgName - prog_path <- findExecutable prog - case prog_path of - Nothing -> return () -- silently fail - Just p -> do args <- getArgs - executeFile p True args Nothing +isClient w = withWorkspace $ return . W.member w diff --git a/StackSet.hs b/StackSet.hs index 9fbd6bb..b5ff9e6 100644 --- a/StackSet.hs +++ b/StackSet.hs @@ -5,229 +5,355 @@ -- License : BSD3-style (see LICENSE) -- -- Maintainer : dons@cse.unsw.edu.au --- Stability : stable --- Portability : portable +-- Stability : experimental +-- Portability : portable, Haskell 98 -- ----------------------------------------------------------------------------- -- --- The 'StackSet' data type encodes a set of stacks. A given stack in the --- set is always current. Elements may appear only once in the entire --- stack set. +-- ** Introduction -- --- A StackSet provides a nice data structure for window managers with --- multiple physical screens, and multiple workspaces, where each screen --- has a stack of windows, and a window may be on only 1 screen at any --- given time. +-- The 'StackSet' data type encodes a window manager abstraction. The +-- window manager is a set of virtual workspaces. On each workspace is a +-- stack of windows. A given workspace is always current, and a given +-- window on each workspace has focus. The focused window on the current +-- workspace is the one which will take user input. It can be visualised +-- as follows: -- +-- Workspace { 0*} { 1 } { 2 } { 3 } { 4 } +-- +-- Windows [1 [] [3* [6*] [] +-- ,2*] ,4 +-- ,5] +-- +-- Note that workspaces are indexed from 0, windows are numbered +-- uniquely. A '*' indicates the window on each workspace that has +-- focus, and which workspace is current. +-- +-- ** Zipper +-- +-- We encode all the focus tracking directly in the data structure, with a 'zipper': +-- +-- A Zipper is essentially an `updateable' and yet pure functional +-- cursor into a data structure. Zipper is also a delimited +-- continuation reified as a data structure. +-- +-- The Zipper lets us replace an item deep in a complex data +-- structure, e.g., a tree or a term, without an mutation. The +-- resulting data structure will share as much of its components with +-- the old structure as possible. +-- +-- Oleg Kiselyov, 27 Apr 2005, haskell@, "Zipper as a delimited continuation" +-- +-- We use the zipper to keep track of the focused workspace and the +-- focused window on each workspace, allowing us to have correct focus +-- by construction. We closely follow Huet's original implementation: +-- +-- G. Huet, /Functional Pearl: The Zipper/, +-- 1997, J. Functional Programming 75(5):549-554. +-- and: +-- R. Hinze and J. Jeuring, /Functional Pearl: The Web/. +-- +-- and Conor McBride's zipper differentiation paper. +-- Another good reference is: +-- +-- The Zipper, Haskell wikibook +-- +-- ** Xinerama support: +-- +-- Xinerama in X11 lets us view multiple virtual workspaces +-- simultaneously. While only one will ever be in focus (i.e. will +-- receive keyboard events), other workspaces may be passively viewable. +-- We thus need to track which virtual workspaces are associated +-- (viewed) on which physical screens. We use a simple Map Workspace +-- Screen for this. +-- +-- ** 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 where {- all top level functions -} + +import qualified Data.Map as M +import Data.Maybe (listToMaybe) + + +-- API changes from xmonad 0.1: +-- StackSet constructor arguments changed. StackSet workspace window screen +-- new, -- was: empty +-- view, +-- index, +-- peek, -- was: peek/peekStack +-- focusLeft, focusRight, -- was: rotate +-- focus -- was: raiseFocus +-- insertLeft, -- was: insert/push +-- delete, +-- swap, -- was: promote +-- member, +-- shift, +-- lookupWorkspace, -- was: workspace +-- visibleWorkspaces -- gone. +-- +------------------------------------------------------------------------ -module StackSet ( - StackSet(..), -- abstract +-- +-- A cursor into a non-empty list of workspaces. +-- +data StackSet i a screen = + StackSet { size :: !i -- number of workspaces + , current :: !(Workspace i a) -- currently focused workspace + , prev :: [Workspace i a] -- workspaces to the left + , next :: [Workspace i a] -- workspaces to the right + , screens :: M.Map i screen -- a map of visible workspaces to their screens + } deriving (Show, Eq) + +-- +-- A workspace is just a tag - its index - and a stack +-- +data Workspace i a = Workspace { tag :: !i, stack :: Stack a } + deriving (Show, Eq) - screen, peekStack, index, empty, peek, push, delete, member, - raiseFocus, rotate, promote, shift, view, workspace, insert, - visibleWorkspaces, swap {- helper -} - ) where +-- TODO an unmanaged floating layer would go in here somewhere (a 2nd stack?) -import Data.Maybe -import qualified Data.List as L (delete,elemIndex) -import qualified Data.Map as M +-- +-- A stack is a cursor onto a (possibly empty) window list. +-- The data structure tracks focus by construction, and we follow the +-- master separately (since the wrapping behaviour of focusLeft/Right +-- reorders the window distribution, so we can't rely on the left most +-- window remaining as master (TODO double check this)). +-- +-- A 'Stack' can be viewed as a list with a hole punched in it to make +-- the focused position. Under the zipper/calculus view of such +-- structures, it is the differentiation of a [a], and integrating it +-- back has a natural implementation used in 'index'. +-- +data Stack a = Empty + | Node { focus :: !a -- focused thing in this set + , left :: [a] -- clowns to the left + , right :: [a] } -- jokers to the right + deriving (Show, Eq) + +-- --------------------------------------------------------------------- +-- 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. +-- +-- 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 h [] ts xine + | otherwise = error "non-positive arguments to StackSet.new" + where (h:ts) = Workspace 0 Empty : [ Workspace i Empty | i <- [1 ..n-1]] + xine = M.fromList [ (fromIntegral s, s) | s <- [0 .. m-1] ] + +-- +-- /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 +-- is raised on the current screen. If it is already visible, focus is +-- just moved. +-- +view :: Integral i => i -> StackSet i a s -> StackSet i a s +view i s@(StackSet sz (Workspace n _) _ _ scrs) + | i >= 0 && i < sz + = setCurrent $ if M.member i scrs + then s -- already visisble. just set current. + else case M.lookup n scrs of -- TODO current should always be valid + Nothing -> error "xmonad:view: No physical screen" + Just sc -> s { screens = M.insert i sc (M.delete n scrs) } + | otherwise = s + + -- actually moving focus is easy: + where setCurrent x = foldr traverse x [1..abs (i-n)] + + -- work out which direction to move + traverse _ = if signum (i-n) >= 0 then viewRight else viewLeft + + -- /O(1)/. Move workspace focus left or right one node, a la Huet. + viewLeft (StackSet m t (l:ls) rs sc) = StackSet m l ls (t:rs) sc + viewLeft t = t + viewRight (StackSet m t ls (r:rs) sc) = StackSet m r (t:ls) rs sc + viewRight t = t + +-- --------------------------------------------------------------------- +-- Xinerama operations + +-- | 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 [ i | (i,s) <- M.assocs (screens w), s == sc ] + +-- --------------------------------------------------------------------- +-- Operations on the current stack ------------------------------------------------------------------------- +-- +-- The 'with' function takes a default value, a function, and a +-- StackSet. If the current stack is Empty, '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 (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? --- | The StackSet data structure. Multiple screens containing tables of --- stacks, with a current pointer -data StackSet i j a = - StackSet - { current :: !i -- ^ the currently visible stack - , screen2ws:: !(M.Map j i) -- ^ screen -> workspace - , ws2screen:: !(M.Map i j) -- ^ workspace -> screen map - , stacks :: !(M.Map i ([a], [a])) -- ^ screen -> (floating, normal) - , focus :: !(M.Map i [a]) -- ^ the stack of window focus in each stack - , cache :: !(M.Map a i) -- ^ a cache of windows back to their stacks - } deriving (Eq, Show) - --- The cache is used to check on insertion that we don't already have --- this window managed on another stack +-- +-- Apply a function, and a default value for Empty, to modify the current stack. +-- +modify :: Stack a -> (Stack a -> Stack a) -> StackSet i a s -> StackSet i a s +modify d f s = s { current = (current s) { stack = with d f s } } ------------------------------------------------------------------------- +-- +-- /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 = with Nothing (return . focus) --- | /O(n)/. Create a new stackset, of empty stacks, of size 'n', --- indexed from 0, with 'm' screens. (also indexed from 0) The 0-indexed --- stack will be current. -empty :: (Integral i, Integral j) => Int -> Int -> StackSet i j a -empty n m = StackSet { current = 0 - , screen2ws = wsScrs2Works - , ws2screen = wsWorks2Scrs - , stacks = M.fromList (zip [0..fromIntegral n-1] (repeat ([], []))) - , focus = M.empty - , cache = M.empty } - - where scrs_wrks = unzip $ map (\x -> (fromIntegral x, fromIntegral x)) [0..m-1] - scrs = fst scrs_wrks - wrks = snd scrs_wrks - wsScrs2Works = M.fromList (zip scrs wrks) - wsWorks2Scrs = M.fromList (zip wrks scrs) - --- | /O(log w)/. True if x is somewhere in the StackSet -member :: Ord a => a -> StackSet i j a -> Bool -member a w = M.member a (cache w) - --- | /O(log n)/. Looks up the workspace that x is in, if it is in the StackSet --- lookup :: (Monad m, Ord a) => a -> StackSet i j a -> m i --- lookup x w = M.lookup x (cache w) - --- | /O(n)/. Number of stacks --- size :: StackSet i j a -> Int --- size = M.size . stacks +-- +-- /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 ------------------------------------------------------------------------- +-- let is = t : r ++ reverse l in take (length is) (dropWhile (/= m) (cycle is)) --- | Push. Insert an element onto the top of the current stack. --- If the element is already in the current stack, it is moved to the top. --- If the element is managed on another stack, it is removed from that --- stack first. -push :: (Integral i, Ord a) => a -> StackSet i j a -> StackSet i j a -push k w = insert k (current w) w - --- | /O(log s)/. Extract the element on the top of the current stack. If no such --- element exists, Nothing is returned. -peek :: Integral i => StackSet i j a -> Maybe a -peek w = peekStack (current w) w - --- | /O(log s)/. Extract the element on the top of the given stack. If no such --- element exists, Nothing is returned. -peekStack :: Integral i => i -> StackSet i j a -> Maybe a -peekStack i w = M.lookup i (focus w) >>= maybeHead - -maybeHead :: [a] -> Maybe a -maybeHead (x:_) = Just x -maybeHead [] = Nothing - --- | /O(log s)/. Set the focus for the given stack to the given element. -pushFocus :: (Eq a, Integral i) => i -> a -> StackSet i j a -> StackSet i j a -pushFocus i a w = w { focus = M.insert i ((a:) $ L.delete a $ M.findWithDefault [] i $ focus w) (focus w) } - -popFocus :: (Eq a, Integral i) => i -> a -> StackSet i j a -> StackSet i j a -popFocus i a w = w { focus = M.update upd i (focus w) } - where upd xs = case L.delete a xs of [] -> Nothing; xs' -> Just xs' - --- | /O(log s)/. Index. Extract the stack at workspace 'n'. --- If the index is invalid, returns Nothing. -index :: Integral i => i -> StackSet i j a -> Maybe [a] -index k w = fmap (uncurry (++)) $ M.lookup k (stacks w) - --- | view. Set the stack specified by the argument as being visible and the --- current StackSet. If the stack wasn't previously visible, it will become --- visible on the current screen. If the index is out of range 'view' returns --- the initial 'StackSet' unchanged. -view :: (Integral i, Integral j) => i -> StackSet i j a -> StackSet i j a -view n w | M.member n (stacks w) - = if M.member n (ws2screen w) then w { current = n } - else maybe w tweak (screen (current w) w) - | otherwise = w +-- +-- /O(1), O(w) on the wrapping case/. Move the window focus left or +-- right, wrapping if we reach the end. The wrapping should model a +-- 'cycle' on the current stack. The 'master' window, and window order, +-- are unaffected by movement of focus. +-- +focusLeft, focusRight :: StackSet i a s -> StackSet i a s +focusLeft = 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 + +focusRight = 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 + +-- +-- | /O(1) on current window, O(n) in general/. Focus the window 'w' on +-- the current workspace. If 'w' isn't on the current workspace, leave +-- the StackSet unmodified. +-- +-- TODO: focusWindow give focus to any window on visible workspace +-- +focusWindow :: (Integral i, Eq a) => a -> StackSet i a s -> StackSet i a s +focusWindow w s | Just w == peek s = s + | otherwise = maybe s id $ do + n <- findIndex w s -- TODO, needs to check visible workspaces + if n /= tag (current s) then Nothing -- not on this screen + else return $ until ((Just w ==) . peek) focusLeft s + + +-- +-- 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 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 a s = listToMaybe [ tag w | w <- current s : prev s ++ next s, has a (stack w) ] + where has _ Empty = False + has x (Node t l r) = x `elem` (t : l ++ r) + +-- --------------------------------------------------------------------- +-- Modifying the stackset + +-- +-- /O(n)/. (Complexity due to duplicate check). Insert a new element into +-- the stack, to the left of the currently focused element. +-- +-- The new element is given focus, and is set as the master window. +-- The previously focused element is moved to the right. The previously +-- 'master' element is forgotten. (Thus, 'insert' will cause a retiling). +-- +-- If the element is already in the stackset, the original stackset is +-- returned unmodified. +-- +-- Semantics in Huet's paper is that insert doesn't move the cursor. +-- However, we choose to insert to the left, and move the focus. +-- +insertLeft :: Eq a => a -> StackSet i a s -> StackSet i a s +insertLeft 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 + +-- insertRight :: a -> StackSet i a s -> StackSet i a s +-- insertRight a = modify (Node a [] []) $ \(Node t l r) -> Node a (t:l) r +-- Old semantics, from Huet. +-- > w { right = a : right 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 +-- * otherwise, try to move focus to the right +-- * otherwise, try to move focus to the left +-- * otherwise, you've got an empty workspace, becomes Empty +-- +-- 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) => 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 . current $ s) (findIndex w s) where - tweak sc = w { screen2ws = M.insert sc n (screen2ws w) - , ws2screen = M.insert n sc (M.filter (/=sc) (ws2screen w)) - , current = n } - --- | That screen that workspace 'n' is visible on, if any. -screen :: Integral i => i -> StackSet i j a -> Maybe j -screen n w = M.lookup n (ws2screen w) - --- | The workspace visible on screen 'sc'. Nothing if screen is out of bounds. -workspace :: Integral j => j -> StackSet i j a -> Maybe i -workspace sc w = M.lookup sc (screen2ws w) - --- | A list of the currently visible workspaces. -visibleWorkspaces :: StackSet i j a -> [i] -visibleWorkspaces = M.keys . ws2screen - --- --- | /O(log n)/. rotate. cycle the current window list up or down. --- Has the effect of rotating focus. In fullscreen mode this will cause --- a new window to be visible. --- --- rotate EQ --> [5,6,7,8,1,2,3,4] --- rotate GT --> [6,7,8,1,2,3,4,5] --- rotate LT --> [4,5,6,7,8,1,2,3] --- --- where xs = [5..8] ++ [1..4] --- -rotate :: (Integral i, Eq a) => Ordering -> StackSet i j a -> StackSet i j a -rotate o w = maybe w id $ do - f <- peekStack (current w) w - s <- fmap (uncurry (++)) $ M.lookup (current w) (stacks w) - ea <- case o of EQ -> Nothing - _ -> elemAfter f (if o == GT then s else reverse s) - return $ pushFocus (current w) ea w - --- | /O(log n)/. shift. move the client on top of the current stack to --- the top of stack 'n'. If the stack to move to is not valid, and --- exception is thrown. --- -shift :: (Integral i, Ord a) => i -> StackSet i j a -> StackSet i j a -shift n w = maybe w (\k -> insert k n w) (peek w) - --- | /O(log n)/. Insert an element onto the top of stack 'n'. --- If the element is already in the stack 'n', it is moved to the top. --- If the element exists on another stack, it is removed from that stack. --- If the index is wrong an exception is thrown. --- -insert :: (Integral i, Ord a) => a -> i -> StackSet i j a -> StackSet i j a -insert k n old = pushFocus n k $ - new { cache = M.insert k n (cache new) - , stacks = M.adjust (\(f, ks) -> (f, k:ks)) n (stacks new) } - where new = delete k old - --- | /O(log n)/. Delete an element entirely from from the StackSet. --- This can be used to ensure that a given element is not managed elsewhere. --- If the element doesn't exist, the original StackSet is returned unmodified. -delete :: (Integral i, Ord a) => a -> StackSet i j a -> StackSet i j a -delete k w = maybe w del (M.lookup k (cache w)) - where del i = popFocus i k $ - w { cache = M.delete k (cache w) - , stacks = M.adjust (\(xs, ys) -> (L.delete k xs, L.delete k ys)) i (stacks w) } - --- | /O(log n)/. If the given window is contained in a workspace, make it the --- focused window of that workspace, and make that workspace the current one. -raiseFocus :: (Integral i, Integral j, Ord a) => a -> StackSet i j a -> StackSet i j a -raiseFocus k w = maybe w (\i -> pushFocus i k $ view i w) $ M.lookup k (cache w) - --- | Swap the currently focused window with the master window (the --- window on top of the stack). Focus moves to the master. -promote :: (Integral i, Ord a) => StackSet i j a -> StackSet i j a -promote w = maybe w id $ do - a <- peek w -- fail if null - (f, xs@(x:_)) <- M.lookup (current w) (stacks w) - let w' = w { stacks = M.insert (current w) (f, swap a x xs) (stacks w) } - return $ insert a (current w) w' -- and maintain focus (?) - --- | Swap first occurences of 'a' and 'b' in list. --- If both elements are not in the list, the list is unchanged. --- --- Given a set as a list (no duplicates) --- --- > swap a b . swap a b == id --- -swap :: Eq a => a -> a -> [a] -> [a] -swap a b xs = maybe xs id $ do - ai <- L.elemIndex a xs - bi <- L.elemIndex b xs - return . insertAt bi a . insertAt ai b $ xs - where insertAt n x ys = as ++ x : drop 1 bs - where (as,bs) = splitAt n ys - --- --- cycling: --- promote w = w { stacks = M.adjust next (current w) (stacks w) } --- where next [] = [] --- next xs = last xs : init xs --- - --- | Returns true if the window is in the floating layer -isFloat :: (Ord a, Ord i) => a -> StackSet i j a -> Bool -isFloat k w = maybe False (elem k . fst . (stacks w M.!)) (M.lookup k (cache w)) - --- | Find the element in the (circular) list after given element. -elemAfter :: Eq a => a -> [a] -> Maybe a -elemAfter w ws = listToMaybe . filter (/= w) . dropWhile (/= w) $ ws ++ ws + -- find and remove window script + removeWindow o n = foldr ($) s [view o,remove ,until ((Just w ==) . peek) focusLeft,view n] + + -- actual removal logic, and focus/master logic: + remove = modify Empty $ \c -> case c of + Node _ ls (r:rs) -> Node r ls rs -- try right first + Node _ (l:ls) [] -> Node l ls [] -- else left. + Node _ [] [] -> Empty + +------------------------------------------------------------------------ +-- Setting the master 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. +swap :: StackSet i a s -> StackSet i a s +swap = 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 furthest left, move furthest +-- left to current position. + +-- --------------------------------------------------------------------- +-- Composite operations +-- + +-- /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 to the left of 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, Integral i) => i -> StackSet i a s -> StackSet i a s +shift n s = if and [n >= 0,n < size s,n /= tag (current s)] then maybe s go (peek s) else s + where go w = foldr ($) s [view (tag (current s)),insertLeft w,view n,delete w] + -- ^^ poor man's state monad :-) + @@ -18,7 +18,7 @@ module XMonad ( X, WindowSet, WorkspaceId(..), ScreenId(..), XState(..), XConf(..), Layout(..), Typeable, Message, SomeMessage(..), fromMessage, - runX, io, withDisplay, isRoot, spawn, trace, whenJust + runX, io, withDisplay, withWorkspace, isRoot, spawn, restart, trace, whenJust, whenX ) where import StackSet (StackSet) @@ -28,6 +28,8 @@ import Control.Monad.Reader import System.IO import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession) import System.Exit +import System.Environment +import System.Directory import Graphics.X11.Xlib import Data.Typeable @@ -53,7 +55,7 @@ data XConf = XConf , normalBorder :: !Color -- ^ border color of unfocused windows , focusedBorder :: !Color } -- ^ border color of the focused window -type WindowSet = StackSet WorkspaceId ScreenId Window +type WindowSet = StackSet WorkspaceId Window ScreenId -- | Virtual workspace indicies newtype WorkspaceId = W Int deriving (Eq,Ord,Show,Enum,Num,Integral,Real) @@ -85,6 +87,10 @@ runX c st (X a) = runStateT (runReaderT a c) st >> return () withDisplay :: (Display -> X ()) -> X () withDisplay f = asks display >>= f +-- | Run a monadic action with the current workspace +withWorkspace :: (WindowSet -> X a) -> X a +withWorkspace f = gets workspace >>= f + -- | True if the given window is the root window isRoot :: Window -> X Bool isRoot w = liftM (w==) (asks theRoot) @@ -119,12 +125,11 @@ fromMessage :: Message m => SomeMessage -> Maybe m fromMessage (SomeMessage m) = cast m -- --------------------------------------------------------------------- --- Utilities +-- General utilities -- | Lift an IO action into the X monad io :: IO a -> X a io = liftIO -{-# INLINE io #-} -- | spawn. Launch an external application spawn :: String -> X () @@ -136,10 +141,32 @@ spawn x = io $ do getProcessStatus True False pid return () +-- | Restart xmonad by exec()'ing self. This doesn't save state and xmonad has +-- to be in PATH for this to work. +restart :: IO () +restart = do + prog <- getProgName + prog_path <- findExecutable prog + case prog_path of + Nothing -> return () -- silently fail + Just p -> do args <- getArgs + executeFile p True args Nothing + -- | Run a side effecting action with the current workspace. Like 'when' but whenJust :: Maybe a -> (a -> X ()) -> X () whenJust mg f = maybe (return ()) f mg +-- | Conditionally run an action, using a X event to decide +whenX :: X Bool -> X () -> X () +whenX a f = a >>= \b -> when b f + +-- | Grab the X server (lock it) from the X monad +-- withServerX :: X () -> X () +-- withServerX f = withDisplay $ \dpy -> do +-- io $ grabServer dpy +-- f +-- io $ ungrabServer dpy + -- | A 'trace' for the X monad. Logs a string to stderr. The result may -- be found in your .xsession-errors file trace :: String -> X () diff --git a/tests/Properties.hs b/tests/Properties.hs index 01adc7d..170bc36 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -13,9 +13,10 @@ import Control.Exception (assert) import Control.Monad import Test.QuickCheck hiding (promote) import System.IO -import System.Random +import System.Random hiding (next) import Text.Printf -import Data.List (nub,sort,group,sort,intersperse,genericLength) +import Data.List (nub,sort,sortBy,group,sort,intersperse,genericLength) +import qualified Data.List as L import Data.Char (ord) import Data.Map (keys,elems) import qualified Data.Map as M @@ -23,12 +24,42 @@ import qualified Data.Map as M -- --------------------------------------------------------------------- -- QuickCheck properties for the StackSet +-- Some general hints for creating StackSet properties: +-- +-- * ops that mutate the StackSet are usually local +-- * most ops on StackSet should either be trivially reversible, or +-- idempotent, or both. + +-- +-- The all important Arbitrary instance for StackSet. +-- +instance (Integral i, Integral s, Eq a, Arbitrary a) => Arbitrary (StackSet i a s) 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 + ls <- vector sz -- a vector of sz workspaces + + -- pick a random item in each stack to focus + fs <- sequence [ if null s then return Nothing + else liftM Just (choose ((-1),length s-1)) + | s <- ls ] + + return $ fromList (fromIntegral n, fromIntegral sc,fs,ls) + coarbitrary = error "no coarbitrary for StackSet" + -- | fromList. Build a new StackSet from a list of list of elements, -- keeping track of the currently focused workspace, and the total -- number of workspaces. If there are duplicates in the list, the last -- occurence wins. -fromList :: (Integral i, Integral j, Ord a) => (i, Int, [Maybe a], [[a]]) -> StackSet i j a +-- +-- 'o' random workspace +-- 'm' number of physical screens +-- '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 (_,_,_,[]) = error "Cannot build a StackSet from an empty list" fromList (n,m,fs,xs) | n < 0 || n >= genericLength xs @@ -36,235 +67,392 @@ fromList (n,m,fs,xs) | n < 0 || n >= genericLength xs | m < 1 || m > genericLength xs = error $ "Can't have more screens than workspaces: " ++ show (m, length xs) --- 'o' random workspace --- 'fs' random focused window on each workspace --- fromList (o,m,fs,xs) = let s = view o $ foldr (\(i,ys) s -> - foldr (\a t -> insert a i t) s ys) - (empty (length xs) m) (zip [0..] xs) - - in foldr (\f s -> case f of - Nothing -> s - Just w -> raiseFocus w s) s fs - --- --------------------------------------------------------------------- + foldr insertLeft (view i s) ys) + (new (genericLength xs) m) (zip [0..] xs) + in foldr (\f t -> case f of + Nothing -> t + Just i -> foldr (const focusLeft) t [0..i] ) s fs --- | /O(n)/. Number of stacks -size :: T -> Int -size = M.size . stacks - --- | Height of stack 'n' -height :: Int -> T -> Int -height i w = maybe 0 length (index i w) +------------------------------------------------------------------------ --- build (non-empty) StackSets with between 1 and 100 stacks -- --- StackSet --- { current :: i --- , screen2ws:: !(M.Map j i) -- ^ screen -> workspace --- , ws2screen:: !(M.Map i j) -- ^ workspace -> screen map --- , stacks :: !(M.Map i ([a], [a])) -- ^ screen -> (floating, normal) --- , cache :: !(M.Map a i) -- ^ a cache of windows back to their stacks --- } +-- Just generate StackSets with Char elements. -- --- Use 'raiseFocus' to bring focus to the front' --- -instance (Integral i, Integral j, Ord a, Arbitrary a) => Arbitrary (StackSet i j a) where - arbitrary = do - sz <- choose (1,20) - n <- choose (0,sz-1) - sc <- choose (1,sz) - ls <- vector sz +type T = StackSet Int Char Int - -- pick a random element of each stack to focus. - fs <- sequence [ if null s then return Nothing - else liftM Just (elements s) - | s <- ls ] - - return $ fromList (fromIntegral n,sc,fs,ls) - coarbitrary = error "no coarbitrary for StackSet" +-- Useful operation, the non-local workspaces +hidden x = [ w | w <- prev x ++ next x ] -- the hidden workspaces --- Invariants: +-- Basic data invariants of the StackSet -- --- * no element should ever appear more than once in a StackSet --- * the current index should always be valid +-- With the new zipper-based StackSet, tracking focus is no longer an +-- issue: the data structure enforces focus by construction. -- --- All operations must preserve this. +-- But we still need to ensure there are no duplicates, and master/and +-- the xinerama mapping aren't checked by the data structure at all. -- -invariant (w :: T) = inBounds w && noDuplicates allWindows - where - allWindows = concatMap (uncurry (++)) . M.elems . stacks $ w - noDuplicates ws = nub ws == ws - inBounds x = current x >= 0 && current x < sz where sz = M.size (stacks x) +-- * no element should ever appear more than once in a StackSet +-- * the xinerama screen map should be: +-- -- keys should always index valid workspaces +-- -- monotonically ascending in the elements +-- * the current workspace should be a member of the xinerama screens +-- +invariant (s :: T) = and + -- no duplicates + [ noDuplicates --- test generator -prop_invariant = invariant + -- all this xinerama stuff says we don't have the right structure + , currentIsVisible + , validScreens + , validWorkspaces + , inBounds + ] + where + ws = [ focus t : left t ++ right t + | w <- current s : prev s ++ next s, let t = stack w, t /= Empty ] + noDuplicates = nub ws == ws --- empty StackSets have no windows in them -prop_empty n m = n > 0 && m > 0 ==> all (null . uncurry (++)) (M.elems (stacks x)) - where x = empty n m :: T + -- xinerama invariants: --- empty StackSets always have focus on workspace 0 -prop_empty_current n m = n > 0 && m > 0 ==> current x == 0 - where x = empty n m :: T + currentIsVisible = M.member (tag (current s)) (screens s) -prop_member1 i n m = n > 0 && m > 0 ==> member i (push i x) - where x = empty n m :: T + validScreens = monotonic . sort . M.elems . screens $ s -prop_member2 i x = not (member i (delete i x)) - where _ = x :: T + validWorkspaces = and [ w `elem` allworkspaces | w <- (M.keys . screens) s ] + where allworkspaces = map tag $ current s : prev s ++ next s -prop_member3 i n m = member i (empty n m :: T) == False + inBounds = and [ w >=0 && w < size s | (w,sc) <- M.assocs (screens s) ] -prop_sizepush is n m = n > 0 ==> size (foldr push x is ) == n - where x = empty n m :: T +monotonic [] = True +monotonic (x:[]) = True +monotonic (x:y:zs) | x == y-1 = monotonic (y:zs) + | otherwise = False -prop_currentpush is n m = n > 0 ==> - height (current x) (foldr push x js) == length js - where - js = nub is - x = empty n m :: T +prop_invariant = invariant -prop_push_idem i (x :: T) = push i x == push i (push i x) +-- and check other ops preserve invariants +prop_empty_I (n :: Positive Int) = forAll (choose (1,fromIntegral n)) $ \m -> + invariant $ new (fromIntegral n) m -prop_pushpeek x is = not (null is) ==> fromJust (peek (foldr push x is)) == head is - where _ = x :: T +prop_view_I (n :: NonNegative Int) (x :: T) = + fromIntegral n < size x ==> invariant $ view (fromIntegral n) x -prop_peekmember x = case peek x of - Just w -> member w x - Nothing -> True {- then we don't know anything -} - where _ = x :: T +prop_focusLeft_I (n :: NonNegative Int) (x :: T) = + invariant $ foldr (const focusLeft) x [1..n] +prop_focusRight_I (n :: NonNegative Int) (x :: T) = + invariant $ foldr (const focusRight) x [1..n] -prop_peek_peekStack n x = - if current x == n then peekStack n x == peek x - else True -- so we don't exhaust - where _ = x :: T +prop_focus_I (n :: NonNegative Int) (x :: T) = + case peek x of + Nothing -> True + Just _ -> let w = focus . stack . current $ foldr (const focusLeft) x [1..n] + in invariant $ focusWindow w x -prop_notpeek_peekStack n x = current x /= n && isJust (peek x) ==> peekStack n x /= peek x - where _ = x :: T +prop_insertLeft_I n (x :: T) = invariant $ insertLeft n x ------------------------------------------------------------------------- +prop_delete_I (x :: T) = invariant $ + case peek x of + Nothing -> x + Just i -> delete i x -type T = StackSet Int Int Char +prop_swap_I (x :: T) = invariant $ swap x -prop_delete_uniq i x = not (member i x) ==> delete i x == x - where _ = x :: T +prop_shift_I (n :: NonNegative Int) (x :: T) = + fromIntegral n < size x ==> invariant $ shift (fromIntegral n) x -{- -TODO: enable this property when we have a better story about focus. -prop_delete_push i x = not (member i x) ==> delete i (push i x) == x - where _ = x :: T --} +-- --------------------------------------------------------------------- +-- 'new' -prop_delete_push i x = not (member i x) ==> delete i (push i x) == x - where _ = x :: T +-- empty StackSets have no windows in them +prop_empty (n :: Positive Int) + (m :: Positive Int) = + all (== Empty) [ stack w | w <- current x : prev x ++ next x ] -prop_delete2 i x = - delete i x == delete i (delete i x) - where _ = x :: T + where x = new (fromIntegral n) (fromIntegral m) :: T -prop_focus1 i x = member i x ==> peek (raiseFocus i x) == Just i - where _ = x :: T +-- empty StackSets always have focus on workspace 0 +prop_empty_current (n :: Positive Int) + (m :: Positive Int) = tag (current x) == 0 + where x = new (fromIntegral n) (fromIntegral m) :: T --- rotation is reversible in two directions -prop_rotaterotate1 (x :: T) = rotate LT (rotate GT x') == x' - where x' = rotate LT x -prop_rotaterotate2 (x :: T) = rotate GT (rotate LT x') == x' - where x' = rotate GT x +-- 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 --- rotation through the height of a stack gets us back to the start -prop_rotate_all (x :: T) = f (f x) == f x - where - n = height (current x) x - f x' = foldr (\_ y -> rotate GT y) x' [1..n] +-- --------------------------------------------------------------------- +-- viewing workspaces +-- view sets the current workspace to 'n' +prop_view_current (x :: T) (n :: NonNegative Int) = i < size x ==> + tag (current (view i x)) == i + where + i = fromIntegral n -prop_viewview r x = - let n = current x - sz = size x - i = r `mod` sz - in view n (view (fromIntegral i) x) == x +-- 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 ==> + workspaces x == workspaces (view i x) + where + workspaces a = sortBy (\s t -> tag s `compare` tag t) $ + current a : prev a ++ next a + i = fromIntegral n - where _ = x :: T +-- view should result in a visible xinerama screen +prop_view_xinerama (x :: T) (n :: NonNegative Int) = i < size 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) -{- -TODO: enable this property when we have a better story for focus. +-- view is reversible +prop_view_reversible r (x :: T) = view n (view i x) == x + where n = tag (current x) + sz = size x + i = fromIntegral $ r `mod` sz -prop_shift_reversible r (x :: T) = - let i = fromIntegral $ r `mod` sz - sz = size x - n = current x - in height n x > 0 ==> (view n . shift n . view i . shift i) x == x --} +-- --------------------------------------------------------------------- +-- Xinerama +-- every screen should yield a valid workspace +prop_lookupWorkspace (n :: NonNegative Int) (x :: T) = + s < M.size (screens x) ==> + fromJust (lookupWorkspace s x) `elem` (map tag $ current x : prev x ++ next x) + where + s = fromIntegral n -prop_fullcache x = cached == allvals where - cached = sort . keys $ cache x - allvals = sort . concat . map (uncurry (++)) . elems $ stacks x - _ = x :: T +-- --------------------------------------------------------------------- +-- peek/index -prop_currentwsvisible x = (current x) `elem` (visibleWorkspaces x) - where _ = x :: T +-- peek either yields nothing on the Empty workspace, or Just a valid window +prop_member_peek (x :: T) = + case peek x of + Nothing -> True {- then we don't know anything -} + Just i -> member i x -prop_ws2screen_screen2ws x = (ws == ws') && (sc == sc') - where ws = sort . keys $ ws2screen x - ws' = sort . elems $ screen2ws x - sc = sort . keys $ screen2ws x - sc' = sort . elems $ ws2screen x - _ = x :: T +-- --------------------------------------------------------------------- +-- index + +-- 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 . current $ x + list = focus it : left it ++ right it -prop_screenworkspace x = all test [0..((fromIntegral $ size x)-1)] - where test ws = case screen ws x of - Nothing -> True - Just sc -> workspace sc x == Just ws - _ = x :: T +-- --------------------------------------------------------------------- +-- rotating focus +-- +-- Unfortunately, in the presence of wrapping of focus, we don't have a +-- simple identity where focusLeft . focusRight == id, as the focus +-- operations repartition the structure on wrapping. +-- +-- Note the issue with equality on Stacks given the wrapping semantics. +-- +-- [1,2,3] ++ [4] ++ [5] +-- +-- should be equivalent to: +-- +-- [] ++ [4] ++ [5,1,2,3] +-- +-- However, we can simply normalise the list, taking focus as the head, +-- and the items should be the same. + +-- So we normalise the stack on the current workspace. +-- We normalise by moving everything to the 'left' of the focused item, +-- to the right. +-- normal (x :: T) = modify Empty (\c -> case c of +-- Node t ls rs -> Node t [] (rs ++ reverse ls)) x +normal = id + +-- master/focus +-- +-- The tiling order, and master window, of a stack is unaffected by focus changes. +-- +prop_focus_left_master (n :: NonNegative Int) (x::T) = + index (foldr (const focusLeft) x [1..n]) == index x +prop_focus_right_master (n :: NonNegative Int) (x::T) = + index (foldr (const focusRight) x [1..n]) == index x +prop_focusWindow_master (n :: NonNegative Int) (x :: T) = + case peek x of + Nothing -> True + Just _ -> let s = index x + i = fromIntegral n `mod` length s + in index (focusWindow (s !! i) x) == index x + +-- shifting focus is trivially reversible +prop_focus_left (x :: T) = normal (focusLeft (focusRight x)) == normal x +prop_focus_right (x :: T) = normal (focusRight (focusLeft x)) == normal x + +-- focusWindow actually leaves the window focused... +prop_focusWindow_works (n :: NonNegative Int) (x :: T) = + case peek x of + Nothing -> True + Just _ -> let s = index x + i = fromIntegral n `mod` length s + in (focus . stack . current) (focusWindow (s !! i) x) == (s !! i) -prop_swap a b xs = swap a b (swap a b ys) == ys - where ys = nub xs :: [Int] +-- rotation through the height of a stack gets us back to the start +prop_focus_all_l (x :: T) = normal (foldr (const focusLeft) x [1..n]) == normal x + where n = length (index x) +prop_focus_all_r (x :: T) = normal (foldr (const focusRight) x [1..n]) == normal x + where n = length (index x) ------------------------------------------------------------------------- +-- prop_rotate_all (x :: T) = f (f x) == f x +-- f x' = foldr (\_ y -> rotate GT y) x' [1..n] --- promote is idempotent -prop_promote2 x = promote (promote x) == (promote x) - where _ = x :: T +-- focus is local to the current workspace +prop_focus_local (x :: T) = hidden (focusRight x) == hidden x --- focus doesn't change -prop_promotefocus x = focus (promote x) == focus x - where _ = x :: T +prop_focusWindow_local (n :: NonNegative Int) (x::T ) = + case peek x of + Nothing -> True + Just _ -> let s = index x + i = fromIntegral n `mod` length s + in hidden (focusWindow (s !! i) x) == hidden x --- screen certainly should't change -prop_promotecurrent x = current (promote x) == current x - where _ = x :: T +-- --------------------------------------------------------------------- +-- member/findIndex --- the physical screen doesn't change -prop_promotescreen n x = screen n (promote x) == screen n x - where _ = x :: T +-- +-- For all windows in the stackSet, findIndex should identify the +-- correct workspace +-- +prop_findIndex (x :: T) = + and [ tag w == fromJust (findIndex i x) + | w <- current x : prev x ++ next x + , let t = stack w + , t /= Empty + , i <- focus (stack w) : left (stack w) ++ right (stack w) + ] --- promote doesn't mess with other windows -prop_promote_raise_id x = (not . null . fromMaybe [] . flip index x . current $ x) ==> - (promote . promote . promote) x == promote x - where _ = x :: 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 (insertLeft i x) + where x = new (fromIntegral n) (fromIntegral m) :: T + +-- insert should be idempotent +prop_insert_idem i (x :: T) = insertLeft i x == insertLeft i (insertLeft i x) + +-- insert when an item is a member should leave the stackset unchanged +prop_insert_duplicate i (x :: T) = member i x ==> insertLeft i x == x -- push shouldn't change anything but the current workspace -prop_push_local (x :: T) i = not (member i x) ==> hidden x == hidden (push i x) +prop_insert_local (x :: T) i = not (member i x) ==> hidden x == hidden (insertLeft i x) + +-- 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) = + peek (foldr insertLeft 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. +-- +prop_insert_delete n x = not (member n x) ==> delete n (insertLeft n y) == (y :: T) + where + y = swap x -- sets the master window to the current focus. + -- 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) = + size (foldr insertLeft x ws ) == (length ws) where - hidden w = [ index n w | n <- [0 ..sz-1], n /= current w ] - sz = M.size (stacks x) + ws = nub is + x = new (fromIntegral n) (fromIntegral m) :: T + size = length . index + + +-- --------------------------------------------------------------------- +-- 'delete' + +-- deleting the current item removes it. +prop_delete x = + case peek x of + Nothing -> True + Just i -> not (member i (delete i x)) + where _ = x :: T + +-- delete is reversible with 'insert'. +-- It is the identiy, except for the 'master', which is reset on insert and delete. +-- +prop_delete_insert (x :: T) = + case peek x of + Nothing -> True + Just n -> insertLeft n (delete n y) == y + where + y = swap x + +-- delete should be local +prop_delete_local (x :: T) = + case peek x of + Nothing -> True + Just i -> hidden x == hidden (delete i x) + +-- --------------------------------------------------------------------- +-- swap: setting the master window +-- prop_swap_reversible a b xs = swap a b (swap a b ys) == ys +-- where ys = nub xs :: [Int] + +-- swap doesn't change focus +prop_swap_focus (x :: T) + = case peek x of + Nothing -> True + Just f -> focus (stack (current (swap x))) == f + +-- swap is local +prop_swap_local (x :: T) = hidden x == hidden (swap x) + +-- TODO swap is reversible +-- swap is reversible, but involves moving focus back the window with +-- master on it. easy to do with a mouse... +{- +prop_promote_reversible x b = (not . null . fromMaybe [] . flip index x . current $ x) ==> + (raiseFocus y . promote . raiseFocus z . promote) x == x + where _ = x :: T + dir = if b then LT else GT + (Just y) = peek x + (Just (z:_)) = flip index x . current $ x +-} + +prop_swap_idempotent (x :: T) = swap (swap x) == swap x + +-- --------------------------------------------------------------------- +-- shift + +-- 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 (current y) + in case peek y of + Nothing -> True + Just _ -> (view n . shift n . view i . shift i) y == y + where + y = swap x ------------------------------------------------------------------------ -- some properties for layouts: -- 1 window should always be tiled fullscreen +{- prop_tile_fullscreen rect = tile pct rect 1 1 == [rect] -- multiple windows @@ -287,61 +475,7 @@ noOverlaps xs = and [ verts a `notOverlap` verts b = (top1 < bottom2 || top2 < bottom1) || (right1 < left2 || right2 < left1) - ------------------------------------------------------------------------- - -instance Arbitrary Char where - arbitrary = choose ('a','z') - coarbitrary n = coarbitrary (ord n) - -instance Random Word8 where - randomR = integralRandomR - random = randomR (minBound,maxBound) - -instance Arbitrary Word8 where - arbitrary = choose (minBound,maxBound) - coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) - -instance Random Word64 where - randomR = integralRandomR - random = randomR (minBound,maxBound) - -instance Arbitrary Word64 where - arbitrary = choose (minBound,maxBound) - coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) - -integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) -integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, - fromIntegral b :: Integer) g of - (x,g) -> (fromIntegral x, g) - -instance Arbitrary Position where - arbitrary = do n <- arbitrary :: Gen Word8 - return (fromIntegral n) - coarbitrary = undefined - -instance Arbitrary Dimension where - arbitrary = do n <- arbitrary :: Gen Word8 - return (fromIntegral n) - coarbitrary = undefined - -instance Arbitrary Rectangle where - arbitrary = do - sx <- arbitrary - sy <- arbitrary - sw <- arbitrary - sh <- arbitrary - return $ Rectangle sx sy sw sh - coarbitrary = undefined - - -instance Arbitrary Rational where - arbitrary = do - n <- arbitrary - d' <- arbitrary - let d = if d' == 0 then 1 else d' - return (n % d) - coarbitrary = undefined +-} ------------------------------------------------------------------------ @@ -349,81 +483,100 @@ main :: IO () main = do args <- getArgs let n = if null args then 100 else read (head args) - results <- mapM (\(s,a) -> printf "%-25s: " s >> a n) tests + (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-25s: " s >> a n) tests + printf "Passed %d tests!\n" (sum passed) when (not . and $ results) $ fail "Not all tests passed!" where - n = 100 tests = - [("StackSet invariants", mytest prop_invariant) - ,("empty is empty" , mytest prop_empty) - ,("empty / current" , mytest prop_empty_current) - - ,("member/push ", mytest prop_member1) - ,("member/peek ", mytest prop_peekmember) - ,("member/delete ", mytest prop_member2) - ,("member/empty ", mytest prop_member3) - - ,("size/push ", mytest prop_sizepush) - ,("height/push ", mytest prop_currentpush) - ,("push/peek ", mytest prop_pushpeek) - ,("push is local" , mytest prop_push_local) - ,("idempotent push" , mytest prop_push_idem) - - ,("peek/peekStack" , mytest prop_peek_peekStack) - ,("not . peek/peekStack", mytest prop_notpeek_peekStack) - - ,("delete/not.member", mytest prop_delete_uniq) - ,("delete idempotent", mytest prop_delete2) - ,("delete.push identity" , mytest prop_delete_push) - - ,("focus", mytest prop_focus1) - - ,("rotate l >> rotate r", mytest prop_rotaterotate1) - ,("rotate r >> rotate l", mytest prop_rotaterotate2) - ,("rotate all", mytest prop_rotate_all) - - ,("view/view ", mytest prop_viewview) - ,("view idem ", mytest prop_view_idem) - - -- disabled, for now ,("shift reversible ", mytest prop_shift_reversible) - - ,("fullcache ", mytest prop_fullcache) - ,("currentwsvisible ", mytest prop_currentwsvisible) - ,("ws screen mapping", mytest prop_ws2screen_screen2ws) - ,("screen/workspace ", mytest prop_screenworkspace) - - ,("promote idempotent", mytest prop_promote2) - ,("promote focus", mytest prop_promotefocus) - ,("promote current", mytest prop_promotecurrent) - ,("promote only swaps", mytest prop_promote_raise_id) - ,("promote/screen" , mytest prop_promotescreen) - - ,("swap", mytest prop_swap) - ------------------------------------------------------------------------- + [("StackSet invariants" , mytest prop_invariant) + + ,("empty: invariant" , mytest prop_empty_I) + ,("empty is empty" , mytest prop_empty) + ,("empty / current" , mytest prop_empty_current) + ,("empty / member" , mytest prop_member_empty) + + ,("view : invariant" , mytest prop_view_I) + ,("view sets current" , mytest prop_view_current) + ,("view idempotent" , mytest prop_view_idem) + ,("view reviersible" , mytest prop_view_reversible) + ,("view / xinerama" , mytest prop_view_xinerama) + ,("view is local" , mytest prop_view_local) + + ,("valid workspace xinerama", mytest prop_lookupWorkspace) + + ,("peek/member " , mytest prop_member_peek) + + ,("index/length" , mytest prop_index_length) + + ,("focus left : invariant", mytest prop_focusLeft_I) + ,("focus right: invariant", mytest prop_focusRight_I) + ,("focusWindow: invariant", mytest prop_focus_I) + ,("focus left/master" , mytest prop_focus_left_master) + ,("focus right/master" , mytest prop_focus_right_master) + ,("focusWindow master" , mytest prop_focusWindow_master) + ,("focus left/right" , mytest prop_focus_left) + ,("focus right/left" , mytest prop_focus_right) + ,("focus all left " , mytest prop_focus_all_l) + ,("focus all right " , mytest prop_focus_all_r) + ,("focus is local" , mytest prop_focus_local) + ,("focusWindow is local", mytest prop_focusWindow_local) + ,("focusWindow works" , mytest prop_focusWindow_works) + + ,("findIndex" , mytest prop_findIndex) + + ,("insert: invariant" , mytest prop_insertLeft_I) + ,("insert/new" , mytest prop_insert_empty) + ,("insert is idempotent", mytest prop_insert_idem) + ,("insert is reversible", mytest prop_insert_delete) + ,("insert is local" , mytest prop_insert_local) + ,("insert duplicates" , mytest prop_insert_duplicate) + ,("insert/peek " , mytest prop_insert_peek) + ,("insert/size" , mytest prop_size_insert) + + ,("delete: invariant" , mytest prop_delete_I) + ,("delete/empty" , mytest prop_empty) + ,("delete/member" , mytest prop_delete) + ,("delete is reversible", mytest prop_delete_insert) + ,("delete is local" , mytest prop_delete_local) + + ,("swap: invariant " , mytest prop_swap_I) + ,("swap id on focus" , mytest prop_swap_focus) + ,("swap is idempotent" , mytest prop_swap_idempotent) + ,("swap is local" , mytest prop_swap_local) + + ,("shift: invariant" , mytest prop_shift_I) + ,("shift is reversible" , mytest prop_shift_reversible) +{- ,("tile 1 window fullsize", mytest prop_tile_fullscreen) ,("tiles never overlap", mytest prop_tile_non_overlap) +-} ] +------------------------------------------------------------------------ +-- +-- QC driver +-- + debug = False -mytest :: Testable a => a -> Int -> IO Bool +mytest :: Testable a => a -> Int -> IO (Bool, Int) mytest a n = mycheck defaultConfig { configMaxTest=n - , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] } a + -- , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a -mycheck :: Testable a => Config -> a -> IO Bool +mycheck :: Testable a => Config -> a -> IO (Bool, Int) mycheck config a = do rnd <- newStdGen mytests config (evaluate a) rnd 0 0 [] -mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO Bool +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int) mytests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = done "OK," ntest stamps >> return True - | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return True + | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest) + | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest) | otherwise = do putStr (configEvery config ntest (arguments result)) >> hFlush stdout case ok result of @@ -436,7 +589,7 @@ mytests config gen rnd0 ntest nfail stamps ++ show ntest ++ " tests:\n" ++ unlines (arguments result) - ) >> hFlush stdout >> return False + ) >> hFlush stdout >> return (False, ntest) where result = generate (configSize config ntest) rnd2 gen (rnd1,rnd2) = split rnd0 @@ -466,3 +619,111 @@ done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table percentage n m = show ((100 * n) `div` m) ++ "%" ------------------------------------------------------------------------ + +instance Arbitrary Char where + arbitrary = choose ('a','z') + coarbitrary n = coarbitrary (ord n) + +instance Random Word8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Arbitrary Word8 where + arbitrary = choose (minBound,maxBound) + coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) + +instance Random Word64 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Arbitrary Word64 where + arbitrary = choose (minBound,maxBound) + coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) + +integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) +integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, + fromIntegral b :: Integer) g of + (x,g) -> (fromIntegral x, g) + +instance Arbitrary Position where + arbitrary = do n <- arbitrary :: Gen Word8 + return (fromIntegral n) + coarbitrary = undefined + +instance Arbitrary Dimension where + arbitrary = do n <- arbitrary :: Gen Word8 + return (fromIntegral n) + coarbitrary = undefined + +instance Arbitrary Rectangle where + arbitrary = do + sx <- arbitrary + sy <- arbitrary + sw <- arbitrary + sh <- arbitrary + return $ Rectangle sx sy sw sh + coarbitrary = undefined + +instance Arbitrary Rational where + arbitrary = do + n <- arbitrary + d' <- arbitrary + let d = if d' == 0 then 1 else d' + return (n % d) + coarbitrary = undefined + +------------------------------------------------------------------------ +-- QC 2 + +-- from QC2 +-- | NonEmpty xs: guarantees that xs is non-empty. +newtype NonEmptyList a = NonEmpty [a] + deriving ( Eq, Ord, Show, Read ) + +instance Arbitrary a => Arbitrary (NonEmptyList a) where + arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) + coarbitrary = undefined + +newtype NonEmptyNubList a = NonEmptyNubList [a] + deriving ( Eq, Ord, Show, Read ) + +instance (Eq a, Arbitrary a) => Arbitrary (NonEmptyNubList a) where + arbitrary = NonEmptyNubList `fmap` ((liftM nub arbitrary) `suchThat` (not . null)) + coarbitrary = undefined + + +type Positive a = NonZero (NonNegative a) + +newtype NonZero a = NonZero a + deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read ) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonZero a) where + arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0) + coarbitrary = undefined + +newtype NonNegative a = NonNegative a + deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read ) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where + arbitrary = + frequency + [ (5, (NonNegative . abs) `fmap` arbitrary) + , (1, return 0) + ] + coarbitrary = undefined + +-- | Generates a value that satisfies a predicate. +suchThat :: Gen a -> (a -> Bool) -> Gen a +gen `suchThat` p = + do mx <- gen `suchThatMaybe` p + case mx of + Just x -> return x + Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) + +-- | Tries to generate a value that satisfies a predicate. +suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) +gen `suchThatMaybe` p = sized (try 0 . max 1) + where + try _ 0 = return Nothing + try k n = do x <- resize (2*k+n) gen + if p x then return (Just x) else try (k+1) (n-1) |