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.

1 files changed, 83 insertions, 16 deletions

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.