From b7c2db02f46a44fac317a6c81efa001ecfea93a0 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Wed, 24 Feb 2021 01:18:13 +0100 Subject: [PATCH] Colorize keybindings in help --- lisp/faces.el | 4 + lisp/help-fns.el | 17 ++-- lisp/help-macro.el | 226 ++++++++++++++++++++++----------------------- lisp/help.el | 120 +++++++++++++----------- lisp/isearch.el | 8 +- src/keymap.c | 13 ++- 6 files changed, 208 insertions(+), 180 deletions(-) diff --git a/lisp/faces.el b/lisp/faces.el index 90f11bbe3b..d6bab5e732 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2815,6 +2815,10 @@ help-argument-name "Face to highlight argument names in *Help* buffers." :group 'help) +(defface help-key-binding '((t :weight semi-bold :foreground "ForestGreen")) + "Face for keybindings in *Help* buffers." + :group 'help) + (defface glyphless-char '((((type tty)) :inherit underline) (((type pc)) :inherit escape-glyph) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 7244695094..8277bbdad1 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -466,12 +466,15 @@ help-fns--key-bindings ;; If lots of ordinary text characters run this command, ;; don't mention them one by one. (if (< (length non-modified-keys) 10) - (princ (mapconcat #'key-description keys ", ")) + (with-current-buffer standard-output + (insert (mapconcat #'help--key-description-fontified + keys ", "))) (dolist (key non-modified-keys) (setq keys (delq key keys))) (if keys (progn - (princ (mapconcat #'key-description keys ", ")) + (princ (mapconcat #'help--key-description-fontified + keys ", ")) (princ ", and many ordinary text characters")) (princ "many ordinary text characters")))) (when (or remapped keys non-modified-keys) @@ -1825,10 +1828,12 @@ describe-mode (save-excursion (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") nil t) - (help-xref-button 1 'help-function-def mode file-name))))) - (princ ":\n") - (princ (help-split-fundoc (documentation major-mode) nil 'doc)) - (princ (help-fns--list-local-commands))))) + (help-xref-button 1 'help-function-def mode file-name))))) + (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc))) + (with-current-buffer standard-output + (insert ":\n") + (insert fundoc) + (insert (help-fns--list-local-commands))))))) ;; For the sake of IELM and maybe others nil) diff --git a/lisp/help-macro.el b/lisp/help-macro.el index 791b10a878..4bb5e00906 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -92,119 +92,119 @@ make-help-screen with the key sequence that invoked FNAME. When FNAME finally does get a command, it executes that command and then returns." - (let ((doc-fn (intern (concat (symbol-name fname) "-doc")))) - `(progn - (defun ,doc-fn () ,help-text nil) - (defun ,fname () - "Help command." - (interactive) - (let ((line-prompt - (substitute-command-keys ,help-line))) - (when three-step-help - (message "%s" line-prompt)) - (let* ((help-screen (documentation (quote ,doc-fn))) - ;; We bind overriding-local-map for very small - ;; sections, *excluding* where we switch buffers - ;; and where we execute the chosen help command. - (local-map (make-sparse-keymap)) - (new-minor-mode-map-alist minor-mode-map-alist) - (prev-frame (selected-frame)) - config new-frame key char) - (when (string-match "%THIS-KEY%" help-screen) - (setq help-screen - (replace-match (key-description - (substring (this-command-keys) 0 -1)) - t t help-screen))) - (unwind-protect - (let ((minor-mode-map-alist nil)) - (setcdr local-map ,helped-map) - (define-key local-map [t] 'undefined) - ;; Make the scroll bar keep working normally. - (define-key local-map [vertical-scroll-bar] - (lookup-key global-map [vertical-scroll-bar])) - (if three-step-help - (progn - (setq key (let ((overriding-local-map local-map)) - (read-key-sequence nil))) - ;; Make the HELP key translate to C-h. - (if (lookup-key function-key-map key) - (setq key (lookup-key function-key-map key))) - (setq char (aref key 0))) - (setq char ??)) - (when (or (eq char ??) (eq char help-char) - (memq char help-event-list)) - (setq config (current-window-configuration)) - (pop-to-buffer " *Metahelp*" nil t) - (and (fboundp 'make-frame) - (not (eq (window-frame) - prev-frame)) - (setq new-frame (window-frame) - config nil)) - (setq buffer-read-only nil) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert help-screen)) - (let ((minor-mode-map-alist new-minor-mode-map-alist)) - (help-mode) - (setq new-minor-mode-map-alist minor-mode-map-alist)) - (goto-char (point-min)) - (while (or (memq char (append help-event-list - (cons help-char '(?? ?\C-v ?\s ?\177 delete backspace vertical-scroll-bar ?\M-v)))) - (eq (car-safe char) 'switch-frame) - (equal key "\M-v")) - (condition-case nil - (cond - ((eq (car-safe char) 'switch-frame) - (handle-switch-frame char)) - ((memq char '(?\C-v ?\s)) - (scroll-up)) - ((or (memq char '(?\177 ?\M-v delete backspace)) - (equal key "\M-v")) - (scroll-down))) - (error nil)) - (let ((cursor-in-echo-area t) - (overriding-local-map local-map)) - (setq key (read-key-sequence - (format "Type one of the options listed%s: " - (if (pos-visible-in-window-p - (point-max)) - "" ", or SPACE or DEL to scroll"))) - char (aref key 0))) - - ;; If this is a scroll bar command, just run it. - (when (eq char 'vertical-scroll-bar) - (command-execute (lookup-key local-map key) nil key)))) - ;; We don't need the prompt any more. - (message "") - ;; Mouse clicks are not part of the help feature, - ;; so reexecute them in the standard environment. - (if (listp char) - (setq unread-command-events - (cons char unread-command-events) - config nil) - (let ((defn (lookup-key local-map key))) - (if defn - (progn - (when config - (set-window-configuration config) - (setq config nil)) - ;; Temporarily rebind `minor-mode-map-alist' - ;; to `new-minor-mode-map-alist' (Bug#10454). - (let ((minor-mode-map-alist new-minor-mode-map-alist)) - ;; `defn' must make sure that its frame is - ;; selected, so we won't iconify it below. - (call-interactively defn)) - (when new-frame - ;; Do not iconify the selected frame. - (unless (eq new-frame (selected-frame)) - (iconify-frame new-frame)) - (setq new-frame nil))) - (ding))))) - (when config - (set-window-configuration config)) - (when new-frame - (iconify-frame new-frame)) - (setq minor-mode-map-alist new-minor-mode-map-alist)))))))) + `(defun ,fname () + "Help command." + (interactive) + (let ((line-prompt + (substitute-command-keys ,help-line))) + (when three-step-help + (message "%s" line-prompt)) + (let* ((help-screen ,help-text) + ;; We bind overriding-local-map for very small + ;; sections, *excluding* where we switch buffers + ;; and where we execute the chosen help command. + (local-map (make-sparse-keymap)) + (new-minor-mode-map-alist minor-mode-map-alist) + (prev-frame (selected-frame)) + config new-frame key char) + (when (string-match "%THIS-KEY%" help-screen) + (setq help-screen + (replace-match (propertize + (key-description + (substring (this-command-keys) 0 -1)) + 'font-lock-face 'help-key-binding + 'face 'help-key-binding) + t t help-screen))) + (unwind-protect + (let ((minor-mode-map-alist nil)) + (setcdr local-map ,helped-map) + (define-key local-map [t] 'undefined) + ;; Make the scroll bar keep working normally. + (define-key local-map [vertical-scroll-bar] + (lookup-key global-map [vertical-scroll-bar])) + (if three-step-help + (progn + (setq key (let ((overriding-local-map local-map)) + (read-key-sequence nil))) + ;; Make the HELP key translate to C-h. + (if (lookup-key function-key-map key) + (setq key (lookup-key function-key-map key))) + (setq char (aref key 0))) + (setq char ??)) + (when (or (eq char ??) (eq char help-char) + (memq char help-event-list)) + (setq config (current-window-configuration)) + (pop-to-buffer " *Metahelp*" nil t) + (and (fboundp 'make-frame) + (not (eq (window-frame) + prev-frame)) + (setq new-frame (window-frame) + config nil)) + (setq buffer-read-only nil) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (substitute-command-keys help-screen))) + (let ((minor-mode-map-alist new-minor-mode-map-alist)) + (help-mode) + (setq new-minor-mode-map-alist minor-mode-map-alist)) + (goto-char (point-min)) + (while (or (memq char (append help-event-list + (cons help-char '(?? ?\C-v ?\s ?\177 delete backspace vertical-scroll-bar ?\M-v)))) + (eq (car-safe char) 'switch-frame) + (equal key "\M-v")) + (condition-case nil + (cond + ((eq (car-safe char) 'switch-frame) + (handle-switch-frame char)) + ((memq char '(?\C-v ?\s)) + (scroll-up)) + ((or (memq char '(?\177 ?\M-v delete backspace)) + (equal key "\M-v")) + (scroll-down))) + (error nil)) + (let ((cursor-in-echo-area t) + (overriding-local-map local-map)) + (setq key (read-key-sequence + (format "Type one of the options listed%s: " + (if (pos-visible-in-window-p + (point-max)) + "" ", or SPACE or DEL to scroll"))) + char (aref key 0))) + + ;; If this is a scroll bar command, just run it. + (when (eq char 'vertical-scroll-bar) + (command-execute (lookup-key local-map key) nil key)))) + ;; We don't need the prompt any more. + (message "") + ;; Mouse clicks are not part of the help feature, + ;; so reexecute them in the standard environment. + (if (listp char) + (setq unread-command-events + (cons char unread-command-events) + config nil) + (let ((defn (lookup-key local-map key))) + (if defn + (progn + (when config + (set-window-configuration config) + (setq config nil)) + ;; Temporarily rebind `minor-mode-map-alist' + ;; to `new-minor-mode-map-alist' (Bug#10454). + (let ((minor-mode-map-alist new-minor-mode-map-alist)) + ;; `defn' must make sure that its frame is + ;; selected, so we won't iconify it below. + (call-interactively defn)) + (when new-frame + ;; Do not iconify the selected frame. + (unless (eq new-frame (selected-frame)) + (iconify-frame new-frame)) + (setq new-frame nil))) + (ding))))) + (when config + (set-window-configuration config)) + (when new-frame + (iconify-frame new-frame)) + (setq minor-mode-map-alist new-minor-mode-map-alist)))))) (provide 'help-macro) diff --git a/lisp/help.el b/lisp/help.el index 084e941549..0247f08706 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -104,8 +104,8 @@ help-map (define-key map "R" 'info-display-manual) (define-key map "s" 'describe-syntax) (define-key map "t" 'help-with-tutorial) - (define-key map "w" 'where-is) (define-key map "v" 'describe-variable) + (define-key map "w" 'where-is) (define-key map "q" 'help-quit) map) "Keymap for characters following the Help key.") @@ -199,52 +199,52 @@ 'help-for-help "You have typed %THIS-KEY%, the help character. Type a Help option: \(Use SPC or DEL to scroll through this text. Type \\\\[help-quit] to exit the Help command.) -a PATTERN Show commands whose name matches the PATTERN (a list of words +\\[apropos-command] PATTERN Show commands whose name matches the PATTERN (a list of words or a regexp). See also the `apropos' command. -b Display all key bindings. -c KEYS Display the command name run by the given key sequence. -C CODING Describe the given coding system, or RET for current ones. -d PATTERN Show a list of functions, variables, and other items whose +\\[describe-bindings] Display all key bindings. +\\[describe-key-briefly] KEYS Display the command name run by the given key sequence. +\\[describe-coding-system] CODING Describe the given coding system, or RET for current ones. +\\[apropos-documentation] PATTERN Show a list of functions, variables, and other items whose documentation matches the PATTERN (a list of words or a regexp). -e Go to the *Messages* buffer which logs echo-area messages. -f FUNCTION Display documentation for the given function. -F COMMAND Show the Emacs manual's section that describes the command. -g Display information about the GNU project. -h Display the HELLO file which illustrates various scripts. -i Start the Info documentation reader: read included manuals. -I METHOD Describe a specific input method, or RET for current. -k KEYS Display the full documentation for the key sequence. -K KEYS Show the Emacs manual's section for the command bound to KEYS. -l Show last 300 input keystrokes (lossage). -L LANG-ENV Describes a specific language environment, or RET for current. -m Display documentation of current minor modes and current major mode, - including their special commands. -n Display news of recent Emacs changes. -o SYMBOL Display the given function or variable's documentation and value. -p TOPIC Find packages matching a given topic keyword. -P PACKAGE Describe the given Emacs Lisp package. -r Display the Emacs manual in Info mode. -R Prompt for a manual and then display it in Info mode. -s Display contents of current syntax table, plus explanations. -S SYMBOL Show the section for the given symbol in the Info manual +\\[view-echo-area-messages] Go to the *Messages* buffer which logs echo-area messages. +\\[describe-function] FUNCTION Display documentation for the given function. +\\[Info-goto-emacs-command-node] COMMAND Show the Emacs manual's section that describes the command. +\\[describe-gnu-project] Display information about the GNU project. +\\[view-hello-file] Display the HELLO file which illustrates various scripts. +\\[info] Start the Info documentation reader: read included manuals. +\\[describe-input-method] METHOD Describe a specific input method, or RET for current. +\\[describe-key] KEYS Display the full documentation for the key sequence. +\\[Info-goto-emacs-key-command-node] KEYS Show the Emacs manual's section for the command bound to KEYS. +\\[view-lossage] Show last 300 input keystrokes (lossage). +\\[describe-language-environment] LANG-ENV Describes a specific language environment, or RET for current. +\\[describe-mode] Display documentation of current minor modes and current major mode, + including their special commands. +\\[view-emacs-news] Display news of recent Emacs changes. +\\[describe-symbol] SYMBOL Display the given function or variable's documentation and value. +\\[finder-by-keyword] TOPIC Find packages matching a given topic keyword. +\\[describe-package] PACKAGE Describe the given Emacs Lisp package. +\\[info-emacs-manual] Display the Emacs manual in Info mode. +\\[info-display-manual] Prompt for a manual and then display it in Info mode. +\\[describe-syntax] Display contents of current syntax table, plus explanations. +\\[info-lookup-symbol] SYMBOL Show the section for the given symbol in the Info manual for the programming language used in this buffer. -t Start the Emacs learn-by-doing tutorial. -v VARIABLE Display the given variable's documentation and value. -w COMMAND Display which keystrokes invoke the given command (where-is). -. Display any available local help at point in the echo area. - -C-a Information about Emacs. -C-c Emacs copying permission (GNU General Public License). -C-d Instructions for debugging GNU Emacs. -C-e External packages and information about Emacs. -C-f Emacs FAQ. +\\[help-with-tutorial] Start the Emacs learn-by-doing tutorial. +\\[describe-variable] VARIABLE Display the given variable's documentation and value. +\\[where-is] COMMAND Display which keystrokes invoke the given command (where-is). +\\[display-local-help] Display any available local help at point in the echo area. + +\\[about-emacs] Information about Emacs. +\\[describe-copying] Emacs copying permission (GNU General Public License). +\\[view-emacs-debugging] Instructions for debugging GNU Emacs. +\\[view-external-packages] External packages and information about Emacs. +\\[view-emacs-FAQ] Emacs FAQ. C-m How to order printed Emacs manuals. C-n News of recent Emacs changes. -C-o Emacs ordering and distribution information. -C-p Info about known Emacs problems. -C-s Search forward \"help window\". -C-t Emacs TODO list. -C-w Information on absence of warranty for GNU Emacs." +\\[describe-distribution] Emacs ordering and distribution information. +\\[view-emacs-problems] Info about known Emacs problems. +\\[search-forward-help-for-help] Search forward \"help window\". +\\[view-emacs-todo] Emacs TODO list. +\\[describe-no-warranty] Information on absence of warranty for GNU Emacs." help-map) @@ -492,6 +492,15 @@ view-lossage ;; Key bindings +(defun help--key-description-fontified (keys &optional prefix) + "Like `key-description' but add face for \"*Help*\" buffers." + ;; We add both the `font-lock-face' and `face' properties here, as this + ;; seems to be the only way to get this to work reliably in any + ;; buffer. + (propertize (key-description keys prefix) + 'font-lock-face 'help-key-binding + 'face 'help-key-binding)) + (defun describe-bindings (&optional prefix buffer) "Display a buffer showing a list of all defined keys, and their definitions. The keys are displayed in order of precedence. @@ -511,7 +520,6 @@ describe-bindings (with-current-buffer (help-buffer) (describe-buffer-bindings buffer prefix)))) -;; This function used to be in keymap.c. (defun describe-bindings-internal (&optional menus prefix) "Show a list of all defined keys, and their definitions. We put that list in a buffer, and display the buffer. @@ -559,7 +567,8 @@ where-is (let* ((remapped (command-remapping symbol)) (keys (where-is-internal symbol overriding-local-map nil nil remapped)) - (keys (mapconcat 'key-description keys ", ")) + (keys (mapconcat #'help--key-description-fontified + keys ", ")) string) (setq string (if insert @@ -587,11 +596,11 @@ where-is nil) (defun help-key-description (key untranslated) - (let ((string (key-description key))) + (let ((string (help--key-description-fontified key))) (if (or (not untranslated) (and (eq (aref untranslated 0) ?\e) (not (eq (aref key 0) ?\e)))) string - (let ((otherstring (key-description untranslated))) + (let ((otherstring (help--key-description-fontified untranslated))) (if (equal string otherstring) string (format "%s (translated from %s)" string otherstring)))))) @@ -1053,12 +1062,14 @@ substitute-command-keys (where-is-internal fun keymap t)))) (if (not key) ;; Function is not on any key. - (progn (insert "M-x ") + (progn (insert (propertize "M-x " + 'font-lock-face 'help-key-binding + 'face 'help-key-binding)) (goto-char (+ end-point 3)) (delete-char 1)) ;; Function is on a key. (delete-char (- end-point (point))) - (insert (key-description key))))) + (insert (help--key-description-fontified key))))) ;; 1D. \{foo} is replaced with a summary of the keymap ;; (symbol-value foo). ;; \ just sets the keymap used for \[cmd]. @@ -1172,7 +1183,7 @@ describe-map-tree (concat title (if prefix (concat " Starting With " - (key-description prefix))) + (help--key-description-fontified prefix))) ":\n")) "key binding\n" "--- -------\n"))) @@ -1244,7 +1255,8 @@ help--describe-translation (cond ((symbolp definition) (insert (symbol-name definition) "\n")) ((or (stringp definition) (vectorp definition)) - (insert (key-description definition nil) "\n")) + (insert (help--key-description-fontified definition nil) + "\n")) ((keymapp definition) (insert "Prefix Command\n")) (t (insert "??\n")))) @@ -1351,9 +1363,9 @@ describe-map (setq end (caar vect)))) ;; Now START .. END is the range to describe next. ;; Insert the string to describe the event START. - (insert (key-description (vector start) prefix)) + (insert (help--key-description-fontified (vector start) prefix)) (when (not (eq start end)) - (insert " .. " (key-description (vector end) prefix))) + (insert " .. " (help--key-description-fontified (vector end) prefix))) ;; Print a description of the definition of this character. ;; Called function will take care of spacing out far enough ;; for alignment purposes. @@ -1420,7 +1432,7 @@ describe-map ;; (setq first nil)) ;; (when (and prefix (> (length prefix) 0)) ;; (insert (format "%s" prefix))) -;; (insert (key-description (vector start-idx) prefix)) +;; (insert (help--key-description-fontified (vector start-idx) prefix)) ;; ;; Find all consecutive characters or rows that have the ;; ;; same definition. ;; (while (equal (keymap--get-keyelt (aref vector (1+ idx)) nil) @@ -1433,7 +1445,7 @@ describe-map ;; (insert " .. ") ;; (when (and prefix (> (length prefix) 0)) ;; (insert (format "%s" prefix))) -;; (insert (key-description (vector idx) prefix))) +;; (insert (help--key-description-fontified (vector idx) prefix))) ;; (if transl ;; (help--describe-translation definition) ;; (help--describe-command definition)) diff --git a/lisp/isearch.el b/lisp/isearch.el index 8266c4b7a0..b691673c9f 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -460,11 +460,11 @@ isearch-help-map (make-help-screen isearch-help-for-help-internal (purecopy "Type a help option: [bkm] or ?") "You have typed %THIS-KEY%, the help character. Type a Help option: -\(Type \\\\[help-quit] to exit the Help command.) +\(Type \\\\[help-quit] to exit the Help command.) -b Display all Isearch key bindings. -k KEYS Display full documentation of Isearch key sequence. -m Display documentation of Isearch mode. +\\[isearch-describe-bindings] Display all Isearch key bindings. +\\[isearch-describe-key] KEYS Display full documentation of Isearch key sequence. +\\[isearch-describe-mode] Display documentation of Isearch mode. You can't type here other help keys available in the global help map, but outside of this help window when you type them in Isearch mode, diff --git a/src/keymap.c b/src/keymap.c index 782931fadf..8df037bffc 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -3021,7 +3021,10 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, if (!NILP (elt_prefix)) insert1 (elt_prefix); - insert1 (Fkey_description (kludge, prefix)); + Lisp_Object desc = Fkey_description (kludge, prefix); + if (keymap_p) + desc = CALLN (Fpropertize, desc, Qfont_lock_face, Qhelp_key_binding); + insert1 (desc); /* Find all consecutive characters or rows that have the same definition. But, if VECTOR is a char-table, we had better @@ -3071,7 +3074,10 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, if (!NILP (elt_prefix)) insert1 (elt_prefix); - insert1 (Fkey_description (kludge, prefix)); + Lisp_Object desc = Fkey_description (kludge, prefix); + if (keymap_p) + desc = CALLN (Fpropertize, desc, Qfont_lock_face, Qhelp_key_binding); + insert1 (desc); } /* Print a description of the definition of this character. @@ -3107,7 +3113,8 @@ syms_of_keymap (void) { DEFSYM (Qkeymap, "keymap"); DEFSYM (Qdescribe_map_tree, "describe-map-tree"); - + DEFSYM (Qfont_lock_face, "font-lock-face"); + DEFSYM (Qhelp_key_binding, "help-key-binding"); DEFSYM (Qkeymap_canonicalize, "keymap-canonicalize"); /* Now we are ready to set up this property, so we can -- 2.30.0