Elaborate 'help-complete-keys'

diff --git a/lisp/help.el b/lisp/help.el
index 504932ecd724f178e4df62ef7a84cec185324a86..f5213bdfa9acf77f5b5b706d5a2b8efb3c661ae0 100644 (file)
--- 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.