Overhaul how Wml is implemented.

This adds a new "KeyFeed" monad which is reminiscent of a parsec-type
monad. This allows keys like 'g' to be mapped using a subbind and the
actual WML part be handled in the catch-all handler.

This also significantly cleans up the typing and complexity of the Wml
implementation.

1 files changed, 138 insertions, 234 deletions

diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
index 675d56e..0c09fd1 100644
--- a/src/Rahm/Desktop/Keys/Wml.hs
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -33,9 +33,6 @@ module Rahm.Desktop.Keys.Wml
     alternateWorkspace,
     floatWorkspace,
     joinMaybe,
-    feedKeys,
-    feedKeysT,
-    workspaceForKeysT,
     workspaceForKeys,
     workspaceForStringT,
     workspaceForString,
@@ -43,17 +40,24 @@ module Rahm.Desktop.Keys.Wml
     locationSetForKeys,
     readNextWorkspaceName,
     workspaceName,
-    withNextWorkspaceOrKey,
   )
 where
 
 import Control.Monad (forM_, join, void, when)
+-- getMostRecentLocationInHistory,
+
+-- pastHistory,
+
+import Control.Monad.Reader (ReaderT (runReaderT))
 import Control.Monad.Trans.Class (MonadTrans (lift))
 import Control.Monad.Trans.Maybe (MaybeT (..), mapMaybeT)
 import Control.Monad.Trans.State as S
-  ( StateT (StateT),
+  ( StateT (StateT, runStateT),
+    evalState,
     evalStateT,
     get,
+    gets,
+    modify',
     put,
   )
 import Data.Char (isAlpha, isAlphaNum, isDigit, ord)
@@ -72,10 +76,6 @@ import qualified Data.Map as Map
 import Data.Maybe (catMaybes, fromJust, fromMaybe)
 import Data.Ord (Down (..))
 import Data.Typeable (cast)
--- getMostRecentLocationInHistory,
-
--- pastHistory,
-
 import Data.Void (Void, absurd)
 import Rahm.Desktop.BorderColors (BorderColor (BorderColor), setBorderColor)
 import Rahm.Desktop.Common
@@ -91,6 +91,7 @@ import Rahm.Desktop.History
   ( lastLocation,
     nextLocation,
   )
+import Rahm.Desktop.Keys.KeyFeed
 import Rahm.Desktop.Layout.PinWindow (pinnedWindows)
 import Rahm.Desktop.Logger (LogLevel (Info, Trace), logs)
 import Rahm.Desktop.Marking
@@ -149,8 +150,6 @@ import XMonad.Prompt.ConfirmPrompt (confirmPrompt)
 import qualified XMonad.Util.ExtensibleState as XS (get, modify, put)
 import Prelude hiding (head, last)
 
-type KeyString = [(KeyMask, KeySym, String)]
-
 data MaybeMacros = NoMacros | YesMacros Macros
   deriving (Read, Show)
 
@@ -373,46 +372,9 @@ floatWorkspace ws@Workspace {extraWorkspaceData = d} =
 joinMaybe :: (Monad m) => MaybeT m (Maybe a) -> MaybeT m a
 joinMaybe (MaybeT ma) = MaybeT $ join <$> ma
 
-class (Monad m) => KeyFeeder m where
-  fromX :: X a -> m a
-
-  fromMaybeTX :: MaybeT X a -> MaybeT m a
-  fromMaybeTX = mapMaybeT fromX
-
-  readNextKey ::
-    (KeyMask -> KeySym -> String -> MaybeT m a) -> MaybeT m a
-
-instance KeyFeeder X where
-  fromX = id
-  readNextKey fn = mapNextStringWithKeysym $
-    \mask sym str -> do
-      lift $ fromX $ addStringToPendingBuffer str
-      fn mask sym str
-
-newtype FeedKeys a = FeedKeys {unFeedKeys :: StateT KeyString X a}
-  deriving (Monad, Functor, Applicative)
-
-instance KeyFeeder FeedKeys where
-  fromX = FeedKeys . lift
-
-  readNextKey fn = do
-    ls <- lift $ FeedKeys S.get
-    case ls of
-      ((mask, sym, str) : t) -> do
-        lift $ FeedKeys $ S.put t
-        fn mask sym str
-      _ -> MaybeT (return Nothing)
-
-feedKeys :: KeyString -> MaybeT FeedKeys a -> X (Maybe a)
-feedKeys s mf = flip evalStateT s . unFeedKeys $ runMaybeT mf
-
-feedKeysT :: KeyString -> MaybeT FeedKeys a -> MaybeT X a
-feedKeysT s mf = MaybeT $ feedKeys s mf
-
--- Allows a reference to a workspace in terms of its description in the window
--- management language.
+-- Like the above, but unwrap the MaybeT
 workspaceForKeysT :: KeyString -> MaybeT X Workspace
-workspaceForKeysT str = feedKeysT str readNextWorkspace
+workspaceForKeysT str = runKeyFeedWithKeys str readNextWorkspace
 
 -- Like the above, but unwrap the MaybeT
 workspaceForKeys :: KeyString -> X (Maybe Workspace)
@@ -429,211 +391,160 @@ workspaceForString = runMaybeT . workspaceForStringT
 
 -- Like the above, but unwrap the MaybeT
 locationSetForKeysT :: KeyString -> MaybeT X [Location]
-locationSetForKeysT s = feedKeysT s readNextLocationSet
+locationSetForKeysT s = runKeyFeedWithKeys s readNextLocationSet
 
 locationSetForKeys :: KeyString -> X [Location]
 locationSetForKeys s = fromMaybe [] <$> runMaybeT (locationSetForKeysT s)
 
-lift1 :: (KeyFeeder m) => (a -> X b) -> (a -> MaybeT m b)
-lift1 = fmap (lift . fromX)
+readNextWorkspaceName :: KeyFeed WorkspaceId
+readNextWorkspaceName = absorbMaybe $ workspaceName <$> readNextWorkspace
 
-readNextWorkspaceName :: (KeyFeeder m) => MaybeT m WorkspaceId
-readNextWorkspaceName = joinMaybe $ workspaceName <$> readNextWorkspace
-
-readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace
-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
+lift1 :: (a -> X b) -> (a -> KeyFeed b)
+lift1 fn = liftXToFeed . fn
 
 -- 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 ->
-          fmap Right $
-            MaybeT $ return Nothing
-      -- Macros takes precedence over everything.
-      (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.
+readNextWorkspace :: KeyFeed Workspace
+readNextWorkspace =
+  readNextKey $ \key -> do
+    macros <- liftXToFeed $ workspaceMacros <$> getMacros
+
+    case key of
+      (mask, keysym, _)
+        | (Just macro) <- Map.lookup (mask, keysym) macros -> do
+            pushKeys macro
+            readNextWorkspace
       (_, _, [ch])
         | isAlphaNum ch || ch == '*' ->
-          return $ Right $ justWorkspace [ch]
-      -- to the non-visible workspace left of the next workspace.
+            return $ justWorkspace [ch]
       (_, _, "[") ->
-        fmap Right $
-          justWorkspace
-            <$> ( lift1 (adjacentWorkspaceNotVisible prev)
-                    =<< readNextWorkspaceName
-                )
+        justWorkspace
+          <$> ( lift1 (adjacentWorkspaceNotVisible prev)
+                  =<< readNextWorkspaceName
+              )
       -- to the non-visible workspace right of the next workspace
       (_, _, "]") ->
-        fmap Right $
-          justWorkspace
-            <$> ( lift1 (adjacentWorkspaceNotVisible next)
-                    =<< readNextWorkspaceName
-                )
+        justWorkspace
+          <$> ( lift1 (adjacentWorkspaceNotVisible next)
+                  =<< readNextWorkspaceName
+              )
       -- To the left of the next workspace
       (_, _, "(") ->
-        fmap Right $
-          justWorkspace
-            <$> ( lift1 (adjacentWorkspace prev)
-                    =<< readNextWorkspaceName
-                )
+        justWorkspace
+          <$> ( lift1 (adjacentWorkspace prev)
+                  =<< readNextWorkspaceName
+              )
       -- To the right of the next workspace
       (_, _, ")") ->
-        fmap Right $
-          justWorkspace
-            <$> ( lift1 (adjacentWorkspace next)
-                    =<< readNextWorkspaceName
-                )
+        justWorkspace
+          <$> ( lift1 (adjacentWorkspace next)
+                  =<< readNextWorkspaceName
+              )
       -- The workspace on the leftmost screen
       (_, _, "^") ->
-        fmap Right $
-          mapMaybeT fromX $
-            MaybeT $
-              withWindowSet $ \ws ->
-                return $
-                  ( fmap
-                      ( justWorkspace . W.tag . W.workspace . snd
-                      )
-                      . head
+        liftXMaybe $
+          withWindowSet $ \ws ->
+            return $
+              ( fmap
+                  ( justWorkspace . W.tag . W.workspace . snd
                   )
-                    (getHorizontallyOrderedScreens ws)
+                  . head
+              )
+                (getHorizontallyOrderedScreens ws)
       -- The last workspace in history.
       (_, _, "'") ->
-        fmap Right $
-          fromMaybeTX $
-            justWorkspace . locationWorkspace <$> MaybeT lastLocation
+        justWorkspace . locationWorkspace <$> liftXMaybe lastLocation
       -- The current workspace.
       (_, _, ".") ->
-        fmap Right $
-          mt $ justWorkspace <$> getCurrentWorkspace
+        liftXToFeed $ justWorkspace <$> getCurrentWorkspace
       -- The workspace on the rightmost screen
-      (_, _, "$") -> fmap Right $
-        MaybeT $
-          fromX $
-            withWindowSet $ \ws ->
-              return $
-                (fmap (justWorkspace . W.tag . W.workspace . snd) . last)
-                  (getHorizontallyOrderedScreens ws)
+      (_, _, "$") ->
+        liftXMaybe $
+          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).
       (_, _, ":") ->
-        fmap Right $
-          floatWorkspace <$> readNextWorkspace
+        floatWorkspace <$> readNextWorkspace
       -- Workspace to the next screen to the right of the next workspace.
-      (_, _, ",") ->
-        fmap Right $ do
-          ws <- readNextWorkspace
-          screens <-
-            mt $
-              map (W.tag . W.workspace . snd)
-                <$> withWindowSet (return . getHorizontallyOrderedScreens)
+      (_, _, ",") -> do
+        ws <- readNextWorkspace
+        screens <-
+          liftXToFeed $
+            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 <$> hoistMaybe (head $ tail rest)
 
       -- Workspace to the next screen to the left of the next workspace.
-      (_, _, ";") ->
-        fmap Right $ do
-          ws <- readNextWorkspace
-          screens <-
-            mt $
-              map (W.tag . W.workspace . snd)
-                <$> withWindowSet (return . reverse . getHorizontallyOrderedScreens)
+      (_, _, ";") -> do
+        ws <- readNextWorkspace
+        screens <-
+          liftXToFeed $
+            map (W.tag . W.workspace . snd)
+              <$> withWindowSet (return . reverse . getHorizontallyOrderedScreens)
 
-          let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens)
+        let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens)
 
-          justWorkspace <$> MaybeT (return $ head $ tail rest)
+        justWorkspace <$> hoistMaybe (head $ tail rest)
 
       -- The workspace with the searched for window.
       (_, _, "/") ->
-        fmap Right $
-          fromMaybeTX $ do
-            justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT (head <$> askWindowId))
-
+        justWorkspace
+          <$> ( (liftXMaybe . workspaceWithWindow) =<< liftXMaybe (head <$> askWindowId)
+              )
       -- The workspace with the next read window on it.
-      (_, _, "@") ->
-        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
+      (_, _, "@") -> do
+        loc <- readNextLocationSet
+        liftXMaybe $
+          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.
       (_, _, "~") ->
-        fmap Right $
-          justWorkspace . accompaningWorkspace <$> readNextWorkspaceName
+        justWorkspace . accompaningWorkspace <$> readNextWorkspaceName
       -- The accompaning workspace to the current workspace (equivalent to ~.)
       (_, _, " ") ->
-        fmap Right $
-          mt $
-            justWorkspace . accompaningWorkspace <$> getCurrentWorkspace
+        liftXToFeed $
+          justWorkspace . accompaningWorkspace <$> getCurrentWorkspace
       -- The balck hole workspace
       (_, _, "_") ->
-        return $ Right blackHoleWorkspace
+        return blackHoleWorkspace
       -- The alternate workspace
       (_, _, "-") ->
-        return $ Right alternateWorkspace
+        return alternateWorkspace
       -- If the next two read workspaces are equal, go to the third workspace
       -- otherwise go to the fourth workspace.
-      (_, _, "=") ->
-        fmap Right $ do
-          ws1 <- readNextWorkspace
-          ws2 <- readNextWorkspace
+      (_, _, "=") -> do
+        ws1 <- readNextWorkspace
+        ws2 <- readNextWorkspace
 
-          ws3 <- readNextWorkspace
-          ws4 <- readNextWorkspace
-
-          return $
-            if workspaceName ws1 == workspaceName ws2
-              then ws3
-              else ws4
+        ws3 <- readNextWorkspace
+        ws4 <- readNextWorkspace
 
+        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.
-      (_, _, "?") ->
-        fmap Right $ do
-          l1 <- readNextLocationSet
-
-          ws1 <- readNextWorkspace
-          ws2 <- readNextWorkspace
+      (_, _, "?") -> do
+        l1 <- readNextLocationSet
 
-          mt $ logs Trace "If not empty %s then %s else %s" (show l1) (show $ workspaceName ws1) (show $ workspaceName ws2)
+        ws1 <- readNextWorkspace
+        ws2 <- readNextWorkspace
 
-          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
+        return $
+          if null l1
+            then ws2
+            else ws1
+      _ -> feedFail
 
 nonempty :: (Monad m) => m [a] -> MaybeT m [a]
 nonempty l = MaybeT $ do
@@ -643,32 +554,30 @@ nonempty l = MaybeT $ do
             a -> return (Just a)
         )
 
-readNextLocationSet :: (KeyFeeder m) => MaybeT m [Location]
+readNextLocationSet :: KeyFeed [Location]
 readNextLocationSet = do
-  (WindowSelect mp) <- MaybeT (Just <$> fromX XS.get)
+  (WindowSelect mp) <- liftXToFeed XS.get
   case Map.keys mp of
     [] -> readNextLocationSet'
     wins -> do
-      lift $ fromX $ addStringToPendingBuffer "<sel> "
-      fromMaybeTX $
-        mapM windowLocation
-          =<< MaybeT (Just <$> fromX getAndResetWindowSelection)
+      liftXToFeed $ addStringToPendingBuffer "<sel> "
+      mapM (hoistMaybeT . windowLocation)
+        =<< liftXToFeed getAndResetWindowSelection
 
 -- Like readNextLocationSet, but ignores the window selection.
-readNextLocationSet' :: (KeyFeeder m) => MaybeT m [Location]
+readNextLocationSet' :: KeyFeed [Location]
 readNextLocationSet' =
-  readNextKey $ \mask sym str -> do
-    macros <- (lift . fromX) $ windowsetMacros <$> getMacros
+  readNextKey $ \key -> do
+    macros <- liftXToFeed $ windowsetMacros <$> getMacros
 
-    case (mask, sym, str) of
-      -- Escape returns nothing and aborts reading the next location.
-      (_, e, _) | e == xK_Escape -> MaybeT $ return Nothing
+    case key of
       -- Macros takes precedence.
       (mask, keysym, _) | (Just macro) <- Map.lookup (mask, keysym) macros -> do
-        fromMaybeTX $ locationSetForKeysT macro
+        hoistMaybeT $ locationSetForKeysT macro
 
       -- A character is the base-case. Refers to a collection of windows.
-      (_, _, [ch]) | isAlpha ch -> mt $ getMarkedLocations [ch]
+      (_, _, [ch]) | isAlpha ch -> liftXToFeed $ getMarkedLocations [ch]
+
       -- Goes to the most recent location in history.
       -- (_, _, "0") -> (: []) <$> MaybeT (fromX getMostRecentLocationInHistory)
       -- A Digit goes to the past history.
@@ -676,50 +585,47 @@ readNextLocationSet' =
       --   | isDigit ch ->
       --     (: []) <$> MaybeT (fromX $ pastHistory (ord ch - 0x30))
       -- The current window.
-      (_, _, ".") -> (: []) <$> mt getCurrentLocation
+      (_, _, ".") -> (: []) <$> liftXToFeed getCurrentLocation
       -- The selected windows in the selection set.
       (_, _, "#") ->
-        MaybeT . fromX $ Just . map (Location "*" . Just) <$> pinnedWindows
+        liftXToFeed $ map (Location "*" . Just) <$> pinnedWindows
       -- The window on the far-left of the screens.
-      (_, _, "^") -> (: []) <$> fromMaybeTX farLeftWindow
+      (_, _, "^") -> (: []) <$> hoistMaybeT farLeftWindow
       -- The windows on the far-right of the screens.
-      (_, _, "$") -> (: []) <$> fromMaybeTX farRightWindow
+      (_, _, "$") -> (: []) <$> hoistMaybeT farRightWindow
       -- The next location in history.
-      (_, _, "\"") -> (: []) <$> MaybeT (fromX nextLocation)
+      (_, _, "\"") -> (: []) <$> liftXMaybe nextLocation
       -- The previous location in history.
-      (_, _, "'") -> (: []) <$> MaybeT (fromX lastLocation)
+      (_, _, "'") -> (: []) <$> liftXMaybe lastLocation
       -- All visible windows.
-      (_, _, "*") -> mt $ do
+      (_, _, "*") -> liftXToFeed $ do
         wins <- withWindowSet $ return . W.allVisibleWindows
         catMaybes <$> mapM (runMaybeT . windowLocation) wins
 
       -- The last referenced windows.
       (_, _, "-") ->
-        fromMaybeTX $
+        hoistMaybeT $
           mapM windowLocation =<< lift getAlternateWindows
       -- Search for the windows.
       (_, _, "/") ->
-        fromMaybeTX $
+        hoistMaybeT $
           mapM windowLocation =<< nonempty askWindowId
       -- All windows.
-      (_, _, "%") -> fromMaybeTX $ do
-        ret <- mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows))
-        lift $ logs Info "allWindows %s" (intercalate "\n" (map show ret))
-        return ret
-
+      (_, _, "%") -> hoistMaybeT $
+        mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows))
       -- Windows in a workspace
       (_, _, s)
         | s == "\t" || s == "@" || s == "\n" ->
-          (mt . windowsInWorkspace) =<< readNextWorkspaceName
+            (liftXToFeed . windowsInWorkspace) =<< readNextWorkspaceName
       -- The first window in the next window set.
-      (_, _, "!") -> (: []) <$> joinMaybe (head <$> readNextLocationSet)
+      (_, _, "!") -> (: []) <$> absorbMaybe (head <$> readNextLocationSet)
       -- The windows except the first in a window set.
       (_, _, ",") -> tail <$> readNextLocationSet
       -- The next window set, but reversed
       (_, _, "~") -> reverse <$> readNextLocationSet
       -- All the floating windows
       (_, _, ":") ->
-        mt $
+        liftXToFeed $
           withWindowSet $
             fmap catMaybes
               . mapM (runMaybeT . windowLocation)
@@ -751,7 +657,5 @@ readNextLocationSet' =
         l1 <- readNextLocationSet
         l2 <- readNextLocationSet
         return $ filter (`elem` l2) l1
-      _ -> MaybeT (return Nothing)
-  where
-    mt :: (KeyFeeder m) => X a -> MaybeT m a
-    mt = lift . fromX
+
+      _ -> feedFail