Add withNextWorkspaceOrKey.

This function invokes a handler if a WML workspace is entered, or if a
non-Wml key is entered, it invokes a different handler.

This allows Wml-tied keys like 'g' to handle non-wml sequences. I.e. "g
<F1>" now displays help.

1 files changed, 142 insertions, 91 deletions

diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
index 5565c31..61c19b2 100644
--- a/src/Rahm/Desktop/Keys/Wml.hs
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -43,6 +43,7 @@ module Rahm.Desktop.Keys.Wml
     locationSetForKeys,
     readNextWorkspaceName,
     workspaceName,
+    withNextWorkspaceOrKey,
   )
 where
 
@@ -75,6 +76,7 @@ import Data.Typeable (cast)
 
 -- pastHistory,
 
+import Data.Void (Void, absurd)
 import Rahm.Desktop.BorderColors (BorderColor (BorderColor), setBorderColor)
 import Rahm.Desktop.Common
   ( Location (..),
@@ -438,148 +440,197 @@ lift1 = fmap (lift . fromX)
 readNextWorkspaceName :: (KeyFeeder m) => MaybeT m WorkspaceId
 readNextWorkspaceName = joinMaybe $ workspaceName <$> readNextWorkspace
 
--- Returns the next workspaces associated with the next set of keystrokes.
 readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace
-readNextWorkspace =
+readNextWorkspace = unEither <$> readNextWorkspaceWithHandler (const doNothing)
+  where
+    doNothing :: (Monad m) => MaybeT m Void
+    doNothing = MaybeT (return Nothing)
+
+    unEither :: Either Void a -> a
+    unEither = either absurd id
+
+withNextWorkspaceOrKey ::
+  (KeyFeeder m) =>
+  (Workspace -> m ()) ->
+  ((KeyMask, KeySym, String) -> m ()) ->
+  MaybeT m ()
+withNextWorkspaceOrKey wFn kFn =
+  either (lift . kFn) (lift . wFn) =<< readNextWorkspaceWithHandler return
+
+-- Returns the next workspaces associated with the next set of keystrokes, or
+-- invokes the handler if the next stroke is not associated with WML command.
+readNextWorkspaceWithHandler :: (KeyFeeder m) => ((KeyMask, KeySym, String) -> MaybeT m b) -> MaybeT m (Either b Workspace)
+readNextWorkspaceWithHandler handle =
   readNextKey $ \mask sym str -> do
     macros <- (lift . fromX) $ workspaceMacros <$> getMacros
 
     case (mask, sym, str) of
       -- Escape kills the "readNextWorkspace" and returns nothing.
-      (_, e, _) | e == xK_Escape -> MaybeT $ return Nothing
+      (_, e, _)
+        | e == xK_Escape ->
+          fmap Right $
+            MaybeT $ return Nothing
       -- Macros takes precedence over everything.
-      (mask, keysym, _) | (Just macro) <- Map.lookup (mask, keysym) macros -> do
-        fromMaybeTX $ workspaceForKeysT macro
+      (mask, keysym, _) | (Just macro) <- Map.lookup (mask, keysym) macros ->
+        fmap Right $ do
+          fromMaybeTX $ workspaceForKeysT macro
 
       -- A single alphanumeric character is the atomic reference to a workspace.
-      (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch]
+      (_, _, [ch])
+        | isAlphaNum ch || ch == '*' ->
+          return $ Right $ justWorkspace [ch]
       -- to the non-visible workspace left of the next workspace.
       (_, _, "[") ->
-        justWorkspace
-          <$> ( lift1 (adjacentWorkspaceNotVisible prev)
-                  =<< readNextWorkspaceName
-              )
+        fmap Right $
+          justWorkspace
+            <$> ( lift1 (adjacentWorkspaceNotVisible prev)
+                    =<< readNextWorkspaceName
+                )
       -- to the non-visible workspace right of the next workspace
       (_, _, "]") ->
-        justWorkspace
-          <$> ( lift1 (adjacentWorkspaceNotVisible next)
-                  =<< readNextWorkspaceName
-              )
+        fmap Right $
+          justWorkspace
+            <$> ( lift1 (adjacentWorkspaceNotVisible next)
+                    =<< readNextWorkspaceName
+                )
       -- To the left of the next workspace
       (_, _, "(") ->
-        justWorkspace
-          <$> ( lift1 (adjacentWorkspace prev)
-                  =<< readNextWorkspaceName
-              )
+        fmap Right $
+          justWorkspace
+            <$> ( lift1 (adjacentWorkspace prev)
+                    =<< readNextWorkspaceName
+                )
       -- To the right of the next workspace
       (_, _, ")") ->
-        justWorkspace
-          <$> ( lift1 (adjacentWorkspace next)
-                  =<< readNextWorkspaceName
-              )
+        fmap Right $
+          justWorkspace
+            <$> ( lift1 (adjacentWorkspace next)
+                    =<< readNextWorkspaceName
+                )
       -- The workspace on the leftmost screen
-      (_, _, "^") -> mapMaybeT fromX $
-        MaybeT $
-          withWindowSet $ \ws ->
-            return $
-              ( fmap
-                  ( justWorkspace . W.tag . W.workspace . snd
+      (_, _, "^") ->
+        fmap Right $
+          mapMaybeT fromX $
+            MaybeT $
+              withWindowSet $ \ws ->
+                return $
+                  ( fmap
+                      ( justWorkspace . W.tag . W.workspace . snd
+                      )
+                      . head
                   )
-                  . head
-              )
-                (getHorizontallyOrderedScreens ws)
+                    (getHorizontallyOrderedScreens ws)
       -- The last workspace in history.
-      (_, _, "'") -> fromMaybeTX $ justWorkspace . locationWorkspace <$> MaybeT lastLocation
+      (_, _, "'") ->
+        fmap Right $
+          fromMaybeTX $
+            justWorkspace . locationWorkspace <$> MaybeT lastLocation
       -- The current workspace.
-      (_, _, ".") -> mt $ justWorkspace <$> getCurrentWorkspace
+      (_, _, ".") ->
+        fmap Right $
+          mt $ justWorkspace <$> getCurrentWorkspace
       -- The workspace on the rightmost screen
-      (_, _, "$") -> MaybeT $
-        fromX $
-          withWindowSet $ \ws ->
-            return $
-              (fmap (justWorkspace . W.tag . W.workspace . snd) . last)
-                (getHorizontallyOrderedScreens ws)
+      (_, _, "$") -> fmap Right $
+        MaybeT $
+          fromX $
+            withWindowSet $ \ws ->
+              return $
+                (fmap (justWorkspace . W.tag . W.workspace . snd) . last)
+                  (getHorizontallyOrderedScreens ws)
       -- Modify the next workspace as a "floating" workspace. (Windows sent to
       -- it will float).
-      (_, _, ":") -> floatWorkspace <$> readNextWorkspace
+      (_, _, ":") ->
+        fmap Right $
+          floatWorkspace <$> readNextWorkspace
       -- Workspace to the next screen to the right of the next workspace.
-      (_, _, ",") -> do
-        ws <- readNextWorkspace
-        screens <-
-          mt $
-            map (W.tag . W.workspace . snd)
-              <$> withWindowSet (return . getHorizontallyOrderedScreens)
+      (_, _, ",") ->
+        fmap Right $ do
+          ws <- readNextWorkspace
+          screens <-
+            mt $
+              map (W.tag . W.workspace . snd)
+                <$> withWindowSet (return . getHorizontallyOrderedScreens)
 
-        let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens)
+          let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens)
 
-        justWorkspace <$> MaybeT (return $ head $ tail rest)
+          justWorkspace <$> MaybeT (return $ head $ tail rest)
 
       -- Workspace to the next screen to the left of the next workspace.
-      (_, _, ";") -> do
-        ws <- readNextWorkspace
-        screens <-
-          mt $
-            map (W.tag . W.workspace . snd)
-              <$> withWindowSet (return . getHorizontallyOrderedScreens)
+      (_, _, ";") ->
+        fmap Right $ do
+          ws <- readNextWorkspace
+          screens <-
+            mt $
+              map (W.tag . W.workspace . snd)
+                <$> withWindowSet (return . getHorizontallyOrderedScreens)
 
-        let (front, _) = break ((== workspaceName ws) . Just) (screens ++ screens)
+          let (front, _) = break ((== workspaceName ws) . Just) (screens ++ screens)
 
-        justWorkspace <$> MaybeT (return $ last front)
+          justWorkspace <$> MaybeT (return $ last front)
 
       -- The workspace with the searched for window.
-      (_, _, "/") -> fromMaybeTX $ do
-        justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT (head <$> askWindowId))
+      (_, _, "/") ->
+        fmap Right $
+          fromMaybeTX $ do
+            justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT (head <$> askWindowId))
 
       -- The workspace with the next read window on it.
-      (_, _, "@") -> do
-        loc <- readNextLocationSet
-        MaybeT $
-          fromX $
-            withWindowSet $ \ws -> return $ do
-              win <- locationWindow =<< head loc
-              winLocation <- W.findWindow ws win
-              justWorkspaceWithPreferredWindow win . W.tag <$> W.getLocationWorkspace winLocation
+      (_, _, "@") ->
+        fmap Right $ do
+          loc <- readNextLocationSet
+          MaybeT $
+            fromX $
+              withWindowSet $ \ws -> return $ do
+                win <- locationWindow =<< head loc
+                winLocation <- W.findWindow ws win
+                justWorkspaceWithPreferredWindow win . W.tag <$> W.getLocationWorkspace winLocation
 
       -- The accompaning worksapce to the next read workspace.
       (_, _, "~") ->
-        justWorkspace . accompaningWorkspace <$> readNextWorkspaceName
+        fmap Right $
+          justWorkspace . accompaningWorkspace <$> readNextWorkspaceName
       -- The accompaning workspace to the current workspace (equivalent to ~.)
       (_, _, " ") ->
-        mt $
-          justWorkspace . accompaningWorkspace <$> getCurrentWorkspace
+        fmap Right $
+          mt $
+            justWorkspace . accompaningWorkspace <$> getCurrentWorkspace
       -- The balck hole workspace
-      (_, _, "_") -> return blackHoleWorkspace
+      (_, _, "_") ->
+        return $ Right blackHoleWorkspace
       -- The alternate workspace
-      (_, _, "-") -> return alternateWorkspace
+      (_, _, "-") ->
+        return $ Right alternateWorkspace
       -- If the next two read workspaces are equal, go to the third workspace
       -- otherwise go to the fourth workspace.
-      (_, _, "=") -> do
-        ws1 <- readNextWorkspace
-        ws2 <- readNextWorkspace
+      (_, _, "=") ->
+        fmap Right $ do
+          ws1 <- readNextWorkspace
+          ws2 <- readNextWorkspace
 
-        ws3 <- readNextWorkspace
-        ws4 <- readNextWorkspace
+          ws3 <- readNextWorkspace
+          ws4 <- readNextWorkspace
 
-        return $
-          if workspaceName ws1 == workspaceName ws2
-            then ws3
-            else ws4
+          return $
+            if workspaceName ws1 == workspaceName ws2
+              then ws3
+              else ws4
 
       -- If the next read location set is not empty, go to the next read
       -- workspace, otherwise go to the next-next read workspace.
-      (_, _, "?") -> do
-        l1 <- readNextLocationSet
+      (_, _, "?") ->
+        fmap Right $ do
+          l1 <- readNextLocationSet
 
-        ws1 <- readNextWorkspace
-        ws2 <- readNextWorkspace
+          ws1 <- readNextWorkspace
+          ws2 <- readNextWorkspace
 
-        mt $ logs Trace "If not empty %s then %s else %s" (show l1) (show $ workspaceName ws1) (show $ workspaceName ws2)
+          mt $ logs Trace "If not empty %s then %s else %s" (show l1) (show $ workspaceName ws1) (show $ workspaceName ws2)
 
-        return $
-          if null l1
-            then ws2
-            else ws1
-      _ -> MaybeT (return Nothing)
+          return $
+            if null l1
+              then ws2
+              else ws1
+      _ -> Left <$> handle (mask, sym, str)
   where
     mt :: (KeyFeeder m) => X a -> MaybeT m a
     mt = lift . fromX
@@ -659,7 +710,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.