Merge pull request #1697 from lem-project/key-conversions

Add a mechanism to perform conversions such as C-m/Return and C-i/Tab in a unified manner
lem-project · Dec 9, 2024 · f69ae8b · f69ae8b
2 parents 237bdf1 + e753b33
commit f69ae8b
Show file tree

Hide file tree

Showing 2 changed files with 37 additions and 19 deletions.
diff --git a/frontends/sdl2/keyboard.lisp b/frontends/sdl2/keyboard.lisp
@@ -53,24 +53,11 @@
 (defun make-key (&key ctrl meta shift super sym)
   (when (equal sym (string #\yen_sign))
     (setf sym "\\"))
-  (cond ((and ctrl (equal sym "i"))
-         (lem:make-key :ctrl nil
-                       :meta meta
-                       :super super
-                       :shift shift
-                       :sym "Tab"))
-        ((and ctrl (equal sym "m"))
-         (lem:make-key :ctrl nil
-                       :meta meta
-                       :super super
-                       :shift shift
-                       :sym "Return"))
-        (t
-         (lem:make-key :ctrl ctrl
-                       :meta meta
-                       :super super
-                       :shift shift
-                       :sym sym))))
+  (lem:make-key :ctrl ctrl
+                :meta meta
+                :super super
+                :shift shift
+                :sym sym))
 
 (defstruct modifier
   shift

diff --git a/src/key.lisp b/src/key.lisp
@@ -29,6 +29,16 @@
 
 (defmethod print-object ((object key) stream)
   (with-slots (ctrl meta super hypher shift sym) object
+    (write-string (key-to-string :ctrl ctrl
+                                 :meta meta
+                                 :super super
+                                 :hypher hypher
+                                 :shift shift
+                                 :sym sym)
+                  stream)))
+
+(defun key-to-string (&key ctrl meta super hypher shift sym)
+  (with-output-to-string (stream)
     (when hypher (write-string "H-" stream))
     (when super (write-string "S-" stream))
     (when meta (write-string "M-" stream))
@@ -38,10 +48,31 @@
         (write-string "Space" stream)
         (write-string sym stream))))
 
+(defvar *key-conversions* '(("C-m" . "Return")
+                            ("C-i" . "Tab")
+                            ("C-[" . "Escape")))
+
 (defvar *key-constructor-cache* (make-hash-table :test 'equal))
 
+(defun convert-key (&rest args &key ctrl meta super hypher shift sym)
+  (let ((elt (assoc (apply #'key-to-string args) *key-conversions* :test #'equal)))
+    (if elt
+        (let ((key (first (parse-keyspec (cdr elt)))))
+          (list :ctrl (key-ctrl key)
+                :meta (key-meta key)
+                :super (key-super key)
+                :hypher (key-hypher key)
+                :shift (key-shift key)
+                :sym (key-sym key)))
+        (list :ctrl ctrl
+              :meta meta
+              :super super
+              :hypher hypher
+              :shift shift
+              :sym sym))))
+
 (defun make-key (&rest args &key ctrl meta super hypher shift sym)
-  (let ((hashkey (list ctrl meta super hypher shift sym)))
+  (let ((hashkey (apply #'convert-key args)))
     (or (gethash hashkey *key-constructor-cache*)
         (setf (gethash hashkey *key-constructor-cache*)
               (apply #'%make-key args)))))