Replacing existing binder DSL with a better and more expressive DSL.

This new DSL is cleaner and more powerful. This new DSL allows mixing
key and mouse bindings in submappings, which can be very useful.

4 files changed, 455 insertions, 838 deletions

diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 2cc3d79..412d8f5 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -60,29 +60,7 @@ import Rahm.Desktop.History
     historyForward,
     jumpToLastLocation,
   )
-import Rahm.Desktop.Keys.Dsl
-  ( ButtonBinding (..),
-    ButtonBindings,
-    Documented (..),
-    KeyBinding (..),
-    KeyBindings,
-    altMask,
-    altMod,
-    altgrMod,
-    bind,
-    buttonDocumentation,
-    controlMod,
-    doc,
-    documentation,
-    getConfig,
-    justMod,
-    noMod,
-    rawMask,
-    runButtons,
-    runKeys,
-    shiftMod,
-    (-|-),
-  )
+import Rahm.Desktop.Keys.Dsl2
 import Rahm.Desktop.Keys.Wml
   ( addWindowToSelection,
     clearWindowSelection,
@@ -186,9 +164,6 @@ spawnX = spawn
 safeSpawnX :: String -> [String] -> X ()
 safeSpawnX = safeSpawn
 
-noWindow :: b -> Window -> b
-noWindow = const
-
 selectedWindowsColor = BorderColor "#00ffff" "#00ffff"
 
 decreaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ -5%"
@@ -249,34 +224,6 @@ button14 = 14
 button15 :: Button
 button15 = 15
 
-keyBindingToKeymap :: (XConfig l -> KeyBindings) -> KeyMap l
-keyBindingToKeymap bindings config = Map.mapWithKey bindingToX (bindings config)
-  where
-    bindingToX :: (KeyMask, KeySym) -> Documented KeyBinding -> X ()
-    bindingToX key b =
-      case b of
-        Documented _ (Action x) -> x
-        Documented _ (Submap mapping) ->
-          -- This is a submap, add it to the pending buffer.
-          --
-          -- This could potentially use the current event in the XState and
-          -- lookupString to potentially recover the real string typed, but
-          -- for now, this will do.
-          pushAddPendingBuffer (keysymToString $ snd key) $ do
-            submap (Map.mapWithKey bindingToX mapping)
-        Documented _ (Repeat mapping) -> do
-          pushAddPendingBuffer (keysymToString $ snd key) $ do
-            mapM_ (bindingToX key) (Map.lookup key mapping)
-            fix $ \recur -> do
-              submap
-                ( Map.mapWithKey
-                    ( \k b -> do
-                        pushAddPendingBuffer (keysymToString $ snd k) $
-                          bindingToX k b >> recur
-                    )
-                    mapping
-                )
-
 mapWindows :: (Ord b) => (a -> b) -> W.StackSet i l a s sd -> W.StackSet i l b s sd
 mapWindows fn (W.StackSet cur vis hidden float) =
   W.StackSet
@@ -290,13 +237,8 @@ mapWindows fn (W.StackSet cur vis hidden float) =
 
 data ShiftType = JustShift | ShiftAndFollow | ShiftAndSwap
 
-keymap :: XConfig l -> KeyBindings
-keymap = runKeys $ do
-  config <- getConfig
-
-  let subkeys keysM = Submap (runKeys keysM config)
-      repeatable keysM = Repeat (runKeys keysM config)
-
+bindings :: Binder ()
+bindings = do
   bind xK_apostrophe $ do
     justMod $
       doc "Jump to a window/tile currently dragging window" $ do
@@ -364,33 +306,33 @@ keymap = runKeys $ do
       doc "Move XMobar to another screen." $
         spawnX "pkill -SIGUSR1 xmobar"
 
-  bind xK_F1 $ do
-    justMod $
-      doc
-        "Print this documentation"
-        ( safeSpawn
-            "gxmessage"
-            [ "-fn",
-              "Source Code Pro",
-              "Key Bindings\n\n"
-                ++ documentation (keymap config)
-                ++ "\n\nButton Bindings\n\n"
-                ++ buttonDocumentation (mouseMap config)
-            ] ::
-            X ()
-        )
-
-  bind xK_F7 $ do
-    justMod $
-      doc
-        "Print this documentation to stdout (at LogLevel Info)"
-        ( logs
-            Info
-            "KeyBindings\n\n%s\n\nButtonBindings\n\n%s"
-            (documentation (keymap config))
-            (buttonDocumentation (mouseMap config)) ::
-            X ()
-        )
+  -- bind xK_F1 $ do
+  --   justMod $
+  --     doc
+  --       "Print this documentation"
+  --       ( safeSpawn
+  --           "gxmessage"
+  --           [ "-fn",
+  --             "Source Code Pro",
+  --             "Key Bindings\n\n"
+  --               ++ documentation (keymap config)
+  --               ++ "\n\nButton Bindings\n\n"
+  --               ++ buttonDocumentation (mouseMap config)
+  --           ] ::
+  --           X ()
+  --       )
+
+  -- bind xK_F7 $ do
+  --   justMod $
+  --     doc
+  --       "Print this documentation to stdout (at LogLevel Info)"
+  --       ( logs
+  --           Info
+  --           "KeyBindings\n\n%s\n\nButtonBindings\n\n%s"
+  --           (documentation (keymap config))
+  --           (buttonDocumentation (mouseMap config)) ::
+  --           X ()
+  --       )
 
   bind xK_F10 $ do
     justMod playPauseDoc
@@ -423,9 +365,6 @@ keymap = runKeys $ do
         doc ("Move the current window to screen " ++ show idx) $
           withScreen W.shift idx
 
-      altgrMod
-        (logs Info "Test altgr" :: X ())
-
   bind xK_bracketright $ do
     justMod $
       doc "Increase the gaps between windows." $
@@ -500,7 +439,7 @@ keymap = runKeys $ do
   bind xK_d $
     justMod $
       doc "Record (define) macros." $
-        subkeys $ do
+        subbind $ do
           bind xK_w
             $ noMod
             $ doc
@@ -746,7 +685,7 @@ keymap = runKeys $ do
   bind xK_space $ do
     justMod $
       doc "Layout-related bindings" $
-        subkeys $ do
+        subbind $ do
           bind xK_n $
             (noMod -|- justMod) $
               doc "Use the next layout in the layout list." $ do
@@ -833,7 +772,7 @@ keymap = runKeys $ do
   bind xK_t $ do
     justMod $
       doc "Spawn a terminal." $
-        spawnX (terminal config)
+        spawnX =<< asks (terminal . config)
 
     shiftMod $
       doc "Sink the current window into the tiling." $
@@ -843,26 +782,7 @@ keymap = runKeys $ do
 
     altMod $
       doc "Spawn a floating terminal" $
-        spawnX (terminal config ++ " -t Floating\\ Term")
-
-  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
-
-      bind xK_l $
-        justMod increaseVolumeDoc
-
-      bind xK_v $
-        justMod (return () :: X ())
+        spawnX =<< asks ((++ " -t Floating\\ Term") . terminal . config)
 
   bind xK_x $ do
     justMod $
@@ -872,7 +792,7 @@ keymap = runKeys $ do
   bind xK_z $ do
     justMod $
       doc "Less often used keybindings." $
-        subkeys $ do
+        subbind $ do
           bind xK_e $ do
             (justMod -|- noMod) $
               doc "Select an emoji" $
@@ -955,7 +875,9 @@ keymap = runKeys $ do
         logs next "LogLevel set to %s." (show next)
 
   bind xF86XK_Calculator $ do
-    noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3"
+    noMod $
+      spawnX
+        =<< asks ((++ " -t Floating\\ Term -e /usr/bin/env python3") . terminal . config)
 
   bind xF86XK_AudioLowerVolume $ do
     noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ -1%"
@@ -990,63 +912,6 @@ keymap = runKeys $ do
     noMod $ spawnX "set-backlight.sh -0.05"
     justMod $ spawnX "set-backlight.sh 0.01"
     rawMask shiftMask $ spawnX "set-backlight.sh 0"
-
-buttonBindingsToButtonMap :: (XConfig l -> ButtonBindings) -> ButtonsMap l
-buttonBindingsToButtonMap bindings config = Map.mapWithKey bindingToX (bindings config)
-  where
-    bindingToX :: (ButtonMask, Button) -> Documented ButtonBinding -> (Window -> X ())
-    bindingToX click@(mask, btn) = \case
-      Documented _ (ButtonAction action) -> action
-      Documented _ (ButtonSubmap sm) ->
-        pushAddPendingBuffer (printf "b%d " btn)
-          . submapButtonsWithKey (\_ _ -> return ()) (Map.mapWithKey bindingToX sm)
-      Documented _ (ButtonContinuous sm) -> \window ->
-        pushAddPendingBuffer (printf "b%d " btn) $ do
-          mapM_ (flip (bindingToX click) window) (Map.lookup click sm)
-          fix $ \recur -> do
-            submapButtonsWithKey
-              ( \_ _ -> return ()
-              )
-              ( Map.mapWithKey
-                  ( \k b w ->
-                      pushAddPendingBuffer (printf "b%d " (snd k)) $
-                        bindingToX k b w >> recur
-                  )
-                  sm
-              )
-              window
-
-myMouseMoveWindow =
-  D.mouseMoveWindowAndThen X.focus $
-    mconcat
-      [ D.ifReleased button3 D.sinkOnRelease,
-        D.ifReleased' button2 $ \w _ -> X.killWindow w
-      ]
-
-myMouseResizeAction =
-  D.mouseResizeWindowAndThen X.focus $
-    mconcat
-      [ D.ifReleased button1 D.sinkOnRelease
-      ]
-
-mouseMap :: forall l. XConfig l -> ButtonBindings
-mouseMap = runButtons $ do
-  config <- getConfig
-
-  -- let x button = Map.lookup button (mouseMap config)
-
-  -- let defaultButtons button =
-  --       fromMaybe (\w -> return ()) $
-  --         Map.lookup button (mouseMap config)
-  let subMouse = ButtonSubmap . flip runButtons config
-
-      continuous buttons = do
-        let bindingMap = runButtons buttons config
-         in forM_ (Map.toList bindingMap) $ \((m, b), _) -> do
-              bind b $
-                rawMask m $
-                  ButtonContinuous bindingMap
-
   bind button1 $ do
     justMod $
       doc
@@ -1087,50 +952,63 @@ mouseMap = runButtons $ do
       doc "Media next" $
         noWindow mediaNext
 
-  bind button14 $ do
-    noMod $
-      doc "Additional Mouse Bindings" $
-        subMouse $ do
-          bind button3 $
-            noMod $
-              doc "Drag a workspace to a different screen" $
-                noWindow D.dragWorkspace
+  let button14Binder = do
+        bind button3 $
+          noMod $
+            doc "Drag a workspace to a different screen" $
+              noWindow D.dragWorkspace
+
+        bind button1 $
+          noMod $
+            doc "Swap a window with another window by dragging." $
+              noWindow D.dragWindow
+
+        bind button14 $ do
+          noMod $
+            doc "Pop the window under the cursor" $
+              noWindow $
+                click >> sendMessage togglePop
+
+        bind button15 $ do
+          noMod $
+            doc "Spawn 'pavucontrol'" $
+              noWindow $
+                spawnX "pavucontrol"
+
+        let mediaButtons =
+              [ (button4, "Increase volume", noWindow increaseVolume),
+                (button5, "Decrease volume", noWindow decreaseVolume),
+                (button2, "Play/Pause", noWindow playPause),
+                (button9, "History Forward", noWindow (viewAdjacentTo pointerWorkspace next)),
+                (button8, "History Back", noWindow (viewAdjacentTo pointerWorkspace prev)),
+                (button6, "Media Previous", noWindow mediaPrev),
+                (button7, "Media Next", noWindow mediaNext)
+              ]
+
+        continuous $ do
+          forM_ mediaButtons $ \(b, d, a) ->
+            bind b $ noMod $ doc d a
 
-          bind button1 $
-            noMod $
-              doc "Swap a window with another window by dragging." $
-                noWindow D.dragWindow
+          bind xK_h $
+            justMod decreaseVolumeDoc
 
-          bind button14 $ do
-            noMod $
-              doc "Pop the window under the cursor" $
-                noWindow $
-                  click >> sendMessage togglePop
+          bind xK_l $
+            justMod increaseVolumeDoc
 
-          bind button15 $ do
-            noMod $
-              doc "Spawn 'pavucontrol'" $
-                noWindow $
-                  spawnX "pavucontrol"
-
-          let mediaButtons =
-                [ (button4, "Increase volume", noWindow increaseVolume),
-                  (button5, "Decrease volume", noWindow decreaseVolume),
-                  (button2, "Play/Pause", noWindow playPause),
-                  (button9, "History Forward", noWindow (viewAdjacentTo pointerWorkspace next)),
-                  (button8, "History Back", noWindow (viewAdjacentTo pointerWorkspace prev)),
-                  (button6, "Media Previous", noWindow mediaPrev),
-                  (button7, "Media Next", noWindow mediaNext)
-                ]
+  bind button14 $ do
+    noMod $
+      doc "Additional Mouse Bindings" $
+        subbind button14Binder
 
-          continuous $
-            forM_ mediaButtons $ \(b, d, a) ->
-              bind b $ noMod $ doc d a
+  bind xK_v $ do
+    justMod $
+      doc "Same as button14" $
+        subbind button14Binder
 
   bind button13 $
     noMod $
       doc "General Window Management Extra Mouse Bindings" $
-        subMouse $ do
+        subbind $ do
           bind button1 $
             noMod $
               doc
@@ -1164,10 +1042,10 @@ mouseMap = runButtons $ do
 
           bind button13 $
             noMod $
-              subMouse $ do
+              subbind $ do
                 bind button13 $
                   noMod $
-                    subMouse $ do
+                    subbind $ do
                       bind button13 $
                         noMod $
                           doc "Lock the screen" $
@@ -1182,7 +1060,7 @@ mouseMap = runButtons $ do
   bind button15 $ do
     noMod $
       doc "General navigation extra mouse bindings" $
-        subMouse $ do
+        subbind $ do
           bind button13 $
             noMod $
               doc "Goto the accompaning workspace to the current one." $
@@ -1220,7 +1098,7 @@ mouseMap = runButtons $ do
 
             bind button14 $
               noMod $
-                subMouse $ do
+                subbind $ do
                   bind button1 $
                     noMod $
                       doc "Pin the selected windows" $
@@ -1273,19 +1151,42 @@ mouseMap = runButtons $ do
                                 )
                          in windows f >> escape
 
--- Bindings specific to a window. These are set similarly to th ekeymap above,
--- but uses a Query monad to tell which windows the keys will apply to.
---
--- This is useful to create hotkeys in applications where hot keys are not
--- configurable, or to remove keybindings that are irritating (looking at you,
--- ctrl+w in Chrome!!).
+myMouseMoveWindow =
+  D.mouseMoveWindowAndThen X.focus $
+    mconcat
+      [ D.ifReleased button3 D.sinkOnRelease,
+        D.ifReleased' button2 $ \w _ -> X.killWindow w
+      ]
+
+myMouseResizeAction =
+  D.mouseResizeWindowAndThen X.focus $
+    mconcat
+      [ D.ifReleased button1 D.sinkOnRelease
+      ]
+
+applyKeys :: XConfig l -> IO (XConfig l)
+applyKeys c =
+  let conf' = withBindings bindings c
+   in return $
+        windowBindings $
+          conf'
+            { keys =
+                Map.insert
+                  (modMask c .|. shiftMask, xK_q)
+                  (spawnX "xmonad --recompile && xmonad --restart")
+                  . keys conf'
+            }
+
 windowSpecificBindings ::
   XConfig l -> WriterT (Map (KeyMask, KeySym) (X ())) Query ()
 windowSpecificBindings config = do
   w <- lift ask
 
+  let altMask = mod1Mask
   let mods = permuteMods [shiftMask, controlMask, 0]
-  let configureIf b k = tell =<< lift (b --> return (keyBindingToKeymap (runKeys k) config))
+  let configureIf b k =
+        let (keymap, _) = resolveBindings (runBinder config k)
+         in tell =<< lift (b --> return (keymap config))
       emitKey = flip sendKey w
 
   configureIf (flip elem (browsers ++ spotify) <$> className) $ do
@@ -1398,20 +1299,11 @@ windowBindings xconfig =
       map <- execWriterT $ windowSpecificBindings xconfig
       w <- ask
 
-      liftX $ logs Info "For Window: %s" (show w)
+      liftX $ logs Debug "For Window: %s" (show w)
       forM_ (Map.toList map) $ \(key, action) -> do
-        liftX $ logs Info "   -- remap: %s" (show key)
+        liftX $ logs Debug "   -- remap: %s" (show key)
         remapKey key action
 
-applyKeys :: XConfig l -> IO (XConfig l)
-applyKeys config =
-  return $
-    windowBindings $
-      config
-        { keys = keyBindingToKeymap keymap,
-          mouseBindings = buttonBindingsToButtonMap mouseMap
-        }
-
 modifyWindowBorder :: Integer -> SpacingModifier
 modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) ->
   Border (clip $ a + i) (clip $ b + i) (clip $ c + i) (clip $ d + i)
diff --git a/src/Rahm/Desktop/Keys/Dsl.hs b/src/Rahm/Desktop/Keys/Dsl.hs
deleted file mode 100644
index 1246d3b..0000000
--- a/src/Rahm/Desktop/Keys/Dsl.hs
+++ /dev/null
@@ -1,607 +0,0 @@
-{-# LANGUAGE FunctionalDependencies #-}
-
-module Rahm.Desktop.Keys.Dsl
-  ( doc,
-    (-|-),
-    ButtonBinding (..),
-    ButtonBindings,
-    Documented (..),
-    HasConfig,
-    KeyBinding (..),
-    KeyBindings,
-    altAltgrMod,
-    altHyperAltgrMod,
-    altHyperMod,
-    altMask,
-    altMod,
-    altSuperAltgrMod,
-    altSuperHyperAltgrMod,
-    altSuperHyperMod,
-    altSuperMod,
-    altgrMask,
-    altgrMod,
-    bind,
-    buttonDocumentation,
-    controlAltAltgrMod,
-    controlAltHyperAltgrMod,
-    controlAltHyperMod,
-    controlAltMod,
-    controlAltSuperAltgrMod,
-    controlAltSuperHyperAltgrMod,
-    controlAltSuperHyperMod,
-    controlAltSuperMod,
-    controlAltgrMod,
-    controlHyperAltgrMod,
-    controlHyperMod,
-    controlMod,
-    controlSuperAltgrMod,
-    controlSuperHyperAltgrMod,
-    controlSuperHyperMod,
-    controlSuperMod,
-    documentation,
-    getConfig,
-    hyperAltgrMod,
-    hyperMask,
-    hyperMod,
-    justMod,
-    maskMod,
-    noMod,
-    rawMask,
-    runButtons,
-    runKeys,
-    shiftAltAltgrMod,
-    shiftAltHyperAltgrMod,
-    shiftAltHyperMod,
-    shiftAltMod,
-    shiftAltSuperAltgrMod,
-    shiftAltSuperHyperAltgrMod,
-    shiftAltSuperHyperMod,
-    shiftAltSuperMod,
-    shiftAltgrMod,
-    shiftControlAltAltgrMod,
-    shiftControlAltHyperAltgrMod,
-    shiftControlAltHyperMod,
-    shiftControlAltMod,
-    shiftControlAltSuperAltgrMod,
-    shiftControlAltSuperHyperAltgrMod,
-    shiftControlAltSuperHyperMod,
-    shiftControlAltSuperMod,
-    shiftControlAltgrMod,
-    shiftControlHyperAltgrMod,
-    shiftControlHyperMod,
-    shiftControlMod,
-    shiftControlSuperAltgrMod,
-    shiftControlSuperHyperAltgrMod,
-    shiftControlSuperHyperMod,
-    shiftControlSuperMod,
-    shiftHyperAltgrMod,
-    shiftHyperMod,
-    shiftMod,
-    shiftSuperAltgrMod,
-    shiftSuperHyperAltgrMod,
-    shiftSuperHyperMod,
-    shiftSuperMod,
-    superAltgrMod,
-    superHyperAltgrMod,
-    superHyperMod,
-    superMask,
-    superMod,
-  )
-where
-
-import Control.Arrow (first, second)
-import Control.Monad.State (State, execState, modify')
-import Control.Monad.Writer
-  ( MonadWriter (tell),
-    execWriter,
-    forM_,
-    when,
-  )
-import Data.Bits ((.&.))
-import Data.List (intercalate, sortOn)
-import Data.Map (Map)
-import qualified Data.Map as Map
-  ( empty,
-    fromList,
-    fromListWith,
-    toList,
-  )
-import Text.Printf (printf)
-import XMonad
-  ( Button,
-    ButtonMask,
-    KeyMask,
-    KeySym,
-    MonadState (get),
-    Window,
-    X,
-    XConfig (modMask),
-    controlMask,
-    keysymToString,
-    mod1Mask,
-    mod3Mask,
-    mod4Mask,
-    shiftMask,
-    (.|.),
-  )
-
-data Documented t = Documented String t
-
-data KeyBinding
-  = Action (X ())
-  | Submap KeyBindings
-  | Repeat KeyBindings
-
-type KeyBindings = Map (KeyMask, KeySym) (Documented KeyBinding)
-
-data ButtonBinding
-  = ButtonAction (Window -> X ())
-  | ButtonSubmap ButtonBindings
-  | ButtonContinuous ButtonBindings
-
--- Window -> X ()
-
-type ButtonBindings = Map (KeyMask, Button) (Documented ButtonBinding)
-
-{- Module that defines a DSL for binding keys. -}
-newtype KeysM l a = KeysM (State (XConfig l, KeyBindings) a)
-  deriving (Functor, Applicative, Monad)
-
-newtype ButtonsM l a = ButtonsM (State (XConfig l, ButtonBindings) a)
-  deriving (Functor, Applicative, Monad)
-
-newtype BindingBuilder b a = BindingBuilder (State (KeyMask, [(KeyMask, b)]) a)
-  deriving (Functor, Applicative, Monad)
-
-class HasConfig m where
-  getConfig :: m l (XConfig l)
-
-class Bindable k where
-  type BindableValue k :: *
-  type BindableMonad k :: (* -> *) -> * -> *
-
-  bind :: k -> BindingBuilder (BindableValue k) a -> BindableMonad k l ()
-
--- section :: String -> BindableMonad k l () -> BindableMonad k l ()
-
-class Binding k b where
-  toB :: k -> b
-
-  rawMask :: KeyMask -> k -> BindingBuilder b ()
-  rawMask m x = BindingBuilder $ modify' (second ((m, toB x) :))
-
-instance Binding (Window -> X ()) (Documented ButtonBinding) where
-  toB = Documented "" . ButtonAction
-
-instance Binding (X ()) (Documented KeyBinding) where
-  toB = Documented "" . Action
-
-instance Binding KeyBindings (Documented KeyBinding) where
-  toB = Documented "" . Submap
-
-instance Binding a (Documented a) where
-  toB = Documented ""
-
-instance Binding a a where
-  toB = id
-
--- Relationships to witness which types can be used with the "doc" function,
--- which is used to document actions in a safe and programmable way..
-class Relation k b | k -> b
-
-instance Relation (X ()) KeyBinding
-
-instance Relation KeyBinding KeyBinding
-
-instance Relation ButtonBinding ButtonBinding
-
-instance Relation (Window -> X ()) ButtonBinding
-
-doc :: (Relation k b, Binding k (Documented b)) => String -> k -> Documented b
-doc str k = let (Documented _ t) = toB k in Documented str t
-
-runKeys :: KeysM l a -> XConfig l -> KeyBindings
-runKeys (KeysM stateM) config =
-  snd $ execState stateM (config, Map.empty)
-
-runButtons :: ButtonsM l a -> XConfig l -> ButtonBindings
-runButtons (ButtonsM stateM) config =
-  snd $ execState stateM (config, Map.empty)
-
-instance HasConfig KeysM where
-  getConfig = fst <$> KeysM get
-
-instance HasConfig ButtonsM where
-  getConfig = fst <$> ButtonsM get
-
-{- Generally it is assumed that the mod key shoud be pressed, but not always. -}
-noMod :: (Binding k b) => k -> BindingBuilder b ()
-noMod = rawMask 0
-
-maskMod :: (Binding k b) => KeyMask -> k -> BindingBuilder b ()
-maskMod mask action = do
-  modMask <- fst <$> BindingBuilder get
-  rawMask (modMask .|. mask) action
-
-altMask :: KeyMask
-altMask = mod1Mask
-
-hyperMask :: KeyMask
-hyperMask = mod3Mask
-
-altgrMask :: KeyMask
-altgrMask = 0x80
-
-superMask :: KeyMask
-superMask = mod4Mask
-
-justMod :: (Binding k b) => k -> BindingBuilder b ()
-justMod = maskMod 0
-
-instance Bindable KeySym where
-  type BindableValue KeySym = Documented KeyBinding
-  type BindableMonad KeySym = KeysM
-
-  -- bind :: KeySym -> BindingBuilder (X x) a -> KeysM l ()
-  bind key (BindingBuilder stM) = do
-    m <- modMask <$> getConfig
-    let (_, values) = execState stM (m, [])
-
-    KeysM $
-      modify' $
-        second $
-          flip (<>) (Map.fromList (map (\(m, v) -> ((m, key), v)) values))
-
-instance Bindable Button where
-  type BindableValue Button = Documented ButtonBinding
-  type BindableMonad Button = ButtonsM
-
-  -- bind :: KeySym -> BindingBuilder (Window -> X ()) a -> ButtonsM l ()
-  bind button (BindingBuilder stM) = do
-    m <- modMask <$> getConfig
-    let (_, values) = execState stM (m, [])
-
-    ButtonsM $
-      modify' $
-        second $
-          flip (<>) (Map.fromList (map (\(m, v) -> ((m, button), v)) values))
-
-shiftControlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlAltSuperHyperAltgrMod =
-  maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask)
-
-shiftControlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlAltSuperHyperMod =
-  maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. hyperMask)
-
-shiftControlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlAltSuperAltgrMod =
-  maskMod (shiftMask .|. controlMask .|. altMask .|. superMask .|. altgrMask)
-
-shiftControlAltSuperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlAltSuperMod =
-  maskMod (shiftMask .|. controlMask .|. altMask .|. superMask)
-
-shiftControlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlAltHyperAltgrMod =
-  maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask .|. altgrMask)
-
-shiftControlAltHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlAltHyperMod =
-  maskMod (shiftMask .|. controlMask .|. altMask .|. hyperMask)
-
-shiftControlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlAltAltgrMod =
-  maskMod (shiftMask .|. controlMask .|. altMask .|. altgrMask)
-
-shiftControlAltMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlAltMod =
-  maskMod (shiftMask .|. controlMask .|. altMask)
-
-shiftControlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlSuperHyperAltgrMod =
-  maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask .|. altgrMask)
-
-shiftControlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlSuperHyperMod =
-  maskMod (shiftMask .|. controlMask .|. superMask .|. hyperMask)
-
-shiftControlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlSuperAltgrMod =
-  maskMod (shiftMask .|. controlMask .|. superMask .|. altgrMask)
-
-shiftControlSuperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlSuperMod =
-  maskMod (shiftMask .|. controlMask .|. superMask)
-
-shiftControlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlHyperAltgrMod =
-  maskMod (shiftMask .|. controlMask .|. hyperMask .|. altgrMask)
-
-shiftControlHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlHyperMod =
-  maskMod (shiftMask .|. controlMask .|. hyperMask)
-
-shiftControlAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlAltgrMod =
-  maskMod (shiftMask .|. controlMask .|. altgrMask)
-
-shiftControlMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftControlMod =
-  maskMod (shiftMask .|. controlMask)
-
-shiftAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftAltSuperHyperAltgrMod =
-  maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask)
-
-shiftAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftAltSuperHyperMod =
-  maskMod (shiftMask .|. altMask .|. superMask .|. hyperMask)
-
-shiftAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftAltSuperAltgrMod =
-  maskMod (shiftMask .|. altMask .|. superMask .|. altgrMask)
-
-shiftAltSuperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftAltSuperMod =
-  maskMod (shiftMask .|. altMask .|. superMask)
-
-shiftAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftAltHyperAltgrMod =
-  maskMod (shiftMask .|. altMask .|. hyperMask .|. altgrMask)
-
-shiftAltHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftAltHyperMod =
-  maskMod (shiftMask .|. altMask .|. hyperMask)
-
-shiftAltAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftAltAltgrMod =
-  maskMod (shiftMask .|. altMask .|. altgrMask)
-
-shiftAltMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftAltMod =
-  maskMod (shiftMask .|. altMask)
-
-shiftSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftSuperHyperAltgrMod =
-  maskMod (shiftMask .|. superMask .|. hyperMask .|. altgrMask)
-
-shiftSuperHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftSuperHyperMod =
-  maskMod (shiftMask .|. superMask .|. hyperMask)
-
-shiftSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftSuperAltgrMod =
-  maskMod (shiftMask .|. superMask .|. altgrMask)
-
-shiftSuperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftSuperMod =
-  maskMod (shiftMask .|. superMask)
-
-shiftHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftHyperAltgrMod =
-  maskMod (shiftMask .|. hyperMask .|. altgrMask)
-
-shiftHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftHyperMod =
-  maskMod (shiftMask .|. hyperMask)
-
-shiftAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftAltgrMod =
-  maskMod (shiftMask .|. altgrMask)
-
-shiftMod :: (Binding k b) => k -> BindingBuilder b ()
-shiftMod = maskMod shiftMask
-
-controlAltSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-controlAltSuperHyperAltgrMod =
-  maskMod (controlMask .|. altMask .|. superMask .|. hyperMask .|. altgrMask)
-
-controlAltSuperHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-controlAltSuperHyperMod =
-  maskMod (controlMask .|. altMask .|. superMask .|. hyperMask)
-
-controlAltSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-controlAltSuperAltgrMod =
-  maskMod (controlMask .|. altMask .|. superMask .|. altgrMask)
-
-controlAltSuperMod :: (Binding k b) => k -> BindingBuilder b ()
-controlAltSuperMod =
-  maskMod (controlMask .|. altMask .|. superMask)
-
-controlAltHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-controlAltHyperAltgrMod =
-  maskMod (controlMask .|. altMask .|. hyperMask .|. altgrMask)
-
-controlAltHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-controlAltHyperMod =
-  maskMod (controlMask .|. altMask .|. hyperMask)
-
-controlAltAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-controlAltAltgrMod =
-  maskMod (controlMask .|. altMask .|. altgrMask)
-
-controlAltMod :: (Binding k b) => k -> BindingBuilder b ()
-controlAltMod =
-  maskMod (controlMask .|. altMask)
-
-controlSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-controlSuperHyperAltgrMod =
-  maskMod (controlMask .|. superMask .|. hyperMask .|. altgrMask)
-
-controlSuperHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-controlSuperHyperMod =
-  maskMod (controlMask .|. superMask .|. hyperMask)
-
-controlSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-controlSuperAltgrMod =
-  maskMod (controlMask .|. superMask .|. altgrMask)
-
-controlSuperMod :: (Binding k b) => k -> BindingBuilder b ()
-controlSuperMod =
-  maskMod (controlMask .|. superMask)
-
-controlHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-controlHyperAltgrMod =
-  maskMod (controlMask .|. hyperMask .|. altgrMask)
-
-controlHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-controlHyperMod =
-  maskMod (controlMask .|. hyperMask)
-
-controlAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-controlAltgrMod =
-  maskMod (controlMask .|. altgrMask)
-
-controlMod :: (Binding k b) => k -> BindingBuilder b ()
-controlMod = maskMod controlMask
-
-altSuperHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-altSuperHyperAltgrMod =
-  maskMod (altMask .|. superMask .|. hyperMask .|. altgrMask)
-
-altSuperHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-altSuperHyperMod =
-  maskMod (altMask .|. superMask .|. hyperMask)
-
-altSuperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-altSuperAltgrMod =
-  maskMod (altMask .|. superMask .|. altgrMask)
-
-altSuperMod :: (Binding k b) => k -> BindingBuilder b ()
-altSuperMod =
-  maskMod (altMask .|. superMask)
-
-altHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-altHyperAltgrMod =
-  maskMod (altMask .|. hyperMask .|. altgrMask)
-
-altHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-altHyperMod =
-  maskMod (altMask .|. hyperMask)
-
-altAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-altAltgrMod =
-  maskMod (altMask .|. altgrMask)
-
-altMod :: (Binding k b) => k -> BindingBuilder b ()
-altMod = maskMod altMask
-
-superHyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-superHyperAltgrMod =
-  maskMod (superMask .|. hyperMask .|. altgrMask)
-
-superHyperMod :: (Binding k b) => k -> BindingBuilder b ()
-superHyperMod =
-  maskMod (superMask .|. hyperMask)
-
-superAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-superAltgrMod =
-  maskMod (superMask .|. altgrMask)
-
-superMod :: (Binding k b) => k -> BindingBuilder b ()
-superMod = maskMod superMask
-
-hyperAltgrMod :: (Binding k b) => k -> BindingBuilder b ()
-hyperAltgrMod =
-  maskMod (hyperMask .|. altgrMask)
-
-hyperMod :: (Binding k b) => k -> BindingBuilder b ()
-hyperMod = maskMod hyperMask
-
-altgrMod :: (Binding k b) => k -> BindingBuilder b ()
-altgrMod = maskMod altgrMask
-
-{- Can combine two or more of the functions above to apply the same action to
- - multiple masks. -}
-(-|-) ::
-  (Binding k b) =>
-  (k -> BindingBuilder b ()) ->
-  (k -> BindingBuilder b ()) ->
-  k ->
-  BindingBuilder b ()
-(-|-) fn1 fn2 f = fn1 f >> fn2 f
-
-buttonDocumentation :: ButtonBindings -> String
-buttonDocumentation = execWriter . document' ""
-  where
-    document' pref keybindings =
-      forM_ (sortOn (map (\(a, b) -> (b, a)) . snd . snd) $ Map.toList (keyBindingsToList keybindings)) $ \(doc, (thing, keys)) -> do
-        when (not (null doc) || hasSubmap thing) $
-          tell $ printf "%s%s: %s\n" pref (intercalate " or " $ map prettyShow keys) doc
-        case thing of
-          ButtonAction _ -> return ()
-          ButtonSubmap submap -> document' (pref ++ "  ") submap
-          ButtonContinuous submap -> do
-            tell pref
-            tell "  (repeatable):\n"
-            document' (pref ++ "    ") submap
-
-    keyBindingsToList :: ButtonBindings -> Map String (ButtonBinding, [(ButtonMask, Button)])
-    keyBindingsToList b =
-      (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list))
-        <$> group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b)
-
-    prettyShow :: (ButtonMask, Button) -> String
-    prettyShow (mask, button) = printf "%s%s" (showMask mask) (buttonToString button)
-
-    buttonToString = \case
-      1 -> "Left Click"
-      2 -> "Middle Click"
-      3 -> "Right Click"
-      4 -> "Wheel Up"
-      5 -> "Wheel Down"
-      6 -> "Wheel Left"
-      7 -> "Wheel Right"
-      8 -> "Browser Back"
-      9 -> "Browser Forward"
-      13 -> "Thumb Target"
-      14 -> "Index Forward"
-      15 -> "Index Back"
-      b -> "Button " ++ show b
-
-    hasSubmap b = case b of
-      ButtonAction _ -> False
-      _ -> True
-
-documentation :: KeyBindings -> String
-documentation = execWriter . document' ""
-  where
-    document' pref keybindings =
-      forM_ (sortOn (map (\(a, b) -> (b, a)) . snd . snd) $ Map.toList (keyBindingsToList keybindings)) $ \(doc, (thing, keys)) -> do
-        when (not (null doc) || hasSubmap thing) $
-          tell $ printf "%s%s: %s\n" pref (intercalate " or " $ map prettyShow keys) doc
-        case thing of
-          Action _ -> return ()
-          Submap submap -> document' (pref ++ "  ") submap
-          Repeat submap -> do
-            tell pref
-            tell "  (repeatable):\n"
-            document' (pref ++ "    ") submap
-
-    keyBindingsToList :: KeyBindings -> Map String (KeyBinding, [(KeyMask, KeySym)])
-    keyBindingsToList b =
-      (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list))
-        <$> group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b)
-
-    prettyShow :: (KeyMask, KeySym) -> String
-    prettyShow (mask, key) = printf "%s%s" (showMask mask) (keysymToString key)
-
-    hasSubmap b = case b of
-      Action _ -> False
-      _ -> True
-
-showMask :: KeyMask -> String
-showMask mask =
-  let masks =
-        [ (shiftMask, "S"),
-          (altMask, "A"),
-          (mod3Mask, "H"),
-          (mod4Mask, "M"),
-          (altgrMask, "AGr"),
-          (controlMask, "C")
-        ]
-   in concatMap ((++ "-") . snd) $ filter ((/= 0) . (.&. mask) . fst) masks
-
-group :: (Ord b) => (a -> b) -> [a] -> Map b [a]
-group fn = Map.fromListWith (++) . map (first fn . (\a -> (a, [a])))
diff --git a/src/Rahm/Desktop/Keys/Dsl2.hs b/src/Rahm/Desktop/Keys/Dsl2.hs
new file mode 100644
index 0000000..3debc48
--- /dev/null
+++ b/src/Rahm/Desktop/Keys/Dsl2.hs
@@ -0,0 +1,254 @@
+module Rahm.Desktop.Keys.Dsl2 where
+
+import Control.Monad.Fix (fix)
+import Control.Monad.RWS (MonadTrans (lift), MonadWriter, forM_)
+import Control.Monad.Reader (Reader, ask, runReader)
+import Control.Monad.State (MonadTrans, StateT (StateT))
+import Control.Monad.Trans.Maybe (MaybeT (..))
+import Control.Monad.Trans.Writer (Writer, WriterT, execWriter, execWriterT)
+import Control.Monad.Writer.Class (tell)
+import Data.Functor.Identity (Identity)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+import Rahm.Desktop.Common (pointerWindow, runMaybeT_)
+import Rahm.Desktop.Logger (LogLevel (Debug), logs)
+import Rahm.Desktop.Submap (ButtonOrKeyEvent (ButtonPress, KeyPress), getStringForKey, nextButtonOrKeyEvent)
+import Rahm.Desktop.XMobarLog (spawnXMobar)
+import Rahm.Desktop.XMobarLog.PendingBuffer (pushAddPendingBuffer, pushPendingBuffer)
+import XMonad
+
+data Documented t = Documented
+  { docString :: String,
+    undocument :: t
+  }
+
+type family Action t where
+  Action KeySym = X ()
+  Action Button = Window -> X ()
+
+data XConfigH where
+  XConfigH :: forall l. XConfig l -> XConfigH
+
+data Binding t
+  = Action (Action t)
+  | Submap (forall l. XConfig l -> BindingsMap)
+  | Repeat (Binding t) (forall l. XConfig l -> BindingsMap)
+  | NoBinding
+
+data BindingsMap = BindingsMap
+  { key_bindings :: Map (KeyMask, KeySym) (Documented (Binding KeySym)),
+    button_bindings :: Map (KeyMask, Button) (Documented (Binding Button)),
+    no_match_catch_key :: (KeyMask, KeySym, String) -> X (),
+    no_match_catch_button :: (KeyMask, Button) -> Window -> X ()
+  }
+
+newtype MaskBinder k a = MaskBinder
+  { unMaskBinder :: WriterT (Map KeyMask (Documented (Binding k))) (Reader XConfigH) a
+  }
+  deriving
+    ( Functor,
+      Applicative,
+      Monad,
+      MonadWriter (Map KeyMask (Documented (Binding k))),
+      MonadReader XConfigH
+    )
+
+instance Semigroup BindingsMap where
+  (BindingsMap mk1 mb1 _ _) <> (BindingsMap mk2 mb2 fk fb) =
+    BindingsMap (mk1 <> mk2) (mb1 <> mb2) fk fb
+
+instance Monoid BindingsMap where
+  mempty = BindingsMap mempty mempty (\_ -> return ()) (\_ _ -> return ())
+
+newtype Binder a = Binder (WriterT BindingsMap (Reader XConfigH) a)
+  deriving (Functor, Applicative, Monad, MonadWriter BindingsMap, MonadReader XConfigH)
+
+bindOtherKeys :: ((KeyMask, KeySym, String) -> X ()) -> Binder ()
+bindOtherKeys fn = Binder $ tell (mempty {no_match_catch_key = fn})
+
+bindOtherButtons :: ((KeyMask, Button) -> Window -> X ()) -> Binder ()
+bindOtherButtons fn = Binder $ tell (mempty {no_match_catch_button = fn})
+
+class Documentable a b where
+  toDocumented :: a -> b
+
+instance Documentable (Documented a) (Documented a) where
+  toDocumented = id
+
+instance Documentable a (Documented a) where
+  toDocumented = Documented ""
+
+class BindingType a where
+  type BoundTo a :: *
+
+  toBinding :: a -> Documented (Binding (BoundTo a))
+
+instance BindingType (Binding t) where
+  type BoundTo (Binding t) = t
+  toBinding = Documented ""
+
+instance BindingType (X ()) where
+  type BoundTo (X ()) = KeySym
+  toBinding = Documented "" . Action
+
+instance BindingType (Window -> X ()) where
+  type BoundTo (Window -> X ()) = Button
+  toBinding = Documented "" . Action
+
+instance (BindingType a) => BindingType (Documented a) where
+  type BoundTo (Documented a) = BoundTo a
+  toBinding (Documented s (toBinding -> (Documented _ a))) = Documented s a
+
+class Bind k where
+  doBinding :: k -> Map KeyMask (Documented (Binding k)) -> BindingsMap
+  rawMaskRaw :: KeyMask -> Documented (Binding k) -> MaskBinder k ()
+
+instance Bind Button where
+  doBinding but mp = mempty {button_bindings = Map.mapKeys (,but) mp}
+  rawMaskRaw mask act = tell (Map.singleton mask act)
+
+instance Bind KeySym where
+  doBinding key mp = mempty {key_bindings = Map.mapKeys (,key) mp}
+  rawMaskRaw mask act = tell (Map.singleton mask act)
+
+rawMask :: (Bind (BoundTo a), BindingType a) => KeyMask -> a -> MaskBinder (BoundTo a) ()
+rawMask mask act = rawMaskRaw mask (toBinding act)
+
+withMod :: (Bind (BoundTo a), BindingType a) => KeyMask -> a -> MaskBinder (BoundTo a) ()
+withMod m act = do
+  (XConfigH (modMask -> mm)) <- ask
+  rawMask (mm .|. m) act
+
+noMod, justMod, shiftMod, controlMod, altMod :: (Bind (BoundTo a), BindingType a) => a -> MaskBinder (BoundTo a) ()
+justMod = withMod 0
+noMod = rawMask 0
+shiftMod = withMod shiftMask
+controlMod = withMod controlMask
+altMod = withMod mod1Mask
+
+(-|-) ::
+  (Bind (BoundTo a), BindingType a) =>
+  (a -> MaskBinder (BoundTo a) ()) ->
+  (a -> MaskBinder (BoundTo a) ()) ->
+  a ->
+  MaskBinder (BoundTo a) ()
+m1 -|- m2 = \act -> m1 act >> m2 act
+
+bind :: (Bind k) => k -> MaskBinder k () -> Binder ()
+bind k h =
+  tell . doBinding k . runReader (execWriterT $ unMaskBinder h) =<< ask
+
+bindL :: (Bind k) => [k] -> MaskBinder k () -> Binder ()
+bindL ks h = mapM_ (`bind` h) ks
+
+doc :: String -> a -> Documented a
+doc = Documented
+
+noWindow :: X () -> Window -> X ()
+noWindow fn _ = fn
+
+resolveBindings ::
+  BindingsMap ->
+  ( XConfig l -> Map (KeyMask, KeySym) (X ()),
+    XConfig l -> Map (ButtonMask, Button) (Window -> X ())
+  )
+resolveBindings (BindingsMap keyBindings buttonBindings _ _) =
+  ( \c -> Map.mapWithKey (\k -> pushK k (bindingToX c) . undocument) keyBindings,
+    \c -> Map.mapWithKey (\k -> pushB k (bindingToWinX c) . undocument) buttonBindings
+  )
+  where
+    pushB :: (ButtonMask, Button) -> (Binding Button -> Window -> X ()) -> Binding Button -> Window -> X ()
+    pushB (_, b) fn binding win =
+      if isRepeatOrSubmap binding
+        then pushPendingBuffer ("b" ++ show b ++ " ") $ fn binding win
+        else fn binding win
+
+    pushK (m, k) fn binding =
+      if isRepeatOrSubmap binding
+        then do
+          let s = getStringForKey (m, k)
+          pushPendingBuffer (s ++ " ") $ fn binding
+        else fn binding
+
+    bindingToX :: forall l. XConfig l -> Binding KeySym -> X ()
+    bindingToX conf = \case
+      NoBinding -> return ()
+      Action a -> a
+      Submap sm -> doSubmap conf (sm conf) (return ())
+      Repeat a sm -> bindingToX conf a >> fix (doSubmap conf (sm conf))
+
+    bindingToWinX :: forall l. XConfig l -> Binding Button -> Window -> X ()
+    bindingToWinX conf binding win = case binding of
+      NoBinding -> return ()
+      Action fn -> fn win
+      Submap sm -> doSubmap conf (sm conf) (return ())
+      Repeat a sm -> bindingToWinX conf a win >> fix (doSubmap conf (sm conf))
+
+    doSubmap :: forall l. XConfig l -> BindingsMap -> X () -> X ()
+    doSubmap conf (BindingsMap kbind bbind _ _) after = runMaybeT_ $ do
+      nextPressEvent $
+        \case
+          (ButtonPress m b) -> do
+            binding <- hoist $ Map.lookup (m, b) bbind
+            lift $ do
+              win <- pointerWindow
+              bindingToWinX conf (undocument binding) win
+              after
+          (KeyPress m k s) -> do
+            binding <- hoist $ Map.lookup (m, k) kbind
+            lift $ do
+              bindingToX conf (undocument binding)
+              after
+
+    isRepeatOrSubmap = \case
+      Repeat {} -> True
+      Submap {} -> True
+      _ -> False
+
+    nextPressEvent fn = do
+      ev <- nextButtonOrKeyEvent
+      let str = case ev of
+            ButtonPress m b -> "b" ++ show b
+            KeyPress _ _ s -> s
+      lift $
+        pushAddPendingBuffer (str ++ " ") $
+          runMaybeT_ $
+            fn ev
+
+    hoist = MaybeT . return
+
+subbind :: Binder () -> Binding t
+subbind (Binder b) =
+  Submap $ \config ->
+    runReader (execWriterT b) (XConfigH config)
+
+repeatable :: Binder () -> Binding t
+repeatable (Binder b) =
+  Repeat NoBinding $ \config ->
+    runReader (execWriterT b) (XConfigH config)
+
+-- Similar to repeatable, but all the keys in the binder start the loop.
+continuous :: Binder () -> Binder ()
+continuous (Binder b) = do
+  conf <- ask
+  let bm@(BindingsMap keyBinds mouseBinds _ _) =
+        runReader (execWriterT b) conf
+
+  forM_ (Map.toList keyBinds) $ \((m, k), Documented _ b) ->
+    bind k $ rawMask m $ Repeat b $ const bm
+
+  forM_ (Map.toList mouseBinds) $ \((m, k), Documented _ b) ->
+    bind k $ rawMask m $ Repeat b $ const bm
+
+runBinder :: XConfig l -> Binder a -> BindingsMap
+runBinder conf (Binder binder) = runReader (execWriterT binder) (XConfigH conf)
+
+withBindings :: Binder a -> XConfig l -> XConfig l
+withBindings b config =
+  let (keyBinds, buttonBinds) =
+        resolveBindings $ runBinder config b
+   in config
+        { keys = keyBinds,
+          mouseBindings = buttonBinds
+        }
diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
index b705a24..9c20381 100644
--- a/src/Rahm/Desktop/Submap.hs
+++ b/src/Rahm/Desktop/Submap.hs
@@ -8,19 +8,28 @@ module Rahm.Desktop.Submap
     submap,
     submapDefault,
     submapDefaultWithKey,
+    ButtonOrKeyEvent (..),
+    nextButtonOrKeyEvent,
+    getStringForKey,
     escape,
   )
 where
 
 import Control.Concurrent (threadDelay)
+import Control.Exception (SomeException (SomeException), catch)
+import Control.Monad (when)
 import Control.Monad.Fix (fix)
 import Control.Monad.Trans (MonadTrans (lift))
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
+import Data.Aeson (Result (Error))
+import Data.Bits ((.&.))
+import Data.Char (toUpper)
 import Data.Map (Map)
 import qualified Data.Map as Map (findWithDefault, lookup)
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Data.Word (Word64)
 import Rahm.Desktop.Common (pointerWindow, runMaybeT_)
+import Rahm.Desktop.Logger (logs)
 import XMonad
   ( Button,
     ButtonMask,
@@ -37,6 +46,7 @@ import XMonad
     XEventPtr,
     allocaXEvent,
     asKeyEvent,
+    asks,
     buttonPressMask,
     checkMaskEvent,
     cleanMask,
@@ -49,14 +59,19 @@ import XMonad
     isModifierKey,
     keyPressMask,
     keycodeToKeysym,
+    keysymToKeycode,
+    keysymToString,
     lookupString,
     maskEvent,
     pointerMotionMask,
+    setKeyEvent,
+    shiftMask,
     ungrabKeyboard,
     ungrabPointer,
     (.|.),
   )
 import qualified XMonad.Util.ExtensibleState as XS
+import XMonad.Util.Loggers (logSp)
 
 newtype Escape = Escape Bool
 
@@ -98,6 +113,51 @@ getMaskEventWithTimeout timeout d mask fn = do
             then return True
             else threadDelay 1000 >> getMaskEventWithTimeout' ptr timeout
 
+data ButtonOrKeyEvent
+  = ButtonPress
+      { event_mask :: KeyMask,
+        event_button :: Button
+      }
+  | KeyPress
+      { event_mask :: KeyMask,
+        event_keysym :: KeySym,
+        event_string :: String
+      }
+
+nextButtonOrKeyEvent :: MaybeT X ButtonOrKeyEvent
+nextButtonOrKeyEvent = do
+  b <- lift getEscape
+  when b (MaybeT (return Nothing))
+
+  XConf {theRoot = root, display = d} <- ask
+  io $ do
+    grabKeyboard d root False grabModeAsync grabModeAsync currentTime
+    grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime
+
+  ret <- MaybeT $
+    io $
+      fix $ \tryAgain -> do
+        ret <-
+          getMaskEventWithTimeout 5000 d (keyPressMask .|. buttonPressMask) $ \p -> do
+            ev <- getEvent p
+            case ev of
+              ButtonEvent {ev_button = b, ev_state = m} ->
+                return $ ButtonPress m b
+              KeyEvent {ev_keycode = code, ev_state = m} -> do
+                keysym <- keycodeToKeysym d code 0
+                (_, str) <- lookupString (asKeyEvent p)
+                return $ KeyPress m keysym str
+        case ret of
+          Just (KeyPress m sym str) | isModifierKey sym -> tryAgain
+          x -> return x
+
+  io $ do
+    ungrabKeyboard d currentTime
+    ungrabPointer d currentTime
+
+  m' <- lift $ cleanMask (event_mask ret)
+  return ret {event_mask = m'}
+
 {-
  - Like submap fram XMonad.Actions.Submap, but sends the string from
  - XLookupString to the function along side the keysym.
@@ -134,6 +194,24 @@ mapNextStringWithKeysym fn = do
   m <- lift $ cleanMask m'
   fn m keysym str
 
+-- getStringForKey :: (KeyMask, KeySym) -> X String
+-- getStringForKey (m, sym) = do
+--   d <- asks display
+--   io $
+--     allocaXEvent
+--       ( \xev -> do
+--           kc <- keysymToKeycode d sym
+--           setKeyEvent xev 0 0 0 m kc False
+--           (_, str) <- lookupString (asKeyEvent xev)
+--           return str
+--       )
+--       `catch` ( \e -> do
+--                   putStrLn $ "Error in getStringForKey: " ++ show (e :: SomeException)
+--                   return "?"
+--               )
+getStringForKey :: (KeyMask, KeySym) -> String
+getStringForKey (m, sym) = (if (m .&. shiftMask) /= 0 then map toUpper else id) (keysymToString sym)
+
 {- Like submap, but on the character typed rather than the kysym. -}
 mapNextString :: (KeyMask -> String -> MaybeT X a) -> MaybeT X a
 mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s)