Add ability to swap two workspaces with the W command

4 files changed, 223 insertions, 149 deletions

diff --git a/src/Rahm/Desktop/Common.hs b/src/Rahm/Desktop/Common.hs
index 47156bb..4787598 100644
--- a/src/Rahm/Desktop/Common.hs
+++ b/src/Rahm/Desktop/Common.hs
@@ -185,7 +185,9 @@ withBorderWidth width ws fn = do
   return ret
 
 gotoWorkspace :: WorkspaceId -> X ()
-gotoWorkspace wid = windows $ S.greedyView wid
+gotoWorkspace wid = do
+   logs Debug "GotoWorkspace %s" wid
+   windows $ S.greedyView wid
 
 moveLocationToWorkspace :: Location -> WorkspaceId -> X ()
 moveLocationToWorkspace (Location _ (Just win)) wid =
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index d153a18..9e3e427 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -83,10 +83,11 @@ import Rahm.Desktop.Keys.Wml
     moveWindowToWorkspaceFn,
     readNextLocationSet,
     readNextWorkspace,
+    readNextWorkspaceName,
     readWindowsetMacro,
     readWorkspaceMacro,
-    workspaceForStringT,
     workspaceForString,
+    workspaceForStringT,
     workspaceName,
   )
 import Rahm.Desktop.Layout (nLayouts)
@@ -296,9 +297,28 @@ keymap = runKeys $ do
             withBorderColorM "#00ffff" l1 $ do
               lift $ addStringToPendingBuffer " "
               l2 <- mapMaybe (\(Location _ w) -> w) <$> readNextLocationSet
+              let (l1', l2') =
+                    if length l1 > length l2
+                      then (l1, l2)
+                      else (l2, l1)
+                  l1'' = filter (not . (`elem` l2')) l1'
+
               lift $ do
-                setAlternateWindows l1
-                windows $ W.swapWindows $ zip l1 l2 ++ zip l2 l1
+                setAlternateWindows (l1'' ++ l2')
+                windows $ W.swapWindows $ zip l1'' l2' ++ zip l2' l1''
+    shiftMod $
+      doc "Swap two workspaces (or rename the current one). \
+      \(only works on normal workspaces)." $
+        pushPendingBuffer "W "$ do
+          logs Debug "%s" . W.dbgStackSet =<< gets windowset
+          runMaybeT_ $ do
+            w1 <- readNextWorkspaceName
+            wins <- lift $ W.windowsOnWorkspace w1 <$> gets windowset
+            withBorderColorM "#00ffff" wins $ do
+              lift $ addStringToPendingBuffer " "
+              w2 <- readNextWorkspaceName
+              lift $ windows $ W.swapWorkspaces w1 w2
+
 
   bind xK_BackSpace $ do
     -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if
@@ -406,8 +426,8 @@ keymap = runKeys $ do
         sendMessage flipHorizontally
 
   bind xK_g $ do
-    justMod
-      $ doc
+    justMod $
+      doc
         "Goto To a workspace\n\n\t\
         \Workspacs are alphanumeric characters. So if the next key typed is an\n\t\
         \alphanumeric character, that's the workspace to operate on\n\n\
@@ -426,12 +446,12 @@ keymap = runKeys $ do
         \_: Black hole. Sending a window here closes it.\n\n\t\
         \Other keybindings starting with H-g\n\t\t\
         \F1: display this help.\n\n\t"
-      $ pushPendingBuffer "g "
-      $ runMaybeT_
-      $ (lift . gotoWorkspaceFn) =<< readNextWorkspace
+        $ pushPendingBuffer "g " $
+          runMaybeT_ $
+            (lift . gotoWorkspaceFn) =<< readNextWorkspace
 
-    shiftMod
-      $ doc
+    shiftMod $
+      doc
         "Switch to a different theater.\n\n\t\
         \Theaters are like super-workspaces. They are used for different\n\t\
         \'contexts'. Theaters share all the windows with eachother, but\n\t\
@@ -439,47 +459,47 @@ keymap = runKeys $ do
         \one theater can have window 'x' on workspace 'y', but another might\n\t\
         \have 'x' on 'z' instead. If a theater does explicity place a window,\n\t\
         \the window is placed in the hidden workspace (which is '*')\n"
-      $ pushPendingBuffer "G "
-      $ runMaybeT_
-      $ do
-        mapNextString $ \_ str -> lift $
-          case str of
-            [ch] | isAlpha ch -> restoreTheater (Just [ch])
-            [' '] -> restoreTheater Nothing
-            _ -> return ()
+        $ pushPendingBuffer "G " $
+          runMaybeT_ $
+            do
+              mapNextString $ \_ str -> lift $
+                case str of
+                  [ch] | isAlpha ch -> restoreTheater (Just [ch])
+                  [' '] -> restoreTheater Nothing
+                  _ -> return ()
 
   bind xK_d $
     justMod $
       doc "Record (define) macros." $
         subkeys $ do
-          bind xK_w
-            $ noMod
-            $ doc
-              "Record a windowset macro.\n\n\t\
-              \To record a 'windowset' macro, type <M-d>w<key> and then\n\t\
-              \type a character sequence followed by Enter. Now <key> can\n\t\
-              \be used anywhere a 'windowset' is required and that macro\n\t\
-              \will be used.\n\n\t\
-              \For example, if one wants to define '+' as 'all windows \n\t\
-              \not on the current workspace, one can type:\n\n\t\
-              \<M-d>w+\\%@.<Enter>\n"
-            $ pushPendingBuffer "Win Macro "
-            $ runMaybeT_ readWindowsetMacro
-
-          bind xK_t
-            $ noMod
-            $ doc
-              "Record a workspace macro\n\n\t\
-              \To record a 'workspace' macro, type <M-d>t<key> and then\n\t\
-              \type a character sequence followed by Enter. Now <key> can\n\t\
-              \be used anywhere a 'workspace' is required and that macro\n\t\
-              \will be used.\n\n\t\
-              \For example, if one wants to define '<c-s>' as 'the workspace with\n\t\
-              \the window 's' on it or the last workspace if already on that \n\t\
-              \workspace (more useful that one would think):\n\n\t\
-              \<M-d>t<c-s>?&s@.'s<Enter>\n"
-            $ pushPendingBuffer "Wksp Macro "
-            $ runMaybeT_ readWorkspaceMacro
+          bind xK_w $
+            noMod $
+              doc
+                "Record a windowset macro.\n\n\t\
+                \To record a 'windowset' macro, type <M-d>w<key> and then\n\t\
+                \type a character sequence followed by Enter. Now <key> can\n\t\
+                \be used anywhere a 'windowset' is required and that macro\n\t\
+                \will be used.\n\n\t\
+                \For example, if one wants to define '+' as 'all windows \n\t\
+                \not on the current workspace, one can type:\n\n\t\
+                \<M-d>w+\\%@.<Enter>\n"
+                $ pushPendingBuffer "Win Macro " $
+                  runMaybeT_ readWindowsetMacro
+
+          bind xK_t $
+            noMod $
+              doc
+                "Record a workspace macro\n\n\t\
+                \To record a 'workspace' macro, type <M-d>t<key> and then\n\t\
+                \type a character sequence followed by Enter. Now <key> can\n\t\
+                \be used anywhere a 'workspace' is required and that macro\n\t\
+                \will be used.\n\n\t\
+                \For example, if one wants to define '<c-s>' as 'the workspace with\n\t\
+                \the window 's' on it or the last workspace if already on that \n\t\
+                \workspace (more useful that one would think):\n\n\t\
+                \<M-d>t<c-s>?&s@.'s<Enter>\n"
+                $ pushPendingBuffer "Wksp Macro " $
+                  runMaybeT_ readWorkspaceMacro
 
   bind xK_h $ do
     justMod $
@@ -530,44 +550,44 @@ keymap = runKeys $ do
         spawnX "xsecurelock"
 
   bind xK_minus $ do
-    justMod
-      $ doc
+    justMod $
+      doc
         "Decrease the number of windows in the  master region, or decrease\n\t\
         \the size of the master region if the current layout cannot have more\n\t\
         \than one window in the master region."
-      $ sendMessage
-      $ IncMasterN (-1)
+        $ sendMessage $
+          IncMasterN (-1)
 
     shiftMod $
       doc "For mosaic layout, shrink the size-share of the current window" $
         sendMessage =<< shrinkPositionAlt
 
   bind xK_m $ do
-    justMod
-      $ doc
+    justMod $
+      doc
         "Mark the windows described by the window set with a given character.\n\n\t\
         \For example, to mark the current window use <M-m>.<character>. That window\n\n\t\
         \can then be recalled anywhere that requires a WML window.\n"
-      $ do
-        pushPendingBuffer "m " $ do
-          locs <- fromMaybe [] <$> runMaybeT readNextLocationSet
-          let wins = mapMaybe locationWindow locs
-          unless (null wins) $ do
-            withBorderColor "#00ffff" wins $ do
-              runMaybeT_ $ do
-                mapNextString $ \_ str -> lift $
-                  case str of
-                    [ch] | isAlpha ch -> markAllLocations str locs
-                    _ -> return ()
+        $ do
+          pushPendingBuffer "m " $ do
+            locs <- fromMaybe [] <$> runMaybeT readNextLocationSet
+            let wins = mapMaybe locationWindow locs
+            unless (null wins) $ do
+              withBorderColor "#00ffff" wins $ do
+                runMaybeT_ $ do
+                  mapNextString $ \_ str -> lift $
+                    case str of
+                      [ch] | isAlpha ch -> markAllLocations str locs
+                      _ -> return ()
 
   bind xK_plus $ do
-    justMod
-      $ doc
+    justMod $
+      doc
         "Increase the number of windows in the  master region, or increase\n\t\
         \the size of the master region if the current layout cannot have more\n\t\
         \than one window in the master region.\n"
-      $ sendMessage
-      $ IncMasterN 1
+        $ sendMessage $
+          IncMasterN 1
 
     shiftMod $
       doc "For mosaic layout, increase the size-share of the current window." $
@@ -586,46 +606,46 @@ 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 ")
-        $ runMaybeT_
-        $ do
-          stackset <- lift $ X.windowset <$> X.get
-          selection <- mapMaybe locationWindow <$> readNextLocationSet
-
-          withBorderColorM "#00ffff" selection $ do
-            ws <- readNextWorkspace
-            lift $ do
-              (Endo allMovements) <-
-                mconcat
-                  <$> mapM (fmap Endo . moveWindowToWorkspaceFn ws) selection
-
-              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
+          $ pushPendingBuffer (if doView then "S " else "s ") $
+            runMaybeT_ $
+              do
+                stackset <- lift $ X.windowset <$> X.get
+                selection <- mapMaybe locationWindow <$> readNextLocationSet
+
+                withBorderColorM "#00ffff" selection $ do
+                  ws <- readNextWorkspace
+                  lift $ do
+                    (Endo allMovements) <-
+                      mconcat
+                        <$> mapM (fmap Endo . moveWindowToWorkspaceFn ws) selection
+
+                    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"
 
@@ -708,24 +728,23 @@ keymap = runKeys $ do
       doc "Spawn a floating terminal" $
         spawnX (terminal config ++ " -t Floating\\ Term")
 
-  bind xK_v
-    $
+  bind xK_v $
     -- Allows repeated strokes of M-h and M-l to reduce and increase volume
     -- respectively.
-    justMod
-    $ doc
-      "Allows repeated strokes of M-h and M-l to decrease and\n\
-      \increase volume respectively"
-    $ repeatable
-    $ do
-      bind xK_h $
-        justMod decreaseVolumeDoc
+    justMod $
+      doc
+        "Allows repeated strokes of M-h and M-l to decrease and\n\
+        \increase volume respectively"
+        $ repeatable $
+          do
+            bind xK_h $
+              justMod decreaseVolumeDoc
 
-      bind xK_l $
-        justMod increaseVolumeDoc
+            bind xK_l $
+              justMod increaseVolumeDoc
 
-      bind xK_v $
-        justMod (return () :: X ())
+            bind xK_v $
+              justMod (return () :: X ())
 
   bind xK_x $ do
     justMod $
@@ -796,8 +815,8 @@ keymap = runKeys $ do
         sendMessage togglePop
 
   bind xK_F8 $ do
-    justMod
-      $ doc
+    justMod $
+      doc
         "Set the log level.\n\
         \Log levels are, in order\n\n\t\
         \Trace\n\t\
@@ -807,15 +826,15 @@ keymap = runKeys $ do
         \Error\n\t\
         \Fatal\n\n\
         \Log is sent to stdout."
-      $ do
-        ll <- getLogLevel
-        let next = if minBound == ll then maxBound else pred ll
-
-        safeSpawnX
-          "notify-send"
-          ["-t", "2000", printf "LogLevel set to %s" (show next)]
-        setLogLevel next
-        logs next "LogLevel set to %s." (show next)
+        $ do
+          ll <- getLogLevel
+          let next = if minBound == ll then maxBound else pred ll
+
+          safeSpawnX
+            "notify-send"
+            ["-t", "2000", printf "LogLevel set to %s" (show next)]
+          setLogLevel next
+          logs next "LogLevel set to %s." (show next)
 
   bind xF86XK_Calculator $ do
     noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3"
diff --git a/src/Rahm/Desktop/StackSet.hs b/src/Rahm/Desktop/StackSet.hs
index 89e7eed..355c5c6 100644
--- a/src/Rahm/Desktop/StackSet.hs
+++ b/src/Rahm/Desktop/StackSet.hs
@@ -1,6 +1,8 @@
 module Rahm.Desktop.StackSet
   ( masterWindow,
+    windowsOnWorkspace,
     findWorkspace,
+    dbgStackSet,
     ensureWorkspace,
     swapWorkspaces,
     greedyView,
@@ -17,6 +19,7 @@ module Rahm.Desktop.StackSet
   )
 where
 
+import Control.Monad.Writer
 import Data.List (find)
 import Data.List.Safe (head)
 import qualified Data.Map as Map
@@ -26,6 +29,8 @@ import qualified Data.Map as Map
     mapKeys,
   )
 import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
+import Text.Printf (printf)
+import XMonad (Rectangle (..), ScreenDetail (..), WindowSet)
 import XMonad.StackSet as W
   ( RationalRect (..),
     Screen (..),
@@ -125,30 +130,80 @@ ensureWorkspace t ss =
        in (ss {hidden = ws : hidden ss}, ws)
     Just ws -> (ss, ws)
 
+ensureWorkspaces ::
+  (Eq i) =>
+  [i] ->
+  StackSet i l a s sd ->
+  (StackSet i l a s sd, [Workspace i l a])
+ensureWorkspaces (t : ts) ss =
+  let (ss', w) = ensureWorkspace t ss
+      (ss'', ws) = ensureWorkspaces ts ss'
+   in (ss'', w : ws)
+ensureWorkspaces [] ss = (ss, [])
+
 swapWorkspaces ::
   (Eq i) =>
   i ->
   i ->
   StackSet i l a s sd ->
   StackSet i l a s sd
-swapWorkspaces wid1 wid2 ss =
-  let (ss', workspace1) = ensureWorkspace wid1 ss
-      (ss'', workspace2) = ensureWorkspace wid2 ss'
-   in mapWorkspace
-        ( \w ->
-            case () of
-              _ | tag w == wid1 -> workspace2
-              _ | tag w == wid2 -> workspace1
-              _ -> w
-        )
-        ss''
+swapWorkspaces tag1 tag2 =
+  W.mapWorkspace
+    ( \(W.Workspace t a b) ->
+        W.Workspace
+          ( case (t == tag1, t == tag2) of
+              (True, False) -> tag2
+              (False, True) -> tag1
+              _ -> t
+          )
+          a
+          b
+    )
+
+switchWorkspaces ::
+  (Eq i) =>
+  i ->
+  i ->
+  StackSet i l a s sd ->
+  StackSet i l a s sd
+switchWorkspaces t1 t2 (ensureWorkspaces [t1, t2] -> (ss, [w1, w2])) =
+  W.mapWorkspace
+    ( \case
+        (Workspace t _ _) | t == t1 -> w2
+        (Workspace t _ _) | t == t2 -> w1
+        w -> w
+    )
+    ss
+
+dbgStackSet :: WindowSet -> String
+dbgStackSet ws@(W.StackSet cur vis hidden _) = execWriter $ do
+  tell "* " >> logScreen cur >> tell "\n"
+  mapM_ (\s -> tell "  " >> logScreen s >> tell "\n") vis
+
+  mapM_ logWorkspace (W.workspaces ws)
+  where
+    logWorkspace (Workspace tag _ st) = do
+      tell $ printf "WS %s\n" tag
+      forM_ st $ \(Stack foc up down) -> do
+        mapM_ (tell . printf "    %d\n") up
+        tell $ printf "  * %d\n" foc
+        mapM_ (tell . printf "    %d\n") down
+
+    logScreen (Screen ws sid (SD (Rectangle _ _ w h))) = do
+      tell (printf "id=%s (%sx%s) - [%s]" (show sid) (show w) (show h) (W.tag ws))
 
 greedyView :: (Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd
-greedyView wid ss = swapWorkspaces (tag . workspace . current $ ss) wid ss
+greedyView wid ss = switchWorkspaces (tag . workspace . current $ ss) wid ss
 
 shiftWin :: (Ord a, Eq s, Eq i) => i -> a -> StackSet i l a s sd -> StackSet i l a s sd
 shiftWin wid a = XMonad.StackSet.shiftWin wid a . fst . ensureWorkspace wid
 
+windowsOnWorkspace :: (Eq i) => i -> StackSet i l a s sd -> [a]
+windowsOnWorkspace i ss = fromMaybe [] $ do
+  ws <- find ((== i) . W.tag) (W.workspaces ss)
+  s <- W.stack ws
+  return (W.integrate s)
+
 screenRotateBackward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd
 screenRotateBackward (W.StackSet current visible others floating) = do
   let screens = current : visible
diff --git a/src/Rahm/Desktop/SwapMaster.hs b/src/Rahm/Desktop/SwapMaster.hs
index 68072a9..f95303d 100644
--- a/src/Rahm/Desktop/SwapMaster.hs
+++ b/src/Rahm/Desktop/SwapMaster.hs
@@ -26,16 +26,13 @@ import XMonad
 import qualified XMonad.Util.ExtensibleState as XS (get, modify, put)
 
 newtype LastWindow = LastWindow
-  { lastWindow :: Map String Window
+  { lastWindows :: Map String Window
   }
   deriving (Show, Read)
 
 instance ExtensionClass LastWindow where
   initialValue = LastWindow mempty
 
-hoist :: (Monad m) => Maybe a -> MaybeT m a
-hoist = MaybeT . return
-
 swapMaster :: X ()
 swapMaster =
   runMaybeT_ $ do
@@ -49,7 +46,7 @@ swapMaster =
         return (a, b)
 
     lift $ do
-      st <- lastWindow <$> XS.get
+      st <- lastWindows <$> XS.get
       windows . W.swapWindows $
         case focused == master of
           True
@@ -58,7 +55,8 @@ swapMaster =
           False -> [(master, focused)]
           _ -> []
 
-      XS.modify $
-        \(LastWindow m) ->
-          LastWindow $ Map.insert (W.currentTag ss) master m
+      XS.modify $ mlw (Map.insert (W.currentTag ss) master)
       windows W.focusMaster
+  where
+    mlw fn (LastWindow l) = LastWindow (fn l)
+    hoist = MaybeT . return