Simplify A.WorkspaceCursors use of layout for state, add documentation

Ignore-this: 5a4cb6f165edd266a55e42ccedc8c0a7

darcs-hash:20090705050629-1499c-d2fe308976f6606a3c52c0d44d0efa96faaee1da.gz

1 files changed, 121 insertions, 72 deletions

diff --git a/XMonad/Actions/WorkspaceCursors.hs b/XMonad/Actions/WorkspaceCursors.hs
index 9aedc5f..631c77d 100644
--- a/XMonad/Actions/WorkspaceCursors.hs
+++ b/XMonad/Actions/WorkspaceCursors.hs
@@ -9,77 +9,108 @@
 -- Stability    : unstable
 -- Portability  : portable
 --
--- Generalizes plane to arbitrary dimensions.
+-- Like Plane for an arbitrary number of dimensions.
 -----------------------------------------------------------------------------
 
 module XMonad.Actions.WorkspaceCursors
     (
     -- * Usage
     -- $usage
-    toList
-    ,focusDepth
 
+     focusDepth
+    ,makeCursors
+    ,toList
     ,workspaceCursors
 
+    ,WorkspaceCursors
+    ,getFocus
+
+    -- * Modifying the focus
     ,modifyLayer
-    ,makeCursors
-    ,sampleCursors
+    ,modifyLayer'
+    ,shiftModifyLayer,shiftLayer
 
     -- * Functions to pass to 'modifyLayer'
     ,focusNth'
     ,noWrapUp,noWrapDown
+
+    -- * Todo
+    -- $todo
     ) where
 
+import qualified XMonad.StackSet as W
 
 import XMonad.Actions.FocusNth(focusNth')
-import XMonad.Layout.LayoutModifier(LayoutModifier(handleMess,
-                                                   redoLayout))
+import XMonad.Layout.LayoutModifier(ModifiedLayout(..),
+                                    LayoutModifier(handleMess, redoLayout))
 import XMonad(Typeable, Message, WorkspaceId, X, XState(windowset),
               fromMessage, sendMessage, windows, gets)
+import Control.Monad((<=<), guard, liftM, liftM2, when)
 import Control.Applicative((<$>))
-import Control.Monad(Monad(return, (>>=), (>>)), Functor(..),
-                     guard, unless)
 import Data.Foldable(Foldable(foldMap), toList)
-import Data.Maybe(Maybe(Nothing), fromJust, listToMaybe)
-import Data.Monoid(Monoid(mconcat, mappend))
+import Data.Maybe(fromJust, listToMaybe)
+import Data.Monoid(Monoid(mappend, mconcat))
 import Data.Traversable(sequenceA)
 
-import qualified XMonad.StackSet as W
-
 -- $usage
 --
 -- Here is an example config:
 --
 -- > import XMonad
 -- > import XMonad.Actions.WorkspaceCursors
--- > import XMonad.Config.Desktops
+-- > import XMonad.Hooks.DynamicLog
 -- > import XMonad.Util.EZConfig
+-- > import qualified XMonad.StackSet as W
 -- >
 -- > main = do
--- >    xmonad $ additionalKeysP desktopConfig
--- >        { workspaces = toList sampleCurs
--- >        , layoutHook = workspaceCursors myCursors $ layoutHook desktopConfig
--- >        }
--- >        [("M-"++shift++[k], modifyLayer f depth)
--- >          | (f,shift) <- zip [W.focusUp',W.focusDown'] [[],"S-"]
--- >          , (depth,k) <- zip [1..focusDepth myCursors] "asdf"]
+-- >     x <- xmobar conf
+-- >     xmonad x
+-- >
+-- > conf = additionalKeysP defaultConfig
+-- >        { layoutHook = workspaceCursors myCursors $ layoutHook defaultConfig
+-- >        , workspaces = toList myCursors } $
+-- >        [("M-"++shift++control++[k], f direction depth)
+-- >          | (f,shift) <- zip [modifyLayer,shiftModifyLayer] ["","S-"]
+-- >          , (direction,control) <- zip [W.focusUp',W.focusDown'] ["C-",""]
+-- >          , (depth,k) <- zip (reverse [1..focusDepth myCursors]) "asdf"]
+-- >        ++ moreKeybindings
+-- >
+-- > moreKeybindings = []
 -- >
--- > myCursors = makeCursors $ map (map show) [[1..3],[1..3],[1..3],[1..9]]
+-- > myCursors = makeCursors $ map (map (\x -> [x])) [ "1234", "abc", "xyz"]
+-- > -- myCursors = makeCursors [["wsA","wsB","wsC"],["-alpha-","-beta-","-gamma-"],["x","y"]]
 
--------------------------------------------------------------------------------
 
-sampleCursors ::  Cursors String
-sampleCursors = makeCursors $ map (map show) [[1..3::Int],[1..3],[1..9]]
+-- $todo
+--
+-- * Find and document how to raise the allowable length of arguments:
+--   restoring xmonad's state results in: @xmonad: executeFile: resource
+--   exhausted (Argument list too long)@ when you specify more than about 50
+--   workspaces. Or change it such that workspaces are created when you try to
+--   view it.
+--
+-- * Function for pretty printing for DynamicLog that groups workspaces by
+-- common prefixes
+--
+-- * Examples of adding workspaces to the cursors, having them appear multiple
+--   times for being able to show jumping to some n'th multiple workspace
 
+-- | makeCursors requires a nonempty string, and each sublist must be nonempty
 makeCursors ::  [[String]] -> Cursors String
-makeCursors (x:xs) = Prelude.foldr addDim (end x) xs
-makeCursors [] = error "Cursors cannot be empty"
-
-addDim ::  (Monoid a) => [a] -> Cursors a -> Cursors a
-addDim prefixes prev = Cons . fromJust . W.differentiate
-            $ map (\p -> fmap (p `mappend`) prev) prefixes
-
-end :: [String] -> Cursors String
+makeCursors [] = error "Workspace Cursors cannot be empty"
+makeCursors a = concat . reverse <$> foldl addDim x xs
+    where x = end $ map return $ head a
+          xs = map (map return) $ tail a
+          -- this could probably be simplified, but this true:
+          -- toList . makeCursors == map (concat . reverse) . sequence . reverse . map (map (:[]))
+          -- the strange order is used because it makes the regular M-1..9
+          -- bindings change the prefixes first
+
+addDim ::  (Monoid a) => Cursors a -> [a] -> Cursors a
+addDim prev prefixes = Cons . fromJust . W.differentiate
+            $ map ((<$> prev) . mappend) prefixes
+
+end :: [a] -> Cursors a
 end = Cons . fromJust . W.differentiate . map End
 
 data Cursors a
@@ -88,14 +119,17 @@ data Cursors a
 
 instance Foldable Cursors where
     foldMap f (End x) = f x
-    foldMap f (Cons st) = mconcat $ map (foldMap f) $ W.integrate st
+    foldMap f (Cons (W.Stack x y z)) = foldMap f x `mappend` mconcat (map (foldMap f) $ reverse y ++ z)
 
 instance Functor Cursors where
     fmap f (End a) = End $ f a
     fmap f (Cons (W.Stack x y z)) = Cons $ W.Stack (fmap f x) (fmap (fmap f) y) (fmap (fmap f) z)
 
 changeFocus ::  (Cursors t -> Bool) -> Cursors t -> [Cursors t]
-changeFocus p (Cons x) = chFocus p x >>= changeFocus p . Cons
+changeFocus p (Cons x) = do
+    choose <- chFocus p x
+    foc    <- changeFocus p $ W.focus choose
+    return . Cons $ choose { W.focus = foc }
 changeFocus p x = guard (p x) >> return x
 
 chFocus :: (a -> Bool) -> W.Stack a -> [W.Stack a]
@@ -105,15 +139,16 @@ getFocus ::  Cursors b -> b
 getFocus (Cons x) = getFocus $ W.focus x
 getFocus (End x) = x
 
+-- This could be made more efficient, if the fact that the suffixes are grouped
 focusTo ::  (Eq t) => t -> Cursors t -> Maybe (Cursors t)
-focusTo x = listToMaybe . changeFocus ((x==) . getFocus)
+focusTo x = listToMaybe . filter ((x==) . getFocus) . changeFocus (const True)
 
--- | non-wrapping version of 'XMonad.StackSet.focusUp''
+-- | non-wrapping version of 'W.focusUp''
 noWrapUp ::  W.Stack t -> W.Stack t
 noWrapUp (W.Stack t (l:ls) rs) = W.Stack l ls (t:rs)
 noWrapUp x@(W.Stack _ []   _ ) = x
 
--- | non-wrapping version of 'XMonad.StackSet.focusDown''
+-- | non-wrapping version of 'W.focusDown''
 noWrapDown ::  W.Stack t -> W.Stack t
 noWrapDown = reverseStack . noWrapUp . reverseStack
     where reverseStack (W.Stack t ls rs) = W.Stack t rs ls
@@ -122,49 +157,63 @@ focusDepth ::  Cursors t -> Int
 focusDepth (Cons x) = 1 + focusDepth (W.focus x)
 focusDepth (End  _) = 0
 
-descend :: (W.Stack (Cursors a) -> W.Stack (Cursors a))-> Int-> Cursors a-> Cursors a
-descend f 1 (Cons x) = Cons $ f x
-descend f n (Cons x) | n > 1 = Cons $ descend f (pred n) `onFocus` x
-descend _ _ x = x
+descend :: Monad m =>(W.Stack (Cursors a) -> m (W.Stack (Cursors a)))-> Int-> Cursors a-> m (Cursors a)
+descend f 1 (Cons x) = Cons `liftM` f x
+descend f n (Cons x) | n > 1 = liftM Cons $ descend f (pred n) `onFocus` x
+descend _ _ x = return x
 
-onFocus ::  (a -> a) -> W.Stack a -> W.Stack a
-onFocus f st = st { W.focus = f $ W.focus st }
+onFocus :: (Monad m) => (a1 -> m a1) -> W.Stack a1 -> m (W.Stack a1)
+onFocus f st = (\x -> st { W.focus = x}) `liftM` f (W.focus st)
 
+-- | @modifyLayer@ is used to change the focus at a given depth
 modifyLayer :: (W.Stack (Cursors String) -> W.Stack (Cursors String)) -> Int -> X ()
-modifyLayer f depth = modifyCursors (return . descend f depth)
+modifyLayer f depth = modifyCursors (descend (return . f) depth)
+
+-- | @shiftModifyLayer@ is the same as 'modifyLayer', but also shifts the
+-- currently focused window to the new workspace
+shiftModifyLayer :: (W.Stack (Cursors String) -> W.Stack (Cursors WorkspaceId))-> Int-> X ()
+shiftModifyLayer f = modifyLayer' $ \st -> do
+    let st' = f st
+    windows $ W.shift $ getFocus (Cons st')
+    return st'
+
+-- | @shiftLayer@ is the same as 'shiftModifyLayer', but the focus remains on
+-- the current workspace.
+shiftLayer :: (W.Stack (Cursors String) -> W.Stack (Cursors WorkspaceId))-> Int-> X ()
+shiftLayer f = modifyLayer' $ \st -> do
+    windows $ W.shift $ getFocus $ Cons $ f st
+    return st
+
+-- | example usages are 'shiftLayer' and 'shiftModifyLayer'
+modifyLayer' :: (W.Stack (Cursors String) -> X (W.Stack (Cursors String))) -> Int -> X ()
+modifyLayer' f depth = modifyCursors (descend f depth)
 
 modifyCursors ::  (Cursors String -> X (Cursors String)) -> X ()
-modifyCursors = sendMessage . ChangeCursors
-
-currentWs :: X WorkspaceId
-currentWs = gets $ W.tag . W.workspace . W.current . windowset
+modifyCursors = sendMessage . ChangeCursors . (liftM2 (>>) updateXMD return <=<)
 
-data WorkspaceCursors a = WorkspaceCursors Bool (Cursors String) deriving (Typeable,Read,Show)
+data WorkspaceCursors a = WorkspaceCursors (Cursors String)
+    deriving (Typeable,Read,Show)
 
--- | WorkspaceCursors is implemented as a layout modifier, since that state is
--- serialized, and easily modified (with sendMessage)
-workspaceCursors ::  Cursors String -> WorkspaceCursors a
-workspaceCursors = WorkspaceCursors False
+-- | The state is stored in the 'WorkspaceCursors' layout modifier. Put this as
+-- your outermost modifier, unless you want different cursors at different
+-- times (using "XMonad.Layout.MultiToggle")
+workspaceCursors :: Cursors String -> l a -> ModifiedLayout WorkspaceCursors l a
+workspaceCursors = ModifiedLayout . WorkspaceCursors
 
-data ChangeCursors = ChangeCursors {
-    unWrap :: Cursors String -> X (Cursors String)
-    } deriving (Typeable)
+data ChangeCursors = ChangeCursors { unWrap :: Cursors String -> X (Cursors String) }
+    deriving (Typeable)
 
 instance Message ChangeCursors
 
+updateXMD ::  Cursors WorkspaceId -> X ()
+updateXMD cs = do
+    changed <- gets $ (getFocus cs /=) . W.currentTag . windowset
+    when changed $ windows $ W.greedyView $ getFocus cs
+
 instance LayoutModifier WorkspaceCursors a where
-    redoLayout (WorkspaceCursors False cs) _ _ arrs = do
-        cws <- currentWs
-        return (arrs,do
-            guard (getFocus cs /= cws)
-            fmap (WorkspaceCursors True) $ focusTo cws cs)
-
-    redoLayout (WorkspaceCursors _ cs) _ _ arrs = do
-        cws <- currentWs
-        -- redundant check to avoid switching workspaces
-        unless (getFocus cs == cws) $ windows $ W.greedyView (getFocus cs)
-        return (arrs,Nothing)
-
-    handleMess (WorkspaceCursors prevMod cs) m =
-        let wrap x = WorkspaceCursors (max prevMod (x /= cs)) x
-        in sequenceA $ fmap wrap . ($ cs) . unWrap <$> fromMessage m
+    redoLayout (WorkspaceCursors cs) _ _ arrs = do
+        cws <- gets $ W.currentTag . windowset
+        return (arrs,WorkspaceCursors <$> focusTo cws cs)
+
+    handleMess (WorkspaceCursors cs) m =
+        sequenceA $ fmap WorkspaceCursors . ($ cs) . unWrap <$> fromMessage m