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.

3 files changed, 276 insertions, 261 deletions

diff --git a/src/Rahm/Desktop/Keys/Dsl2.hs b/src/Rahm/Desktop/Keys/Dsl2.hs
index c9cea83..cd0035a 100644
--- a/src/Rahm/Desktop/Keys/Dsl2.hs
+++ b/src/Rahm/Desktop/Keys/Dsl2.hs
@@ -23,7 +23,7 @@ module Rahm.Desktop.Keys.Dsl2 where
 
 import Control.Applicative ((<|>))
 import Control.Monad.Fix (fix)
-import Control.Monad.RWS (All (All), MonadTrans (lift), MonadWriter, forM_, when, forM)
+import Control.Monad.RWS (All (All), MonadTrans (lift), MonadWriter, forM, forM_, when)
 import Control.Monad.Reader (Reader, ask, runReader)
 import Control.Monad.State (MonadTrans, StateT (StateT))
 import Control.Monad.Trans.Maybe (MaybeT (..))
@@ -35,13 +35,13 @@ import Data.List (intercalate)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
-import Rahm.Desktop.Keys.KeyCodeMapping (setupKeycodeMapping)
-import Rahm.Desktop.Keys.Grab
 import Rahm.Desktop.Common (pointerWindow, runMaybeT_)
+import Rahm.Desktop.Keys.Grab
+import Rahm.Desktop.Keys.KeyCodeMapping (setupKeycodeMapping)
 import Rahm.Desktop.Logger (LogLevel (Debug, Info), logs)
 import Rahm.Desktop.Submap (ButtonOrKeyEvent (ButtonPress, KeyPress, event_keycode, event_mask), getStringForKey, nextButtonOrKeyEvent)
 import Rahm.Desktop.XMobarLog (spawnXMobar)
-import Rahm.Desktop.XMobarLog.PendingBuffer (pushAddPendingBuffer, pushPendingBuffer)
+import Rahm.Desktop.XMobarLog.PendingBuffer (pushAddPendingBuffer, pushPendingBuffer, clearPendingBuffer)
 import XMonad
 
 -- | A documented "thing." It is essentially an item with a string attached to
@@ -58,10 +58,10 @@ instance Functor Documented where
 -- | Type family for an action associated with a type. This type family
 -- indicates what type of action a keytype can be bound to.
 type family Action t where
--- KeySyms are bound to contextless actions with type X ()
+  -- KeySyms are bound to contextless actions with type X ()
   Action KeySymOrKeyCode = X ()
--- Buttons are associated with actions with type Window -> X (). In other
--- words, actions bound to a button have windows associated with it.
+  -- Buttons are associated with actions with type Window -> X (). In other
+  -- words, actions bound to a button have windows associated with it.
   Action Button = Window -> X ()
 
 class (Bind (Super k)) => LiftBinding k where
@@ -248,9 +248,9 @@ resolveBindings ::
   BindingsMap -> Bindings
 resolveBindings (BindingsMap keyAndKeyCodeBindings buttonBindings _ _) =
   Bindings
-    (\c -> Map.mapWithKey (\k -> pushK k (bindingToX c) . undocument) keyBindings)
-    (\c -> Map.mapWithKey (\k -> bindingToX c . undocument) keycodeBindings)
-    (\c -> Map.mapWithKey (\k -> pushB k (bindingToWinX c) . undocument) buttonBindings)
+    (\c -> Map.mapWithKey (\k v -> pushK k (bindingToX c) (undocument v)) keyBindings)
+    (\c -> Map.mapWithKey (\k v -> bindingToX c (undocument v)) keycodeBindings)
+    (\c -> Map.mapWithKey (\k v -> pushB k (bindingToWinX c) (undocument v)) buttonBindings)
   where
     (keyBindings, keycodeBindings) =
       partitionMap
@@ -260,17 +260,19 @@ resolveBindings (BindingsMap keyAndKeyCodeBindings buttonBindings _ _) =
         )
         keyAndKeyCodeBindings
 
-    pushB (_, b) fn binding win =
+    pushB (_, b) fn binding win = do
       if isRepeatOrSubmap binding
         then pushPendingBuffer ("b" ++ show b ++ " ") $ fn binding win
         else fn binding win
+      clearPendingBuffer
 
-    pushK (m, k) fn binding =
+    pushK (m, k) fn binding = do
       if isRepeatOrSubmap binding
         then do
           let s = getStringForKey (m, k)
           pushPendingBuffer (s ++ " ") $ fn binding
         else fn binding
+      clearPendingBuffer
 
     bindingToX :: forall l. XConfig l -> Binding KeySymOrKeyCode -> X ()
     bindingToX conf = \case
@@ -288,20 +290,22 @@ resolveBindings (BindingsMap keyAndKeyCodeBindings buttonBindings _ _) =
 
     doSubmap :: forall l. XConfig l -> BindingsMap -> X () -> X ()
     doSubmap conf (BindingsMap kbind bbind catk catb) after = do
-      nextPressEvent $
+      nextPressEvent $ \str ->
         \case
           (ButtonPress m b) -> do
             win <- pointerWindow
             case Map.lookup (m, b) bbind of
-              (Just binding) -> do
-                bindingToWinX conf (undocument binding) win
-                after
+              (Just binding) ->
+                pushAddPendingBuffer (str ++ " ") $ do
+                  bindingToWinX conf (undocument binding) win
+                  after
               Nothing -> catb (m, b) win
           (KeyPress m k c s) -> do
             case Map.lookup (m, Kc c) kbind <|> Map.lookup (m, Ks k) kbind of
-              (Just binding) -> do
-                bindingToX conf (undocument binding)
-                after
+              (Just binding) ->
+                pushAddPendingBuffer (str ++ " ") $ do
+                  bindingToX conf (undocument binding)
+                  after
               Nothing -> catk (m, k, s)
 
     isRepeatOrSubmap = \case
@@ -315,8 +319,7 @@ resolveBindings (BindingsMap keyAndKeyCodeBindings buttonBindings _ _) =
             ButtonPress m b -> "b" ++ show b
             KeyPress _ _ _ s -> s
       lift $
-        pushAddPendingBuffer (str ++ " ") $
-          fn ev
+        fn str ev
 
 -- Create a submap in place of an action.
 subbind :: Binder () -> Binding t
@@ -349,12 +352,11 @@ withBindings :: Binder a -> XConfig l -> XConfig l
 withBindings b config =
   let (Bindings keyBinds keycodeBinds buttonBinds) =
         resolveBindings $ runBinder config b
-   in
-     setupKeycodeMapping keycodeBinds $
-       config {
-         keys = keyBinds,
-         mouseBindings = buttonBinds
-       }
+   in setupKeycodeMapping keycodeBinds $
+        config
+          { keys = keyBinds,
+            mouseBindings = buttonBinds
+          }
 
 documentation :: XConfig l -> Binder () -> String
 documentation conf binder =
diff --git a/src/Rahm/Desktop/Keys/KeyFeed.hs b/src/Rahm/Desktop/Keys/KeyFeed.hs
new file mode 100644
index 0000000..c7b08e1
--- /dev/null
+++ b/src/Rahm/Desktop/Keys/KeyFeed.hs
@@ -0,0 +1,109 @@
+-- Module for the KeyFeed monad.
+--
+-- The KeyFeed Monad abstracts control flow over a stream of key presses in RDE.
+module Rahm.Desktop.Keys.KeyFeed where
+
+import Control.Monad (void, when)
+import Control.Monad.State (MonadTrans (lift), StateT, evalStateT, modify')
+import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
+import Data.List.Safe (head, last)
+import Rahm.Desktop.Common (Xish (..))
+import Rahm.Desktop.Submap (mapNextStringWithKeysym)
+import Rahm.Desktop.XMobarLog.PendingBuffer (addStringToPendingBuffer, pushAddPendingBuffer, pushPendingBuffer)
+import XMonad
+import Prelude hiding (head, last)
+
+-- A key is a mask and a keysym. The string is the string returned from
+-- XLookupString.
+type Key = (KeyMask, KeySym, String)
+
+-- A list of keys
+type KeyString = [Key]
+
+-- List of actions which return a key.
+type KeyStream = [MaybeT X Key]
+
+newtype KeyFeed a = KeyFeed (StateT KeyStream (MaybeT X) a)
+  deriving (Functor, Applicative, Monad)
+
+instance Xish KeyFeed where
+  liftFromX = liftXToFeed
+
+-- Executes a KeyFeed, returning a MaybeT of the result
+runKeyFeed :: KeyFeed a -> MaybeT X a
+runKeyFeed = runKeyFeedWithStartingKeys []
+
+-- Executes a KeyFeed, evaluating down to an X (Maybe a)
+runKeyFeedX :: KeyFeed a -> X (Maybe a)
+runKeyFeedX = runMaybeT . runKeyFeed
+
+-- Exceutes a KeyFeed. Does not evaluate the results.
+execKeyFeed :: KeyFeed a -> X ()
+execKeyFeed = void . runMaybeT . runKeyFeed
+
+-- Executes a KeyFeed, evaluating the keystring first, then evaluating actual
+-- key presses.
+runKeyFeedWithStartingKeys :: KeyString -> KeyFeed a -> MaybeT X a
+runKeyFeedWithStartingKeys st (KeyFeed r) =
+  evalStateT r $
+    (map return st ++) $
+      repeat $ do
+        mapNextStringWithKeysym $ \m s st -> return (m, s, st)
+
+-- Executes a KeyFeed only on the given key presses.
+runKeyFeedWithKeys :: KeyString -> KeyFeed a -> MaybeT X a
+runKeyFeedWithKeys st (KeyFeed r) = evalStateT r (toKeyStream st)
+
+-- Executes a function on the next key read and returns the result.
+readNextKey :: ((KeyMask, KeySym, String) -> KeyFeed a) -> KeyFeed a
+readNextKey fn = KeyFeed $ do
+  keyList <- get
+  nextKeyFn <- upMaybe $ head keyList
+  nextKey@(_, sym, str) <- lift nextKeyFn
+
+  -- escape always ends a key feed.
+  when (sym == xK_Escape) $ do
+    let (KeyFeed r) = feedFail in r
+
+  modify' tail
+  let (KeyFeed r) = liftFromX (addStringToPendingBuffer str) >> fn nextKey in r
+  where
+    upMaybe :: Maybe a -> StateT KeyStream (MaybeT X) a
+    upMaybe m = lift $ MaybeT (return m)
+
+-- Lifts a Maybe int o a KeyFeed.
+hoistMaybe :: Maybe a -> KeyFeed a
+hoistMaybe = KeyFeed . lift . MaybeT . return
+
+-- Lifts a Maybe int o a KeyFeed.
+hoistMaybeT :: MaybeT X a -> KeyFeed a
+hoistMaybeT = KeyFeed . lift
+
+-- Fails a KeyFeed action.
+feedFail :: KeyFeed a
+feedFail = KeyFeed $ lift (MaybeT $ return Nothing)
+
+-- Lifts an X action into a KeyFeed action.
+liftXToFeed :: X a -> KeyFeed a
+liftXToFeed = KeyFeed . lift . lift
+
+-- Lifts an X action into a KeyFeed action.
+liftXMaybe :: X (Maybe a) -> KeyFeed a
+liftXMaybe = KeyFeed . lift . MaybeT
+
+-- Removes a maybe and pushes it into the KeyFeed monad. If the maybe is
+-- Nothing, the KeyFeed fails.
+absorbMaybe :: KeyFeed (Maybe a) -> KeyFeed a
+absorbMaybe fn = hoistMaybe =<< fn
+
+-- Inserts keys to the beginnig of the KeyFeed buffer.
+pushKeys :: KeyString -> KeyFeed ()
+pushKeys ks = KeyFeed $ modify' (map return ks ++)
+
+-- Inserts a single key to the beginning of the KeyFeed buffer.
+pushKey :: (KeyMask, KeySym, String) -> KeyFeed ()
+pushKey = pushKeys . (: [])
+
+-- Converts a string of keys to a stream of keys.
+toKeyStream :: KeyString -> KeyStream
+toKeyStream = map return
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