New module: X.L.Groups

Ignore-this: 167e191d520a36b94cf24121ead67dae

The mother of all layout combinators.

darcs-hash:20100117005301-5ccef-d1c1a05b6b9150c919373238df5659f23566249d.gz

2 files changed, 497 insertions, 0 deletions

diff --git a/XMonad/Layout/Groups.hs b/XMonad/Layout/Groups.hs
new file mode 100644
index 0000000..2e9556d
--- /dev/null
+++ b/XMonad/Layout/Groups.hs
@@ -0,0 +1,496 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-}
+{-# LANGUAGE StandaloneDeriving, FlexibleContexts, DeriveDataTypeable
+  , UndecidableInstances, FlexibleInstances, MultiParamTypeClasses
+  , PatternGuards, Rank2Types, TypeSynonymInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.Groups
+-- Copyright   :  Quentin Moser <moserq@gmail.com>
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Quentin Moser <quentin.moser@unifr.ch>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Two-level layout with windows split in individual layout groups,
+-- themselves managed by a user-provided layout.
+--
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.Groups ( -- * Usage
+                              -- $usage
+                              -- * Creation
+                              group
+                              -- * Messages
+                            , GroupsMessage(..)
+                            , ModifySpec
+                              -- ** Useful 'ModifySpec's
+                            , swapUp
+                            , swapDown
+                            , swapMaster
+                            , focusUp
+                            , focusDown
+                            , focusMaster
+                            , swapGroupUp
+                            , swapGroupDown
+                            , swapGroupMaster
+                            , focusGroupUp
+                            , focusGroupDown
+                            , focusGroupMaster
+                            , moveToGroupUp
+                            , moveToGroupDown
+                            , moveToNewGroupUp
+                            , moveToNewGroupDown
+                            , splitGroup
+                              -- * Types
+                            , Groups
+                            , Group(..)
+                            , onZipper
+                            , onLayout
+                            , WithID
+                            , sameID
+                            ) where
+
+import XMonad
+import qualified XMonad.StackSet as W
+
+import XMonad.Util.Stack
+
+import Data.Maybe (isJust, isNothing, fromMaybe, catMaybes)
+import Data.List ((\\))
+import Control.Arrow ((>>>))
+import Control.Applicative ((<$>))
+import Control.Monad (forM)
+
+-- $usage
+-- This module provides a layout combinator that allows you
+-- to manage your windows in independent groups. You can provide
+-- both the layout with which to arrange the windows inside each
+-- group, and the layout with which the groups themselves will
+-- be arranged on the screen.
+--
+-- The "XMonad.Layout.Groups.Examples" module contains examples of
+-- layouts that can be defined with this combinator, and useful
+-- operations on them. It is also the recommended starting point 
+-- if you are a beginner and looking for something you can use easily.
+--
+-- One thing to note is that 'Groups'-based layout have their own
+-- notion of the order of windows, which is completely separate
+-- from XMonad's. For this reason, operations like 'XMonad.StackSet.SwapUp'
+-- will have no visible effect, and those like 'XMonad.StackSet.focusUp'
+-- will focus the windows in an imprevisible order. For a better way of
+-- rearranging windows and moving focus in such a layout, see the
+-- example 'ModifySpec's (to be passed to the 'Modify' message) provided 
+-- by this module.
+--
+-- If you use both 'Groups'-based and other layouts, The "XMonad.Layout.Groups.Examples"
+-- module provides actions that can work correctly with both, defined using
+-- functions from "XMonad.Actions.MessageFeedback".
+
+-- | Create a 'Groups' layout.
+--
+-- Note that the second parameter (the layout for arranging the
+-- groups) is not used on 'Windows', but on 'Group's. For this
+-- reason, you can only use layouts that don't specifically
+-- need to manage 'Window's. This is obvious, when you think
+-- about it.
+group :: l Window -> l2 (Group l Window) -> Groups l l2 Window
+group l l2 = Groups l l2 emptyZ (U 0 0)
+
+
+-- * Stuff with unique keys
+
+data Uniq = U Integer Integer
+  deriving (Eq, Show, Read)
+
+-- | From a seed, generate an infinite list of keys and a new 
+-- seed. All keys generated with this method will be different
+-- provided you don't use 'gen' again with a key from the list.
+-- (if you need to do that, see 'split' instead)
+gen :: Uniq -> (Uniq, [Uniq])
+gen (U i1 i2) = (U (i1+1) i2, zipWith U (repeat i1) [i2..])
+
+-- | Split an infinite list into two. I ended up not
+-- needing this, but let's keep it just in case.
+split :: [a] -> ([a], [a])
+split as = snd $ foldr step (True, ([], [])) as
+    where step a (True, (as1, as2)) = (False, (a:as1, as2))
+          step a (False, (as1, as2)) = (True, (as1, a:as2))
+
+-- | Add a unique identity to a layout so we can
+-- follow it around.
+data WithID l a = ID { getID :: Uniq 
+                     , unID :: (l a)}
+  deriving (Show, Read)
+
+-- | Compare the ids of two 'WithID' values
+sameID :: WithID l a -> WithID l a -> Bool
+sameID (ID id1 _) (ID id2 _) = id1 == id2
+
+instance Eq (WithID l a) where
+    ID id1 _ == ID id2 _ = id1 == id2
+
+instance LayoutClass l a => LayoutClass (WithID l) a where
+    runLayout ws@W.Workspace { W.layout = ID id l } r 
+        = do (placements, ml') <- flip runLayout r 
+                                     ws { W.layout = l}
+             return (placements, ID id <$> ml')
+    handleMessage (ID id l) sm = do ml' <- handleMessage l sm
+                                    return $ ID id <$> ml'
+    description (ID _ l) = description l
+
+          
+
+-- * The 'Groups' layout
+
+
+-- ** Datatypes
+
+-- | A group of windows and its layout algorithm.
+data Group l a = G { gLayout :: WithID l a
+                   , gZipper :: Zipper a }
+  deriving (Show, Read, Eq)
+
+onLayout :: (WithID l a -> WithID l a) -> Group l a -> Group l a
+onLayout f g = g { gLayout = f $ gLayout g }
+
+onZipper :: (Zipper a -> Zipper a) -> Group l a -> Group l a
+onZipper f g = g { gZipper = f $ gZipper g }
+
+-- | The type of our layouts.
+data Groups l l2 a = Groups { -- | The starting layout for new groups
+                              baseLayout :: l a
+                              -- | The layout for placing each group on the screen
+                            , partitioner :: l2 (Group l a)
+                              -- | The window groups
+                            , groups :: Zipper (Group l a)
+                              -- | A seed for generating unique ids
+                            , seed :: Uniq
+                            }
+
+deriving instance (Show a, Show (l a), Show (l2 (Group l a))) => Show (Groups l l2 a)
+deriving instance (Read a, Read (l a), Read (l2 (Group l a))) => Read (Groups l l2 a)
+
+-- | Messages accepted by 'Groups'-based layouts.
+-- All other messages are forwarded to the layout of the currently
+-- focused subgroup (as if they had been wrapped in 'ToFocused').
+data GroupsMessage = ToEnclosing SomeMessage -- ^ Send a message to the enclosing layout
+                                             -- (the one that places the groups themselves)
+                   | ToGroup Int SomeMessage -- ^ Send a message to the layout for nth group
+                                             -- (starting at 0)
+                   | ToFocused SomeMessage -- ^ Send a message to the layout for the focused
+                                           -- group
+                   | ToAll SomeMessage -- ^ Send a message to all the sub-layouts
+                   | Refocus -- ^ Refocus the window which should be focused according
+                             -- to the layout.
+                   | Modify ModifySpec -- ^ Modify the ordering\/grouping\/focusing
+                                       -- of windows according to a 'ModifySpec'
+                     deriving Typeable
+
+instance Show GroupsMessage where
+    show (ToEnclosing _) = "ToEnclosing {...}"
+    show (ToGroup i _) = "ToGroup "++show i++" {...}"
+    show (ToFocused _) = "ToFocused {...}"
+    show (ToAll _) = "ToAll {...}"
+    show Refocus = "Refocus"
+    show (Modify _) = "Modify {...}"
+
+instance Message GroupsMessage
+
+modifyGroups :: (Zipper (Group l a) -> Zipper (Group l a))
+             -> Groups l l2 a -> Groups l l2 a
+modifyGroups f g = g { groups = f $ groups g }
+
+
+-- ** Readaptation
+
+-- | Adapt our groups to a new stack.
+-- This algorithm handles window additions and deletions correctly,
+-- ignores changes in window ordering, and tries to react to any 
+-- other stack changes as gracefully as possible.
+readapt :: Eq a => Zipper a -> Groups l l2 a -> Groups l l2 a
+readapt Nothing g = g { groups = Nothing }
+readapt (Just s) g = let f = W.focus s
+                         (seed', id:_) = gen $ seed g
+                         g' = g { seed = seed' }
+                     in flip modifyGroups g' $ mapZ_ (onZipper $ removeDeleted s)
+                                             >>> filterZ_ (isJust . gZipper)
+                                             >>> findNewWindows (W.integrate s)
+                                             >>> addWindows (ID id $ baseLayout g)
+                                             >>> focusGroup f
+                                             >>> onFocusedZ (onZipper $ focusWindow f)
+
+-- | Remove the windows from a group which are no longer present in
+-- the stack.
+removeDeleted :: Eq a => W.Stack a -> Zipper a -> Zipper a
+removeDeleted s = filterZ_ (flip elemZ $ Just s)
+
+-- | Identify the windows not already in a group.
+findNewWindows :: Eq a => [a] -> Zipper (Group l a) 
+               -> (Zipper (Group l a), [a])
+findNewWindows as gs = (gs, foldrZ_ removePresent as gs)
+    where removePresent g as' = filter (not . flip elemZ (gZipper g)) as'
+
+-- | Add windows to the focused group. If you need to create one,
+-- use the given layout and an id from the given list.
+addWindows :: WithID l a -> (Zipper (Group l a), [a]) -> Zipper (Group l a)
+addWindows l (Nothing, as) = singletonZ $ G l (W.differentiate as)
+addWindows _ (z, as) = onFocusedZ (onZipper add) z
+    where add z = foldl (flip insertUpZ) z as
+
+-- | Focus the group containing the given window
+focusGroup :: Eq a => a -> Zipper (Group l a) -> Zipper (Group l a)
+focusGroup a = fromTags . map (tagBy $ elemZ a . gZipper) . W.integrate'
+
+-- | Focus the given window
+focusWindow :: Eq a => a -> Zipper a -> Zipper a
+focusWindow a = fromTags . map (tagBy (==a)) . W.integrate'
+
+
+-- * Interface
+
+-- ** Layout instance
+
+instance (LayoutClass l Window, LayoutClass l2 (Group l Window))
+    => LayoutClass (Groups l l2) Window where
+
+        description (Groups b p gs _) = s1++" by "++s2
+            where s1 = fromMaybe (description b) $ fmap (description . gLayout) $ getFocusZ gs
+                  s2 = description p
+
+        runLayout ws@(W.Workspace _ _l z) r = let l = readapt z _l in
+            do (areas, mpart') <- runLayout ws { W.layout = partitioner l
+                                               , W.stack = groups l } r
+
+               results <- forM areas $ \(g, r') -> runLayout ws { W.layout = gLayout g
+                                                                , W.stack = gZipper g } r'
+
+               let hidden = map gLayout (W.integrate' $ groups l) \\ map (gLayout . fst) areas
+               hidden' <- mapM (flip handleMessage $ SomeMessage Hide) hidden
+
+               let placements = concatMap fst results
+                   newL = justMakeNew l mpart' (map snd results ++ hidden')
+                                        
+               return $ (placements, newL)
+
+        handleMessage l@(Groups _ p _ _) sm | Just (ToEnclosing sm') <- fromMessage sm 
+            = do mp' <- handleMessage p sm'
+                 return $ maybeMakeNew l mp' []
+
+        handleMessage l@(Groups _ p gs _) sm | Just (ToAll sm') <- fromMessage sm
+            = do mp' <- handleMessage p sm'
+                 mg's <- mapZM_ (handle sm') gs
+                 return $ maybeMakeNew l mp' $ W.integrate' mg's
+            where handle sm (G l _) = handleMessage l sm
+
+        handleMessage l sm | Just a <- fromMessage sm
+            = let _rightType = a == Hide -- Is there a better-looking way
+                                         -- of doing this?
+              in handleMessage l $ SomeMessage $ ToAll sm
+
+        handleMessage l@(Groups _ _ z@(Just _) _) sm = case fromMessage sm of
+              Just (ToFocused sm') -> do mg's <- W.integrate' <$> handleOnFocused sm' z
+                                         return $ maybeMakeNew l Nothing mg's
+              Just (ToGroup i sm') -> do mg's <- handleOnIndex i sm' z
+                                         return $ maybeMakeNew l Nothing mg's
+              Just (Modify spec) -> case applySpec spec l of
+                                      Just l' -> refocus l' >> return (Just l')
+                                      Nothing -> return $ Just l
+              Just Refocus -> refocus l >> return (Just l)
+              Just _ -> return Nothing
+              Nothing -> handleMessage l $ SomeMessage (ToFocused sm)
+            where handleOnFocused sm z = mapZM step z
+                      where step True (G l _) = handleMessage l sm
+                            step False _ = return Nothing
+                  handleOnIndex i sm z = mapM step $ zip [0..] $ W.integrate' z
+                      where step (j, (G l _)) | i == j = handleMessage l sm
+                            step _ = return Nothing
+
+        handleMessage _ _ = return Nothing
+
+
+justMakeNew :: Groups l l2 a -> Maybe (l2 (Group l a)) -> [Maybe (WithID l a)] 
+            -> Maybe (Groups l l2 a)
+justMakeNew g mpart' ml's = Just g { partitioner = fromMaybe (partitioner g) mpart'
+                                   , groups = combine (groups g) ml's }
+    where combine z ml's = let table = map (\(ID id a) -> (id, a)) $ catMaybes ml's
+                           in flip mapZ_ z $ \(G (ID id l) ws) -> case lookup id table of
+                                        Nothing -> G (ID id l) ws
+                                        Just l' -> G (ID id l') ws
+
+
+maybeMakeNew :: Groups l l2 a -> Maybe (l2 (Group l a)) -> [Maybe (WithID l a)]
+             -> Maybe (Groups l l2 a)
+maybeMakeNew _ Nothing [] = Nothing
+maybeMakeNew _ Nothing ml's | all isNothing ml's = Nothing
+maybeMakeNew g mpart' ml's = justMakeNew g mpart' ml's
+
+refocus :: Groups l l2 Window -> X ()
+refocus g = case getFocusZ (groups g) >>= (getFocusZ . gZipper)
+            of Just w -> focus w
+               Nothing -> return ()
+
+-- ** ModifySpec type
+
+-- | Type of functions describing modifications to a 'Groups' layout. They 
+-- are transformations on 'Zipper's of groups.
+--
+-- Things you shouldn't do:
+--
+-- * Forge new windows (they will be ignored)
+--
+-- * Duplicate windows (whatever happens is your problem)
+--
+-- * Remove windows (they will be added again)
+--
+-- Duplicating a layout might cause problems with layouts that
+-- keep state in IORefs or such, but otherwise it's okay.
+type ModifySpec = forall l. WithID l Window
+                -> Zipper (Group l Window) 
+                -> Zipper (Group l Window)
+
+-- | Apply a ModifySpec.
+applySpec :: ModifySpec -> Groups l l2 Window -> Maybe (Groups l l2 Window)
+applySpec f g = let (seed', id:ids) = gen $ seed g
+                    gs' = f (ID id $ baseLayout g) (groups g)
+                    gs'' = fromTags $ snd $ foldr reID ((ids, []), []) $ toTags gs'
+                in case groups g == gs' of
+                     True -> Nothing
+                     False -> Just g { groups = gs'', seed = seed' }
+
+    where reID eg ((id:ids, seen), egs)
+              = let myID = getID $ gLayout $ fromE eg
+                in case elem myID seen of
+                     False -> ((id:ids, myID:seen), eg:egs)
+                     True -> ((ids, seen), mapE_ (setID id) eg:egs)
+              where setID id (G (ID _ l) z) = G (ID id l) z
+          reID _ (([], _), _) = undefined -- The list of ids is infinite
+
+
+
+
+
+-- ** Misc. ModifySpecs
+
+-- | helper
+onFocused :: (Zipper Window -> Zipper Window) -> ModifySpec
+onFocused f _ gs = onFocusedZ (onZipper f) gs
+
+-- | Swap the focused window with the previous one.
+swapUp :: ModifySpec
+swapUp = onFocused swapUpZ
+
+-- | Swap the focused window with the next one.
+swapDown :: ModifySpec
+swapDown = onFocused swapDownZ
+
+-- | Swap the focused window with the (group's) master
+-- window.
+swapMaster :: ModifySpec
+swapMaster = onFocused swapMasterZ
+
+-- | Swap the focused group with the previous one.
+swapGroupUp :: ModifySpec
+swapGroupUp _ = swapUpZ
+
+-- | Swap the focused group with the next one.
+swapGroupDown :: ModifySpec
+swapGroupDown _ = swapDownZ
+
+-- | Swap the focused group with the master group.
+swapGroupMaster :: ModifySpec
+swapGroupMaster _ = swapMasterZ
+
+-- | Move focus to the previous window in the group.
+focusUp :: ModifySpec
+focusUp = onFocused focusUpZ
+
+-- | Move focus to the next window in the group.
+focusDown :: ModifySpec
+focusDown = onFocused focusDownZ
+
+-- | Move focus to the group's master window.
+focusMaster :: ModifySpec
+focusMaster = onFocused focusMasterZ
+
+-- | Move focus to the previous group.
+focusGroupUp :: ModifySpec
+focusGroupUp _ = focusUpZ
+
+-- | Move focus to the next group.
+focusGroupDown :: ModifySpec
+focusGroupDown _ = focusDownZ
+
+-- | Move focus to the master group.
+focusGroupMaster :: ModifySpec
+focusGroupMaster _ = focusMasterZ
+
+-- | helper
+_removeFocused :: W.Stack a -> (a, Zipper a)
+_removeFocused (W.Stack f (u:up) down) = (f, Just $ W.Stack u up down)
+_removeFocused (W.Stack f [] (d:down)) = (f, Just $ W.Stack d [] down)
+_removeFocused (W.Stack f [] []) = (f, Nothing)
+
+-- helper
+_moveToNewGroup :: WithID l Window -> W.Stack (Group l Window)
+                -> (Group l Window -> Zipper (Group l Window) 
+                                   -> Zipper (Group l Window))
+                -> Zipper (Group l Window)
+_moveToNewGroup l0 s insertX | G l (Just f) <- W.focus s
+    = let (w, f') = _removeFocused f
+          s' = s { W.focus = G l f' }
+      in insertX (G l0 $ singletonZ w) $ Just s'
+_moveToNewGroup _ s _ = Just s
+ 
+-- | Move the focused window to a new group before the current one.
+moveToNewGroupUp :: ModifySpec
+moveToNewGroupUp _ Nothing = Nothing
+moveToNewGroupUp l0 (Just s) = _moveToNewGroup l0 s insertUpZ
+
+-- | Move the focused window to a new group after the current one.
+moveToNewGroupDown :: ModifySpec
+moveToNewGroupDown _ Nothing = Nothing
+moveToNewGroupDown l0 (Just s) = _moveToNewGroup l0 s insertDownZ
+
+
+-- | Move the focused window to the previous group.
+-- If 'True', when in the first group, wrap around to the last one.
+-- If 'False', create a new group before it.
+moveToGroupUp :: Bool -> ModifySpec
+moveToGroupUp _ _ Nothing = Nothing
+moveToGroupUp False l0 (Just s) = if null (W.up s) then moveToNewGroupUp l0 (Just s)
+                                                   else moveToGroupUp True l0 (Just s)
+moveToGroupUp True _ (Just s@(W.Stack _ [] [])) = Just s
+moveToGroupUp True _ (Just s@(W.Stack (G l (Just f)) _ _))
+    = let (w, f') = _removeFocused f
+      in onFocusedZ (onZipper $ insertUpZ w) $ focusUpZ $ Just s { W.focus = G l f' }
+moveToGroupUp True _ gs = gs
+
+-- | Move the focused window to the next group.
+-- If 'True', when in the last group, wrap around to the first one.
+-- If 'False', create a new group after it.
+moveToGroupDown :: Bool -> ModifySpec
+moveToGroupDown _ _ Nothing = Nothing
+moveToGroupDown False l0 (Just s) = if null (W.down s) then moveToNewGroupDown l0 (Just s)
+                                                       else moveToGroupDown True l0 (Just s)
+moveToGroupDown True _ (Just s@(W.Stack _ [] [])) = Just s
+moveToGroupDown True _ (Just s@(W.Stack (G l (Just f)) _ _))
+    = let (w, f') = _removeFocused f
+      in onFocusedZ (onZipper $ insertUpZ w) $ focusDownZ $ Just s { W.focus = G l f' }
+moveToGroupDown True _ gs = gs
+
+-- | Split the focused group into two at the position of the focused window (below it,
+-- unless it's the last window - in that case, above it).
+splitGroup :: ModifySpec
+splitGroup _ Nothing = Nothing
+splitGroup _ z@(Just s) | G l (Just ws) <- W.focus s
+    = case ws of
+        W.Stack _ [] [] -> z
+        W.Stack f (u:up) [] -> let g1 = G l $ Just $ W.Stack f [] []
+                                   g2 = G l $ Just $ W.Stack u up []
+                               in insertDownZ g1 $ onFocusedZ (const g2) z
+        W.Stack f up (d:down) -> let g1 = G l $ Just $ W.Stack f up []
+                                     g2 = G l $ Just $ W.Stack d [] down
+                                 in insertUpZ g1 $ onFocusedZ (const g2) z
+splitGroup _ _ = Nothing
\ No newline at end of file
diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal
index cf849d3..01dfbd9 100644
--- a/xmonad-contrib.cabal
+++ b/xmonad-contrib.cabal
@@ -176,6 +176,7 @@ library
                         XMonad.Layout.Gaps
                         XMonad.Layout.Grid
                         XMonad.Layout.GridVariants
+                        XMonad.Layout.Groups
                         XMonad.Layout.HintedGrid
                         XMonad.Layout.HintedTile
                         XMonad.Layout.IM