Add ability to tile-drag

1 files changed, 55 insertions, 2 deletions

diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 4bb87d6..29e0ef7 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -161,6 +161,7 @@ import XMonad.Layout.Spacing
     SpacingModifier (..),
   )
 import XMonad.Util.Run (safeSpawn)
+import XMonad.Util.WindowProperties
 import Prelude hiding ((!!))
 
 type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ())
@@ -1025,6 +1026,50 @@ mouseMap = runButtons $ do
             noMod $
               doc "Start moving the window under the cursor" mouseMoveWindow
 
+          bind button14 $
+            noMod $
+              doc "Start moving the mouse under the cursor, but tile when completed." $
+                noWindow $ do
+                  click
+                  mwindow <- withWindowSet (return . W.getFocusedWindow)
+                  forM_ mwindow $ \window -> do
+                    mouseMoveWindow window
+                    X.modify $ \case
+                      st@(XState {dragging = Just (fn, cleanup)}) ->
+                        st
+                          { dragging =
+                              Just
+                                ( fn,
+                                  do
+                                    cleanup
+                                    (dpy, root) <- asks $ (,) <$> display <*> theRoot
+                                    aw <- withWindowSet (return . W.allVisibleWindows)
+                                    let fi :: (Integral a, Integral b) => a -> b
+                                        fi = fromIntegral
+                                    (_, _, _, fi -> cx, fi -> cy, _, _, _) <- io $ queryPointer dpy root
+                                    match <-
+                                      filterM
+                                        ( \win -> do
+                                            (_, fi -> x, fi -> y, fi -> w, fi -> h, _, _) <- io $ X.getGeometry dpy win
+                                            return
+                                              ( cx > x
+                                                  && cx < x + fi w
+                                                  && cy > y
+                                                  && cy < y + h
+                                                  && win /= window
+                                              )
+                                        )
+                                        aw
+                                    logs Debug "Sink by %d %s" window (show match)
+                                    windows $
+                                      W.focusWindow window
+                                        . case match of
+                                          (w' : _) -> W.sinkBy window w'
+                                          _ -> W.sink window
+                                )
+                          }
+                      s -> s
+
           bind button2 $
             noMod $
               doc "Sink the window under the cursor into the tiling" $
@@ -1323,9 +1368,17 @@ dragWindow = do
         $ do
           (_, _, w', fromIntegral -> nx, fromIntegral -> ny, _, _, _) <- io $ queryPointer dpy root
           (_, iocleanup) <- io $ readIORef ref
-
+          dock <- getAtom "_NET_WM_WINDOW_TYPE_DOCK"
+          desk <- 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
-            0 ->
+            _ | w' == 0 || isDock ->
               runMaybeT_ $ do
                 (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ pointScreen nx ny
                 lift $ do