Added a couple of draggable bindings.

These new bindings allow the user to click on a window and "drag" it to
a different window. This will swap the two windows once the drag button
is released. The other binding is similar, but for whole workspaces.

1 files changed, 82 insertions, 13 deletions

diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 55a0742..4bb87d6 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -18,6 +18,7 @@ import Control.Monad.Writer
     tell,
   )
 import Data.Char (isAlpha)
+import Data.IORef
 import Data.List (foldl')
 import Data.List.Safe ((!!))
 import Data.Map (Map)
@@ -46,6 +47,7 @@ import Rahm.Desktop.Common
     locationWindow,
     locationWorkspace,
     runMaybeT_,
+    setBorderColor,
     withBorderColor,
     withBorderColorM,
   )
@@ -451,18 +453,20 @@ keymap = runKeys $ do
             (lift . gotoWorkspaceFn) =<< readNextWorkspace
 
     shiftMod $
-      doc "Switch a workspace with another workspace. \
-          \This is a more powerful version of the 'g' command, which does not\
-          \assume the current workspace.\
-          \which takes two workspaces as arguments and switches them whereas\
-          \the 'g' command operates only on the current workspace (.).\
-          \thereby G.<ws> is the same as g<ws>" $ do
-        pushPendingBuffer "G " $ do
-          runMaybeT_ $ do
-            w1 <- readNextWorkspaceName
-            lift $ addStringToPendingBuffer " "
-            w2 <- readNextWorkspaceName
-            lift $ windows $ W.switchWorkspaces w1 w2
+      doc
+        "Switch a workspace with another workspace. \
+        \This is a more powerful version of the 'g' command, which does not\
+        \assume the current workspace.\
+        \which takes two workspaces as arguments and switches them whereas\
+        \the 'g' command operates only on the current workspace (.).\
+        \thereby G.<ws> is the same as g<ws>"
+        $ do
+          pushPendingBuffer "G " $ do
+            runMaybeT_ $ do
+              w1 <- readNextWorkspaceName
+              lift $ addStringToPendingBuffer " "
+              w2 <- readNextWorkspaceName
+              lift $ windows $ W.switchWorkspaces w1 w2
 
   bind xK_d $
     justMod $
@@ -976,6 +980,11 @@ mouseMap = runButtons $ do
               doc "Move to workspace 's' (Spotify)" $
                 noWindow (gotoWorkspace "s")
 
+          bind button1 $
+            noMod $
+              doc "Swap a window with another window by dragging." $
+                noWindow dragWindow
+
           bind button13 $ do
             noMod $
               doc "Kill the window under the cursor" $
@@ -1075,7 +1084,7 @@ mouseMap = runButtons $ do
           bind button1 $
             noMod $
               doc "'drag' a workspace to another screen" $
-                 \w -> mouseMoveWindow w
+                noWindow dragWorkspace
 
           let workspaceButtons =
                 [ ( button2,
@@ -1269,3 +1278,63 @@ modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) ->
   where
     clip i | i < 0 = 0
     clip i = i
+
+dragWorkspace :: X ()
+dragWorkspace = do
+  (dpy, root) <- asks $ (,) <$> display <*> theRoot
+  (_, _, _, fromIntegral -> ox, fromIntegral -> oy, _, _, _) <- io $ queryPointer dpy root
+  mouseDrag (\_ _ -> return ()) $ do
+    (_, _, _, fromIntegral -> nx, fromIntegral -> ny, _, _, _) <- io $ queryPointer dpy root
+    runMaybeT_ $ do
+      (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ pointScreen ox oy
+      (W.Screen (W.tag -> ws2) _ _) <- MaybeT $ pointScreen nx ny
+
+      lift $ windows $ W.switchWorkspaces ws1 ws2
+
+dragWindow :: X ()
+dragWindow = do
+  (dpy, root) <- asks $ (,) <$> display <*> theRoot
+  (_, _, w, _, _, _, _, _) <- io $ queryPointer dpy root
+  if w == 0
+    then dragWorkspace
+    else do
+      cleanup <- setBorderColor "#00ffff" [w]
+
+      ref <- io $ newIORef (w, return ())
+
+      mouseDrag
+        ( \_ _ -> do
+            (_, _, w', _, _, _, _, _) <- io $ queryPointer dpy root
+            (ow, ocleanup) <- io $ readIORef ref
+            logs Debug "%s, %s, %s\n" (show w) (show w') (show ow)
+            case () of
+              () | ow /= w' -> do
+                ocleanup
+                logs Debug "setBorderColor %s\n" w'
+                cleanup' <-
+                  if w' == 0 || w' == w
+                    then return (return ())
+                    else setBorderColor "#80a0a0" [w']
+                io $ writeIORef ref (w', cleanup')
+              () -> return ()
+
+            return ()
+        )
+        $ do
+          (_, _, w', fromIntegral -> nx, fromIntegral -> ny, _, _, _) <- io $ queryPointer dpy root
+          (_, iocleanup) <- io $ readIORef ref
+
+          case w' of
+            0 ->
+              runMaybeT_ $ do
+                (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ pointScreen nx ny
+                lift $ do
+                  setAlternateWindows [w]
+                  windows $ W.sink w . W.shiftWin ws1 w
+            _ -> do
+              windows $ W.focusWindow w . W.swapWindows [(w, w')]
+
+              setAlternateWindows [w, w']
+
+              iocleanup
+              cleanup