Add ability to tile-drag

4 files changed, 111 insertions, 70 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
diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
index 7a59cbd..6c46361 100644
--- a/src/Rahm/Desktop/Keys/Wml.hs
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -88,21 +88,6 @@ import Rahm.Desktop.Marking
     windowLocation,
   )
 import qualified Rahm.Desktop.StackSet as W
-  ( RationalRect (RationalRect),
-    Screen (workspace),
-    StackSet (current, floating),
-    Workspace (stack, tag),
-    allWindows,
-    findWindow,
-    float,
-    focusWindow,
-    getLocationWorkspace,
-    greedyView,
-    integrate',
-    screens,
-    shiftWin,
-    sink,
-  )
 import Rahm.Desktop.Submap (mapNextStringWithKeysym)
 import Rahm.Desktop.Workspaces
   ( accompaningWorkspace,
@@ -568,10 +553,7 @@ readNextLocationSet =
       (_, _, "'") -> (: []) <$> MaybeT (fromX lastLocation)
       -- All visible windows.
       (_, _, "*") -> mt $ do
-        wins <-
-          withWindowSet $
-            return . concatMap (W.integrate' . W.stack . W.workspace) . W.screens
-
+        wins <- withWindowSet $ return . W.allVisibleWindows
         catMaybes <$> mapM (runMaybeT . windowLocation) wins
 
       -- The last referenced windows.
@@ -591,7 +573,7 @@ readNextLocationSet =
       -- Windows in a workspace
       (_, _, s)
         | s == "\t" || s == "@" || s == "\n" ->
-            (mt . windowsInWorkspace) =<< readNextWorkspaceName
+          (mt . windowsInWorkspace) =<< readNextWorkspaceName
       -- The first window in the next window set.
       (_, _, "!") -> (: []) <$> joinMaybe (head <$> readNextLocationSet)
       -- The windows except the first in a window set.
diff --git a/src/Rahm/Desktop/Layout/Flip.hs b/src/Rahm/Desktop/Layout/Flip.hs
index b3162c9..1863a28 100644
--- a/src/Rahm/Desktop/Layout/Flip.hs
+++ b/src/Rahm/Desktop/Layout/Flip.hs
@@ -43,11 +43,11 @@ data DoFlip where
 
 -- DoFlip is a monoid.
 instance Semigroup DoFlip where
-  (<>) = mappend
+  (DoFlip a) <> (DoFlip b) = DoFlip (a . b)
 
 instance Monoid DoFlip where
   mempty = DoFlip id
-  mappend (DoFlip a) (DoFlip b) = DoFlip (a . b)
+  mappend = (<>)
 
 -- Makes a layout Flippable.
 flippable :: l a -> ModifiedLayout Flip l a
diff --git a/src/Rahm/Desktop/StackSet.hs b/src/Rahm/Desktop/StackSet.hs
index 9b027d6..36d41a4 100644
--- a/src/Rahm/Desktop/StackSet.hs
+++ b/src/Rahm/Desktop/StackSet.hs
@@ -1,5 +1,6 @@
 module Rahm.Desktop.StackSet
   ( masterWindow,
+    allVisibleWindows,
     windowsOnWorkspace,
     findWorkspace,
     dbgStackSet,
@@ -16,6 +17,9 @@ module Rahm.Desktop.StackSet
     WindowLocation (..),
     windowMemberOfWorkspace,
     findWindow,
+    sinkBy,
+    modifyWorkspace,
+    getFocusedWindow,
     module W,
   )
 where
@@ -32,52 +36,7 @@ import qualified Data.Map as Map
 import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
 import Text.Printf (printf)
 import XMonad (Rectangle (..), ScreenDetail (..), WindowSet)
-import XMonad.StackSet as W
-  ( RationalRect (..),
-    Screen (..),
-    Stack (..),
-    StackSet (..),
-    Workspace (..),
-    abort,
-    allWindows,
-    currentTag,
-    delete,
-    delete',
-    differentiate,
-    ensureTags,
-    filter,
-    findTag,
-    float,
-    focusDown,
-    focusDown',
-    focusMaster,
-    focusUp,
-    focusUp',
-    focusWindow,
-    index,
-    insertUp,
-    integrate,
-    integrate',
-    lookupWorkspace,
-    mapLayout,
-    mapWorkspace,
-    member,
-    modify,
-    modify',
-    new,
-    peek,
-    renameTag,
-    screens,
-    shift,
-    shiftMaster,
-    sink,
-    swapDown,
-    swapMaster,
-    swapUp,
-    tagMember,
-    view,
-    workspaces,
-  )
+import XMonad.StackSet as W hiding (greedyView, shiftWin)
 import qualified XMonad.StackSet (shiftWin)
 import Prelude hiding (head)
 
@@ -91,6 +50,10 @@ getLocationWorkspace (OnScreen (Screen w _ _)) = Just w
 getLocationWorkspace (OnHiddenWorkspace w) = Just w
 getLocationWorkspace _ = Nothing
 
+allVisibleWindows :: StackSet i l a s sd -> [a]
+allVisibleWindows =
+  concatMap (W.integrate' . W.stack . W.workspace) <$> W.screens
+
 mapWindows :: (Ord a, Ord b) => (a -> b) -> StackSet i l a s sd -> StackSet i l b s sd
 mapWindows fn (StackSet cur vis hid float) =
   StackSet
@@ -251,3 +214,46 @@ findWindow (StackSet cur vis hid float) win =
 
 windowMemberOfWorkspace :: (Eq a) => Workspace i l a -> a -> Bool
 windowMemberOfWorkspace (Workspace _ _ s) w = w `elem` integrate' s
+
+modifyWorkspace :: (Eq i) => i -> (Workspace i l a -> Workspace i l a) -> StackSet i l a s sd -> StackSet i l a s sd
+modifyWorkspace tag fn =
+  mapWorkspace
+    ( \ws ->
+        if W.tag ws == tag
+          then fn ws
+          else ws
+    )
+
+getFocusedWindow :: StackSet i l a s sd -> Maybe a
+getFocusedWindow (StackSet cur _ _ _) = W.focus <$> (W.stack . W.workspace) cur
+
+sinkBy :: (Eq a, Eq i, Ord a) => a -> a -> StackSet i l a s sd -> StackSet i l a s sd
+sinkBy win toSinkBy ss =
+  case (findTag win ss, findTag toSinkBy ss) of
+    (Nothing, _) -> ss
+    (Just w1, Just w2)
+      | w1 == w2 ->
+        modifyWorkspace
+          w1
+          ( \(W.Workspace t l s) ->
+              W.Workspace t l (Just $ insertBy win toSinkBy s)
+          )
+          $ W.delete win ss
+    _ -> W.sink win ss
+  where
+    insertBy win to Nothing = W.Stack win [] []
+    insertBy win to (Just (W.Stack foc down up)) =
+      case () of
+        ()
+          | to `elem` down ->
+            W.Stack
+              foc
+              (concatMap (\e -> if e == to then [e, win] else [e]) down)
+              up
+        ()
+          | to `elem` up ->
+            W.Stack
+              foc
+              down
+              (concatMap (\e -> if e == to then [win, e] else [e]) up)
+        () -> W.Stack win (foc : down) up