Bunch of changes. Not good git ettiquite

 - Added ShiftAndSwap functionality, which allows user to shift a
   <windowset> to a <workspace> and then swap that workspace with
   another <workspace>

   e.g. move Spotify to workspace 's' and put workspace 's' on the last
   monitor.

   This replaces the shift-and-follow as this is more powerful (shift
   and follow just puts the "shifted-to" workspace on the current
   monitor.)

   ofc if the two workspaces to swap are not visible, this just operates
   as a normal shift command.

 - Moved more dragging functionality to the Dragging.hs file and cleaned
   it up a little. More is certainly needed.

 - With the more powerful dragging functionality, many bindings are made
   redundant. I replaced one of these redundant bindings (button13 ->
   mouseWheel). This used to move the focused window around the stack,
   but this has been made redundant by the drag-to-swap functionality
   (button14 -> left-click-drag), so now it changes the master region
   size.

1 files changed, 130 insertions, 47 deletions

diff --git a/src/Rahm/Desktop/Dragging.hs b/src/Rahm/Desktop/Dragging.hs
index 555555d..8485a46 100644
--- a/src/Rahm/Desktop/Dragging.hs
+++ b/src/Rahm/Desktop/Dragging.hs
@@ -1,13 +1,31 @@
 module Rahm.Desktop.Dragging where
 
-import Control.Monad (filterM)
+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 qualified Rahm.Desktop.Common as C
+import Rahm.Desktop.Common (runMaybeT_, setBorderColor)
 import Rahm.Desktop.Layout.Hole (addHoleForWindow, removeHoleForWindow, resetHole)
 import Rahm.Desktop.Logger
+import Rahm.Desktop.Marking (setAlternateWindows)
 import qualified Rahm.Desktop.StackSet as W
 import XMonad (X, io)
 import qualified XMonad as X
+import XMonad.Util.WindowProperties (getProp32s)
+
+-- Action which happens after a dragging event.
+--
+-- The window is the window under
+newtype AfterDragAction = AfterDragAction (X.Window -> X.Button -> X ())
+
+instance Semigroup AfterDragAction where
+  (AfterDragAction f1) <> (AfterDragAction f2) =
+    AfterDragAction $ \w b -> f1 w b >> f2 w b
+
+instance Monoid AfterDragAction where
+  mappend = (<>)
+  mempty = AfterDragAction $ \_ _ -> return ()
 
 afterDrag :: X () -> X ()
 afterDrag action = do
@@ -22,7 +40,7 @@ windowsUnderCursor = do
   aw <- X.withWindowSet (return . W.allVisibleWindows)
   let fi :: (Integral a, Integral b) => a -> b
       fi = fromIntegral
-  (_, _, _, fi -> cx, fi -> cy, _, _, _) <- io $ X.queryPointer dpy root
+  (cx, cy) <- pointerLocation
 
   filterM
     ( \win -> do
@@ -36,34 +54,9 @@ windowsUnderCursor = do
     )
     aw
 
--- mouseMoveWindowAndSink :: X ()
--- mouseMoveWindowAndSink = do
---   C.click
---   (>>=) (X.withWindowSet $ return . W.getFocusedWindow) $
---     mapM_ $ \window -> do
---       tilePosition <- X.withWindowSet $ return . W.windowTilePosition window
---       logs Debug "TilePos %s" (show tilePosition)
---       mapM_ (X.broadcastMessage . flip addHoleForWindow window) tilePosition
---       X.mouseMoveWindow window
---
---       afterDrag $ do
---         curev <- X.asks X.currentEvent
---         logs Debug "Current Event: %s" (show curev)
---
---         logs Info "\n\n***AFTER DRAG****\n\n"
---         wins <- filter (/= window) <$> windowsUnderCursor
---         logs Debug "Remove hole for window [%s]" (show window)
---         X.broadcastMessage $ removeHoleForWindow window
---         logs Debug "Windows under cursor %s" (show wins)
---         X.windows $
---           W.focusWindow window
---             . case wins of
---               (h : _) -> W.sinkBy window h
---               _ -> W.sink window
-thenSink :: X.Window -> X.Button -> X ()
-thenSink window _ = do
-  (dpy, root) <- X.asks $ (,) <$> X.display <*> X.theRoot
-  (_, _, _, fi -> cx, fi -> cy, _, _, _) <- io $ X.queryPointer dpy root
+sinkOnRelease :: AfterDragAction
+sinkOnRelease = AfterDragAction $ \window _ -> do
+  (cx, cy) <- pointerLocation
   wins <- filter (/= window) <$> windowsUnderCursor
   t <- fmap (W.tag . W.workspace) <$> X.pointScreen cx cy
 
@@ -79,19 +72,109 @@ thenSink window _ = do
   where
     fi = fromIntegral
 
-mouseMoveWindowAndSink :: X ()
-mouseMoveWindowAndSink = mouseMoveWindow thenSink
-
-mouseMoveWindow :: (X.Window -> X.Button -> X ()) -> X ()
-mouseMoveWindow afterAction = do
-  C.click
-  (>>=) (X.withWindowSet $ return . W.getFocusedWindow) $
-    mapM_ $ \window -> do
-      tilePosition <- X.withWindowSet $ return . W.windowTilePosition window
-      mapM_ (X.broadcastMessage . flip addHoleForWindow window) tilePosition
-      X.mouseMoveWindow window
-
-      afterDrag $ do
-        X.broadcastMessage $ removeHoleForWindow window
-        curev <- X.asks X.currentEvent
-        afterAction window (maybe 0 X.ev_button curev)
+ifReleased :: X.Button -> AfterDragAction -> AfterDragAction
+ifReleased but (AfterDragAction act) = AfterDragAction $ \win b -> do
+  when (but == b) $ act win b
+
+-- Like ifReleased, but with a function instead of an AfterDragAction
+ifReleased' :: X.Button -> (X.Window -> X.Button -> X ()) -> AfterDragAction
+ifReleased' but act = ifReleased but (AfterDragAction act)
+
+mouseMoveWindowAndThen ::
+  (X.Window -> X ()) ->
+  AfterDragAction ->
+  X.Window ->
+  X ()
+mouseMoveWindowAndThen beforeAction (AfterDragAction releaseAction) window = do
+  beforeAction window
+  tilePosition <- X.withWindowSet $ return . W.windowTilePosition window
+  mapM_ (X.broadcastMessage . flip addHoleForWindow window) tilePosition
+  X.mouseMoveWindow window
+
+  afterDrag $ do
+    X.broadcastMessage $ removeHoleForWindow window
+    curev <- X.asks X.currentEvent
+    releaseAction window (maybe 0 X.ev_button curev)
+    X.refresh
+
+getDisplayAndRoot :: X (X.Display, X.Window)
+getDisplayAndRoot = X.asks $ (,) <$> X.display <*> X.theRoot
+
+pointerLocation :: (Integral a, Integral b) => X (a, b)
+pointerLocation = do
+  (dpy, root) <- getDisplayAndRoot
+  (_, _, _, fromIntegral -> x, fromIntegral -> y, _, _, _) <-
+    io $ X.queryPointer dpy root
+  return (x, y)
+
+pointerWindow :: X X.Window
+pointerWindow = do
+  (dpy, root) <- getDisplayAndRoot
+  (_, _, w, _, _, _, _, _) <-
+    io $ X.queryPointer dpy root
+  return w
+
+dragWorkspace :: X ()
+dragWorkspace = do
+  (ox, oy) <- pointerLocation
+  X.mouseDrag (\_ _ -> return ()) $ do
+    (nx, ny) <- pointerLocation
+    runMaybeT_ $ do
+      (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ X.pointScreen ox oy
+      (W.Screen (W.tag -> ws2) _ _) <- MaybeT $ X.pointScreen nx ny
+
+      lift $ X.windows $ W.switchWorkspaces ws1 ws2
+
+dragWindow :: X ()
+dragWindow = do
+  w <- pointerWindow
+  if w == 0
+    then dragWorkspace
+    else do
+      cleanup <- setBorderColor "#00ffff" [w]
+
+      ref <- io $ newIORef (w, return ())
+
+      X.mouseDrag
+        ( \_ _ -> do
+            w' <- pointerWindow
+            (ow, ocleanup) <- io $ readIORef ref
+            case () of
+              () | ow /= w' -> do
+                ocleanup
+                cleanup' <-
+                  if w' == 0 || w' == w
+                    then return (return ())
+                    else setBorderColor "#80a0a0" [w']
+                io $ writeIORef ref (w', cleanup')
+              () -> return ()
+
+            return ()
+        )
+        $ 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
+              X.windows $ W.focusWindow w . W.swapWindows [(w, w')]
+
+              setAlternateWindows [w, w']
+
+              iocleanup
+              cleanup