summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Main.hs164
-rw-r--r--StackSet.hs383
-rw-r--r--W.hs65
3 files changed, 479 insertions, 133 deletions
diff --git a/Main.hs b/Main.hs
index 714fe8d..8d01241 100644
--- a/Main.hs
+++ b/Main.hs
@@ -13,14 +13,11 @@
-- thunk, a minimal window manager for X11
--
-import Data.Bits hiding (rotate)
import Data.List
-import qualified Data.Sequence as S
-import qualified Data.Foldable as F
+import Data.Bits hiding (rotate)
import qualified Data.Map as M
import System.IO
-import System.Process (runCommand)
import System.Exit
import Graphics.X11.Xlib
@@ -29,6 +26,7 @@ import Graphics.X11.Xlib.Extras
import Control.Monad.State
import W
+import qualified StackSet as W
--
-- The number of workspaces:
@@ -44,13 +42,13 @@ keys = M.fromList $
[ ((mod1Mask .|. shiftMask, xK_Return), spawn "xterm")
, ((mod1Mask, xK_p ), spawn "exe=`dmenu_path | dmenu` && exec $exe")
, ((controlMask, xK_space ), spawn "gmrun")
- , ((mod1Mask, xK_Tab ), focus 1)
- , ((mod1Mask, xK_j ), focus 1)
- , ((mod1Mask, xK_k ), focus (-1))
+ , ((mod1Mask, xK_Tab ), focus GT)
+ , ((mod1Mask, xK_j ), focus GT)
+ , ((mod1Mask, xK_k ), focus LT)
, ((mod1Mask .|. shiftMask, xK_c ), kill)
, ((mod1Mask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess)
] ++
- -- generate keybindings for each workspace:
+ -- generate keybindings to each workspace:
[((m .|. mod1Mask, xK_0 + fromIntegral i), f i)
| i <- [1 .. workspaces]
, (f, m) <- [(view, 0), (tag, shiftMask)]]
@@ -67,7 +65,7 @@ main = do
{ display = dpy
, screenWidth = displayWidth dpy dflt
, screenHeight = displayHeight dpy dflt
- , workspace = (0,S.fromList (replicate workspaces [])) -- empty workspaces
+ , workspace = W.empty workspaces
}
runW initState $ do
@@ -105,9 +103,7 @@ handle (KeyEvent {event_type = t, state = m, keycode = code})
| t == keyPress = do
dpy <- gets display
s <- io $ keycodeToKeysym dpy code 0
- case M.lookup (m,s) keys of
- Nothing -> return ()
- Just a -> a
+ maybe (return ()) id (M.lookup (m,s) keys)
handle e@(ConfigureRequestEvent {}) = do
dpy <- gets display
@@ -127,112 +123,88 @@ handle e = trace (eventName e) -- return ()
-- ---------------------------------------------------------------------
-- Managing windows
--- | spawn. Launch an external application
-spawn :: String -> W ()
-spawn = io_ . runCommand
-
---
-- | refresh. Refresh the currently focused window. Resizes to full
-- screen and raises the window.
---
refresh :: W ()
-refresh = do
- (n,wks) <- gets workspace
- let ws = wks `S.index` n
- case ws of
- [] -> return () -- do nothing. hmm. so no empty workspaces?
- -- we really need to hide all non-visible windows
- -- ones on other screens
- (w:_) -> do
- d <- gets display
- sw <- liftM fromIntegral (gets screenWidth)
- sh <- liftM fromIntegral (gets screenHeight)
- io $ do moveResizeWindow d w 0 0 sw sh -- fullscreen
- raiseWindow d w
-
--- | Modify the current window list with a pure funtion, and refresh
-withWindows :: (Windows -> Windows) -> W ()
-withWindows f = do
- modifyWindows f
+refresh = whenJust W.peek $ \w -> do
+ d <- gets display
+ sw <- liftM fromIntegral (gets screenWidth)
+ sh <- liftM fromIntegral (gets screenHeight)
+ io $ do moveResizeWindow d w 0 0 sw sh -- fullscreen
+ raiseWindow d w
+
+-- | hide. Hide a list of windows by moving them offscreen.
+hide :: Window -> W ()
+hide w = do
+ dpy <- gets display
+ sw <- liftM fromIntegral (gets screenWidth)
+ sh <- liftM fromIntegral (gets screenHeight)
+ io $ moveWindow dpy w (2*sw) (2*sh)
+
+-- | reveal. Expose a list of windows, moving them on screen
+reveal :: Window -> W ()
+reveal w = do
+ dpy <- gets display
+ io $ moveWindow dpy w 0 0
+
+-- | windows. Modify the current window list with a pure function, and refresh
+windows :: (WorkSpace -> WorkSpace) -> W ()
+windows f = do
+ modifyWorkspace f
refresh
+-- ---------------------------------------------------------------------
+-- Window operations
+
-- | 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 -> W ()
manage w = do
d <- gets display
io $ mapWindow d w
- withWindows (nub . (w :))
+ windows $ W.push w
-- | unmanage. A window no longer exists, remove it from the window
-- list, on whatever workspace it is.
unmanage :: Window -> W ()
unmanage w = do
- (_,wks) <- gets workspace
- mapM_ rm (F.toList wks)
- where
- rm ws = when (w `elem` ws) $ do
- dpy <- gets display
- io $ do grabServer dpy
- sync dpy False
- ungrabServer dpy
- withWindows $ filter (/= w)
+ ws <- gets workspace
+ when (W.member w ws) $ do
+ dpy <- gets display
+ io $ do grabServer dpy
+ sync dpy False
+ ungrabServer dpy
+ windows $ W.delete w
-- | focus. focus to window at offset 'n' in list.
-- The currently focused window is always the head of the list
-focus :: Int -> W ()
-focus n = withWindows (rotate n)
+focus :: Ordering -> W ()
+focus = windows . W.rotate
-- | Kill the currently focused client
kill :: W ()
kill = do
- dpy <- gets display
- (n,wks) <- gets workspace
- let ws = wks `S.index` n
- case ws of
- [] -> return ()
- (w:_) -> do
- -- if(isprotodel(sel))
- -- sendevent(sel->win, wmatom[WMProtocols], wmatom[WMDelete]);
- io $ killClient dpy w -- ignoring result
- return ()
-
--- | tag. associate a window with a new workspace
+ dpy <- gets display
+ whenJust W.peek $ io_ . killClient dpy
+
+-- | tag. Move a window to a new workspace
tag :: Int -> W ()
-tag n = do
- let new = n-1
- (old,wks) <- gets workspace
- when (new /= old && new >= 0 && new < S.length wks) $ do
- let this = wks `S.index` old
- if null this
- then return () -- no client to retag
- else do let (t:_) = this
- modifyWorkspaces $ \(i,w) ->
- let w' = S.adjust tail old w
- w'' = S.adjust (t:) new w' in (i,w'')
- hideWindows [t]
- refresh
-
--- | Change the current workspace to workspce at offset 'n-1'.
+tag o = do
+ ws <- gets workspace
+ when (n /= W.cursor ws) $
+ whenJust W.peek $ \w -> do
+ hide w
+ windows $ W.shift n
+ where n = o -1
+
+-- | view. Change the current workspace to workspce at offset 'n-1'.
view :: Int -> W ()
-view n = do
- let new = n-1
- (old,wks) <- gets workspace
- when (new /= old && new >= 0 && new < S.length wks) $ do
- modifyWorkspaces $ \_ -> (new,wks)
- hideWindows (wks `S.index` old)
- showWindows (wks `S.index` new)
- refresh
-
--- | Hide a list of windows by moving them offscreen.
-hideWindows :: Windows -> W ()
-hideWindows ws = do
- dpy <- gets display
- sw <- liftM fromIntegral (gets screenWidth)
- sh <- liftM fromIntegral (gets screenHeight)
- forM_ ws $ \w -> io $ moveWindow dpy w (2*sw) (2*sh)
+view o = do
+ ws <- gets workspace
+ when (n /= W.cursor ws) $
+ whenJust (flip W.index n) $ \new -> do
+ mapM_ hide (W.stack ws)
+ mapM_ reveal new
+ windows $ W.view n
+ where n = o-1
--- | Expose a list of windows, moving them on screen
-showWindows :: Windows -> W ()
-showWindows ws = do
- dpy <- gets display
- forM_ ws $ \w -> io $ moveWindow dpy w 0 0
diff --git a/StackSet.hs b/StackSet.hs
new file mode 100644
index 0000000..7c388f2
--- /dev/null
+++ b/StackSet.hs
@@ -0,0 +1,383 @@
+{-# OPTIONS -cpp #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : StackSet
+-- Copyright : (c) Don Stewart 2007
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : dons@cse.unsw.edu.au
+-- Stability : stable
+-- Portability : portable, needs GHC 6.6
+--
+-----------------------------------------------------------------------------
+--
+-- The 'StackSet' data type encodes a set of stacks. A given stack in the
+-- set is always current.
+--
+
+module StackSet (
+
+ StackSet, -- abstract
+
+ -- * Introduction
+ empty, -- :: Int -> StackSet a
+ fromList, -- :: [[a]] -> StackSet a
+
+ -- * Inspection
+ member, -- :: Ord a => a -> StackSet a -> Bool
+ peek, -- :: StackSet a -> Maybe a
+ stack, -- :: StackSet a -> [a]
+ cursor, -- :: StackSet a -> Int
+ index, -- :: StackSet a -> Int -> Maybe [a]
+
+ -- * Modification to the current stack
+ push, -- :: Ord a => a -> StackSet a -> StackSet a
+ pop, -- :: Ord a => StackSet a -> StackSet a
+ rotate, -- :: Ordering -> StackSet a -> StackSet a
+ shift, -- :: Ord a => Int -> StackSet a -> StackSet a
+
+ -- * Modification to arbitrary stacks
+ delete, -- :: Ord a => a -> StackSet a -> StackSet a
+
+ -- * Changing which stack is 'current'
+ view, -- :: Int -> StackSet a -> StackSet a
+
+ ) where
+
+import Data.Maybe
+import qualified Data.Foldable as F
+import qualified Data.List as L
+import qualified Data.Map as M
+import qualified Data.Sequence as S
+
+-- All for testing:
+#if TESTING
+import Control.Exception (assert)
+import Control.Monad
+import Test.QuickCheck
+import System.IO
+import System.Random
+import Text.Printf
+import Data.List (sort,group,sort,intersperse)
+#endif
+
+------------------------------------------------------------------------
+
+-- | The StackSet data structure. A table of stacks, with a cursor
+data StackSet a =
+ StackSet
+ { cursor :: {-# UNPACK #-} !Int -- ^ the currently visible stack
+ , size :: {-# UNPACK #-} !Int -- ^ size of the stack list
+ , stacks :: {-# UNPACK #-} !(S.Seq [a]) -- ^ the separate stacks
+ , cache :: {-# UNPACK #-} !(M.Map a Int) -- ^ a cache of windows back to their stacks
+ } deriving Eq
+
+instance Show a => Show (StackSet a) where show = show . toList
+
+-- Ord a constraint on 'a' as we use it as a key.
+--
+-- The cache is used to check on insertion that we don't already have
+-- this window managed on another stack
+--
+-- Currently stacks are of a fixed size. There's no firm reason to
+-- do this (new empty stacks could be created on the fly).
+
+------------------------------------------------------------------------
+
+-- | Create a new empty stacks of size 'n', indexed from 0. The
+-- 0-indexed stack will be current.
+empty :: Int -> StackSet a
+empty n = StackSet { cursor = 0
+ , size = n -- constant
+ , stacks = S.fromList (replicate n [])
+ , cache = M.empty
+ }
+
+-- | True if x is somewhere in the StackSet
+member :: Ord a => a -> StackSet a -> Bool
+member a w = M.member a (cache w)
+
+------------------------------------------------------------------------
+
+-- | fromList. Build a new StackSet from a list of list of elements
+-- If there are duplicates in the list, the last occurence wins.
+fromList :: Ord a => (Int,[[a]]) -> StackSet a
+fromList (_,[])
+ = error "Cannot build a StackSet from an empty list"
+
+fromList (n,xs)
+ | n < 0 || n >= length xs
+ = error $ "Cursor index is out of range: " ++ show (n, length xs)
+
+fromList (o,xs) = view o $
+ foldr (\(i,ys) s ->
+ foldr (\a t -> insert a i t) s ys)
+ (empty (length xs)) (zip [0..] xs)
+
+-- | toList. Flatten a stackset to a list of lists
+toList :: StackSet a -> (Int,[[a]])
+toList x = (cursor x, F.toList (stacks x))
+
+------------------------------------------------------------------------
+
+-- | 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 :: Ord a => a -> StackSet a -> StackSet a
+push k w = insert k (cursor w) w
+
+-- | Pop. Pop the element off the top of the stack and discard it.
+-- A new StackSet is returned. If the current stack is empty, the
+-- original StackSet is returned unchanged.
+pop :: Ord a => StackSet a -> StackSet a
+pop w = case peek w of
+ Nothing -> w
+ Just t -> delete t w
+
+-- | Extract the element on the top of the current stack. If no such
+-- element exists, Nothing is returned.
+peek :: StackSet a -> Maybe a
+peek = listToMaybe . stack
+
+-- | Index. Extract stack at index 'n'. If the index is invalid,
+-- Nothing is returned.
+index :: StackSet a -> Int -> Maybe [a]
+index w n | n < 0 || n >= size w = Nothing
+ | otherwise = Just (stacks w `S.index` n)
+
+-- | Return the current stack
+stack :: StackSet a -> [a]
+stack w = case index w (cursor w) of
+ Just s -> s
+ Nothing -> error $ "current: no 'current' stack in StackSet: " ++ show (cursor w) -- can't happen
+
+-- | rotate. cycle the current window list up or down.
+--
+-- 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 :: Ordering -> StackSet a -> StackSet a
+rotate o = unsafeModify rot -- safe, since 'rot' is guaranteed to only permute the list
+ where
+ rot s = take l . drop offset . cycle $ s
+ where
+ n = fromEnum o - 1
+ l = length s
+ offset = if n < 0 then l + n else n
+
+-- ---------------------------------------------------------------------
+
+-- | view. Set the stack specified by the Int argument as being the
+-- current StackSet. If the index is out of range, the original
+-- StackSet is returned. StackSet are indexed from 0.
+view :: Int -> StackSet a -> StackSet a
+view n w | n >= 0 && n < size w = w { cursor = n }
+ | otherwise = w
+
+-- | shift. move the client on top of the current stack to the top of stack 'n'.
+-- The new StackSet is returned.
+--
+-- If the stack to move to is not valid, the original StackSet is returned.
+-- If there are no elements in the current stack, nothing changes.
+--
+shift :: Ord a => Int -> StackSet a -> StackSet a
+shift n w | n < 0 || n >= size w = w
+ | otherwise = case peek w of
+ Nothing -> w -- nothing to do
+ Just k -> insert k n (pop w)
+
+------------------------------------------------------------------------
+
+-- | Insert an element onto the top of stack 'n'.
+-- If the index is wrong, the original StackSet is returned unchanged.
+-- 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.
+--
+insert :: Ord a => a -> Int -> StackSet a -> StackSet a
+insert k n old
+ | n < 0 || n >= size old = old
+ | otherwise = new { cache = M.insert k n (cache new)
+ , stacks = S.adjust (L.nub . (k:)) n (stacks new) }
+ where new = delete k old
+
+-- | 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 :: Ord a => a -> StackSet a -> StackSet a
+delete k w = case M.lookup k (cache w) of
+ Nothing -> w -- we don't know about this window
+ Just i -> w { cache = M.delete k (cache w)
+ , stacks = S.adjust (L.delete k) i (stacks w) }
+
+-- ---------------------------------------------------------------------
+-- Internal functions
+
+-- | modify the current stack with a pure function. This function is
+-- unsafe: the argument function must only permute the current stack,
+-- and must not add or remove elements, or duplicate elements.
+--
+unsafeModify :: ([a] -> [a]) -> StackSet a -> StackSet a
+unsafeModify f w = w { stacks = S.adjust f (cursor w) (stacks w) }
+
+
+#if TESTING
+-- ---------------------------------------------------------------------
+-- QuickCheck properties
+
+-- | Height of stack 'n'
+height :: Int -> StackSet a -> Int
+height i w = length (S.index (stacks w) i)
+
+-- build (non-empty) StackSets with between 1 and 100 stacks
+instance (Ord a, Arbitrary a) => Arbitrary (StackSet a) where
+ arbitrary = do
+ sz <- choose (1,20)
+ n <- choose (0,sz-1)
+ ls <- vector sz
+ return $ fromList (n,ls)
+ coarbitrary = error "no coarbitrary for StackSet"
+
+prop_id x = fromList (toList x) == x
+ where _ = x :: StackSet Int
+
+prop_uniq_pushpop i x = not (member i x) ==>
+ (pop . push i) x == x
+ where _ = x :: StackSet Int
+
+prop_pushpop i x =
+ (pop . push i) x == delete i x
+ where _ = x :: StackSet Int
+
+-- popping an empty stack leaves an empty stack
+prop_popempty x = height (cursor x) x == 0 ==> pop x == x
+ where _ = x :: StackSet Int
+
+prop_popone x =
+ let l = height (cursor x) x
+ in l > 0 ==> height (cursor x) (pop x) == l-1
+ where _ = x :: StackSet Int
+
+-- check the cache of the size works
+prop_size_length x =
+ size x == S.length (stacks x)
+ where _ = x :: StackSet Int
+
+prop_delete_uniq i x = not (member i x) ==>
+ delete i x == x
+ where _ = x :: StackSet Int
+
+prop_delete2 i x =
+ delete i x == delete i (delete i x)
+ where _ = x :: StackSet Int
+
+prop_uniq_insertdelete i n x = not (member i x) ==>
+ delete i (insert i n x) == x
+ where _ = x :: StackSet Int
+
+prop_insertdelete i n x =
+ delete i (insert i n x) == delete i x
+ where _ = x :: StackSet Int
+
+prop_rotaterotate x = rotate LT (rotate GT x) == x
+ where _ = x :: StackSet Int
+
+prop_viewview r x =
+ let n = cursor x
+ sz = size x
+ i = r `mod` sz
+ in
+ view n (view i x) == x
+
+ where _ = x :: StackSet Int
+
+prop_shiftshift r x =
+ let n = cursor x
+ in
+ shift n (shift r x) == x
+ where _ = x :: StackSet Int
+
+------------------------------------------------------------------------
+
+testall :: IO ()
+testall = mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests
+ where
+ n = 100
+
+ tests =
+ [("fromList.toList ", mytest prop_id)
+ ,("pop/push ", mytest prop_uniq_pushpop)
+ ,("pop/push/delete ", mytest prop_pushpop)
+ ,("pop/empty ", mytest prop_popempty)
+ ,("size/length ", mytest prop_size_length)
+ ,("delete/not.member", mytest prop_delete_uniq)
+ ,("delete idempotent", mytest prop_delete2)
+ ,("delete/insert new", mytest prop_uniq_insertdelete)
+ ,("delete/insert ", mytest prop_insertdelete)
+ ,("rotate/rotate ", mytest prop_rotaterotate)
+ ,("pop one ", mytest prop_popone)
+ ,("view/view ", mytest prop_viewview)
+ ]
+
+debug = False
+
+mytest :: Testable a => a -> Int -> IO ()
+mytest a n = mycheck defaultConfig
+ { configMaxTest=n
+ , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a
+
+mycheck :: Testable a => Config -> a -> IO ()
+mycheck config a = do
+ rnd <- newStdGen
+ mytests config (evaluate a) rnd 0 0 []
+
+mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
+mytests config gen rnd0 ntest nfail stamps
+ | ntest == configMaxTest config = do done "OK," ntest stamps
+ | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
+ | otherwise =
+ do putStr (configEvery config ntest (arguments result)) >> hFlush stdout
+ case ok result of
+ Nothing ->
+ mytests config gen rnd1 ntest (nfail+1) stamps
+ Just True ->
+ mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
+ Just False ->
+ putStr ( "Falsifiable after "
+ ++ show ntest
+ ++ " tests:\n"
+ ++ unlines (arguments result)
+ ) >> hFlush stdout
+ where
+ result = generate (configSize config ntest) rnd2 gen
+ (rnd1,rnd2) = split rnd0
+
+done :: String -> Int -> [[String]] -> IO ()
+done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
+ where
+ table = display
+ . map entry
+ . reverse
+ . sort
+ . map pairLength
+ . group
+ . sort
+ . filter (not . null)
+ $ stamps
+
+ display [] = ".\n"
+ display [x] = " (" ++ x ++ ").\n"
+ display xs = ".\n" ++ unlines (map (++ ".") xs)
+
+ pairLength xss@(xs:_) = (length xss, xs)
+ entry (n, xs) = percentage n ntest
+ ++ " "
+ ++ concat (intersperse ", " xs)
+
+ percentage n m = show ((100 * n) `div` m) ++ "%"
+
+------------------------------------------------------------------------
+#endif
diff --git a/W.hs b/W.hs
index 93d8ea6..36fcd86 100644
--- a/W.hs
+++ b/W.hs
@@ -16,22 +16,23 @@
module W where
+import StackSet
+
import Control.Monad.State
import System.IO
+import System.Process (runCommand)
import Graphics.X11.Xlib (Display,Window)
-import qualified Data.Sequence as S
-- | WState, the window manager state.
-- Just the display, width, height and a window list
data WState = WState
{ display :: Display
- , screenWidth :: !Int
- , screenHeight :: !Int
- , workspace :: !WorkSpaces -- ^ workspace list
+ , screenWidth :: {-# UNPACK #-} !Int
+ , screenHeight :: {-# UNPACK #-} !Int
+ , workspace :: {-# UNPACK #-} !WorkSpace -- ^ workspace list
}
-type WorkSpaces = (Int, S.Seq Windows)
-type Windows = [Window]
+type WorkSpace = StackSet Window
-- | The W monad, a StateT transformer over IO encapuslating the window
-- manager state
@@ -51,6 +52,14 @@ io = liftIO
io_ :: IO a -> W ()
io_ f = liftIO f >> return ()
+-- | Run an action forever
+forever :: (Monad m) => m a -> m b
+forever a = a >> forever a
+
+-- | spawn. Launch an external application
+spawn :: String -> W ()
+spawn = io_ . runCommand
+
-- | A 'trace' for the W monad. Logs a string to stderr. The result may
-- be found in your .xsession-errors file
trace :: String -> W ()
@@ -58,36 +67,18 @@ trace msg = io $ do
hPutStrLn stderr msg
hFlush stderr
--- ---------------------------------------------------------------------
--- Getting at the window manager state
-
-- | Modify the workspace list
-modifyWorkspaces :: (WorkSpaces -> WorkSpaces) -> W ()
-modifyWorkspaces f = modify $ \s -> s { workspace = f (workspace s) }
-
--- | Modify the current window list
-modifyWindows :: (Windows -> Windows) -> W ()
-modifyWindows f = modifyWorkspaces $ \(i,wk) -> (i, S.adjust f i wk)
-
--- ---------------------------------------------------------------------
--- Generic utilities
-
--- | Run an action forever
-forever :: (Monad m) => m a -> m b
-forever a = a >> forever a
-
--- | Rotate a list by 'n' elements.
---
--- rotate 0 --> [5,6,7,8,1,2,3,4]
--- rotate 1 --> [6,7,8,1,2,3,4,5]
--- rotate (-1) --> [4,5,6,7,8,1,2,3]
---
--- where xs = [5..8] ++ [1..4]
---
-rotate :: Int -> [a] -> [a]
-rotate n xs = take l . drop offset . cycle $ xs
- where
- l = length xs
- offset | n < 0 = l + n
- | otherwise = n
+modifyWorkspace :: (WorkSpace -> WorkSpace) -> W ()
+modifyWorkspace f = do
+ modify $ \s -> s { workspace = f (workspace s) }
+ ws <- gets workspace
+ trace (show $ ws)
+
+-- | Like 'when' but for (WorkSpace -> Maybe a)
+whenJust :: (WorkSpace -> Maybe a) -> (a -> W ()) -> W ()
+whenJust mg f = do
+ ws <- gets workspace
+ case mg ws of
+ Nothing -> return ()
+ Just w -> f w