From: Eshel Yaron Date: Sat, 1 Jun 2024 16:42:04 +0000 (+0200) Subject: New command 'help-complete-keys' for 'prefix-help-command' X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=09e6bf29f860d8ecc00e1aae90b7cca412499830;p=emacs.git New command 'help-complete-keys' for 'prefix-help-command' --- diff --git a/lisp/help.el b/lisp/help.el index 73cce247768..504932ecd72 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -568,6 +568,166 @@ of the key sequence that ran this command." (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) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index b074c159b8e..3211081dcba 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1174,7 +1174,8 @@ styles for specific categories, such as files, buffers, etc." (info-menu (styles . (basic substring))) (symbol-help (styles . (basic shorthand substring))) (multiple-choice (styles . (basic substring)) (sort-function . identity)) - (calendar-month (sort-function . identity))) + (calendar-month (sort-function . identity)) + (keybinding (sort-function . minibuffer-sort-alphabetically))) "Default settings for specific completion categories. Each entry has the shape (CATEGORY . ALIST) where ALIST is