{-# 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
