From a5b811e4ed0361558eaedd8e52f51aeceabb0c26 Mon Sep 17 00:00:00 2001 From: David Roundy Date: Sat, 20 Oct 2007 21:17:48 +0200 Subject: introduce new combineTwo layout combinator. This layout combinator is similar in spirit (and in code) to the old combo combinator, but only allows two sublayouts. As a result, we don't need to wrap these in existentials, and reading works seamlessly. Also, we add the feature (which could also be added to combo) of being able to change which sublayout a given window is in through integration with WindowNavigation. I envision combo being deprecated soon. combineTwo isn't quite so flexible, but it's much easier and is better-coded also. darcs-hash:20071020191748-72aca-b431b4f7c13f63a2060c7b19b4404245b6939251.gz --- Combo.hs | 103 +++++++++++++++++++++++++++++++++++++++++++++++----- WindowNavigation.hs | 22 ++++++++--- 2 files changed, 109 insertions(+), 16 deletions(-) diff --git a/Combo.hs b/Combo.hs index 558928b..36ef53e 100644 --- a/Combo.hs +++ b/Combo.hs @@ -17,16 +17,17 @@ module XMonadContrib.Combo ( -- * Usage -- $usage - combo + combo, combineTwo ) where import Control.Arrow ( first ) -import Data.List ( delete ) +import Data.List ( delete, intersect, (\\) ) import Data.Maybe ( isJust ) import XMonad -import Operations ( LayoutMessages(ReleaseResources) ) +import Operations ( LayoutMessages(ReleaseResources,Hide) ) import StackSet ( integrate, Stack(..) ) import XMonadContrib.Invisible +import XMonadContrib.WindowNavigation ( MoveWindowToWindow(..) ) import qualified StackSet as W ( differentiate ) -- $usage @@ -37,7 +38,11 @@ import qualified StackSet as W ( differentiate ) -- -- and add something like -- --- > combo (TwoPane 0.03 0.5) [(Full,1),(tabbed shrinkText defaultTConf,1)] +-- > combo (TwoPane 0.03 0.5) [(Layout Full,1),(Layout $ tabbed shrinkText defaultTConf,1)] +-- +-- or alternatively +-- +-- > combineTwo (TwoPane 0.03 0.5) (tabbed shrinkText defaultTConf) (tabbed shrinkText defaultTConf) -- -- to your layouts. -- @@ -48,9 +53,86 @@ import qualified StackSet as W ( differentiate ) -- windows this section should hold. This number is ignored for the last -- layout, which will hold any excess windows. +-- combineTwo is a new simpler (and yet in some ways more powerful) layout +-- combinator. It only allows the combination of two layouts, but has the +-- advantage of allowing you to dynamically adjust the layout, in terms of +-- the number of windows in each sublayout. To do this, use +-- WindowNavigation, and add the following key bindings (or something similar): + +-- , ((modMask .|. controlMask .|. shiftMask, xK_Right), sendMessage $ Move R) +-- , ((modMask .|. controlMask .|. shiftMask, xK_Left), sendMessage $ Move L) +-- , ((modMask .|. controlMask .|. shiftMask, xK_Up), sendMessage $ Move U) +-- , ((modMask .|. controlMask .|. shiftMask, xK_Down), sendMessage $ Move D) + +-- These bindings will move a window into the sublayout that is +-- up/down/left/right of its current position. Note that there is some +-- weirdness in combineTwo, in that the mod-tab focus order is not very +-- closely related to the layout order. This is because we're forced to +-- keep track of the window positions sparately, and this is ugly. If you +-- don't like this, lobby for hierarchical stacks in core xmonad or go +-- reimelement the core of xmonad yourself. + -- %import XMonadContrib.Combo -- %layout , combo (twoPane 0.03 0.5) [(full,1),(tabbed shrinkText defaultTConf,1)] +data CombineTwo l l1 l2 a = C2 [a] [a] (l ()) (l1 a) (l2 a) + deriving (Read, Show) + +combineTwo :: (Read a, Eq a, LayoutClass super (), LayoutClass l1 a, LayoutClass l2 a) => + super () -> l1 a -> l2 a -> CombineTwo super l1 l2 a +combineTwo = C2 [] [] + +instance (LayoutClass l (), LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) + => LayoutClass (CombineTwo l l1 l2) a where + doLayout (C2 f w2 super l1 l2) rinput s = arrange (integrate s) + where arrange [] = do l1' <- maybe l1 id `fmap` handleMessage l1 (SomeMessage Hide) + l2' <- maybe l2 id `fmap` handleMessage l2 (SomeMessage Hide) + return ([], Just $ C2 [] [] super l1' l2') + arrange [w] = do l1' <- maybe l1 id `fmap` handleMessage l1 (SomeMessage Hide) + l2' <- maybe l2 id `fmap` handleMessage l2 (SomeMessage Hide) + return ([(w,rinput)], Just $ C2 [w] [w] super l1' l2') + arrange origws = + do let w2' = case origws `intersect` w2 of [] -> [head origws] + [x] -> [x] + x -> case origws \\ x of + [] -> init x + _ -> x + superstack = if focus s `elem` w2' + then Stack { focus=(), up=[], down=[()] } + else Stack { focus=(), up=[], down=[()] } + s1 = differentiate f' (origws \\ w2') + s2 = differentiate f' w2' + f' = focus s:delete (focus s) f + ([((),r1),((),r2)], msuper') <- doLayout super rinput superstack + (wrs1, ml1') <- runLayout l1 r1 s1 + (wrs2, ml2') <- runLayout l2 r2 s2 + return (wrs1++wrs2, Just $ C2 f' w2' + (maybe super id msuper') (maybe l1 id ml1') (maybe l2 id ml2')) + handleMessage (C2 f ws2 super l1 l2) m + | Just (MoveWindowToWindow w1 w2) <- fromMessage m, + w1 `notElem` ws2, + w2 `elem` ws2 = do l1' <- maybe l1 id `fmap` handleMessage l1 m + l2' <- maybe l2 id `fmap` handleMessage l2 m + return $ Just $ C2 f (w1:ws2) super l1' l2' + | Just (MoveWindowToWindow w1 w2) <- fromMessage m, + w1 `elem` ws2, + w2 `notElem` ws2 = do l1' <- maybe l1 id `fmap` handleMessage l1 m + l2' <- maybe l2 id `fmap` handleMessage l2 m + let ws2' = case delete w1 ws2 of [] -> [w2] + x -> x + return $ Just $ C2 f ws2' super l1' l2' + | otherwise = do ml1' <- broadcastPrivate m [l1] + ml2' <- broadcastPrivate m [l2] + msuper' <- broadcastPrivate m [super] + if isJust msuper' || isJust ml1' || isJust ml2' + then return $ Just $ C2 f ws2 + (maybe super head msuper') + (maybe l1 head ml1') + (maybe l2 head ml2') + else return Nothing + description (C2 _ _ super l1 l2) = "combining "++ description l1 ++" and "++ + description l2 ++" with "++ description super + combo :: (Eq a, Show a, Read a, ReadableLayout a, LayoutClass l (Layout a, Int)) => (l (Layout a, Int)) -> [(Layout a, Int)] -> Combo l a combo = Combo (I []) @@ -76,12 +158,6 @@ instance (Eq a, ReadableLayout a, LayoutClass l (Layout a, Int)) foo (_, Nothing) x = x foo (_, Just l') (_, n) = (l', n) return (concat $ map fst out, Just $ Combo (I f') super' origls') - differentiate :: Eq q => [q] -> [q] -> Maybe (Stack q) - differentiate (z:zs) xs | z `elem` xs = Just $ Stack { focus=z - , up = reverse $ takeWhile (/=z) xs - , down = tail $ dropWhile (/=z) xs } - | otherwise = differentiate zs xs - differentiate [] xs = W.differentiate xs handleMessage (Combo (I f) super origls) m = do mls <- broadcastPrivate m (map fst origls) let mls' = (\x->zipWith first (map const x) origls) `fmap` mls @@ -93,6 +169,13 @@ instance (Eq a, ReadableLayout a, LayoutClass l (Layout a, Int)) Just [super'] -> return $ Just $ Combo (I f') super' $ maybe origls id mls' _ -> return $ Combo (I f') super `fmap` mls' +differentiate :: Eq q => [q] -> [q] -> Maybe (Stack q) +differentiate (z:zs) xs | z `elem` xs = Just $ Stack { focus=z + , up = reverse $ takeWhile (/=z) xs + , down = tail $ dropWhile (/=z) xs } + | otherwise = differentiate zs xs +differentiate [] xs = W.differentiate xs + broadcastPrivate :: LayoutClass l b => SomeMessage -> [l b] -> X (Maybe [l b]) broadcastPrivate a ol = do nml <- mapM f ol if any isJust nml diff --git a/WindowNavigation.hs b/WindowNavigation.hs index 54661de..e66e2bd 100644 --- a/WindowNavigation.hs +++ b/WindowNavigation.hs @@ -20,12 +20,14 @@ module XMonadContrib.WindowNavigation ( -- $usage windowNavigation, configurableNavigation, Navigate(..), Direction(..), + MoveWindowToWindow(..), navigateColor, navigateBrightness, noNavigateBorders, defaultWNConfig ) where import Graphics.X11.Xlib ( Rectangle(..), Window, Pixel, setWindowBorder ) import Control.Monad.Reader ( ask ) +import Control.Monad.State ( gets ) import Data.List ( nub, sortBy, (\\) ) import XMonad import qualified StackSet as W @@ -67,8 +69,10 @@ import XMonadContrib.XUtils -- %layout -- or -- %layout -- layoutHook = Layout $ configurableNavigation (navigateBorder "green") $ ... +data MoveWindowToWindow a = MoveWindowToWindow a a deriving ( Read, Show, Typeable ) +instance Typeable a => Message (MoveWindowToWindow a) -data Navigate = Go Direction | Swap Direction deriving ( Read, Show, Typeable ) +data Navigate = Go Direction | Swap Direction | Move Direction deriving ( Read, Show, Typeable ) data Direction = U | D | R | L deriving ( Read, Show, Eq ) instance Message Navigate @@ -136,12 +140,12 @@ instance LayoutModifier WindowNavigation Window where mapM_ (\(win,c) -> sc c win) wnavigablec return (wrs, Just $ WindowNavigation conf $ I $ Just $ NS pt wnavigable) - handleMess (WindowNavigation conf (I (Just (NS pt wrs)))) m + handleMessOrMaybeModifyIt (WindowNavigation conf (I (Just (NS pt wrs)))) m | Just (Go d) <- fromMessage m = case sortby d $ filter (inr d pt . snd) wrs of [] -> return Nothing ((w,r):_) -> do focus w - return $ Just $ WindowNavigation conf $ I $ Just $ + return $ Just $ Left $ WindowNavigation conf $ I $ Just $ NS (centerd d pt r) wrs | Just (Swap d) <- fromMessage m = case sortby d $ filter (inr d pt . snd) wrs of @@ -159,13 +163,19 @@ instance LayoutModifier WindowNavigation Window where , W.up = [] } windows $ W.modify' swap return Nothing + | Just (Move d) <- fromMessage m = + case sortby d $ filter (inr d pt . snd) wrs of + [] -> return Nothing + ((w,_):_) -> do mst <- gets (W.stack . W.workspace . W.current . windowset) + return $ do st <- mst + Just $ Right $ SomeMessage $ MoveWindowToWindow (W.focus st) w | Just Hide <- fromMessage m = do XConf { normalBorder = nbc } <- ask mapM_ (sc nbc . fst) wrs - return $ Just $ WindowNavigation conf $ I $ Just $ NS pt [] + return $ Just $ Left $ WindowNavigation conf $ I $ Just $ NS pt [] | Just ReleaseResources <- fromMessage m = - handleMess (WindowNavigation conf (I $ Just (NS pt wrs))) (SomeMessage Hide) - handleMess _ _ = return Nothing + handleMessOrMaybeModifyIt (WindowNavigation conf (I $ Just (NS pt wrs))) (SomeMessage Hide) + handleMessOrMaybeModifyIt _ _ = return Nothing truncHead :: [a] -> [a] truncHead (x:_) = [x] -- cgit v1.2.3