Change some of how Workspaces work in WML.

This change adds a "workspaceWindows" function on a pseudo-workspace
level so now the windowsets '@_', '@#', '@-' actually have meaning.

Also now the "move to workspace" function buffers the windows which
makes things more responsive and intuitive.

3 files changed, 126 insertions, 55 deletions

diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 4848998..6dceffd 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -705,7 +705,7 @@ bindings = do
           $ do
             stackset <- lift $ X.windowset <$> X.get
             selection <- mapMaybe locationWindow <$> runKeyFeed readNextLocationSet
-            withBorderColorM selectedWindowsColor selection $ do
+            (allMovements, finalSwap) <- withBorderColorM selectedWindowsColor selection $ do
               lift $ addStringToPendingBuffer " "
               ws <- runKeyFeed readNextWorkspace
               finalSwap <-
@@ -717,9 +717,7 @@ bindings = do
                   _ -> return id
 
               lift $ do
-                (Endo allMovements) <-
-                  mconcat
-                    <$> mapM (fmap Endo . moveWindowToWorkspaceFn ws) selection
+                allMovements <- moveWindowsToWorkspaceFn ws selection
 
                 setAlternateWindows selection
 
@@ -730,19 +728,21 @@ bindings = do
                         setAlternateWorkspace win t
                     )
                     (W.findTag win stackset)
-
-                withWindowsUnpinned selection $
-                  windows $
-                    finalSwap
-                      . ( \ss ->
-                            case shiftType of
-                              ShiftAndFollow
-                                | (w : _) <- selection,
-                                  Just ws <- W.findTag w ss ->
-                                    W.greedyView ws ss
-                              _ -> ss
-                        )
-                      . allMovements
+                return (allMovements, finalSwap)
+
+            lift $
+              withWindowsUnpinned selection $
+                windows $
+                  finalSwap
+                    . ( \ss ->
+                          case shiftType of
+                            ShiftAndFollow
+                              | (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 d3e741b..19538fc 100644
--- a/src/Rahm/Desktop/Keys/Wml.hs
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -19,7 +19,7 @@ module Rahm.Desktop.Keys.Wml
     readNextLocationSet,
     readNextLocationSet',
     moveLocationToWorkspace,
-    moveWindowToWorkspaceFn,
+    moveWindowsToWorkspaceFn,
     getAndResetWindowSelection,
     getAndResetWindowSelectionOrCurrent,
     getWindowSelection,
@@ -68,6 +68,7 @@ import Data.List.Safe (head, last)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (catMaybes, fromJust, fromMaybe, maybeToList)
+import Data.Monoid (Endo (Endo, appEndo))
 import Data.Ord (Down (..))
 import Data.Typeable (cast)
 import Data.Void (Void, absurd)
@@ -86,7 +87,7 @@ import Rahm.Desktop.History
     nextLocation,
   )
 import Rahm.Desktop.Keys.KeyFeed
-import Rahm.Desktop.Layout.PinWindow (pinnedWindows)
+import Rahm.Desktop.Layout.PinWindow (pinWindows, pinnedWindows, unpinWindow)
 import Rahm.Desktop.Logger
 import Rahm.Desktop.Marking
   ( farLeftWindow,
@@ -265,12 +266,17 @@ getAndResetWindowSelectionOrCurrent = do
 data Workspace = forall a.
   (Typeable a) =>
   Workspace
-  { moveWindowToWorkspaceFn :: Window -> X (WindowSet -> WindowSet),
+  { moveWindowsToWorkspaceFn :: [Window] -> X (WindowSet -> WindowSet),
     gotoWorkspaceFn :: X (),
     workspaceName :: Maybe String,
+    accompanying :: Maybe Workspace,
+    workspaceWindows :: X [Location],
     extraWorkspaceData :: a
   }
 
+forSingleWindow :: (Window -> X (WindowSet -> WindowSet)) -> [Window] -> X (WindowSet -> WindowSet)
+forSingleWindow fn ws = appEndo . mconcat <$> mapM (fmap Endo . fn) ws
+
 readWorkspaceMacro :: MaybeT X ()
 readWorkspaceMacro =
   mapNextStringWithKeysym $ \mask sym s -> do
@@ -303,16 +309,18 @@ readMacroString = do
 justWorkspace :: String -> Workspace
 justWorkspace s =
   Workspace
-    { moveWindowToWorkspaceFn = return . W.shiftWin s,
+    { moveWindowsToWorkspaceFn = forSingleWindow $ return . W.shiftWin s,
       gotoWorkspaceFn = gotoWorkspace s,
       workspaceName = Just s,
+      accompanying = Just $ justWorkspace $ accompanyingWorkspace s,
+      workspaceWindows = windowsInWorkspace s,
       extraWorkspaceData = ()
     }
 
 justWorkspaceWithPreferredWindow :: Window -> String -> Workspace
 justWorkspaceWithPreferredWindow w s =
   Workspace
-    { moveWindowToWorkspaceFn = return . W.shiftWin s,
+    { moveWindowsToWorkspaceFn = forSingleWindow $ return . W.shiftWin s,
       gotoWorkspaceFn = do
         windows $ \ws' ->
           let ws = W.greedyView s ws'
@@ -321,23 +329,27 @@ justWorkspaceWithPreferredWindow w s =
                 then W.focusWindow w ws
                 else ws,
       workspaceName = Just s,
+      accompanying = Just $ justWorkspace $ accompanyingWorkspace s,
+      workspaceWindows = windowsInWorkspace s,
       extraWorkspaceData = ()
     }
 
 blackHoleWorkspace :: Workspace
 blackHoleWorkspace =
   Workspace
-    { moveWindowToWorkspaceFn = \w -> killWindow w >> return id,
+    { moveWindowsToWorkspaceFn = forSingleWindow $ \w -> killWindow w >> return id,
       gotoWorkspaceFn =
         confirmPrompt def "Do you want to exit xmonad" $ io exitSuccess,
       workspaceName = Nothing,
+      accompanying = Nothing,
+      workspaceWindows = return [],
       extraWorkspaceData = ()
     }
 
 alternateWorkspace :: Workspace
 alternateWorkspace =
   Workspace
-    { moveWindowToWorkspaceFn = \win -> do
+    { moveWindowsToWorkspaceFn = forSingleWindow $ \win -> do
         alter <- getAlternateWorkspace win
         return $ \ss ->
           maybe ss (\a -> W.shiftWin a win ss) alter,
@@ -348,6 +360,39 @@ alternateWorkspace =
           Just win -> do
             mapM_ gotoWorkspace =<< getAlternateWorkspace win,
       workspaceName = Nothing,
+      accompanying = Nothing,
+      workspaceWindows =
+        let m Nothing = []
+            m (Just l) = l
+         in fmap m $
+              runMaybeT $
+                mapM windowLocation =<< lift getAlternateWindows,
+      extraWorkspaceData = ()
+    }
+
+unpinningWorkspace :: Workspace
+unpinningWorkspace =
+  Workspace
+    { moveWindowsToWorkspaceFn = forSingleWindow $ \win -> do
+        unpinWindow win
+        return id,
+      gotoWorkspaceFn = return (),
+      workspaceName = Nothing,
+      accompanying = Just pinningWorkspace,
+      workspaceWindows = return [],
+      extraWorkspaceData = ()
+    }
+
+pinningWorkspace :: Workspace
+pinningWorkspace =
+  Workspace
+    { moveWindowsToWorkspaceFn = \wins -> do
+        pinWindows wins
+        return id,
+      gotoWorkspaceFn = return (),
+      workspaceName = Nothing,
+      accompanying = Just unpinningWorkspace,
+      workspaceWindows = map (Location "*" . Just) <$> pinnedWindows,
       extraWorkspaceData = ()
     }
 
@@ -356,19 +401,39 @@ newtype FloatWorkspace = FloatWorkspace Workspace
 floatWorkspace :: Workspace -> Workspace
 floatWorkspace ws@Workspace {extraWorkspaceData = d} =
   Workspace
-    { moveWindowToWorkspaceFn = \win -> do
+    { moveWindowsToWorkspaceFn = \wins -> do
         case cast d of
           Just (FloatWorkspace ws') -> do
-            movefn <- moveWindowToWorkspaceFn ws' win
-            return $ W.sink win . movefn
+            movefn <- moveWindowsToWorkspaceFn ws' wins
+            return $ (appEndo . mconcat $ map (Endo . W.sink) wins) . movefn
           Nothing -> do
-            movefn <- moveWindowToWorkspaceFn ws win
+            movefn <- moveWindowsToWorkspaceFn ws wins
             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,
+              appEndo
+                ( mconcat $
+                    map
+                      ( \win ->
+                          Endo $
+                            if win `Map.member` W.floating ss
+                              then movefn
+                              else
+                                movefn
+                                  . W.float
+                                    win
+                                    ( W.RationalRect
+                                        (1 / 8)
+                                        (1 / 8)
+                                        (6 / 8)
+                                        (6 / 8)
+                                    )
+                      )
+                      wins
+                )
+                ss,
       gotoWorkspaceFn = gotoWorkspaceFn ws,
       workspaceName = workspaceName ws,
+      accompanying = Just $ floatWorkspace ws,
+      workspaceWindows = workspaceWindows ws,
       extraWorkspaceData = FloatWorkspace ws
     }
 
@@ -520,7 +585,7 @@ readNextWorkspace =
 
       -- The accompanying worksapce to the next read workspace.
       (_, _, "~") ->
-        justWorkspace . accompanyingWorkspace <$> readNextWorkspaceName
+        absorbMaybe $ accompanying <$> readNextWorkspace
       -- The accompanying workspace to the current workspace (equivalent to ~.)
       (_, _, " ") ->
         liftXToFeed $
@@ -531,6 +596,8 @@ readNextWorkspace =
       -- The alternate workspace
       (_, _, "-") ->
         return alternateWorkspace
+      (_, _, "#") ->
+        return pinningWorkspace
       -- If the next two read workspaces are equal, go to the third workspace
       -- otherwise go to the fourth workspace.
       (_, _, "=") -> do
@@ -628,7 +695,7 @@ readNextLocationSet' =
       -- Windows in a workspace
       (_, _, s)
         | s == "\t" || s == "@" || s == "\n" ->
-            (liftXToFeed . windowsInWorkspace) =<< readNextWorkspaceName
+            (liftXToFeed . workspaceWindows) =<< readNextWorkspace
       -- The first window in the next window set.
       (_, _, "!") -> (: []) <$> absorbMaybe (head <$> readNextLocationSet)
       -- The windows except the first in a window set.
diff --git a/src/Rahm/Desktop/Layout/PinWindow.hs b/src/Rahm/Desktop/Layout/PinWindow.hs
index 36dbf27..01be07d 100644
--- a/src/Rahm/Desktop/Layout/PinWindow.hs
+++ b/src/Rahm/Desktop/Layout/PinWindow.hs
@@ -4,7 +4,7 @@ module Rahm.Desktop.Layout.PinWindow where
 
 import Control.Arrow (Arrow (second))
 import Control.Exception (throw)
-import Control.Monad (unless, when)
+import Control.Monad (forM_, unless, when)
 import Control.Monad.Trans (lift)
 import Control.Monad.Trans.Maybe (MaybeT (..))
 import Data.Foldable (find)
@@ -16,13 +16,13 @@ import Data.Maybe (fromMaybe, mapMaybe, maybe)
 import Data.Semigroup (Endo (..))
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Rahm.Desktop.Common (runMaybeT_)
+import Rahm.Desktop.BorderColors (BorderColor (BorderColor), resetBorderColor, setBorderColor)
+import Rahm.Desktop.Common (floatAll, runMaybeT_)
 import Rahm.Desktop.Logger
 import qualified Rahm.Desktop.StackSet as W
 import XMonad
 import qualified XMonad.StackSet as W (filter)
 import qualified XMonad.Util.ExtensibleState as XS
-import Rahm.Desktop.BorderColors (setBorderColor, BorderColor (BorderColor), resetBorderColor)
 
 newtype PinWindowState = PinWindowState (Map ScreenId [(Window, W.RationalRect)])
   deriving (Show, Read)
@@ -85,26 +85,30 @@ instance (LayoutClass l a, sid ~ ScreenId, a ~ Window) => LayoutClass (PinWindow
     return (PinWindowLayout <$> maybeNewLayout)
 
 pinWindow :: Window -> X ()
-pinWindow win = runMaybeT_ $ do
-  lift $ logs Debug "Pinning window %d" win
-  lift $ float win
-
-  ws@(W.StackSet cur vis _ flt) <- gets windowset
-  t <- hoist (W.findTag win ws)
-  scr <- hoist $ find ((== t) . (W.tag . W.workspace)) (cur : vis)
-  rect <- hoist $ Map.lookup win flt
-
+pinWindow = pinWindows . (: [])
+
+pinWindows :: [Window] -> X ()
+pinWindows wins = runMaybeT_ $ do
+  lift $ floatAll wins
+
+  forM_ wins $ \win -> do
+    ws@(W.StackSet cur vis _ flt) <- gets windowset
+    t <- hoist (W.findTag win ws)
+    scr <- hoist $ find ((== t) . (W.tag . W.workspace)) (cur : vis)
+    rect <- hoist $ Map.lookup win flt
+
+    lift $ do
+      XS.modify $ \(PinWindowState mp) ->
+        PinWindowState $
+          Map.alter
+            (Just . maybe [(win, rect)] ((win, rect) :))
+            (W.screen scr)
+            mp
+
+  -- Don't float the window anymore.
   lift $ do
-    XS.modify $ \(PinWindowState mp) ->
-      PinWindowState $
-        Map.alter
-          (Just . maybe [(win, rect)] ((win, rect) :))
-          (W.screen scr)
-          mp
-
-    -- Don't float the window anymore.
-    modifyWindowSet $ W.sink win
-    setBorderColor pinnedWindowColor [win]
+    modifyWindowSet $ appEndo $ mconcat (map (Endo . W.sink) wins)
+    setBorderColor pinnedWindowColor wins
   where
     hoist = MaybeT . return