Ability to move multiple windows at once.

1 files changed, 74 insertions, 27 deletions

diff --git a/src/Rahm/Desktop/Dragging.hs b/src/Rahm/Desktop/Dragging.hs
index f07ea87..c95deff 100644
--- a/src/Rahm/Desktop/Dragging.hs
+++ b/src/Rahm/Desktop/Dragging.hs
@@ -1,12 +1,17 @@
 module Rahm.Desktop.Dragging where
 
-import Control.Monad (filterM, when)
+import Control.Arrow ((&&&))
+import qualified Control.Exception as C
+import Control.Monad (filterM, forM_, when)
 import Control.Monad.Trans (lift)
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
+import qualified Data.Foldable as Foldable
 import Data.IORef (newIORef, readIORef, writeIORef)
-import Data.Maybe (fromMaybe, isJust)
-import Rahm.Desktop.BorderColors (setBorderColor, BorderColor (BorderColor))
-import Rahm.Desktop.Common (pointerLocation, pointerWindow, runMaybeT_)
+import Data.Maybe (fromMaybe, isJust, mapMaybe)
+import qualified Data.Set as Set
+import Graphics.X11.Xlib.Extras
+import Rahm.Desktop.BorderColors (BorderColor (BorderColor), setBorderColor)
+import Rahm.Desktop.Common (pointerLocation, pointerWindow, runMaybeT_, floatAll)
 import Rahm.Desktop.Layout.Hole (addHoleForWindow, removeHoleForWindow, resetHole)
 import Rahm.Desktop.Layout.PinWindow (isWindowPinned, pinWindow, unpinWindow)
 import Rahm.Desktop.Logger
@@ -129,35 +134,77 @@ mouseResizeWindowAndThen beforeAction (AfterDragAction releaseAction) window = d
       )
     X.refresh
 
-mouseMoveWindowAndThen ::
-  (X.Window -> X ()) ->
+mouseMoveWindowsAndThen ::
+  (Foldable f) =>
+  (f X.Window -> X ()) ->
   AfterDragAction ->
-  X.Window ->
+  f X.Window ->
   X ()
-mouseMoveWindowAndThen beforeAction (AfterDragAction releaseAction) window = do
-  beforeAction window
-  windowPinned <- isWindowPinned window
-  unpinWindow window
-  tilePosition <- X.withWindowSet $ return . W.windowTilePosition window
-  mapM_ (X.broadcastMessage . flip addHoleForWindow window) tilePosition
-  X.mouseMoveWindow window
+mouseMoveWindowsAndThen beforeAction (AfterDragAction releaseAction) windowsF = do
+  let windows = Foldable.toList windowsF
+
+  beforeAction windowsF
+
+  pinnedWindows <- Set.fromList <$> filterM isWindowPinned windows
+  mapM_ unpinWindow windows
+
+  tilePositions <- X.withWindowSet $
+    \ws -> return $ mapMaybe (\win -> (win,) <$> W.windowTilePosition win ws) windows
+
+  mapM_
+    ( \(win, pos) ->
+        X.broadcastMessage $ addHoleForWindow pos win
+    )
+    tilePositions
+
+  case windows of
+    [win] -> X.mouseMoveWindow win
+    _ -> X.withDisplay $ \d -> do
+      floatAll windows
+      was <-
+        io $
+          mapM
+            ( \w -> C.handle (\(C.SomeException _) -> return Nothing) $ do
+                wa <- X.getWindowAttributes d w
+                (_, _, _, fi -> ox, fi -> oy, _, _, _) <- io $ X.queryPointer d w
+                return (Just (w, wa, ox, oy))
+            )
+            windows
+      X.mouseDrag
+        ( \ex ey -> do
+            forM_ was $ \case
+              Just (w, wa, ox, oy) -> do
+                io $
+                  X.moveWindow
+                    d
+                    w
+                    (fromIntegral (fromIntegral (wa_x wa) + (ex - ox)))
+                    (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))
+              Nothing -> return ()
+        )
+        (floatAll windows)
 
   afterDrag $ do
-    X.broadcastMessage $ removeHoleForWindow window
+    mapM_ pinWindow pinnedWindows
     curev <- X.asks X.currentEvent
-    when windowPinned $
-      pinWindow window
-    releaseAction
-      window
-      ( maybe
-          0
-          ( \case
-              X.ButtonEvent {X.ev_button = b} -> b
-              _ -> 0
-          )
-          curev
-      )
+
+    forM_ windows $ \window -> do
+      X.broadcastMessage $ removeHoleForWindow window
+
+      releaseAction
+        window
+        ( maybe
+            0
+            ( \case
+                X.ButtonEvent {X.ev_button = b} -> b
+                _ -> 0
+            )
+            curev
+        )
+
     X.refresh
+  where
+    fi = fromIntegral
 
 dragWorkspace :: X ()
 dragWorkspace = do