From 44f7d7097d1867d45ff0be4303203814a5ab6ffe Mon Sep 17 00:00:00 2001 From: Adam Vogt Date: Sun, 5 Jul 2009 07:06:29 +0200 Subject: Simplify A.WorkspaceCursors use of layout for state, add documentation Ignore-this: 5a4cb6f165edd266a55e42ccedc8c0a7 darcs-hash:20090705050629-1499c-d2fe308976f6606a3c52c0d44d0efa96faaee1da.gz --- XMonad/Actions/WorkspaceCursors.hs | 193 +++++++++++++++++++++++-------------- 1 file changed, 121 insertions(+), 72 deletions(-) (limited to 'XMonad/Actions/WorkspaceCursors.hs') 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 -- cgit v1.2.3