Better modelling for moving between windows. Reworked shifting windows and made the movement atomic to improve speed

3 files changed, 57 insertions, 56 deletions

diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs
index 01fa35b..993726b 100644
--- a/src/Rahm/Desktop/Common.hs
+++ b/src/Rahm/Desktop/Common.hs
@@ -19,6 +19,7 @@ module Rahm.Desktop.Common
   )
 where
 
+import Rahm.Desktop.Logger
 import Data.Void (absurd, Void (..))
 import Data.Either (either)
 import Control.Applicative ((<*))
@@ -149,12 +150,10 @@ withBorderColorE color wins fn = do
     lift $ setWindowBorderWithFallback d w colorName px
 
   myFinallyE fn $
-    lift $
-      withFocused $ \fw -> do
-        forM_ wins $ \w ->
-          when (w /= fw) $
-            setWindowBorderWithFallback d w oColorName oPx
-
+    lift $ do
+      forM_ wins $ \w ->
+        setWindowBorderWithFallback d w oColorName oPx
+      withFocused $ \fw ->
         setWindowBorderWithFallback d fw fColorName fPx
 
 withBorderColorM :: String -> [Window] -> MaybeT X a -> MaybeT X a
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 49f0ebf..bc80aa9 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -80,7 +80,7 @@ import Rahm.Desktop.Keys.Dsl
   )
 import Rahm.Desktop.Keys.Wml
   ( gotoWorkspaceFn,
-    moveLocationToWorkspaceFn,
+    moveWindowToWorkspaceFn,
     readNextLocationSet,
     readNextWorkspace,
     readWindowsetMacro,
@@ -144,7 +144,7 @@ import Rahm.Desktop.XMobarLog.PendingBuffer
     pushPendingBuffer,
   )
 import Text.Printf (printf)
-import XMonad
+import XMonad as X
 import XMonad.Actions.CopyWindow as CopyWindow
 import XMonad.Actions.RotSlaves
   ( rotAllDown,
@@ -292,9 +292,12 @@ keymap = runKeys $ do
           runMaybeT_ $ do
             l1 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet
             withBorderColorM "#00ffff" l1 $ do
+              lift $ addStringToPendingBuffer " "
               l2 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet
               let rewriteMap = Map.fromList $ zip l1 l2 ++ zip l2 l1
-              lift $ windows $ mapWindows (\w -> fromMaybe w (Map.lookup w rewriteMap))
+              lift $ do
+                setAlternateWindows l1
+                windows $ mapWindows (\w -> fromMaybe w (Map.lookup w rewriteMap))
 
   bind xK_BackSpace $ do
     -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if
@@ -576,33 +579,34 @@ keymap = runKeys $ do
 
   bind xK_s $ do
     forM_ [(False, justMod), (True, shiftMod)] $ \(doView, f) ->
-      f $
-        doc
+      f $ doc
           ( if doView
               then "Shift a windowset to a workspace and goto that workspace."
               else "Shift a windowset to a workspace"
           )
-          $ pushPendingBuffer (if doView then "S " else "s ") $ do
-            maybeLocs <- runMaybeT readNextLocationSet
-            addStringToPendingBuffer " "
-
-            forM_ maybeLocs $ \locations -> do
-              let locationWindows = mapMaybe locationWindow locations
-              withBorderColor "#00ffff" locationWindows $ do
+          $
+            pushPendingBuffer (if doView then "S " else "s ") $
                 runMaybeT_ $ do
-                  workspace <- readNextWorkspace
-                  mapM_ (lift . moveLocationToWorkspaceFn workspace) locations
-
-                  lift $ setAlternateWindows locationWindows
-                  forM_ locations $ \loc ->
-                    case locationWindow loc of
-                      Nothing -> return ()
-                      Just win -> do
-                        lift $ setAlternateWorkspace win (locationWorkspace loc)
-
-                  wsName <- MaybeT $ return (workspaceName workspace)
-                  when doView $
-                    lift $ windows $ W.greedyView wsName
+                  stackset <- lift $ X.windowset <$> X.get
+                  selection <- mapMaybe locationWindow <$> readNextLocationSet
+
+                  withBorderColorM "#00ffff" selection $ do
+                    ws <- readNextWorkspace
+                    (Endo allMovements) <- lift $ mconcat <$> mapM (fmap Endo . moveWindowToWorkspaceFn ws) selection
+                    lift $ do
+                      setAlternateWindows selection
+                      forM_ selection $ \win -> do
+                        mapM_ (\t -> do
+                           logs Debug "Set alternate workspace %s -> %s" (show win) t
+                           setAlternateWorkspace win t) (W.findTag win stackset)
+
+                      windows $ (\ss ->
+                        case () of
+                          () | doView,
+                               (w:_) <- selection,
+                               Just ws <- W.findTag w ss -> W.greedyView ws ss
+                          _ -> ss
+                        ) . allMovements
 
     altMod $ spawnX "sudo -A systemctl suspend && xsecurelock"
 
diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
index e7a7cb9..8abb17b 100644
--- a/src/Rahm/Desktop/Keys/Wml.hs
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -18,7 +18,7 @@ module Rahm.Desktop.Keys.Wml
     readNextWorkspace,
     readNextLocationSet,
     moveLocationToWorkspace,
-    moveLocationToWorkspaceFn,
+    moveWindowToWorkspaceFn,
     gotoWorkspaceFn,
     readMacroString,
     justWorkspace,
@@ -96,6 +96,7 @@ import qualified Rahm.Desktop.StackSet as W
     focusWindow,
     getLocationWorkspace,
     greedyView,
+    shiftWin,
     integrate',
     screens,
     sink,
@@ -131,6 +132,7 @@ import XMonad
     Typeable,
     Window,
     WorkspaceId,
+    WindowSet,
     X,
     asks,
     directories,
@@ -209,7 +211,8 @@ instance ExtensionClass MaybeMacros where
 data Workspace = forall a.
   (Typeable a) =>
   Workspace
-  { moveLocationToWorkspaceFn :: Location -> X (),
+  {
+    moveWindowToWorkspaceFn :: Window -> X (WindowSet -> WindowSet),
     gotoWorkspaceFn :: X (),
     workspaceName :: Maybe String,
     extraWorkspaceData :: a
@@ -247,7 +250,7 @@ readMacroString = do
 justWorkspace :: String -> Workspace
 justWorkspace s =
   Workspace
-    { moveLocationToWorkspaceFn = flip moveLocationToWorkspace s,
+    { moveWindowToWorkspaceFn = return . W.shiftWin s,
       gotoWorkspaceFn = gotoWorkspace s,
       workspaceName = Just s,
       extraWorkspaceData = ()
@@ -256,7 +259,7 @@ justWorkspace s =
 justWorkspaceWithPreferredWindow :: Window -> String -> Workspace
 justWorkspaceWithPreferredWindow w s =
   Workspace
-    { moveLocationToWorkspaceFn = flip moveLocationToWorkspace s,
+    { moveWindowToWorkspaceFn = return . W.shiftWin s,
       gotoWorkspaceFn = do
         windows $ \ws' ->
           let ws = W.greedyView s ws'
@@ -271,7 +274,7 @@ justWorkspaceWithPreferredWindow w s =
 blackHoleWorkspace :: Workspace
 blackHoleWorkspace =
   Workspace
-    { moveLocationToWorkspaceFn = mapM_ killWindow . locationWindow,
+    { moveWindowToWorkspaceFn = \w -> killWindow w >> return id,
       gotoWorkspaceFn =
         confirmPrompt def "Do you want to exit xmonad" $ io exitSuccess,
       workspaceName = Nothing,
@@ -281,14 +284,10 @@ blackHoleWorkspace =
 alternateWorkspace :: Workspace
 alternateWorkspace =
   Workspace
-    { moveLocationToWorkspaceFn = \l@(Location _ maybeWin) -> do
-        logs Info "Moving Location: %s" (show l)
-        case maybeWin of
-          Nothing -> return ()
-          Just win -> do
-            alter <- getAlternateWorkspace win
-            logs Info "Moving %s to %s" (show win) (show alter)
-            mapM_ (moveLocationToWorkspace l) alter,
+    { moveWindowToWorkspaceFn = \win -> do
+          alter <- getAlternateWorkspace win
+          return $ \ss -> 
+            maybe ss (\a -> W.shiftWin a win ss) alter,
       gotoWorkspaceFn = do
         (Location _ maybeWin) <- getCurrentLocation
         case maybeWin of
@@ -304,18 +303,17 @@ newtype FloatWorkspace = FloatWorkspace Workspace
 floatWorkspace :: Workspace -> Workspace
 floatWorkspace ws@Workspace {extraWorkspaceData = d} =
   Workspace
-    { moveLocationToWorkspaceFn = \location -> do
-        forM_ (locationWindow location) $ \win -> do
-          case cast d of
-            Just (FloatWorkspace ws') -> do
-              windows $ W.sink win
-              moveLocationToWorkspaceFn ws' location
-            Nothing -> do
-              windows $ \ss ->
-                if win `Map.member` W.floating ss
-                  then ss -- win is already floating
-                  else W.float win (W.RationalRect (1 / 8) (1 / 8) (6 / 8) (6 / 8)) ss
-              moveLocationToWorkspaceFn ws location,
+    { moveWindowToWorkspaceFn = \win -> do
+        case cast d of
+          Just (FloatWorkspace ws') -> do
+            movefn <- moveWindowToWorkspaceFn ws' win
+            return $ W.sink win . movefn
+          Nothing ->do
+            movefn <- moveWindowToWorkspaceFn ws win
+            return $ \ss -> do
+              if win `Map.member` W.floating ss
+                then movefn ss
+                else movefn $ W.float win (W.RationalRect (1 / 8) (1 / 8) (6 / 8) (6 / 8)) ss,
       gotoWorkspaceFn = gotoWorkspaceFn ws,
       workspaceName = workspaceName ws,
       extraWorkspaceData = FloatWorkspace ws