[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 68f15e815e 1/5: Factor out new function rmc--add-key-description
From: |
Stefan Kangas |
Subject: |
master 68f15e815e 1/5: Factor out new function rmc--add-key-description |
Date: |
Sun, 26 Dec 2021 11:06:54 -0500 (EST) |
branch: master
commit 68f15e815e0a475a13d8169cc5d163cf05e7e524
Author: Stefan Kangas <stefan@marxist.se>
Commit: Stefan Kangas <stefan@marxist.se>
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.
---
lisp/emacs-lisp/rmc.el | 62 +++++++++++++++++++--------------------
test/lisp/emacs-lisp/rmc-tests.el | 22 ++++++++++++++
2 files changed, 52 insertions(+), 32 deletions(-)
diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el
index 8abe570e64..2f4b10efbb 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 9d8f3d4801..e858ed3940 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))