allow modifiers in keymaps

frame.fnl

@@ -13,7 +13,7 @@
                      "g" #(Command.invoke-interactively
                            "visit-location"
                            {:buffer "main"})
-                     "q" #(Command.invoke-interactively
+                     "M-q" #(Command.invoke-interactively
                            "quit-browser"
                            {})
                      "c" {
@@ -54,7 +54,7 @@
     (tset window :on_key_release_event
           (fn [window event]
             (when (not (Command.active?))
-              (match (recogniser:accept (string.char event.keyval))
+              (match (recogniser:accept-event event)
                 c (c)
                 (nil prompt) (print "prompted" prompt)))
             (when (and event.state.MOD1_MASK

keymap.fnl

@@ -1,19 +1,64 @@
+(local { : Gdk } (require :lgi))
+(local { : view } (require :fennel))
+
+(fn keychord->spec [keychord]
+  (let [Mod Gdk.ModifierType
+        symbol (keychord:match "(%w+)$")
+        upper? (and (symbol:match "%u") true)
+        modmask (accumulate [m (if upper? Mod.SHIFT_MASK 0)
+                             v (keychord:gmatch "(%w+)-")]
+                  (match (v:lower)
+                    "m" (bor m Mod.MOD1_MASK)
+                    "c" (bor m Mod.CONTROL_MASK)
+                    "s" (bor m Mod.MOD4_MASK)))]
+    {
+     :keyval (string.byte (symbol:lower))
+     : modmask
+     }))
+
+(fn spec->index [spec]
+  (string.format "%d:%d" spec.keyval spec.modmask))
+
+(fn event->index [event]
+  (let [modmask
+        (accumulate [m 0
+                     k _ (pairs event.state)]
+          (bor m (. Gdk.ModifierType k)))]
+    (spec->index {:keyval event.keyval : modmask})))
 
 
-(fn recogniser [keymap]
-  (var m keymap)
-  {
-   :accept
-   (fn [_ c]
-     (let [v (. m c)]
-       (match (type v)
-         "table" (do
-                   (set m v)
-                   (values nil (.. c " ")))
-         "function" (do
-                      (set m keymap)
-                      v))))
-   })
+(fn compile-keymap [input]
+  (collect [k v (pairs input)]
+    (let [f (-> k keychord->spec spec->index)]
+      (match (type v)
+        "function" (values f v)
+        "table" (values f (compile-keymap v))))))
+
+(fn recogniser [source-keymap]
+  (let [keymap (compile-keymap source-keymap)]
+    (var m keymap)
+    {
+     :accept-event
+     (fn [_ e]
+       (let [c (event->index e)
+             v (. m c)]
+         (match (type v)
+           "table" (do
+                     (set m v)
+                     (values nil (.. c " ")))
+           "function" (do
+                        (set m keymap)
+                        v)
+           "nil" (do
+                   (set m keymap)
+                   (values nil (.. "No binding for " (view e) " ")))
+
+           )))
+     }))
 
 
-{ : recogniser }
+{ : recogniser
+  :_ {
+      ;; symbols in _ are exported only for testing
+      : keychord->spec
+      } }

test/keymap.fnl

@@ -1,7 +1,11 @@
 (local { : view } (require :fennel))
+(local { : Gdk } (require :lgi))
 
 (local keymap (require :keymap))
 
+
+(local Mod Gdk.ModifierType)
+
 (local km
        {"a"
         {"a" #1
@@ -11,10 +15,33 @@
         "c" #4
         })
 
+(fn fake-key-event [c]
+  {:keyval (string.byte c)
+   :state {}
+   })
+
+
+(let [s (keymap._.keychord->spec "q")]
+  (match s
+    {:keyval 113 :modmask 0} true
+    _ (assert false (view s))))
+
+(let [s (keymap._.keychord->spec "C-a")]
+  (match s
+    {:keyval 97 :modmask 4} true
+    _ (assert false (view s))))
+
+(let [s (keymap._.keychord->spec "C-M-Z")]
+  (match s
+    {:keyval 122 :modmask 13} true
+    _ (assert false (view s))))
+
+
 (let [r (keymap.recogniser km)
       (ok err)
-      (match (r:accept "c")
+      (match (r:accept-event (fake-key-event "c"))
         (where f (= (f) 4)) true
-        x (values false (x)))]
+        x (values false (view x))
+        nil (values false "???"))]
 
   (assert ok err))