aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Config.hs18
-rw-r--r--Config.hs-boot2
-rw-r--r--Main.hs92
-rw-r--r--Operations.hs356
-rw-r--r--StackSet.hs548
-rw-r--r--XMonad.hs35
-rw-r--r--tests/Properties.hs813
7 files changed, 1107 insertions, 757 deletions
diff --git a/Config.hs b/Config.hs
index e6a9101..8fa538c 100644
--- a/Config.hs
+++ b/Config.hs
@@ -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
diff --git a/Main.hs b/Main.hs
index ae0b596..b75c5c3 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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 :-)
+
diff --git a/XMonad.hs b/XMonad.hs
index 22fce97..b985de8 100644
--- a/XMonad.hs
+++ b/XMonad.hs
@@ -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)