module XMonad.Layout.SubLayouts (
subLayout,
subTabbed,
pushGroup, pullGroup,
pushWindow, pullWindow,
onGroup, toSubl, mergeDir,
GroupMsg(..),
Broadcast(..),
defaultSublMap,
)
where
import XMonad.Layout.Decoration(Decoration, DefaultShrinker)
import XMonad.Layout.LayoutModifier(LayoutModifier(handleMess, modifyLayout,
redoLayout),
ModifiedLayout(..))
import XMonad.Layout.Simplest(Simplest(..))
import XMonad.Layout.Tabbed(defaultTheme, shrinkText,
TabbedDecoration, addTabs)
import XMonad.Layout.WindowNavigation(Direction, Navigate(Apply))
import XMonad.Util.Invisible(Invisible(..))
import XMonad
import Control.Applicative((<$>))
import Control.Arrow(Arrow(second, (&&&)))
import Control.Monad(Monad(return), Functor(..),
MonadPlus(mplus), (=<<), sequence, foldM, guard, when, join)
import Data.Function((.), ($), flip, id, on)
import Data.List((++), foldr, filter, map, concatMap, elem,
notElem, null, nubBy, (\\), find)
import Data.Maybe(Maybe(..), maybe, fromMaybe, listToMaybe,
mapMaybe)
import Data.Traversable(sequenceA)
import qualified XMonad.Layout.BoringWindows as B
import qualified XMonad.StackSet as W
import qualified Data.Map as M
import Data.Map(Map)
subLayout :: [Int] -> subl a -> l a -> ModifiedLayout (Sublayout subl) l a
subLayout nextLayout sl x = ModifiedLayout (Sublayout (I []) (nextLayout,sl) []) x
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 defaultTheme $ subLayout [] Simplest x
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
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)
, def :: ([Int], l a)
, subls :: [(l a,W.Stack a)]
}
deriving (Read,Show)
type Groups a = Map a (W.Stack a)
data GroupMsg a
= UnMerge a
| UnMergeAll a
| Merge a a
| MergeAll a
| WithGroup (W.Stack a -> X (W.Stack a)) a
| SubMessage SomeMessage a
deriving (Typeable)
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
deriving (Typeable)
instance Message Broadcast
instance Typeable a => Message (GroupMsg a)
pullGroup :: Direction -> Navigate
pullGroup = mergeNav (\o c -> sendMessage $ Merge o c)
pullWindow :: Direction -> Navigate
pullWindow = mergeNav (\o c -> sendMessage (UnMerge o) >> sendMessage (Merge o c))
pushGroup :: Direction -> Navigate
pushGroup = mergeNav (\o c -> sendMessage $ Merge c o)
pushWindow :: Direction -> Navigate
pushWindow = mergeNav (\o c -> sendMessage (UnMerge c) >> sendMessage (Merge c o))
mergeNav :: (Window -> Window -> X ()) -> Direction -> Navigate
mergeNav f = Apply (\o -> withFocused (f o))
onGroup :: (W.Stack Window -> W.Stack Window) -> X ()
onGroup f = withFocused (sendMessage . WithGroup (return . f))
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'
runLayout (W.Workspace i la st') r
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, mess) sst = do
let handle l (y,_)
| mess = fromMaybe l <$> handleMessage l y
| otherwise = return l
kms = filter ((`elem` M.keys gs') . snd) ms
nl <- foldM handle ol $ filter ((`elem` W.integrate' sst) . snd) kms
fmap (fromMaybe nl) <$> runLayout (W.Workspace n nl sst) rect
(urls,ssts) = unzip [ (newL gr i l sst, sst)
| l <- map (second $ const True) sls
| i <- map show [ 0 :: Int .. ]
| (k,gr) <- arrs, let sst = M.lookup k gs' ]
arrs' <- sequence urls
sls' <- return . Sublayout (I []) defl <$> 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
, let findGrp z = mplus (M.lookup z gs) $ listToMaybe
$ M.elems $ M.filter ((z `elem`) . W.integrate) gs
, Just (W.Stack _ xb xn) <- findGrp x
, Just yst <- findGrp y =
let zs = W.Stack x xb (xn ++ W.integrate yst)
in fgs $ M.update (\_ -> Just zs) x $ M.delete y gs
| Just (UnMerge x) <- fromMessage m =
fgs . M.fromList . map (W.focus &&& id) . M.elems
$ M.mapMaybe (W.filter (x/=)) gs
| otherwise = fmap join $ sequenceA $ catchLayoutMess <$> fromMessage m
where gs = toGroups sls
fgs gs' = do
st <- currentStack
Just . Sublayout (I ms) defl <$> fromGroups defl st gs' sls
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)
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 [] []
remDead = M.fromList . map (\w -> (W.focus w,w))
. mapMaybe (W.filter (`notElem` deads)) . M.elems
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
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' :: (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
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
fromGroups :: (LayoutClass layout a, Ord k) =>
([Int], layout a)
-> Maybe (W.Stack k)
-> Groups k
-> [(layout a, b)]
-> X [(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]
-> [(a, W.Stack k)]
fromGroups' defl defls st gs sls =
[ fromMaybe2 (dl, single w) (l, M.lookup w gs)
| l <- map Just sls ++ repeat Nothing
| 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)