allow modifiers in keymaps

2022-12-23 14:43:29 +00:00
parent ddef8af528
commit 15c0ce3417
3 changed files with 91 additions and 19 deletions
@@ -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
+      } }