New function read-multiple-choice

* doc/lispref/commands.texi (Reading One Event): Document
read-multiple-choice.

* lisp/faces.el (read-multiple-choice-face): New face.

* lisp/subr.el (read-multiple-choice): New function.

4 files changed, 145 insertions, 0 deletions

diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index 9c1df895161..1964ec8e3fe 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -2617,6 +2617,27 @@ causes it to evaluate @code{help-form} and display the result.  It
 then continues to wait for a valid input character, or keyboard-quit.
 @end defun
 
+@defun read-multiple-choice prompt choices
+Ask user a multiple choice question. @var{prompt} should be a string
+that will be displayed as the prompt.
+
+@var{choices} is an alist where the first element in each entry is a
+character to be entered, the second element is a short name for the
+entry to be displayed while prompting (if there's room, it might be
+shortened), and the third, optional entry is a longer explanation that
+will be displayed in a help buffer if the user requests more help.
+
+The return value is the matching value from @var{choices}.
+
+@lisp
+(read-multiple-choice
+ "Continue connecting?"
+ '((?a "always" "Accept this certificate this session and for all future sessions.")
+   (?s "session only" "Accept this certificate this session only.")
+   (?n "no" "Refuse to use this certificate, and close the connection.")))
+@end lisp
+@end defun
+
 @node Event Mod
 @subsection Modifying and Translating Input Events
 @cindex modifiers of events
diff --git a/etc/NEWS b/etc/NEWS
index 1f4f9895315..3b520ec50b1 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -283,6 +283,10 @@ selected window is strongly dedicated to its buffer.
 `even-window-sizes' and now handles window widths as well.
 
 +++
+** New function `read-multiple-choice' use to prompt for
+multiple-choice questions, with a handy way to display help texts.
+
++++
 ** terpri gets an optional arg ENSURE to conditionally output a newline.
 
 +++
diff --git a/lisp/faces.el b/lisp/faces.el
index 612bd1677bb..d80a557feb5 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -2670,6 +2670,12 @@ It is used for characters of no fonts too."
   :version "24.1"
   :group 'basic-faces)
 
+(defface read-multiple-choice-face
+  '((t (:inherit bold)))
+  "Face for the symbol name in Apropos output."
+  :group 'basic-faces
+  :version "25.2")
+
 ;; Faces for TTY menus.
 (defface tty-menu-enabled-face
   '((t
diff --git a/lisp/subr.el b/lisp/subr.el
index c685f95f56f..db1baf09c43 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2233,6 +2233,120 @@ keyboard-quit events while waiting for a valid input."
     (message "%s%s" prompt (char-to-string char))
     char))
 
+(defun read-multiple-choice (prompt choices)
+  "Ask user a multiple choice question.
+PROMPT should be a string that will be displayed as the prompt.
+
+CHOICES is an alist where the first element in each entry is a
+character to be entered, the second element is a short name for
+the entry to be displayed while prompting (if there's room, it
+might be shortened), and the third, optional entry is a longer
+explanation that will be displayed in a help buffer if the user
+requests more help.
+
+The return value is the matching entry from the CHOICES list.
+
+Usage example:
+
+\(read-multiple-choice \"Continue connecting?\"
+                      '((?a \"always\")
+                        (?s \"session only\")
+                        (?n \"no\")))"
+  (let* ((altered-names nil)
+         (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-graphic-p)
+                        (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))
+            choices ", ")))
+         tchar buf)
+    (save-window-excursion
+      (save-excursion
+        (while (not tchar)
+          (message "%s" full-prompt)
+          (setq tchar (condition-case nil
+                          (read-char)
+                        (error nil)))
+          ;; The user has entered an invalid choice, so display the
+          ;; help messages.
+          (when (not (assq tchar choices))
+            (setq tchar nil)
+            (with-help-window (setq buf (get-buffer-create
+                                         "*Multiple Choice Help*"))
+              (with-current-buffer buf
+                (erase-buffer)
+                (pop-to-buffer buf)
+                (insert prompt "\n\n")
+                (let* ((columns (/ (window-width) 25))
+                       (fill-column 21)
+                       (times 0)
+                       (start (point)))
+                  (dolist (elem choices)
+                    (goto-char start)
+                    (unless (zerop times)
+                      (if (zerop (mod times columns))
+                          ;; Go to the next "line".
+                          (goto-char (setq start (point-max)))
+                        ;; Add padding.
+                        (while (not (eobp))
+                          (end-of-line)
+                          (insert (make-string (- (* (mod times columns)
+                                                     (+ fill-column 4))
+                                                  (current-column))
+                                               ?\s))
+                          (forward-line 1))))
+                    (setq times (1+ times))
+                    (let ((text
+                           (with-temp-buffer
+                             (insert (format
+                                      "%c: %s\n"
+                                      (car elem)
+                                      (cdr (assq (car elem) altered-names))))
+                             (fill-region (point-min) (point-max))
+                             (when (nth 2 elem)
+                               (insert (nth 2 elem))
+                               (unless (bolp)
+                                 (insert "\n"))
+                               (fill-region start (point-max)))
+                             (buffer-string))))
+                      (goto-char start)
+                      (dolist (line (split-string text "\n"))
+                        (end-of-line)
+                        (if (bolp)
+                            (insert line "\n")
+                          (insert line))
+                        (forward-line 1)))))))))))
+    (when (buffer-live-p buf)
+      (kill-buffer buf))
+    (assq tchar choices)))
+
 (defun sit-for (seconds &optional nodisp obsolete)
   "Redisplay, then wait for SECONDS seconds.  Stop when input is available.
 SECONDS may be a floating-point value.