From 5f4909d119073155436b8bdfcc5c49bf34c4a3d3 Mon Sep 17 00:00:00 2001 From: "quentin.moser" Date: Sun, 17 Jan 2010 01:53:01 +0100 Subject: New module: X.L.Groups Ignore-this: 167e191d520a36b94cf24121ead67dae The mother of all layout combinators. darcs-hash:20100117005301-5ccef-d1c1a05b6b9150c919373238df5659f23566249d.gz --- XMonad/Layout/Groups.hs | 496 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 496 insertions(+) create mode 100644 XMonad/Layout/Groups.hs (limited to 'XMonad') 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 +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Quentin Moser +-- 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 -- cgit v1.2.3