From: Stefan Kangas <stefan@marxist.se>
Date: Sat, 25 Dec 2021 21:58:59 +0000 (+0100)
Subject: Factor out new function rmc--add-key-description
X-Git-Tag: emacs-29.0.90~3432
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=68f15e815e0a475a13d8169cc5d163cf05e7e524;p=emacs.git

Factor out new function rmc--add-key-description

* lisp/emacs-lisp/rmc.el (rmc--add-key-description): Factor out
new function from...
(read-multiple-choice): ...here.

* test/lisp/emacs-lisp/rmc-tests.el (test-rmc--add-key-description)
(test-rmc--add-key-description/with-attributes)
(test-rmc--add-key-description/non-graphical-display): New tests.
---

diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el
index 8abe570e64b..2f4b10efbbd 100644
--- a/lisp/emacs-lisp/rmc.el
+++ b/lisp/emacs-lisp/rmc.el
@@ -25,6 +25,33 @@
 
 (require 'seq)
 
+(defun rmc--add-key-description (elem)
+  (let* ((name (cadr elem))
+         (pos (seq-position name (car elem)))
+         (altered-name
+          (cond
+           ;; Not in the name string.
+           ((not pos)
+            (format "[%c] %s" (car elem) name))
+           ;; The prompt character is in the name, so highlight
+           ;; it on graphical terminals.
+           ((display-supports-face-attributes-p
+             '(:underline t) (window-frame))
+            (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 (car elem) altered-name)))
+
 ;;;###autoload
 (defun read-multiple-choice (prompt choices &optional help-string)
   "Ask user to select an entry from CHOICES, promting with PROMPT.
@@ -67,42 +94,13 @@ Usage example:
                       \\='((?a \"always\")
                         (?s \"session only\")
                         (?n \"no\")))"
-  (let* ((altered-names nil)
+  (let* ((altered-names (mapcar #'rmc--add-key-description
+                                (append choices '((?? "?")))))
          (full-prompt
           (format
            "%s (%s): "
            prompt
-           (mapconcat
-            (lambda (elem)
-              (let* ((name (cadr elem))
-                     (pos (seq-position name (car elem)))
-                     (altered-name
-                      (cond
-                       ;; Not in the name string.
-                       ((not pos)
-                        (format "[%c] %s" (car elem) name))
-                       ;; The prompt character is in the name, so highlight
-                       ;; it on graphical terminals...
-                       ((display-supports-face-attributes-p
-                         '(:underline t) (window-frame))
-                        (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)))))))
-                (push (cons (car elem) altered-name)
-                      altered-names)
-                altered-name))
-            (append choices '((?? "?")))
-            ", ")))
+           (mapconcat (lambda (e) (cdr e)) altered-names ", ")))
          tchar buf wrong-char answer)
     (save-window-excursion
       (save-excursion
diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el
index 9d8f3d48014..e858ed39405 100644
--- a/test/lisp/emacs-lisp/rmc-tests.el
+++ b/test/lisp/emacs-lisp/rmc-tests.el
@@ -28,8 +28,30 @@
 
 (require 'ert)
 (require 'rmc)
+(require 'cl-lib)
 (eval-when-compile (require 'cl-lib))
 
+(ert-deftest test-rmc--add-key-description ()
+  (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t)))
+    (should (equal (rmc--add-key-description '(?y "yes"))
+                   '(?y . "yes")))
+    (should (equal (rmc--add-key-description '(?n "foo"))
+                   '(?n . "[n] foo")))))
+
+(ert-deftest test-rmc--add-key-description/with-attributes ()
+  (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"))))
+    (should (equal-including-properties
+             (rmc--add-key-description '(?n "foo"))
+             '(?n . "[n] foo")))))
+
+(ert-deftest test-rmc--add-key-description/non-graphical-display ()
+  (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) nil)))
+    (should (equal-including-properties
+             (rmc--add-key-description '(?y "yes"))
+             '(?y . "[Y]es")))))
 
 (ert-deftest test-read-multiple-choice ()
   (dolist (char '(?y ?n))