From a04b53d423f2b16aa253be957213bb2c700594ee Mon Sep 17 00:00:00 2001
From: Adam Vogt <vogt.adam@gmail.com>
Date: Sun, 5 Jul 2009 19:49:34 +0200
Subject: Add Migrate message to L.SubLayouts, for better support of moving
 windows between groups

Ignore-this: d76b2f3e5999999a489b843b4dde59f1

darcs-hash:20090705174934-1499c-b0878bb70fbcdd734deccdc9a6beac9928aded4e.gz
---
 XMonad/Layout/SubLayouts.hs | 36 +++++++++++++++++++++++-------------
 1 file changed, 23 insertions(+), 13 deletions(-)

(limited to 'XMonad/Layout/SubLayouts.hs')

diff --git a/XMonad/Layout/SubLayouts.hs b/XMonad/Layout/SubLayouts.hs
index 064cc10..2cd2a8a 100644
--- a/XMonad/Layout/SubLayouts.hs
+++ b/XMonad/Layout/SubLayouts.hs
@@ -228,7 +228,10 @@ data GroupMsg 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 a focused
+                -- ^ make one large group, keeping the parameter focused
+    | Migrate a a
+                -- ^ used to move windows from one group to another, 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
@@ -252,20 +255,16 @@ data Broadcast = Broadcast SomeMessage -- ^ send a message to all sublayouts
 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).
-pullGroup :: Direction -> Navigate
+-- | @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 :: 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))
+pullWindow = mergeNav (\o c -> sendMessage $ Migrate o c)
+pushWindow = mergeNav (\o c -> sendMessage $ Migrate c o)
 
 mergeNav :: (Window -> Window -> X ()) -> Direction -> Navigate
 mergeNav f = Apply (\o -> withFocused (f o))
@@ -364,12 +363,23 @@ instance (Read (l Window), Show (l Window), LayoutClass l Window) => LayoutModif
             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
-- 
cgit v1.2.3