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, 29 insertions, 27 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 =