509 lines
21 KiB
Haskell
509 lines
21 KiB
Haskell
|
{-# LANGUAGE PatternGuards, ParallelListComp, DeriveDataTypeable, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances #-}
|
||
|
|
-----------------------------------------------------------------------------
|
||
|
|
-- |
|
||
|
|
-- Module : XMonad.Layout.SubLayouts
|
||
|
|
-- Copyright : (c) 2009 Adam Vogt
|
||
|
|
-- License : BSD-style (see xmonad/LICENSE)
|
||
|
|
--
|
||
|
|
-- Maintainer : vogt.adam@gmail.com
|
||
|
|
-- Stability : unstable
|
||
|
|
-- Portability : unportable
|
||
|
|
--
|
||
|
|
-- A layout combinator that allows layouts to be nested.
|
||
|
|
--
|
||
|
|
-- had to copy it because
|
||
|
|
-- * uses the wrong Boring Windows library
|
||
|
|
-----------------------------------------------------------------------------
|
||
|
|
|
||
|
|
module SubLayouts (
|
||
|
|
-- * Usage
|
||
|
|
-- $usage
|
||
|
|
subLayout,
|
||
|
|
subTabbed,
|
||
|
|
|
||
|
|
pushGroup, pullGroup,
|
||
|
|
pushWindow, pullWindow,
|
||
|
|
onGroup, toSubl, mergeDir,
|
||
|
|
|
||
|
|
GroupMsg(..),
|
||
|
|
Broadcast(..),
|
||
|
|
|
||
|
|
defaultSublMap,
|
||
|
|
|
||
|
|
Sublayout,
|
||
|
|
|
||
|
|
-- * Screenshots
|
||
|
|
-- $screenshots
|
||
|
|
|
||
|
|
-- * Todo
|
||
|
|
-- $todo
|
||
|
|
)
|
||
|
|
where
|
||
|
|
|
||
|
|
import XMonad.Layout.Circle () -- so haddock can find the link
|
||
|
|
|
||
|
|
import XMonad.Layout.Decoration(Decoration, DefaultShrinker)
|
||
|
|
import XMonad.Layout.LayoutModifier(LayoutModifier(handleMess, modifyLayout,
|
||
|
|
redoLayout),
|
||
|
|
ModifiedLayout(..))
|
||
|
|
import XMonad.Layout.Simplest(Simplest(..))
|
||
|
|
import XMonad.Layout.Tabbed(shrinkText,
|
||
|
|
TabbedDecoration, addTabs)
|
||
|
|
import XMonad.Layout.WindowNavigation(Navigate(Apply))
|
||
|
|
import XMonad.Util.Invisible(Invisible(..))
|
||
|
|
import XMonad.Util.Types(Direction2D(..))
|
||
|
|
import XMonad hiding (def)
|
||
|
|
import Control.Applicative((<$>),(<*))
|
||
|
|
import Control.Arrow(Arrow(second, (&&&)))
|
||
|
|
import Control.Monad(MonadPlus(mplus), foldM, guard, when, join)
|
||
|
|
import Data.Function(on)
|
||
|
|
import Data.List(nubBy, (\\), find)
|
||
|
|
import Data.Maybe(isNothing, fromMaybe, listToMaybe, mapMaybe)
|
||
|
|
import Data.Traversable(sequenceA)
|
||
|
|
|
||
|
|
import qualified BoringWindows as B
|
||
|
|
import qualified XMonad as X
|
||
|
|
import qualified XMonad.StackSet as W
|
||
|
|
import qualified Data.Map as M
|
||
|
|
import Data.Map(Map)
|
||
|
|
|
||
|
|
-- $screenshots
|
||
|
|
--
|
||
|
|
-- <<http://haskell.org/sitewiki/images/thumb/8/8b/Xmonad-SubLayouts-xinerama.png/480px-Xmonad-SubLayouts-xinerama.png>>
|
||
|
|
--
|
||
|
|
-- Larger version: <http://haskell.org/sitewiki/images/8/8b/Xmonad-SubLayouts-xinerama.png>
|
||
|
|
|
||
|
|
-- $todo
|
||
|
|
-- /Issue 288/
|
||
|
|
--
|
||
|
|
-- "XMonad.Layout.ResizableTile" assumes that its environment
|
||
|
|
-- contains only the windows it is running: sublayouts are currently run with
|
||
|
|
-- the stack containing only the windows passed to it in its environment, but
|
||
|
|
-- any changes that the layout makes are not merged back.
|
||
|
|
--
|
||
|
|
-- Should the behavior be made optional?
|
||
|
|
--
|
||
|
|
-- /Features/
|
||
|
|
--
|
||
|
|
-- * suggested managehooks for merging specific windows, or the apropriate
|
||
|
|
-- layout based hack to find out the number of groups currently showed, but
|
||
|
|
-- the size of current window groups is not available (outside of this
|
||
|
|
-- growing module)
|
||
|
|
--
|
||
|
|
-- /SimpleTabbed as a SubLayout/
|
||
|
|
--
|
||
|
|
-- 'subTabbed' works well, but it would be more uniform to avoid the use of
|
||
|
|
-- addTabs, with the sublayout being Simplest (but
|
||
|
|
-- 'XMonad.Layout.Tabbed.simpleTabbed' is this...). The only thing to be
|
||
|
|
-- gained by fixing this issue is the ability to mix and match decoration
|
||
|
|
-- styles. Better compatibility with some other layouts of which I am not
|
||
|
|
-- aware could be another benefit.
|
||
|
|
--
|
||
|
|
-- 'simpleTabbed' (and other decorated layouts) fail horribly when used as
|
||
|
|
-- subLayouts:
|
||
|
|
--
|
||
|
|
-- * decorations stick around: layout is run after being told to Hide
|
||
|
|
--
|
||
|
|
-- * mouse events do not change focus: the group-ungroup does not respect
|
||
|
|
-- the focus changes it wants?
|
||
|
|
--
|
||
|
|
-- * sending ReleaseResources before running it makes xmonad very slow, and
|
||
|
|
-- still leaves borders sticking around
|
||
|
|
--
|
||
|
|
|
||
|
|
-- $usage
|
||
|
|
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
|
||
|
|
--
|
||
|
|
-- > import XMonad.Layout.SubLayouts
|
||
|
|
-- > import XMonad.Layout.WindowNavigation
|
||
|
|
--
|
||
|
|
-- Using "XMonad.Layout.BoringWindows" is optional and it allows you to add a
|
||
|
|
-- keybinding to skip over the non-visible windows.
|
||
|
|
--
|
||
|
|
-- > import XMonad.Layout.BoringWindows
|
||
|
|
--
|
||
|
|
-- Then edit your @layoutHook@ by adding the 'subTabbed' layout modifier:
|
||
|
|
--
|
||
|
|
-- > myLayout = windowNavigation $ subTabbed $ boringWindows $
|
||
|
|
-- > Tall 1 (3/100) (1/2) ||| etc..
|
||
|
|
-- > main = xmonad def { layoutHook = myLayout }
|
||
|
|
--
|
||
|
|
-- "XMonad.Layout.WindowNavigation" is used to specify which windows to merge,
|
||
|
|
-- and it is not integrated into the modifier because it can be configured, and
|
||
|
|
-- works best as the outer modifier.
|
||
|
|
--
|
||
|
|
-- Then to your keybindings add:
|
||
|
|
--
|
||
|
|
-- > , ((modm .|. controlMask, xK_h), sendMessage $ pullGroup L)
|
||
|
|
-- > , ((modm .|. controlMask, xK_l), sendMessage $ pullGroup R)
|
||
|
|
-- > , ((modm .|. controlMask, xK_k), sendMessage $ pullGroup U)
|
||
|
|
-- > , ((modm .|. controlMask, xK_j), sendMessage $ pullGroup D)
|
||
|
|
-- >
|
||
|
|
-- > , ((modm .|. controlMask, xK_m), withFocused (sendMessage . MergeAll))
|
||
|
|
-- > , ((modm .|. controlMask, xK_u), withFocused (sendMessage . UnMerge))
|
||
|
|
-- >
|
||
|
|
-- > , ((modm .|. controlMask, xK_period), onGroup W.focusUp')
|
||
|
|
-- > , ((modm .|. controlMask, xK_comma), onGroup W.focusDown')
|
||
|
|
--
|
||
|
|
-- These additional keybindings require the optional
|
||
|
|
-- "XMonad.Layout.BoringWindows" layoutModifier. The focus will skip over the
|
||
|
|
-- windows that are not focused in each sublayout.
|
||
|
|
--
|
||
|
|
-- > , ((modm, xK_j), focusDown)
|
||
|
|
-- > , ((modm, xK_k), focusUp)
|
||
|
|
--
|
||
|
|
-- A 'submap' can be used to make modifying the sublayouts using 'onGroup' and
|
||
|
|
-- 'toSubl' simpler:
|
||
|
|
--
|
||
|
|
-- > ,((modm, xK_s), submap $ defaultSublMap conf)
|
||
|
|
--
|
||
|
|
-- /NOTE:/ is there some reason that @asks config >>= submap . defaultSublMap@
|
||
|
|
-- could not be used in the keybinding instead? It avoids having to explicitly
|
||
|
|
-- pass the conf.
|
||
|
|
--
|
||
|
|
-- For more detailed instructions, see:
|
||
|
|
--
|
||
|
|
-- "XMonad.Doc.Extending#Editing_the_layout_hook"
|
||
|
|
-- "XMonad.Doc.Extending#Adding_key_bindings"
|
||
|
|
|
||
|
|
-- | The main layout modifier arguments:
|
||
|
|
--
|
||
|
|
-- @subLayout advanceInnerLayouts innerLayout outerLayout@
|
||
|
|
--
|
||
|
|
-- [@advanceInnerLayouts@] When a new group at index @n@ in the outer layout
|
||
|
|
-- is created (even with one element), the @innerLayout@ is used as the
|
||
|
|
-- layout within that group after being advanced with @advanceInnerLayouts !!
|
||
|
|
-- n@ 'NextLayout' messages. If there is no corresponding element in the
|
||
|
|
-- @advanceInnerLayouts@ list, then @innerLayout@ is not given any 'NextLayout'
|
||
|
|
-- messages.
|
||
|
|
--
|
||
|
|
-- [@innerLayout@] The single layout given to be run as a sublayout.
|
||
|
|
--
|
||
|
|
-- [@outerLayout@] The layout that determines the rectangles given to each
|
||
|
|
-- group.
|
||
|
|
--
|
||
|
|
-- Ex. The second group is 'Tall', the third is 'Circle', all others are tabbed
|
||
|
|
-- with:
|
||
|
|
--
|
||
|
|
-- > myLayout = addTabs shrinkText def
|
||
|
|
-- > $ subLayout [0,1,2] (Simplest ||| Tall 1 0.2 0.5 ||| Circle)
|
||
|
|
-- > $ Tall 1 0.2 0.5 ||| Full
|
||
|
|
subLayout :: [Int] -> subl a -> l a -> ModifiedLayout (Sublayout subl) l a
|
||
|
|
subLayout nextLayout sl x = ModifiedLayout (Sublayout (I []) (nextLayout,sl) []) x
|
||
|
|
|
||
|
|
-- | @subTabbed@ is a use of 'subLayout' with 'addTabs' to show decorations.
|
||
|
|
subTabbed :: (Eq a, LayoutModifier (Sublayout Simplest) a, LayoutClass l a) =>
|
||
|
|
l a -> ModifiedLayout (Decoration TabbedDecoration DefaultShrinker)
|
||
|
|
(ModifiedLayout (Sublayout Simplest) l) a
|
||
|
|
subTabbed x = addTabs shrinkText X.def $ subLayout [] Simplest x
|
||
|
|
|
||
|
|
-- | @defaultSublMap@ is an attempt to create a set of keybindings like the
|
||
|
|
-- defaults ones but to be used as a 'submap' for sending messages to the
|
||
|
|
-- sublayout.
|
||
|
|
defaultSublMap :: XConfig l -> Map (KeyMask, KeySym) (X ())
|
||
|
|
defaultSublMap (XConfig { modMask = modm }) = M.fromList
|
||
|
|
[((modm, xK_space), toSubl NextLayout),
|
||
|
|
((modm, xK_j), onGroup W.focusDown'),
|
||
|
|
((modm, xK_k), onGroup W.focusUp'),
|
||
|
|
((modm, xK_h), toSubl Shrink),
|
||
|
|
((modm, xK_l), toSubl Expand),
|
||
|
|
((modm, xK_Tab), onGroup W.focusDown'),
|
||
|
|
((modm .|. shiftMask, xK_Tab), onGroup W.focusUp'),
|
||
|
|
((modm, xK_m), onGroup focusMaster'),
|
||
|
|
((modm, xK_comma), toSubl $ IncMasterN 1),
|
||
|
|
((modm, xK_period), toSubl $ IncMasterN (-1)),
|
||
|
|
((modm, xK_Return), onGroup swapMaster')
|
||
|
|
]
|
||
|
|
where
|
||
|
|
-- should these go into XMonad.StackSet?
|
||
|
|
focusMaster' st = let (f:fs) = W.integrate st
|
||
|
|
in W.Stack f [] fs
|
||
|
|
swapMaster' (W.Stack f u d) = W.Stack f [] $ reverse u ++ d
|
||
|
|
|
||
|
|
data Sublayout l a = Sublayout
|
||
|
|
{ delayMess :: Invisible [] (SomeMessage,a)
|
||
|
|
-- ^ messages are handled when running the layout,
|
||
|
|
-- not in the handleMessage, I'm not sure that this
|
||
|
|
-- is necessary
|
||
|
|
, def :: ([Int], l a) -- ^ how many NextLayout messages to send to newly
|
||
|
|
-- populated layouts. If there is no corresponding
|
||
|
|
-- index, then don't send any.
|
||
|
|
, subls :: [(l a,W.Stack a)]
|
||
|
|
-- ^ The sublayouts and the stacks they manage
|
||
|
|
}
|
||
|
|
deriving (Read,Show)
|
||
|
|
|
||
|
|
-- | Groups assumes this invariant:
|
||
|
|
-- M.keys gs == map W.focus (M.elems gs) (ignoring order)
|
||
|
|
-- All windows in the workspace are in the Map
|
||
|
|
--
|
||
|
|
-- The keys are visible windows, the rest are hidden.
|
||
|
|
--
|
||
|
|
-- This representation probably simplifies the internals of the modifier.
|
||
|
|
type Groups a = Map a (W.Stack a)
|
||
|
|
|
||
|
|
-- | GroupMsg take window parameters to determine which group the action should
|
||
|
|
-- be applied to
|
||
|
|
data GroupMsg a
|
||
|
|
= UnMerge a -- ^ free the focused window from its tab stack
|
||
|
|
| UnMergeAll a
|
||
|
|
-- ^ separate the focused group into singleton groups
|
||
|
|
| Merge a a -- ^ merge the first group into the second group
|
||
|
|
| MergeAll a
|
||
|
|
-- ^ make one large group, keeping the parameter focused
|
||
|
|
| Migrate a a
|
||
|
|
-- ^ used to the window named in the first argument to the
|
||
|
|
-- second argument's group, this may be replaced by a
|
||
|
|
-- combination of 'UnMerge' and 'Merge'
|
||
|
|
| WithGroup (W.Stack a -> X (W.Stack a)) a
|
||
|
|
| SubMessage SomeMessage a
|
||
|
|
-- ^ the sublayout with the given window will get the message
|
||
|
|
deriving (Typeable)
|
||
|
|
|
||
|
|
-- | merge the window that would be focused by the function when applied to the
|
||
|
|
-- W.Stack of all windows, with the current group removed. The given window
|
||
|
|
-- should be focused by a sublayout. Example usage: @withFocused (sendMessage .
|
||
|
|
-- mergeDir W.focusDown')@
|
||
|
|
mergeDir :: (W.Stack Window -> W.Stack Window) -> Window -> GroupMsg Window
|
||
|
|
mergeDir f w = WithGroup g w
|
||
|
|
where g cs = do
|
||
|
|
let onlyOthers = W.filter (`notElem` W.integrate cs)
|
||
|
|
flip whenJust (sendMessage . Merge (W.focus cs) . W.focus . f)
|
||
|
|
=<< fmap (onlyOthers =<<) currentStack
|
||
|
|
return cs
|
||
|
|
|
||
|
|
data Broadcast = Broadcast SomeMessage -- ^ send a message to all sublayouts
|
||
|
|
deriving (Typeable)
|
||
|
|
|
||
|
|
instance Message Broadcast
|
||
|
|
instance Typeable a => Message (GroupMsg a)
|
||
|
|
|
||
|
|
-- | @pullGroup@, @pushGroup@ allow you to merge windows or groups inheriting
|
||
|
|
-- the position of the current window (pull) or the other window (push).
|
||
|
|
--
|
||
|
|
-- @pushWindow@ and @pullWindow@ move individual windows between groups. They
|
||
|
|
-- are less effective at preserving window positions.
|
||
|
|
pullGroup,pushGroup,pullWindow,pushWindow :: Direction2D -> Navigate
|
||
|
|
pullGroup = mergeNav (\o c -> sendMessage $ Merge o c)
|
||
|
|
pushGroup = mergeNav (\o c -> sendMessage $ Merge c o)
|
||
|
|
pullWindow = mergeNav (\o c -> sendMessage $ Migrate o c)
|
||
|
|
pushWindow = mergeNav (\o c -> sendMessage $ Migrate c o)
|
||
|
|
|
||
|
|
mergeNav :: (Window -> Window -> X ()) -> Direction2D -> Navigate
|
||
|
|
mergeNav f = Apply (\o -> withFocused (f o))
|
||
|
|
|
||
|
|
-- | Apply a function on the stack belonging to the currently focused group. It
|
||
|
|
-- works for rearranging windows and for changing focus.
|
||
|
|
onGroup :: (W.Stack Window -> W.Stack Window) -> X ()
|
||
|
|
onGroup f = withFocused (sendMessage . WithGroup (return . f))
|
||
|
|
|
||
|
|
-- | Send a message to the currently focused sublayout.
|
||
|
|
toSubl :: (Message a) => a -> X ()
|
||
|
|
toSubl m = withFocused (sendMessage . SubMessage (SomeMessage m))
|
||
|
|
|
||
|
|
instance (Read (l Window), Show (l Window), LayoutClass l Window) => LayoutModifier (Sublayout l) Window where
|
||
|
|
modifyLayout (Sublayout { subls = osls }) (W.Workspace i la st) r = do
|
||
|
|
let gs' = updateGroup st $ toGroups osls
|
||
|
|
st' = W.filter (`elem` M.keys gs') =<< st
|
||
|
|
updateWs gs'
|
||
|
|
oldStack <- gets $ W.stack . W.workspace . W.current . windowset
|
||
|
|
setStack st'
|
||
|
|
runLayout (W.Workspace i la st') r <* setStack oldStack
|
||
|
|
-- FIXME: merge back reordering, deletions?
|
||
|
|
|
||
|
|
redoLayout (Sublayout { delayMess = I ms, def = defl, subls = osls }) _r st arrs = do
|
||
|
|
let gs' = updateGroup st $ toGroups osls
|
||
|
|
sls <- fromGroups defl st gs' osls
|
||
|
|
|
||
|
|
let newL :: LayoutClass l Window => Rectangle -> WorkspaceId -> (l Window) -> Bool
|
||
|
|
-> (Maybe (W.Stack Window)) -> X ([(Window, Rectangle)], l Window)
|
||
|
|
newL rect n ol isNew sst = do
|
||
|
|
orgStack <- currentStack
|
||
|
|
let handle l (y,_)
|
||
|
|
| not isNew = fromMaybe l <$> handleMessage l y
|
||
|
|
| otherwise = return l
|
||
|
|
kms = filter ((`elem` M.keys gs') . snd) ms
|
||
|
|
setStack sst
|
||
|
|
nl <- foldM handle ol $ filter ((`elem` W.integrate' sst) . snd) kms
|
||
|
|
result <- runLayout (W.Workspace n nl sst) rect
|
||
|
|
setStack orgStack -- FIXME: merge back reordering, deletions?
|
||
|
|
return $ fromMaybe nl `second` result
|
||
|
|
|
||
|
|
(urls,ssts) = unzip [ (newL gr i l isNew sst, sst)
|
||
|
|
| (isNew,(l,_st)) <- sls
|
||
|
|
| i <- map show [ 0 :: Int .. ]
|
||
|
|
| (k,gr) <- arrs, let sst = M.lookup k gs' ]
|
||
|
|
|
||
|
|
arrs' <- sequence urls
|
||
|
|
sls' <- return . Sublayout (I []) defl . map snd <$> fromGroups defl st gs'
|
||
|
|
[ (l,s) | (_,l) <- arrs' | (Just s) <- ssts ]
|
||
|
|
return (concatMap fst arrs', sls')
|
||
|
|
|
||
|
|
handleMess (Sublayout (I ms) defl sls) m
|
||
|
|
| Just (SubMessage sm w) <- fromMessage m =
|
||
|
|
return $ Just $ Sublayout (I ((sm,w):ms)) defl sls
|
||
|
|
|
||
|
|
| Just (Broadcast sm) <- fromMessage m = do
|
||
|
|
ms' <- fmap (zip (repeat sm) . W.integrate') currentStack
|
||
|
|
return $ if null ms' then Nothing
|
||
|
|
else Just $ Sublayout (I $ ms' ++ ms) defl sls
|
||
|
|
|
||
|
|
| Just B.UpdateBoring <- fromMessage m = do
|
||
|
|
let bs = concatMap unfocused $ M.elems gs
|
||
|
|
ws <- gets (W.workspace . W.current . windowset)
|
||
|
|
flip sendMessageWithNoRefresh ws $ B.Replace "Sublayouts" bs
|
||
|
|
return Nothing
|
||
|
|
|
||
|
|
| Just (WithGroup f w) <- fromMessage m
|
||
|
|
, Just g <- M.lookup w gs = do
|
||
|
|
g' <- f g
|
||
|
|
let gs' = M.insert (W.focus g') g' $ M.delete (W.focus g) gs
|
||
|
|
when (gs' /= gs) $ updateWs gs'
|
||
|
|
when (w /= W.focus g') $ windows (W.focusWindow $ W.focus g')
|
||
|
|
return Nothing
|
||
|
|
|
||
|
|
| Just (MergeAll w) <- fromMessage m =
|
||
|
|
let gs' = fmap (M.singleton w)
|
||
|
|
$ (focusWindow' w =<<) $ W.differentiate
|
||
|
|
$ concatMap W.integrate $ M.elems gs
|
||
|
|
in maybe (return Nothing) fgs gs'
|
||
|
|
|
||
|
|
| Just (UnMergeAll w) <- fromMessage m =
|
||
|
|
let ws = concatMap W.integrate $ M.elems gs
|
||
|
|
_ = w :: Window
|
||
|
|
mkSingleton f = M.singleton f (W.Stack f [] [])
|
||
|
|
in fgs $ M.unions $ map mkSingleton ws
|
||
|
|
|
||
|
|
| Just (Merge x y) <- fromMessage m
|
||
|
|
, Just (W.Stack _ xb xn) <- findGroup x
|
||
|
|
, Just yst <- findGroup y =
|
||
|
|
let zs = W.Stack x xb (xn ++ W.integrate yst)
|
||
|
|
in fgs $ M.insert x zs $ M.delete (W.focus yst) gs
|
||
|
|
|
||
|
|
| Just (UnMerge x) <- fromMessage m =
|
||
|
|
fgs . M.fromList . map (W.focus &&& id) . M.elems
|
||
|
|
$ M.mapMaybe (W.filter (x/=)) gs
|
||
|
|
|
||
|
|
-- XXX sometimes this migrates an incorrect window, why?
|
||
|
|
| Just (Migrate x y) <- fromMessage m
|
||
|
|
, Just xst <- findGroup x
|
||
|
|
, Just (W.Stack yf yu yd) <- findGroup y =
|
||
|
|
let zs = W.Stack x (yf:yu) yd
|
||
|
|
nxsAdd = maybe id (\e -> M.insert (W.focus e) e) $ W.filter (x/=) xst
|
||
|
|
in fgs $ nxsAdd $ M.insert x zs $ M.delete yf gs
|
||
|
|
|
||
|
|
|
||
|
|
| otherwise = fmap join $ sequenceA $ catchLayoutMess <$> fromMessage m
|
||
|
|
where gs = toGroups sls
|
||
|
|
fgs gs' = do
|
||
|
|
st <- currentStack
|
||
|
|
Just . Sublayout (I ms) defl . map snd <$> fromGroups defl st gs' sls
|
||
|
|
|
||
|
|
findGroup z = mplus (M.lookup z gs) $ listToMaybe
|
||
|
|
$ M.elems $ M.filter ((z `elem`) . W.integrate) gs
|
||
|
|
-- catchLayoutMess :: LayoutMessages -> X (Maybe (Sublayout l Window))
|
||
|
|
-- This l must be the same as from the instance head,
|
||
|
|
-- -XScopedTypeVariables should bring it into scope, but we are
|
||
|
|
-- trying to avoid warnings with ghc-6.8.2 and avoid CPP
|
||
|
|
catchLayoutMess x = do
|
||
|
|
let m' = x `asTypeOf` (undefined :: LayoutMessages)
|
||
|
|
ms' <- zip (repeat $ SomeMessage m') . W.integrate'
|
||
|
|
<$> currentStack
|
||
|
|
return $ do guard $ not $ null ms'
|
||
|
|
Just $ Sublayout (I $ ms' ++ ms) defl sls
|
||
|
|
|
||
|
|
currentStack :: X (Maybe (W.Stack Window))
|
||
|
|
currentStack = gets (W.stack . W.workspace . W.current . windowset)
|
||
|
|
|
||
|
|
-- | update Group to follow changes in the workspace
|
||
|
|
updateGroup :: Ord a => Maybe (W.Stack a) -> Groups a -> Groups a
|
||
|
|
updateGroup mst gs =
|
||
|
|
let flatten = concatMap W.integrate . M.elems
|
||
|
|
news = W.integrate' mst \\ flatten gs
|
||
|
|
deads = flatten gs \\ W.integrate' mst
|
||
|
|
|
||
|
|
uniNew = M.union (M.fromList $ map (\n -> (n,single n)) news)
|
||
|
|
single x = W.Stack x [] []
|
||
|
|
|
||
|
|
-- pass through a list to update/remove keys
|
||
|
|
remDead = M.fromList . map (\w -> (W.focus w,w))
|
||
|
|
. mapMaybe (W.filter (`notElem` deads)) . M.elems
|
||
|
|
|
||
|
|
-- update the current tab group's order and focus
|
||
|
|
followFocus hs = fromMaybe hs $ do
|
||
|
|
f' <- W.focus `fmap` mst
|
||
|
|
xs <- find (elem f' . W.integrate) $ M.elems hs
|
||
|
|
xs' <- W.filter (`elem` W.integrate xs) =<< mst
|
||
|
|
return $ M.insert f' xs' $ M.delete (W.focus xs) hs
|
||
|
|
|
||
|
|
in remDead $ uniNew $ followFocus gs
|
||
|
|
|
||
|
|
-- | rearrange the windowset to put the groups of tabs next to eachother, so
|
||
|
|
-- that the stack of tabs stays put.
|
||
|
|
updateWs :: Groups Window -> X ()
|
||
|
|
updateWs = windowsMaybe . updateWs'
|
||
|
|
|
||
|
|
updateWs' :: Groups Window -> WindowSet -> Maybe WindowSet
|
||
|
|
updateWs' gs ws = do
|
||
|
|
f <- W.peek ws
|
||
|
|
let w = W.index ws
|
||
|
|
nes = concatMap W.integrate $ mapMaybe (flip M.lookup gs) w
|
||
|
|
ws' = W.focusWindow f $ foldr W.insertUp (foldr W.delete' ws nes) nes
|
||
|
|
guard $ W.index ws' /= W.index ws
|
||
|
|
return ws'
|
||
|
|
|
||
|
|
-- | focusWindow'. focus an element of a stack, is Nothing if that element is
|
||
|
|
-- absent. See also 'W.focusWindow'
|
||
|
|
focusWindow' :: (Eq a) => a -> W.Stack a -> Maybe (W.Stack a)
|
||
|
|
focusWindow' w st = do
|
||
|
|
guard $ not $ null $ filter (w==) $ W.integrate st
|
||
|
|
if W.focus st == w then Just st
|
||
|
|
else focusWindow' w $ W.focusDown' st
|
||
|
|
|
||
|
|
-- update only when Just
|
||
|
|
windowsMaybe :: (WindowSet -> Maybe WindowSet) -> X ()
|
||
|
|
windowsMaybe f = do
|
||
|
|
xst <- get
|
||
|
|
ws <- gets windowset
|
||
|
|
let up fws = put xst { windowset = fws }
|
||
|
|
maybe (return ()) up $ f ws
|
||
|
|
|
||
|
|
unfocused :: W.Stack a -> [a]
|
||
|
|
unfocused x = W.up x ++ W.down x
|
||
|
|
|
||
|
|
toGroups :: (Ord a) => [(a1, W.Stack a)] -> Map a (W.Stack a)
|
||
|
|
toGroups ws = M.fromList . map (W.focus &&& id) . nubBy (on (==) W.focus)
|
||
|
|
$ map snd ws
|
||
|
|
|
||
|
|
-- | restore the default layout for each group. It needs the X monad to switch
|
||
|
|
-- the default layout to a specific one (handleMessage NextLayout)
|
||
|
|
fromGroups :: (LayoutClass layout a, Ord k) =>
|
||
|
|
([Int], layout a)
|
||
|
|
-> Maybe (W.Stack k)
|
||
|
|
-> Groups k
|
||
|
|
-> [(layout a, b)]
|
||
|
|
-> X [(Bool,(layout a, W.Stack k))]
|
||
|
|
fromGroups (skips,defl) st gs sls = do
|
||
|
|
defls <- mapM (iterateM nextL defl !!) skips
|
||
|
|
return $ fromGroups' defl defls st gs (map fst sls)
|
||
|
|
where nextL l = fromMaybe l <$> handleMessage l (SomeMessage NextLayout)
|
||
|
|
iterateM f = iterate (>>= f) . return
|
||
|
|
|
||
|
|
fromGroups' :: (Ord k) => a -> [a] -> Maybe (W.Stack k) -> Groups k -> [a]
|
||
|
|
-> [(Bool,(a, W.Stack k))]
|
||
|
|
fromGroups' defl defls st gs sls =
|
||
|
|
[ (isNew,fromMaybe2 (dl, single w) (l, M.lookup w gs))
|
||
|
|
| l <- map Just sls ++ repeat Nothing, let isNew = isNothing l
|
||
|
|
| dl <- defls ++ repeat defl
|
||
|
|
| w <- W.integrate' $ W.filter (`notElem` unfocs) =<< st ]
|
||
|
|
where unfocs = unfocused =<< M.elems gs
|
||
|
|
single w = W.Stack w [] []
|
||
|
|
fromMaybe2 (a,b) (x,y) = (fromMaybe a x, fromMaybe b y)
|
||
|
|
|
||
|
|
|
||
|
|
-- this would be much cleaner with some kind of data-accessor
|
||
|
|
setStack :: Maybe (W.Stack Window) -> X ()
|
||
|
|
setStack x = modify (\s -> s { windowset = (windowset s)
|
||
|
|
{ W.current = (W.current $ windowset s)
|
||
|
|
{ W.workspace = (W.workspace $ W.current $ windowset s) { W.stack = x }}}})
|