make focus, up and down complete functions.

This is a rerun of my change to make (Stack a) never be empty.  Gives
us more type-safety.

darcs-hash:20070612150555-72aca-5f6e43aa33979c71679a73b44d93f9e2b8f9d2a8

5 files changed, 76 insertions, 74 deletions

diff --git a/Main.hs b/Main.hs
index ca6f5ad..0d0a442 100644
--- a/Main.hs
+++ b/Main.hs
@@ -88,11 +88,11 @@ main = do
             -- TODO, general iterators for these lists.
             sequence_ [ setInitialProperties w >> reveal w
                       | wk <- map W.workspace (W.current winset : W.visible winset)
-                      , w  <- W.integrate (W.stack wk) ]
+                      , w  <- W.integrate' (W.stack wk) ]
 
             sequence_ [ setInitialProperties w >> hide w
                       | wk <- W.hidden winset
-                      , w  <- W.integrate (W.stack wk) ]
+                      , w  <- W.integrate' (W.stack wk) ]
 
             mapM_ manage ws -- find new windows
             logHook
diff --git a/Operations.hs b/Operations.hs
index 994b773..e03c0fd 100644
--- a/Operations.hs
+++ b/Operations.hs
@@ -134,7 +134,7 @@ windows f = do
     -- and must be called on all visible workspaces.
     broadcastMessage UnDoLayout
     XState { windowset = old, layouts = fls, xineScreens = xinesc, statusGaps = gaps } <- get
-    let oldvisible = concatMap (W.integrate . W.stack . W.workspace) $ W.current old : W.visible old
+    let oldvisible = concatMap (W.integrate' . W.stack . W.workspace) $ W.current old : W.visible old
         ws = f old
     modify (\s -> s { windowset = ws })
     d <- asks display
@@ -145,8 +145,7 @@ windows f = do
             this   = W.view n ws
             Just l = fmap fst $ M.lookup n fls
             flt = filter (flip M.member (W.floating ws)) (W.index this)
-            tiled = W.filter (not . flip M.member (W.floating ws)) 
-                        . W.stack . W.workspace . W.current $ this
+            tiled = W.filter (not . flip M.member (W.floating ws)) . W.stack . W.workspace . W.current $ this
             (Rectangle sx sy sw sh) = genericIndex xinesc (W.screen w)
             (gt,gb,gl,gr)           = genericIndex gaps   (W.screen w)
             viewrect = Rectangle (sx + fromIntegral gl)        (sy + fromIntegral gt)
@@ -154,7 +153,7 @@ windows f = do
 
         -- just the tiled windows:
         -- now tile the windows on this workspace, modified by the gap
-        rs <- doLayout l viewrect tiled -- `mplus` doLayout full viewrect tiled
+        rs <- runLayout l viewrect tiled -- `mplus` doLayout full viewrect tiled
         mapM_ (uncurry tileWindow) rs
 
         -- now the floating windows:
@@ -388,9 +387,7 @@ instance Message IncMasterN
 -- simple fullscreen mode, just render all windows fullscreen.
 -- a plea for tuple sections: map . (,sc)
 full :: Layout
-full = Layout { doLayout     = \sc ws -> return $ case ws of
-                                                    W.Empty        -> []
-                                                    (W.Node f _ _) -> [(f, sc)]
+full = Layout { doLayout     = \sc (W.Stack f _ _) -> return [(f, sc)]
               , modifyLayout = const (return Nothing) } -- no changes
 
 --
diff --git a/StackSet.hs b/StackSet.hs
index 581eb0b..6518d66 100644
--- a/StackSet.hs
+++ b/StackSet.hs
@@ -74,10 +74,11 @@
 --
 
 module StackSet (
-        StackSet(..), Workspace(..), Screen(..), Stack(..), RationalRect(..),
-        new, view, lookupWorkspace, peek, index, integrate, differentiate, focusUp, focusDown,
+        StackSet(..), Workspace(..), Screen(..), StackOrNot, Stack(..), RationalRect(..),
+        new, view, lookupWorkspace, peek, index, integrate, integrate', differentiate,
+        focusUp, focusDown,
         focusWindow, member, findIndex, insertUp, delete, shift, filter,
-        swapMaster, swapUp, swapDown, modify, float, sink -- needed by users
+        swapMaster, swapUp, swapDown, modify, modify', float, sink -- needed by users
     ) where
 
 import Prelude hiding (filter)
@@ -141,7 +142,7 @@ data Screen i a sid = Screen { workspace :: !(Workspace i a), screen :: !sid }
 -- |
 -- A workspace is just a tag - its index - and a stack
 --
-data Workspace i a = Workspace  { tag :: !i, stack :: Stack a }
+data Workspace i a = Workspace  { tag :: !i, stack :: StackOrNot a }
     deriving (Show, Read, Eq)
 
 data RationalRect = RationalRect Rational Rational Rational Rational
@@ -165,10 +166,11 @@ data RationalRect = RationalRect Rational Rational Rational Rational
 -- structures, it is the differentiation of a [a], and integrating it
 -- back has a natural implementation used in 'index'.
 --
-data Stack a = Empty
-             | Node { focus  :: !a        -- focused thing in this set
-                    , up     :: [a]       -- clowns to the left
-                    , down   :: [a] }     -- jokers to the right
+type StackOrNot a = Maybe (Stack a)
+
+data Stack a = Stack { focus  :: !a        -- focused thing in this set
+                     , up     :: [a]       -- clowns to the left
+                     , down   :: [a] }     -- jokers to the right
     deriving (Show, Read, Eq)
 
 
@@ -189,7 +191,7 @@ new :: (Integral i, Integral s) => i -> s -> StackSet i a s
 new n m | n > 0 && m > 0 = StackSet n cur visi unseen M.empty
         | otherwise      = abort "non-positive arguments to StackSet.new"
 
-  where (seen,unseen) = L.genericSplitAt m $ Workspace 0 Empty : [ Workspace i Empty | i <- [1 ..n-1]]
+  where (seen,unseen) = L.genericSplitAt m $ Workspace 0 Nothing : [ Workspace i Nothing | i <- [1 ..n-1]]
         (cur:visi)    = [ Screen i s |  (i,s) <- zip seen [0..] ]
                 -- now zip up visibles with their screen id
 
@@ -232,23 +234,28 @@ lookupWorkspace sc w = listToMaybe [ tag i | Screen i s <- current w : visible w
 
 -- |
 -- The 'with' function takes a default value, a function, and a
--- StackSet. If the current stack is Empty, 'with' returns the
+-- StackSet. If the current stack is Nothing, 'with' returns the
 -- default value. Otherwise, it applies the function to the stack,
 -- returning the result. It is like 'maybe' for the focused workspace.
 --
 with :: b -> (Stack a -> b) -> StackSet i a s -> b
-with dflt f s = case stack (workspace (current s)) of Empty -> dflt; v -> f v
-    -- TODO: ndm: a 'catch' proof here that 'f' only gets Node
-    --            constructors, hence all 'f's are safe below?
+with dflt f = maybe dflt f . stack . workspace . current
 
 -- |
--- Apply a function, and a default value for Empty, to modify the current stack.
+-- Apply a function, and a default value for Nothing, to modify the current stack.
 --
-modify :: Stack a -> (Stack a -> Stack a) -> StackSet i a s -> StackSet i a s
+modify :: StackOrNot a -> (Stack a -> StackOrNot a) -> StackSet i a s -> StackSet i a s
 modify d f s = s { current = (current s)
                         { workspace = (workspace (current s)) { stack = with d f s }}}
 
 -- |
+-- Apply a function to modify the current stack if it isn't empty, and we don't
+--  want to empty it.
+--
+modify' :: (Stack a -> Stack a) -> StackSet i a s -> StackSet i a s
+modify' f = modify Nothing (Just . f)
+
+-- |
 -- /O(1)/. Extract the focused element of the current stack. 
 -- Return Just that element, or Nothing for an empty stack.
 --
@@ -259,27 +266,27 @@ peek = with Nothing (return . focus)
 -- /O(n)/. Flatten a Stack into a list.
 --
 integrate :: Stack a -> [a]
-integrate Empty        = []
-integrate (Node x l r) = reverse l ++ x : r
+integrate (Stack x l r) = reverse l ++ x : r
+
+integrate' :: StackOrNot a -> [a]
+integrate' = maybe [] integrate
 
 -- |
 -- /O(n)/. Texture a list.
 --
-differentiate :: [a] -> Stack a
-differentiate [] = Empty
-differentiate (x:xs) = Node x [] xs
+differentiate :: [a] -> StackOrNot a
+differentiate [] = Nothing
+differentiate (x:xs) = Just $ Stack x [] xs
 
 -- |
 -- /O(n)/. 'filter p s' returns the elements of 's' such that 'p' evaluates to
 -- True.  Order is preserved, and focus moves to the next node to the right (if
 -- necessary).
-filter :: (a -> Bool) -> Stack a -> Stack a
-filter _ Empty          = Empty
-filter p (Node f ls rs) = case L.filter p (f:rs) of
-                            (f':rs') -> Node f' (L.filter p ls) rs'
-                            []       -> case reverse $ L.filter p ls of
-                                            []       -> Empty
-                                            (f':rs') -> Node f' [] rs'
+filter :: (a -> Bool) -> Stack a -> StackOrNot a
+filter p (Stack f ls rs) = case L.filter p (f:rs) of
+                            (f':rs') -> Just $ Stack f' (L.filter p ls) rs'
+                            []       -> do f':rs' <- return $ reverse $ L.filter p ls
+                                           Just $ Stack f' [] rs'
 
 -- |
 -- /O(s)/. Extract the stack on the current workspace, as a list.
@@ -305,23 +312,22 @@ index = with [] integrate
 -- the current stack.
 -- 
 focusUp, focusDown, swapUp, swapDown :: StackSet i a s -> StackSet i a s
-focusUp   = modify Empty focusUp'
-focusDown = modify Empty (reverseStack . focusUp' . reverseStack)
+focusUp   = modify' focusUp'
+focusDown = modify' (reverseStack . focusUp' . reverseStack)
 
-swapUp    = modify Empty swapUp'
-swapDown  = modify Empty (reverseStack . swapUp' . reverseStack)
+swapUp    = modify' swapUp'
+swapDown  = modify' (reverseStack . swapUp' . reverseStack)
 
 focusUp', swapUp' :: Stack a -> Stack a
-focusUp' (Node t (l:ls) rs) = Node l ls (t:rs)
-focusUp' (Node t []     rs) = Node x xs [] where (x:xs) = reverse (t:rs)
+focusUp' (Stack t (l:ls) rs) = Stack l ls (t:rs)
+focusUp' (Stack t []     rs) = Stack x xs [] where (x:xs) = reverse (t:rs)
 
-swapUp'  (Node t (l:ls) rs) = Node t ls (l:rs)
-swapUp'  (Node t []     rs) = Node t (reverse rs) []
+swapUp'  (Stack t (l:ls) rs) = Stack t ls (l:rs)
+swapUp'  (Stack t []     rs) = Stack t (reverse rs) []
 
 -- | reverse a stack: up becomes down and down becomes up.
 reverseStack :: Stack a -> Stack a
-reverseStack (Node t ls rs) = Node t rs ls
-reverseStack x              = x
+reverseStack (Stack t ls rs) = Stack t rs ls
 
 --
 -- | /O(1) on current window, O(n) in general/. Focus the window 'w', 
@@ -348,8 +354,8 @@ member a s = maybe False (const True) (findIndex a s)
 findIndex :: Eq a => a -> StackSet i a s -> Maybe i
 findIndex a s = listToMaybe
     [ tag w | w <- workspace (current s) : map workspace (visible s) ++ hidden s, has a (stack w) ]
-    where has _ Empty         = False
-          has x (Node t l r) = x `elem` (t : l ++ r)
+    where has _ Nothing         = False
+          has x (Just (Stack t l r)) = x `elem` (t : l ++ r)
 
 -- ---------------------------------------------------------------------
 -- | Modifying the stackset
@@ -370,10 +376,10 @@ findIndex a s = listToMaybe
 --
 insertUp :: Eq a => a -> StackSet i a s -> StackSet i a s
 insertUp a s = if member a s then s else insert
-  where insert = modify (Node a [] []) (\(Node t l r) -> Node a l (t:r)) s
+  where insert = modify (Just $ Stack a [] []) (\(Stack t l r) -> Just $ Stack a l (t:r)) s
 
 -- insertDown :: a -> StackSet i a s -> StackSet i a s
--- insertDown a = modify (Node a [] []) $ \(Node t l r) -> Node a (t:l) r
+-- insertDown a = modify (Stack a [] []) $ \(Stack t l r) -> Stack a (t:l) r
 -- Old semantics, from Huet.
 -- >    w { down = a : down w }
 
@@ -381,10 +387,10 @@ insertUp a s = if member a s then s else insert
 -- /O(1) on current window, O(n) in general/. Delete window 'w' if it exists.
 -- There are 4 cases to consider:
 --
---   * delete on an Empty workspace leaves it Empty
+--   * delete on an Nothing workspace leaves it Nothing
 --   * otherwise, try to move focus to the down
 --   * otherwise, try to move focus to the up
---   * otherwise, you've got an empty workspace, becomes Empty
+--   * otherwise, you've got an empty workspace, becomes Nothing
 --
 -- Behaviour with respect to the master:
 --
@@ -399,13 +405,13 @@ delete w s | Just w == peek s = remove s -- common case.
     removeWindow o n = foldr ($) s [view o,remove,view n]
 
     -- actual removal logic, and focus/master logic:
-    remove = modify Empty $ \c ->
+    remove = modify Nothing $ \c ->
       if focus c == w
       then case c of
-        Node _ ls     (r:rs) -> Node r ls rs    -- try down first
-        Node _ (l:ls) []     -> Node l ls []    -- else up
-        Node _ []     []     -> Empty
-      else c { up = w `L.delete` up c, down = w `L.delete` down c }
+        Stack _ ls     (r:rs) -> Just $ Stack r ls rs    -- try down first
+        Stack _ (l:ls) []     -> Just $ Stack l ls []    -- else up
+        Stack _ []     []     -> Nothing
+      else Just $ c { up = w `L.delete` up c, down = w `L.delete` down c }
 
 ------------------------------------------------------------------------
 
@@ -425,9 +431,9 @@ sink w s = s { floating = M.delete w (floating s) }
 -- The old master window is swapped in the tiling order with the focused window.
 -- Focus stays with the item moved.
 swapMaster :: StackSet i a s -> StackSet i a s
-swapMaster = modify Empty $ \c -> case c of
-    Node _ [] _  -> c    -- already master.
-    Node t ls rs -> Node t [] (ys ++ x : rs) where (x:ys) = reverse ls
+swapMaster = modify' $ \c -> case c of
+    Stack _ [] _  -> c    -- already master.
+    Stack t ls rs -> Stack t [] (ys ++ x : rs) where (x:ys) = reverse ls
 
 -- natural! keep focus, move current to the top, move top to current.
 -- 
diff --git a/XMonad.hs b/XMonad.hs
index df1dade..b296a38 100644
--- a/XMonad.hs
+++ b/XMonad.hs
@@ -16,7 +16,7 @@
 
 module XMonad (
     X, WindowSet, WorkspaceId(..), ScreenId(..), XState(..), XConf(..), Layout(..),
-    Typeable, Message, SomeMessage(..), fromMessage,
+    Typeable, Message, SomeMessage(..), fromMessage, runLayout,
     runX, io, catchIO, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX,
     atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW
   ) where
@@ -111,6 +111,9 @@ atom_WM_STATE           = getAtom "WM_STATE"
 data Layout = Layout { doLayout     :: Rectangle -> Stack Window -> X [(Window, Rectangle)]
                      , modifyLayout :: SomeMessage -> X (Maybe Layout) }
 
+runLayout :: Layout -> Rectangle -> StackOrNot Window -> X [(Window, Rectangle)]
+runLayout l r = maybe (return []) (doLayout l r)
+
 -- Based on ideas in /An Extensible Dynamically-Typed Hierarchy of Exceptions/,
 -- Simon Marlow, 2006. Use extensible messages to the modifyLayout handler.
 -- 
diff --git a/tests/Properties.hs b/tests/Properties.hs
index 06e32a5..d9381d8 100644
--- a/tests/Properties.hs
+++ b/tests/Properties.hs
@@ -114,7 +114,7 @@ invariant (s :: T) = and
   where
     ws = concat [ focus t : up t ++ down t
                   | w <- workspace (current s) : map workspace (visible s) ++ hidden s
-                , let t = stack w, t /= Empty ] :: [Char]
+                  , t <- maybeToList (stack w)] :: [Char]
     noDuplicates = nub ws == ws
     calculatedSize = length (visible s) + length (hidden s) + 1   -- +1 is for current
     accurateSize = calculatedSize == size s
@@ -148,7 +148,7 @@ prop_focusDown_I (n :: NonNegative Int) (x :: T) =
 prop_focus_I (n :: NonNegative Int) (x :: T) =
     case peek x of
         Nothing -> True
-        Just _  -> let w = focus . stack . workspace . current $ foldr (const focusUp) x [1..n]
+        Just _  -> let w = focus . fromJust . stack . workspace . current $ foldr (const focusUp) x [1..n]
                    in invariant $ focusWindow w x
 
 prop_insertUp_I n (x :: T) = invariant $ insertUp n x
@@ -175,7 +175,7 @@ prop_shift_I (n :: NonNegative Int) (x :: T) =
 -- empty StackSets have no windows in them
 prop_empty (n :: Positive Int)
            (m :: Positive Int) =
-       all (== Empty) [ stack w | w <- workspace (current x)
+       all (== Nothing) [ stack w | w <- workspace (current x)
                                         : map workspace (visible x) ++ hidden x ]
 
     where x = new (fromIntegral n) (fromIntegral m) :: T
@@ -257,12 +257,9 @@ prop_member_peek (x :: T) =
 -- the list returned by index should be the same length as the actual
 -- windows kept in the zipper
 prop_index_length (x :: T) =
-    case it of
-        Empty   -> length (index x) == 0
-        Node {} -> length (index x) == length list
-  where
-    it   = stack . workspace . current $ x
-    list = focus it : up it ++ down it
+    case stack . workspace . current $ x of
+        Nothing   -> length (index x) == 0
+        Just it -> length (index x) == length (focus it : up it ++ down it)
 
 -- ---------------------------------------------------------------------
 -- rotating focus
@@ -293,7 +290,7 @@ prop_focusWindow_works (n :: NonNegative Int) (x :: T) =
         Nothing -> True
         Just _  -> let s = index x
                        i = fromIntegral n `mod` length s
-                   in (focus . stack . workspace . current) (focusWindow (s !! i) x) == (s !! i)
+                   in (focus . fromJust . stack . workspace . current) (focusWindow (s !! i) x) == (s !! i)
 
 -- rotation through the height of a stack gets us back to the start
 prop_focus_all_l (x :: T) = (foldr (const focusUp) x [1..n]) == x
@@ -324,9 +321,8 @@ prop_focusWindow_local (n :: NonNegative Int) (x::T ) =
 prop_findIndex (x :: T) =
     and [ tag w == fromJust (findIndex i x)
         | w <- workspace (current x) : map workspace (visible x)  ++ hidden x
-        , let t = stack w
-        , t /= Empty
-        , i <- focus (stack w) : up (stack w) ++ down (stack w)
+        , t <- maybeToList (stack w)
+        , i <- focus t : up t ++ down t
         ]
 
 -- ---------------------------------------------------------------------