(insert (format "No commands with a binding that start with %s."
(help--key-description-fontified prefix))))))))
+(defvar help--complete-keys-alist nil)
+
+(defcustom help-complete-keys-method '(nest flat)
+ "How to complete prefix keys in `help-complete-keys'.
+
+This can be either `nest', `flat' or any subset of these two as a list.
+
+If this is `nest' or a list containing `nest', the completions list of
+`help-complete-keys' includes candidates marked with \"...\", which
+represent intermediate prefix maps; these candidates descend into the
+corresponding prefix map and let you continue completing from there.
+
+If this is `flat' or a list containing `flat', `help-complete-keys'
+flattens intermediate prefix maps and lets you complete nested bindings
+directly.
+
+You can set this to a list that contains both `nest' and `flat' to get
+both direct access to nested bindings and the ability to descend into
+intermediate keymaps. Conversely, you can also set this to an empty
+list, nil, to suppress nested bindings altogether and focus only on
+immediate bindings."
+ :type '(choice (const :tag "Descend into nested prefix maps" nest)
+ (const :tag "Flatten nested prefix maps" flat)
+ (repeat :tag "List"
+ (choice (const :tag "Descend into nested prefix maps"
+ nest)
+ (const :tag "Flatten nested prefix maps"
+ flat))))
+ :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'."
+ (cond
+ ((and (symbolp b) (command-remapping b))
+ ;; Follow remappings.
+ (help-complete-keys-add 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))
+ ((commandp b)
+ ;; Found a command.
+ (push (cons (vconcat p (vector e)) b) help--complete-keys-alist))
+ ((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))
+ (when (memq 'flat (ensure-list help-complete-keys-method))
+ (map-keymap (lambda (ee bb) (help-complete-keys-add 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))))
+
+(defun help--sort-by-command-name (cands)
+ "Sort keybinding completion candidates CANDS by command name."
+ (sort cands :key (lambda (cand)
+ (substring cand (+ 2 (string-search "→ " cand))))))
+
+(defun help--complete-keys-affixation (cands)
+ "Annotate completion candidates CANDS with their documentation strings."
+ (let ((max (seq-max (cons 0 (mapcar #'string-width cands)))))
+ (mapcar
+ (lambda (cand)
+ (list cand ""
+ (if-let ((doc (ignore-errors
+ (documentation (get-text-property 0 'binding cand)))))
+ (concat (make-string (1+ (- max (string-width cand))) ?\s)
+ (propertize
+ (substring doc 0 (string-search "\n" doc))
+ 'face 'completions-annotations))
+ "")))
+ cands)))
+
+(declare-function kmacro-p "kmacro")
+
+(defun help--read-keybinding (prefix bindings)
+ "Read a keybinding among BINDINGS to complete PREFIX."
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq-local
+ minibuffer-completions-sort-orders
+ (cons '(?c "command" "Sort by command name"
+ help--sort-by-command-name
+ "command name")
+ minibuffer-completions-sort-orders)
+ minibuffer-completion-action
+ (cons (lambda (cand)
+ (let* ((eb (split-string cand " +→ "))
+ (e (key-parse (car eb)))
+ (b (alist-get e help--complete-keys-alist nil nil #'equal)))
+ (with-selected-window (minibuffer-selected-window)
+ (cond
+ ((keymapp b) (help-complete-keys (vconcat prefix e)))
+ ((arrayp b) (execute-kbd-macro b))
+ (t (call-interactively b nil (vconcat prefix e)))))))
+ "execute"))
+ (minibuffer-completion-help))
+ (completing-read
+ (if (seq-empty-p prefix)
+ "Complete top-level keybinding: "
+ (concat "Complete " (propertize (key-description prefix)
+ 'face 'help-key-binding)
+ ", empty input retracts last prefix key: "))
+ (completion-table-with-metadata
+ bindings
+ '((category . keybinding)
+ (affixation-function . help--complete-keys-affixation)))
+ nil t nil
+ ;; Use different minibuffer history variables for different prefixes.
+ (let ((sym (intern (concat "help-complete-keys"
+ (concat (unless (length= prefix 0) "-")
+ (key-description prefix))
+ "-history"))))
+ (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))))))
+ (let ((help--complete-keys-alist nil))
+ (dolist (active-map (current-active-maps t))
+ (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))))
+ (let* ((m (seq-max (cons 0 (mapcar (compose #'string-width
+ #'key-description
+ #'car)
+ help--complete-keys-alist))))
+ (bindings (mapcar
+ (pcase-lambda (`(,e . ,b))
+ (let ((d (key-description e)))
+ (concat
+ (propertize d 'face 'help-key-binding 'binding b)
+ (make-string (- m (string-width d)) ?\s)
+ (propertize " → " 'face 'shadow)
+ (cond
+ ((keymapp b) (concat (when (symbolp b)
+ (symbol-name b))
+ "..."))
+ ((symbolp b) (symbol-name b))
+ ((or (kmacro-p b) (arrayp b)) "Keyboard macro")
+ (t "Anonymous command")))))
+ help--complete-keys-alist))
+ (choice (help--read-keybinding prefix bindings))
+ (eb (split-string choice " +→ "))
+ (e (key-parse (car eb)))
+ (b (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)))
+ ((length= prefix 0) (user-error "You didn't choose a keybinding"))
+ (t (help-complete-keys (substring prefix 0 (1- (length prefix)))))))))
+
;; Make C-h after a prefix, when not specifically bound,
;; run describe-prefix-bindings.
(setq prefix-help-command 'describe-prefix-bindings)
projects / emacs.git / commitdiff