From: Eshel Yaron Date: Wed, 8 May 2024 16:47:29 +0000 (+0200) Subject: Simplify 'read-multiple-choice' prompt formatting X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=6c3c784f8fe06379c1070c77f8d1039a1a244f76;p=emacs.git Simplify 'read-multiple-choice' prompt formatting --- diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index e743038a778..b632e5e45ea 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -3676,8 +3676,8 @@ The return value is the matching value from @var{choices}. (?n "no" "Refuse to use certificate, close connection."))) @end lisp -The @code{read-multiple-choice-face} face is used to highlight the -matching characters in the name string on graphical terminals. +The @code{read-multiple-choice} face is used to highlight the matching +characters in the name string on graphical terminals. @end defun diff --git a/etc/themes/modus-themes.el b/etc/themes/modus-themes.el index b776f12671e..34c187288af 100644 --- a/etc/themes/modus-themes.el +++ b/etc/themes/modus-themes.el @@ -1642,7 +1642,7 @@ FG and BG are the main colors." `(mm-uu-extract ((,c :foreground ,mail-part))) `(next-error ((,c :inherit modus-themes-prominent-error :extend t))) `(pgtk-im-0 ((,c :inherit modus-themes-prominent-note))) - `(read-multiple-choice-face ((,c :inherit modus-themes-mark-sel))) + `(read-multiple-choice ((,c :inherit modus-themes-mark-sel))) `(rectangle-preview ((,c :inherit secondary-selection))) `(region ((,c :background ,bg-region :foreground ,fg-region))) `(secondary-selection ((,c :background ,bg-hover-secondary :foreground ,fg-main))) diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index 3dc8a0af014..568faf3580d 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -27,41 +27,30 @@ "Customizations for `read-multiple-choice'." :group 'minibuffer) +(defun rmc-format-key-label (key &optional label) + "Format KEY with optional LABEL for display as part of a prompt." + (let ((pos (seq-position label key)) + (desc (key-description (vector key)))) + (if (or (not pos) (member desc '("ESC" "TAB" "RET" "DEL" "SPC"))) + ;; Not in the label string, or a special character. + (format "%s %s" (propertize desc 'face 'read-multiple-choice) label) + (setq label (copy-sequence label)) + (put-text-property pos (1+ pos) 'face 'read-multiple-choice label) + label))) + (defun rmc--add-key-description (elem) - (let* ((char (car elem)) - (name (cadr elem)) - (pos (seq-position name char)) - (desc (key-description (char-to-string char))) - (graphical-terminal - (display-supports-face-attributes-p - '(:underline t) (window-frame))) - (altered-name - (cond - ;; Not in the name string, or a special character. - ((or (not pos) - (member desc '("ESC" "TAB" "RET" "DEL" "SPC"))) - (format "%s %s" - (if graphical-terminal - (propertize desc 'face 'read-multiple-choice-face) - (propertize desc 'face 'help-key-binding)) - name)) - ;; The prompt character is in the name, so highlight - ;; it on graphical terminals. - (graphical-terminal - (setq name (copy-sequence name)) - (put-text-property pos (1+ pos) - 'face 'read-multiple-choice-face - name) - name) - ;; And put it in [bracket] on non-graphical terminals. - (t - (concat - (substring name 0 pos) - "[" - (upcase (substring name pos (1+ pos))) - "]" - (substring name (1+ pos))))))) - (cons char altered-name))) + (let ((char (car elem))) + (cons char (rmc-format-key-label char (cadr elem))))) + +(defun rmc-key-description (key name) + (let ((pos (seq-position name key)) + (desc (key-description (vector key)))) + (if (or (not pos) (member desc '("ESC" "TAB" "RET" "DEL" "SPC"))) + ;; Not in the name string, or a special character. + (format "%s %s" (propertize desc 'face 'read-multiple-choice) name) + (setq name (copy-sequence name)) + (put-text-property pos (1+ pos) 'face 'read-multiple-choice name) + name))) (defcustom read-multiple-choice-help-buffer-name "*Multiple Choice Help*" "Name of the buffer showing help during `read-multiple-choice'." @@ -298,13 +287,13 @@ Usage example: (setq invalid-choice (concat "Invalid choice " (propertize (key-description (vector tchar)) - 'face 'read-multiple-choice-face) + 'face 'read-multiple-choice) ", choose one of the following (" - (propertize "C-h" 'face 'read-multiple-choice-face) + (propertize "C-h" 'face 'read-multiple-choice) " for help, " - (propertize "C-g" 'face 'read-multiple-choice-face) + (propertize "C-g" 'face 'read-multiple-choice) " to quit, " - (propertize "C-r" 'face 'read-multiple-choice-face) + (propertize "C-r" 'face 'read-multiple-choice) " to pause):\n"))))) (message (concat invalid-choice full-prompt)) (setq tchar @@ -320,7 +309,7 @@ Usage example: (mapcar (lambda (elem) (concat (propertize (key-description (char-to-string (car elem))) - 'face 'read-multiple-choice-face) + 'face 'read-multiple-choice) " " (cadr elem))) choices)) (answer diff --git a/lisp/faces.el b/lisp/faces.el index e9f2cb42a56..d88d9885c01 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -3109,13 +3109,14 @@ It is used for characters of no fonts too." :version "24.1" :group 'basic-faces) -(defface read-multiple-choice-face - '((t (:inherit (help-key-binding underline) - :weight bold))) +(defface read-multiple-choice + '((t :inherit (help-key-binding underline) :weight bold)) "Face for the symbol name in `read-multiple-choice' output." :group 'basic-faces :version "26.1") +(put 'read-multiple-choice-face 'face-alias 'read-multiple-choice) + ;; Faces for TTY menus. (defface tty-menu-enabled-face '((((class color)) diff --git a/lisp/repeat.el b/lisp/repeat.el index 412afc35ba7..34cef519067 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -558,14 +558,13 @@ This function can be used to force exit of repetition while it's active." (format-message "Repeat with %s%s" (mapconcat (lambda (key-cmd) - (let* ((key (car key-cmd)) - (cmd (cdr key-cmd)) - (hint (when (symbolp cmd) - (get cmd 'repeat-hint)))) - (substitute-command-keys - (format "\\`%s'%s" - (key-description (vector key)) - (if hint (format ":%s" hint) ""))))) + (let ((key (car key-cmd)) + (cmd (cdr key-cmd))) + (if-let ((hint (and (symbolp cmd) + (get cmd 'repeat-hint)))) + (rmc-key-description key hint) + (propertize (key-description (vector key)) + 'face 'read-multiple-choice)))) keys ", ") (if repeat-exit-key (substitute-command-keys diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index 9b494918d7c..de57011a4a2 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -42,13 +42,13 @@ (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t))) (should (equal-including-properties (rmc--add-key-description '(?y "yes")) - `(?y . ,(concat (propertize "y" 'face 'read-multiple-choice-face) "es")))) + `(?y . ,(concat (propertize "y" 'face 'read-multiple-choice) "es")))) (should (equal-including-properties (rmc--add-key-description '(?n "foo")) - `(?n . ,(concat (propertize "n" 'face 'read-multiple-choice-face) " foo")))) + `(?n . ,(concat (propertize "n" 'face 'read-multiple-choice) " foo")))) (should (equal-including-properties (rmc--add-key-description '(?\s "foo bar")) - `(?\s . ,(concat (propertize "SPC" 'face 'read-multiple-choice-face) " foo bar")))))) + `(?\s . ,(concat (propertize "SPC" 'face 'read-multiple-choice) " foo bar")))))) (ert-deftest test-rmc--add-key-description/non-graphical-display () (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) nil)))