Fix some dragging behavior. Remove some conflicting bindings.

2 files changed, 79 insertions, 84 deletions

diff --git a/src/Rahm/Desktop/Dragging.hs b/src/Rahm/Desktop/Dragging.hs
index 853cf43..4ec0edc 100644
--- a/src/Rahm/Desktop/Dragging.hs
+++ b/src/Rahm/Desktop/Dragging.hs
@@ -4,7 +4,7 @@ import Control.Monad (filterM, when)
 import Control.Monad.Trans (lift)
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
 import Data.IORef (newIORef, readIORef, writeIORef)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Rahm.Desktop.Common (pointerLocation, pointerWindow, runMaybeT_, setBorderColor)
 import Rahm.Desktop.Layout.Hole (addHoleForWindow, removeHoleForWindow, resetHole)
 import Rahm.Desktop.Layout.PinWindow (isWindowPinned, pinWindow, unpinWindow)
@@ -35,6 +35,15 @@ afterDrag action = do
       st {X.dragging = Just (fn, cleanup >> action)}
     s -> s
 
+isDragging :: X Bool
+isDragging = X.gets (isJust . X.dragging)
+
+finishDrag :: X ()
+finishDrag = runMaybeT_ $ do
+  (_, cleanup) <- MaybeT $ X.gets X.dragging
+  X.modify $ \s -> s {X.dragging = Nothing}
+  lift cleanup
+
 windowsUnderCursor :: X [X.Window]
 windowsUnderCursor = do
   (dpy, root) <- X.asks $ (,) <$> X.display <*> X.theRoot
@@ -56,7 +65,10 @@ windowsUnderCursor = do
     aw
 
 sinkOnRelease :: AfterDragAction
-sinkOnRelease = AfterDragAction $ \window _ -> do
+sinkOnRelease = AfterDragAction $ \window _ -> sinkByWindowUnderCursor window
+
+sinkByWindowUnderCursor :: X.Window -> X ()
+sinkByWindowUnderCursor window = do
   (cx, cy) <- pointerLocation
   wins <- filter (/= window) <$> windowsUnderCursor
   t <- fmap (W.tag . W.workspace) <$> X.pointScreen cx cy
@@ -81,8 +93,11 @@ ifReleased but (AfterDragAction act) = AfterDragAction $ \win b -> do
 ifReleased' :: X.Button -> (X.Window -> X.Button -> X ()) -> AfterDragAction
 ifReleased' but act = ifReleased but (AfterDragAction act)
 
-mouseResizeWindowAndThen :: (X.Window -> X ()) ->
-  AfterDragAction -> X.Window -> X ()
+mouseResizeWindowAndThen ::
+  (X.Window -> X ()) ->
+  AfterDragAction ->
+  X.Window ->
+  X ()
 mouseResizeWindowAndThen beforeAction (AfterDragAction releaseAction) window = do
   beforeAction window
   windowPinned <- isWindowPinned window
@@ -97,10 +112,18 @@ mouseResizeWindowAndThen beforeAction (AfterDragAction releaseAction) window = d
     curev <- X.asks X.currentEvent
     when windowPinned $
       pinWindow window
-    releaseAction window (maybe 0 X.ev_button curev)
+    releaseAction
+      window
+      ( maybe
+          0
+          ( \case
+              X.ButtonEvent {X.ev_button = b} -> b
+              _ -> 0
+          )
+          curev
+      )
     X.refresh
 
-
 mouseMoveWindowAndThen ::
   (X.Window -> X ()) ->
   AfterDragAction ->
@@ -119,7 +142,16 @@ mouseMoveWindowAndThen beforeAction (AfterDragAction releaseAction) window = do
     curev <- X.asks X.currentEvent
     when windowPinned $
       pinWindow window
-    releaseAction window (maybe 0 X.ev_button curev)
+    releaseAction
+      window
+      ( maybe
+          0
+          ( \case
+              X.ButtonEvent {X.ev_button = b} -> b
+              _ -> 0
+          )
+          curev
+      )
     X.refresh
 
 dragWorkspace :: X ()
@@ -136,7 +168,8 @@ dragWorkspace = do
 dragWindow :: X ()
 dragWindow = do
   w <- pointerWindow
-  if w == 0
+  isDockOrRoot <- windowIsDockOrRoot w
+  if isDockOrRoot
     then dragWorkspace
     else do
       cleanup <- setBorderColor "#00ffff" [w]
@@ -163,26 +196,28 @@ dragWindow = do
           (nx, ny) <- pointerLocation
           w' <- pointerWindow
           (_, iocleanup) <- io $ readIORef ref
-          dock <- X.getAtom "_NET_WM_WINDOW_TYPE_DOCK"
-          desk <- X.getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"
-          mbr <-
-            if w' == 0
-              then return Nothing
-              else getProp32s "_NET_WM_WINDOW_TYPE" w'
-
-          let isDock =
-                maybe False (any ((`elem` [dock, desk]) . fromIntegral)) mbr
-          case w' of
-            _ | w' == 0 || isDock ->
-              runMaybeT_ $ do
-                (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ X.pointScreen nx ny
-                lift $ do
-                  setAlternateWindows [w]
-                  X.windows $ W.sink w . W.shiftWin ws1 w
-            _ -> do
+          isDockOrRoot <- windowIsDockOrRoot w'
+          if isDockOrRoot
+            then runMaybeT_ $ do
+              (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ X.pointScreen nx ny
+              lift $ do
+                setAlternateWindows [w]
+                X.windows $ W.sink w . W.shiftWin ws1 w
+            else do
               X.windows $ W.focusWindow w . W.swapWindows [(w, w')]
 
               setAlternateWindows [w, w']
 
               iocleanup
               cleanup
+  where
+    windowIsDockOrRoot 0 = return True
+    windowIsDockOrRoot w = do
+      dock <- X.getAtom "_NET_WM_WINDOW_TYPE_DOCK"
+      desk <- X.getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"
+      mbr <-
+        if w == 0
+          then return Nothing
+          else getProp32s "_NET_WM_WINDOW_TYPE" w
+
+      return $ maybe False (any ((`elem` [dock, desk]) . fromIntegral)) mbr
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 94308e5..ae293ee 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -295,15 +295,20 @@ keymap = runKeys $ do
   let subkeys keysM = Submap (runKeys keysM config)
       repeatable keysM = Repeat (runKeys keysM config)
 
-  bind xK_apostrophe $
+  bind xK_apostrophe $ do
     justMod $
-      doc "Jump to a window" $
-        pushPendingBuffer "' " $ do
-          runMaybeT_ $ do
-            l <- readNextLocationSet'
-            case l of
-              (h : _) -> lift (focusLocation h)
-              _ -> return ()
+      doc "Jump to a window/tile currently dragging window" $ do
+        ifM
+          D.isDragging
+          (D.finishDrag >> withFocused D.sinkByWindowUnderCursor)
+          $ pushPendingBuffer "' " $ do
+            runMaybeT_ $ do
+              l <- readNextLocationSet'
+              case l of
+                (h : _) -> lift (focusLocation h)
+                _ -> return ()
+    shiftMod $
+      doc "Drag workspace to another." $ D.dragWindow
 
   bind xK_semicolon $
     justMod $
@@ -1083,20 +1088,14 @@ mouseMap = runButtons $ do
         subMouse $ do
           bind button3 $
             noMod $
-              doc "Move to workspace 's' (Spotify)" $
-                noWindow (gotoWorkspace "s")
+              doc "Drag a workspace to a different screen" $
+                noWindow D.dragWorkspace
 
           bind button1 $
             noMod $
               doc "Swap a window with another window by dragging." $
                 noWindow D.dragWindow
 
-          bind button13 $ do
-            noMod $
-              doc "Kill the window under the cursor" $
-                noWindow $
-                  click >> CopyWindow.kill1
-
           bind button14 $ do
             noMod $
               doc "Pop the window under the cursor" $
@@ -1129,12 +1128,14 @@ mouseMap = runButtons $ do
         subMouse $ do
           bind button1 $
             noMod $
-              doc "Move the mouse under the cursor (like how Mod+leftMouse works)" $
+              doc
+                "Move the mouse under the cursor (like how Mod+leftMouse works)"
                 myMouseMoveWindow
 
           bind button2 $
             noMod $
-              doc "Run the command that started a window." $
+              doc
+                "Run the command that started a window."
                 duplWindow
 
           bind button3 $
@@ -1249,47 +1250,6 @@ mouseMap = runButtons $ do
                                     )
                              in windows f >> escape
 
-          let workspaceButtons =
-                [ ( button2,
-                    "Swap the master window with the one under the cursor",
-                    noWindow swapMaster
-                  ),
-                  ( button9,
-                    "View the next workspace",
-                    noWindow $ viewAdjacent next
-                  ),
-                  ( button8,
-                    "View the previous workspace",
-                    noWindow $ viewAdjacent prev
-                  ),
-                  ( button4,
-                    "Focus the previous window in the stack",
-                    noWindow $ windows W.focusUp
-                  ),
-                  ( button5,
-                    "Focus the next window in the stack",
-                    noWindow $ windows W.focusDown
-                  ),
-                  ( button7,
-                    "Swap the current screen with the one to the right",
-                    noWindow $ do
-                      click
-                      runMaybeT_ $
-                        (lift . gotoWorkspaceFn) =<< workspaceForStringT ",."
-                  ),
-                  ( button6,
-                    "Swap the current screen with the one to the left",
-                    noWindow $ do
-                      click
-                      runMaybeT_ $
-                        (lift . gotoWorkspaceFn) =<< workspaceForStringT ";."
-                  )
-                ]
-
-          continuous $
-            forM_ workspaceButtons $ \(b, d, a) ->
-              bind b $ noMod $ doc d a
-
 -- Bindings specific to a window. These are set similarly to th ekeymap above,
 -- but uses a Query monad to tell which windows the keys will apply to.
 --