diff --git a/bindings.lisp b/bindings.lisp index 359059a..dec801c 100644 --- a/bindings.lisp +++ b/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*)) diff --git a/events.lisp b/events.lisp index 0dd8718..c82b5e6 100644 --- a/events.lisp +++ b/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)) diff --git a/help.lisp b/help.lisp index 139f04e..72629ce 100644 --- a/help.lisp +++ b/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)) diff --git a/kmap.lisp b/kmap.lisp index ea6cc86..02fa327 100644 --- a/kmap.lisp +++ b/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,34 +176,35 @@ 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)))) @@ -196,10 +212,10 @@ Now when you type C-t C-z, you'll see the text ``Zzzzz...'' pop up." (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)))) diff --git a/user.lisp b/user.lisp index 702202a..e8645f9 100644 --- a/user.lisp +++ b/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))) diff --git a/window.lisp b/window.lisp index fff06c7..9c0ddd2 100644 --- a/window.lisp +++ b/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)))