emacs/lisp/emacs-lisp/rmc.el

;;; rmc.el --- read from a multiple choice question -*- lexical-binding: t -*-

;; Copyright (C) 2016-2021 Free Software Foundation, Inc.

;; Maintainer: emacs-devel@gnu.org

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(require 'seq)

;;;###autoload
(defun read-multiple-choice (prompt choices &optional help-string)
  "Ask user a multiple choice question.
PROMPT should be a string that will be displayed as the prompt.

CHOICES is a list of (KEY NAME [DESCRIPTION]).  KEY is a
character to be entered.  NAME is a short name for the entry to
be displayed while prompting (if there's room, it might be
shortened).  DESCRIPTION is an optional longer explanation for
the entry that will be displayed in a help buffer if the user
requests more help.  This help description has a fixed format in
columns, but, for greater flexibility, instead of passing a
DESCRIPTION, the user can use the optional argument HELP-STRING.
This argument is a string that contains the text with the
complete description of all choices.  `read-multiple-choice' will
display that description in a help buffer if the user requests
it.

This function translates user input into responses by consulting
the bindings in `query-replace-map'; see the documentation of
that variable for more information.  In this case, the useful
bindings are `recenter', `scroll-up', `scroll-down', and `edit'.
If the user enters `recenter', `scroll-up', or `scroll-down'
responses, perform the requested window recentering or scrolling
and ask again.  If the user enters `edit', start a recursive
edit.  When the user exit the recursive edit, the multiple choice
prompt gains focus again.

When `use-dialog-box' is t (the default), this function can pop
up a dialog window to collect the user input.  That functionality
requires `display-popup-menus-p' to return t.  Otherwise, a
text dialog will be used.

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-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 '((?? "?")))
            ", ")))
         tchar buf wrong-char answer)
    (save-window-excursion
      (save-excursion
	(while (not tchar)
	  (message "%s%s"
                   (if wrong-char
                       "Invalid choice.  "
                     "")
                   full-prompt)
          (setq tchar
                (if (and (display-popup-menus-p)
                         last-input-event ; not during startup
                         (consp last-nonmenu-event)
                         use-dialog-box)
                    (x-popup-dialog
                     t
                     (cons prompt
                           (mapcar
                            (lambda (elem)
                              (cons (capitalize (cadr elem))
                                    (car elem)))
                            choices)))
                  (condition-case nil
                      (let ((cursor-in-echo-area t))
                        (read-event))
                    (error nil))))
          (setq answer (lookup-key query-replace-map (vector tchar) t))
          (setq tchar
                (cond
                 ((eq answer 'recenter)
                  (recenter) t)
                 ((eq answer 'scroll-up)
                  (ignore-errors (scroll-up-command)) t)
                 ((eq answer 'scroll-down)
                  (ignore-errors (scroll-down-command)) t)
                 ((eq answer 'scroll-other-window)
                  (ignore-errors (scroll-other-window)) t)
                 ((eq answer 'scroll-other-window-down)
                  (ignore-errors (scroll-other-window-down)) t)
                 ((eq answer 'edit)
                  (save-match-data
                    (save-excursion
                      (message "%s"
                               (substitute-command-keys
                                "Recursive edit.  Resume with \\[exit-recursive-edit]"))
                      (recursive-edit))))
                 (t tchar)))
          (when (eq tchar t)
            (setq wrong-char nil
                  tchar nil))
          ;; The user has entered an invalid choice, so display the
          ;; help messages.
          (when (and (not (eq tchar nil))
                     (not (assq tchar choices)))
	    (setq wrong-char (not (memq tchar `(?? ,help-char)))
                  tchar nil)
            (when wrong-char
              (ding))
            (setq buf (get-buffer-create "*Multiple Choice Help*"))
            (if (stringp help-string)
                (with-help-window buf
                  (with-current-buffer buf
                    (insert help-string)))
              (with-help-window buf
                (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 (max (- (* (mod times columns)
                                                            (+ fill-column 4))
                                                         (current-column))
                                                      0)
                                                 ?\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)
                                 (let ((start (point)))
                                   (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)))

(provide 'rmc)

;;; rmc.el ends here