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.

1 files changed, 123 insertions, 231 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)