change kmaps from a hashtable to a struct containing a list

This change was needed because there are now multiple top level maps
that all hang bindings off the escape key. set-prefix-key cannot know
what top level maps it needs to search to update the escape key, so
*escape-key* was created which is a key struct that is used in any map
that wants to use the escape key. Now that key's slots just need to be
updated. But a hashtable's keys cannot change or the lookup fails, so
a list is now used.

bindings.lisp

@@ -85,7 +85,7 @@ a tile-group, both the group map and tile-group map are active.")
   (kbd "C-a") "time"
   (kbd "!")   "exec"
   (kbd "C-g") "abort"
-  (kbd "t")   "meta C-t"
+  *escape-fake-key* "send-escape"
   (kbd ";")   "colon"
   (kbd ":")   "eval"
   (kbd "v")   "version"
@@ -228,7 +228,7 @@ current window. To exit command mode, type @key{C-g}."
   (message "Press C-g to exit command-mode.")
   (push-top-map *root-map*))
 
-(defun set-prefix-key (key)
+(defcommand set-prefix-key (key) ((:key "Key: "))
   "Change the stumpwm prefix key to KEY.
 @example
 \(stumpwm:set-prefix-key (stumpwm:kbd \"C-M-H-s-z\"))
@@ -238,30 +238,18 @@ This will change the prefix key to @key{Control} + @key{Meta} + @key{Hyper} + @k
 the @key{z} key. By most standards, a terrible prefix key but it makes a
 great example."
   (check-type key key)
-  (let (prefix)
-    (dolist (i (lookup-command *top-map* '*root-map*))
-      (setf prefix i)
-      (undefine-key *top-map* i))
-    (define-key *top-map* key '*root-map*)
-    (let* ((meta (make-key :keysym (key-keysym key)))
-           (old-cmd (concatenate 'string "meta " (print-key prefix)))
-           (cmd (concatenate 'string "meta " (print-key key))))
-      (dolist (i (lookup-command *root-map* old-cmd))
-        (undefine-key *root-map* i))
-      (define-key *root-map* meta cmd))
-    (define-key *root-map* key "other")
-    (sync-keys)))
+  (copy-key-into key *escape-key*)
+  (copy-key-into (make-key :keysym (key-keysym key)) *escape-fake-key*)
+  (sync-keys))
 
-(defcommand escape (key) ((:string "Key: "))
-  "Set the prefix key. Here's how you would change the prefix key to @kbd{C-z}.
-
-@example
-escape C-z
-@end example"
-  (set-prefix-key (kbd key)))
+(defcommand-alias escape set-prefix-key)
 
 (defcommand bind (key command)
                  ((:text "Key Chord: ")
                   (:rest "Command: "))
   "Hang a key binding off the escape key."
   (define-key *root-map* (kbd key) command))
+
+(defcommand send-escape () ()
+  "Send the escape key to the current window."
+  (send-meta-key (current-screen) *escape-key*))

events.lisp

@@ -224,14 +224,14 @@ The Caller is responsible for setting up the input focus."
     (run-hook-with-args *key-press-hook* key key-seq match)
     (when update-fn
       (funcall update-fn key-seq))
-    (cond ((kmap-p match)
+    (cond ((kmap-or-kmap-symbol-p match)
            (when grab
              (grab-pointer (current-screen)))
            (let* ((code-state (read-key-no-modifiers))
                   (code (car code-state))
                   (state (cdr code-state)))
              (unwind-protect
-                  (handle-keymap (remove-if-not 'kmap-p bindings) code state key-seq nil update-fn)
+                  (handle-keymap (remove-if-not 'kmap-or-kmap-symbol-p bindings) code state key-seq nil update-fn)
                (when grab (ungrab-pointer)))))
           (match
            (values match key-seq))

help.lisp

@@ -54,7 +54,7 @@
 (defun display-bindings-for-keymaps (key-seq &rest keymaps)
   (let* ((screen (current-screen))
          (data (mapcan (lambda (map)
-                         (mapcar-hash (lambda (k v) (format nil "^5*~5a^n ~a" (print-key k) v)) map))
+                         (mapcar (lambda (b) (format nil "^5*~5a^n ~a" (print-key (binding-key b)) (binding-command b))) (kmap-bindings map)))
                        keymaps))
          (cols (ceiling (1+ (length data))
                         (truncate (- (head-height (current-head)) (* 2 (screen-msg-border-width screen)))
@@ -65,7 +65,7 @@
 
 (defcommand help () ()
 "Display all the bindings in @var{*root-map*}."
-  (display-bindings-for-keymaps *escape-key* *root-map*))
+  (display-bindings-for-keymaps (list *escape-key*) *root-map*))
 
 (defcommand commands () ()
   (let* ((screen (current-screen))

kmap.lisp

@@ -40,6 +40,12 @@
 (defstruct key
   keysym shift control meta alt hyper super)
 
+(defstruct kmap
+  bindings)
+
+(defstruct binding
+  key command)
+
 (defun make-sparse-keymap ()
   "Create an empty keymap. If you want to create a new list of bindings
 in the key binding tree, this is where you start. To hang frame
@@ -55,21 +61,20 @@ related bindings off @kbd{C-t C-f} one might use the following code:
 
 \(stumpwm:define-key stumpwm:*root-map* (stumpwm:kbd \"C-f\") '*my-frame-bindings*)
 @end example"
-  (make-hash-table :test 'equalp))
+  (make-kmap))
 
 (defun lookup-command (keymap command)
   "Return a list of keys that are bound to command"
-  (let (acc)
-    (maphash (lambda (k v)
-               (when (equal command v)
-                 (push k acc)))
-             keymap)
-    acc))
+  (loop for i in (kmap-bindings keymap)
+     when (equal command (binding-command i))
+     collect (binding-key i)))
 
 (defun lookup-key (keymap key &optional accept-default)
-  (or (gethash key keymap)
-      (and accept-default
-           (gethash t keymap))))
+  (labels ((retcmd (key)
+             (when key (binding-command key))))
+    (or (retcmd (find key (kmap-bindings keymap) :key 'binding-key :test 'equalp))
+        (and accept-default
+             (retcmd (find t (kmap-bindings keymap) :key 'binding-key))))))
 
 (defun key-mods-p (key)
   (or (key-shift key)
@@ -135,6 +140,16 @@ others."
   ;; XXX: define-key needs to be fixed to handle a list of keys
   (first (parse-key-seq keys)))
 
+(defun copy-key-into (from to)
+  "copy the contents of TO into FROM."
+  (setf (key-keysym to) (key-keysym from)
+        (key-shift to) (key-shift from)
+        (key-control to) (key-control from)
+        (key-meta to) (key-meta from)
+        (key-alt to) (key-alt from)
+        (key-hyper to) (key-hyper from)
+        (key-super to) (key-super from)))
+
 (defun print-mods (key)
   (concatenate 'string
                (when (key-control key) "C-")
@@ -161,45 +176,46 @@ others."
 @end example
 
 Now when you type C-t C-z, you'll see the text ``Zzzzz...'' pop up."
-  (setf (gethash key map) command)
-  ;; We need to tell the X server when changing the top-map bindings.
-  (when (eq map *top-map*)
-    (sync-keys)))
+  (declare (type kmap map) (type (or key (eql t)) key))
+  (let ((binding (find key (kmap-bindings map) :key 'binding-key :test 'equalp)))
+    (setf (kmap-bindings map)
+          (append (if binding
+                      (delete binding (kmap-bindings map))
+                      (kmap-bindings map))
+                  (list (make-binding :key key :command command))))
+    ;; We need to tell the X server when changing the top-map bindings.
+    (when (eq map *top-map*)
+      (sync-keys))))
 
 (defun undefine-key (map key)
   "Clear the key binding in the specified keybinding."
-  (remhash key map)
+  (setf (kmap-bindings map) (delete key (kmap-bindings map) :key 'binding-key :test 'equalp))
   ;; We need to tell the X server when changing the top-map bindings.
   (when (eq map *top-map*)
     (sync-keys)))
 
 (defun lookup-key-sequence (kmap key-seq)
   "Return the command bound to the key sequenc, KEY-SEQ, in keymap KMAP."
-  (when (and (symbolp kmap)
-             (boundp kmap)
-             (hash-table-p (symbol-value kmap)))
+  (when (kmap-symbol-p kmap)
     (setf kmap (symbol-value kmap)))
-  (check-type kmap hash-table)
+  (check-type kmap kmap)
   (let* ((key (car key-seq))
          (cmd (lookup-key kmap key)))
     (cond ((null (cdr key-seq))
            cmd)
           (cmd
-           (if (or (hash-table-p cmd)
-                   (and (symbolp cmd)
-                        (boundp cmd)
-                        (hash-table-p (symbol-value cmd))))
+           (if (kmap-or-kmap-symbol-p cmd)
                (lookup-key-sequence cmd (cdr key-seq))
                cmd))
           (t nil))))
 
 (defun kmap-symbol-p (x)
   (and (symbolp x)
        (boundp x)
-       (hash-table-p (symbol-value x))))
+       (kmap-p (symbol-value x))))
 
-(defun kmap-p (x)
-  (or (hash-table-p x)
+(defun kmap-or-kmap-symbol-p (x)
+  (or (kmap-p x)
       (kmap-symbol-p x)))
 
 (defun dereference-kmaps (kmaps)
@@ -213,19 +229,14 @@ Now when you type C-t C-z, you'll see the text ``Zzzzz...'' pop up."
   "Search the keymap for the specified binding. Return the key
 sequences that run binding."
   (labels ((search-it (cmd kmap key-seq)
-             (when (and (symbolp kmap)
-                        (boundp kmap)
-                        (hash-table-p (symbol-value kmap)))
+             (when (kmap-symbol-p kmap)
                (setf kmap (symbol-value kmap)))
-             (check-type kmap hash-table)
-             (let (cmds)
-               (maphash (lambda (k v)
-                          (cond ((funcall test v cmd)
-                                 (push (cons k key-seq) cmds))
-                                ((kmap-p v)
-                                 (setf cmds (append cmds (search-it cmd v (cons k key-seq)))))))
-                        kmap)
-               cmds)))
+             (check-type kmap kmap)
+             (loop for i in (kmap-bindings kmap)
+                if (funcall test (binding-command i) cmd)
+                collect (cons (binding-key i) key-seq)
+                else if (kmap-or-kmap-symbol-p (binding-command i))
+                append (search-it cmd (binding-command i) (cons (binding-key i) key-seq)))))
     (mapcar 'reverse (search-it command keymap nil))))
 
 

user.lisp

@@ -311,7 +311,7 @@ such a case, kill the shell command to resume StumpWM."
     (message "~a" string)))
 
 (defun send-meta-key (screen key)
-  "Send the prefix key"
+  "Send the key to the current window on the specified screen."
   (when (screen-current-window screen)
     (send-fake-key (screen-current-window screen) key)))
 

window.lisp

@@ -589,10 +589,8 @@ and bottom_end_x."
                                   :modifiers (x11-mods key t) :owner-p t
                                   :sync-pointer-p nil :sync-keyboard-p nil))))))
     (dolist (map (dereference-kmaps (top-maps screen)))
-      (maphash (lambda (k v)
-                 (declare (ignore v))
-                 (grabit win k))
-               map))))
+      (dolist (i (kmap-bindings map))
+        (grabit win (binding-key i))))))
 
 (defun grab-keys-on-window (win)
   (xwin-grab-keys (window-xwin win) (window-group win)))