From afba4ddc265a58db55e792a3f8e4fdfac8805f2a Mon Sep 17 00:00:00 2001
From: Nat Quayle Nelson <natquaylenelson@gmail.com>
Date: Wed, 2 Feb 2022 14:58:27 -0700
Subject: [PATCH] kiss-tools KeyShortcutHandler based on kiss-vscode shortcut
 system

---
 .../src/kiss_tools/KeyShortcutHandler.hx      | 20 +++++
 .../src/kiss_tools/KeyShortcutHandler.kiss    | 82 +++++++++++++++++++
 projects/kiss-tools/src/kiss_tools/Main.hx    |  1 +
 3 files changed, 103 insertions(+)
 create mode 100644 projects/kiss-tools/src/kiss_tools/KeyShortcutHandler.hx
 create mode 100644 projects/kiss-tools/src/kiss_tools/KeyShortcutHandler.kiss

diff --git a/projects/kiss-tools/src/kiss_tools/KeyShortcutHandler.hx b/projects/kiss-tools/src/kiss_tools/KeyShortcutHandler.hx
new file mode 100644
index 00000000..d3a9be94
--- /dev/null
+++ b/projects/kiss-tools/src/kiss_tools/KeyShortcutHandler.hx
@@ -0,0 +1,20 @@
+package kiss_tools;
+
+import kiss.Prelude;
+import kiss.Stream;
+import kiss.List;
+
+typedef PrefixMap<T> = Map<String, ShortcutKey<T>>;
+typedef PrefixMapHandler<T> = (Map<String, ShortcutKey<T>>) -> Void;
+typedef ItemHandler<T> = (T) -> Void;
+typedef FinishHandler = () -> Void;
+typedef BadKeyHandler<T> = (String, PrefixMap<T>) -> Void;
+typedef BadShortcutHandler<T> = (String,ShortcutKey<T>) -> Void;
+
+enum ShortcutKey<T> {
+    Final(item:T);
+    Prefix(keys:PrefixMap<T>);
+}
+
+@:build(kiss.Kiss.build())
+class KeyShortcutHandler<T> {}
diff --git a/projects/kiss-tools/src/kiss_tools/KeyShortcutHandler.kiss b/projects/kiss-tools/src/kiss_tools/KeyShortcutHandler.kiss
new file mode 100644
index 00000000..b5e12db6
--- /dev/null
+++ b/projects/kiss-tools/src/kiss_tools/KeyShortcutHandler.kiss
@@ -0,0 +1,82 @@
+(prop :PrefixMap<T> rootMap (new Map))
+(prop &mut :PrefixMap<T> currentMap null)
+
+(prop &mut :String cancelKey null)
+(prop &mut :PrefixMapHandler<T> onSelectPrefixMap null)
+(prop &mut :ItemHandler<T> onSelectItem null)
+(prop &mut :FinishHandler onFinishOrCancel null)
+(prop &mut :BadKeyHandler<T> onBadKey null)
+(prop &mut :BadShortcutHandler<T> onBadShortcut null)
+
+(defMacro tryCall [handler &rest args]
+    `(whenLet [handler ,handler]
+        (handler ,@args)))
+
+(defMacro tryCallOrThrow [handler message &rest args]
+    `(ifLet [handler ,handler]
+            (handler ,@args)
+        (throw ,message)))
+
+(method _selectMap [m]
+    (set currentMap m)
+    (tryCall onSelectPrefixMap m))
+
+(method start []
+    (_selectMap rootMap))
+
+(method cancel []
+    (set currentMap null)
+    (tryCall onFinishOrCancel))
+
+(method handleKey [:String key]
+    (unless currentMap (tryCallOrThrow onBadKey "Tried to handle key $key without calling start() first" key null))
+    (case (dictGet currentMap key)
+        ((Final item)
+            (tryCall onSelectItem item)
+            (cancel))
+        ((Prefix nextMap)
+            (_selectMap nextMap))
+        (otherwise
+            (tryCallOrThrow onBadKey "Key $key is not defined in $currentMap and no onBadKey event was given" key currentMap))))
+
+// Extract [k]eyboard [s]hortcuts from a string:
+(method extractKeyboardShortcuts [str &opt :Stream stream :String shortcuts]
+    (unless stream (set stream (Stream.fromString str)))
+    (unless shortcuts (set shortcuts ""))
+    (case (stream.takeUntilAndDrop "[")
+        ((Some _)
+            (case (stream.takeUntilAndDrop "]")
+                ((Some newShortcuts)
+                    (extractKeyboardShortcuts str stream (+ shortcuts (newShortcuts.toLowerCase))))
+                (otherwise
+                    (tryCallOrThrow onBadShortcut "unclosed [ in $str" str null)
+                    "")))
+        (otherwise
+            shortcuts)))
+
+(method :Void registerShortcut [keys description item &opt :PrefixMap<T> prefixMap]
+    (unless prefixMap (set prefixMap rootMap))
+    (let [firstKey (keys.shift)]
+        (cond 
+            ((prefixMap.exists firstKey)
+                (let [existingKey (dictGet prefixMap firstKey)
+                        conflictMessage "Keyboard shortcut for $description conflicts with $existingKey"]
+                    (if keys
+                            (case existingKey
+                                ((Final _)
+                                    (tryCallOrThrow onBadShortcut conflictMessage description existingKey))
+                                ((Prefix innerPrefixMap)
+                                    (registerShortcut keys description item innerPrefixMap))
+                                (otherwise))
+                        (tryCallOrThrow onBadShortcut conflictMessage description existingKey))))
+            (true
+                (if keys
+                        (let [innerPrefixMap (new Map)]
+                            (dictSet prefixMap firstKey (Prefix innerPrefixMap))
+                            (registerShortcut keys description item innerPrefixMap))
+                    (dictSet prefixMap firstKey (Final item)))))))
+
+(method :Void registerItem [description :T item]
+    (whenLet [keyboardShortcut (extractKeyboardShortcuts description)]
+        (registerShortcut (keyboardShortcut.split "") description item)))
+
diff --git a/projects/kiss-tools/src/kiss_tools/Main.hx b/projects/kiss-tools/src/kiss_tools/Main.hx
index d471e385..c81505b8 100644
--- a/projects/kiss-tools/src/kiss_tools/Main.hx
+++ b/projects/kiss-tools/src/kiss_tools/Main.hx
@@ -2,6 +2,7 @@ package kiss_tools;
 
 import kiss.Kiss;
 import kiss.Prelude;
+import kiss_tools.KeyShortcutHandler;
 
 @:build(kiss.Kiss.build())
 class Main {}