From 5c4b507f025d84684945f3f9eccf3fe0b92c70d5 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Sat, 1 Jun 2024 21:47:30 +0200 Subject: [PATCH] Elaborate 'help-complete-keys' --- lisp/help.el | 97 +++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 70 insertions(+), 27 deletions(-) diff --git a/lisp/help.el b/lisp/help.el index 504932ecd72..f5213bdfa9a 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -599,30 +599,36 @@ immediate bindings." :version "30.1" :group 'help) -(defun help-complete-keys-add (e b &optional p) - "Add the binding of event E to B with prefix P to `help--complete-keys-alist'." +(defun help-complete-keys-add (s e b &optional p) + "Add the binding of event E to B with prefix P to `help--complete-keys-alist'. + +S is the source of the binding, either `global', `local', or the name of +a minor mode." (cond ((and (symbolp b) (command-remapping b)) ;; Follow remappings. - (help-complete-keys-add e (command-remapping b) p)) + (help-complete-keys-add s e (command-remapping b) p)) ((and (consp e) (characterp (car e)) (characterp (cdr e))) ;; Handle character ranges, ignore intermediate characters. - (help-complete-keys-add (car e) b p) - (help-complete-keys-add (cdr e) b p)) + (help-complete-keys-add s (car e) b p) + (help-complete-keys-add s (cdr e) b p)) ((commandp b) ;; Found a command. - (push (cons (vconcat p (vector e)) b) help--complete-keys-alist)) + (setf (alist-get (vconcat p (vector e)) help--complete-keys-alist + nil nil #'equal) + (cons b s))) ((keymapp b) ;; Follow prefix map, unless its the remap map (handled above). (unless (eq e 'remap) (let ((pe (vconcat p (vector e)))) (when (memq 'nest (ensure-list help-complete-keys-method)) - (push (cons pe b) help--complete-keys-alist)) + (setf (alist-get pe help--complete-keys-alist nil nil #'equal) + (cons b s))) (when (memq 'flat (ensure-list help-complete-keys-method)) - (map-keymap (lambda (ee bb) (help-complete-keys-add ee bb pe)) b))))) + (map-keymap (lambda (ee bb) (help-complete-keys-add s ee bb pe)) b))))) ((eq (car-safe b) 'menu-item) ;; b is an extended menu item. Real binding at `caddr'. - (help-complete-keys-add e (caddr b) p)))) + (help-complete-keys-add s e (caddr b) p)))) (defun help--sort-by-command-name (cands) "Sort keybinding completion candidates CANDS by command name." @@ -634,7 +640,14 @@ immediate bindings." (let ((max (seq-max (cons 0 (mapcar #'string-width cands))))) (mapcar (lambda (cand) - (list cand "" + (list cand + (propertize + (pcase (get-text-property 0 'source cand) + ('global (propertize "g " 'help-echo "Global binding")) + ('local (propertize "l " 'help-echo "Local binding")) + ('nil " ") + (m (propertize "m " 'help-echo (format "`%s' binding" m)))) + 'face 'completions-annotations) (if-let ((doc (ignore-errors (documentation (get-text-property 0 'binding cand))))) (concat (make-string (1+ (- max (string-width cand))) ?\s) @@ -646,8 +659,21 @@ immediate bindings." (declare-function kmacro-p "kmacro") -(defun help--read-keybinding (prefix bindings) - "Read a keybinding among BINDINGS to complete PREFIX." +(defun help--keys-narrow-to-local () + (cons (lambda (cand) (eq (get-text-property 0 'source cand) 'local)) "keymap=local")) + +(defun help--keys-narrow-to-global () + (cons (lambda (cand) (eq (get-text-property 0 'source cand) 'global)) + "keymap=global")) + +(defun help--keys-narrow-to-minor () + (cons (lambda (cand) + ;; TODO - Prompt for specific minor modes. + (memq (get-text-property 0 'source cand) minor-mode-list)) + "keymap=minor")) + +(defun help--read-keybinding (prefix keymaps bindings alist) + "Read a keybinding among BINDINGS to complete PREFIX in KEYMAPS." (minibuffer-with-setup-hook (lambda () (setq-local @@ -660,10 +686,10 @@ immediate bindings." (cons (lambda (cand) (let* ((eb (split-string cand " +→ ")) (e (key-parse (car eb))) - (b (alist-get e help--complete-keys-alist nil nil #'equal))) + (b (car (alist-get e alist nil nil #'equal)))) (with-selected-window (minibuffer-selected-window) (cond - ((keymapp b) (help-complete-keys (vconcat prefix e))) + ((keymapp b) (help-complete-keys (vconcat prefix e) keymaps)) ((arrayp b) (execute-kbd-macro b)) (t (call-interactively b nil (vconcat prefix e))))))) "execute")) @@ -677,7 +703,11 @@ immediate bindings." (completion-table-with-metadata bindings '((category . keybinding) - (affixation-function . help--complete-keys-affixation))) + (affixation-function . help--complete-keys-affixation) + (narrow-completions-function + . ((?l "local" "Local bindings" help--keys-narrow-to-local) + (?g "global" "Global bindings" help--keys-narrow-to-global) + (?m "minor mode" "Minor mode bindings" help--keys-narrow-to-minor))))) nil t nil ;; Use different minibuffer history variables for different prefixes. (let ((sym (intern (concat "help-complete-keys" @@ -687,26 +717,38 @@ immediate bindings." (unless (boundp sym) (set sym nil)) sym)))) -(defun help-complete-keys (prefix) - "Complete the bindings of PREFIX used to reach this command." - (interactive (let ((keys (this-command-keys-vector))) - (list (substring keys 0 (1- (length keys)))))) +(defun help-complete-keys (&optional prefix keymaps) + "Complete the bindings of PREFIX in KEYMAPS. + +PREFIX is a vector of events, and it defaults to the empty prefix. +KEYMAPS is a list of keymaps in descending order of precendence, and it +defaults to all active keymaps. See also `current-active-maps'." + (interactive) + (setq prefix (or prefix (let ((keys (this-command-keys-vector))) + (substring keys 0 (1- (length keys))))) + keymaps (or keymaps (reverse (current-active-maps t)))) (let ((help--complete-keys-alist nil)) - (dolist (active-map (current-active-maps t)) + (dolist (active-map keymaps) (let* ((value (lookup-key active-map prefix)) (pm (or (and (symbolp value) (command-remapping value)) value))) (when (keymapp pm) ;; Populate `help--complete-keys-alist'. - (map-keymap #'help-complete-keys-add pm)))) + (map-keymap (apply-partially #'help-complete-keys-add + (cond + ((eq active-map (current-global-map)) 'global) + ((eq active-map (current-local-map)) 'local) + (t (car (rassq active-map minor-mode-map-alist))))) + pm)))) (let* ((m (seq-max (cons 0 (mapcar (compose #'string-width #'key-description #'car) help--complete-keys-alist)))) (bindings (mapcar - (pcase-lambda (`(,e . ,b)) + (pcase-lambda (`(,e ,b . ,s)) (let ((d (key-description e))) (concat - (propertize d 'face 'help-key-binding 'binding b) + (propertize d 'face 'help-key-binding + 'binding b 'source s) (make-string (- m (string-width d)) ?\s) (propertize " → " 'face 'shadow) (cond @@ -717,16 +759,17 @@ immediate bindings." ((or (kmacro-p b) (arrayp b)) "Keyboard macro") (t "Anonymous command"))))) help--complete-keys-alist)) - (choice (help--read-keybinding prefix bindings)) + (choice (help--read-keybinding prefix keymaps bindings + help--complete-keys-alist)) (eb (split-string choice " +→ ")) (e (key-parse (car eb))) - (b (alist-get e help--complete-keys-alist nil nil #'equal))) + (b (car (alist-get e help--complete-keys-alist nil nil #'equal)))) (cond ((arrayp b) (execute-kbd-macro b)) ((commandp b) (call-interactively b nil (vconcat prefix e))) - ((keymapp b) (help-complete-keys (vconcat prefix e))) + ((keymapp b) (help-complete-keys (vconcat prefix e) keymaps)) ((length= prefix 0) (user-error "You didn't choose a keybinding")) - (t (help-complete-keys (substring prefix 0 (1- (length prefix))))))))) + (t (help-complete-keys (substring prefix 0 (1- (length prefix))) keymaps)))))) ;; Make C-h after a prefix, when not specifically bound, ;; run describe-prefix-bindings. -- 2.39.2