lisp/emacs-lisp/rmc.el

   1 ;;; rmc.el --- read from a multiple choice question -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2016-2018 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: emacs-devel@gnu.org
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (require 'seq)
  27
  28 ;;;###autoload
  29 (defun read-multiple-choice (prompt choices)
  30   "Ask user a multiple choice question.
  31 PROMPT should be a string that will be displayed as the prompt.
  32
  33 CHOICES is an alist where the first element in each entry is a
  34 character to be entered, the second element is a short name for
  35 the entry to be displayed while prompting (if there's room, it
  36 might be shortened), and the third, optional entry is a longer
  37 explanation that will be displayed in a help buffer if the user
  38 requests more help.
  39
  40 This function translates user input into responses by consulting
  41 the bindings in `query-replace-map'; see the documentation of
  42 that variable for more information.  In this case, the useful
  43 bindings are `recenter', `scroll-up', and `scroll-down'.  If the
  44 user enters `recenter', `scroll-up', or `scroll-down' responses,
  45 perform the requested window recentering or scrolling and ask
  46 again.
  47
  48 When `use-dialog-box' is t (the default), this function can pop
  49 up a dialog window to collect the user input. That functionality
  50 requires `display-popup-menus-p' to return t. Otherwise, a text
  51 dialog will be used.
  52
  53 The return value is the matching entry from the CHOICES list.
  54
  55 Usage example:
  56
  57 \(read-multiple-choice \"Continue connecting?\"
  58                       \\='((?a \"always\")
  59                         (?s \"session only\")
  60                         (?n \"no\")))"
  61   (let* ((altered-names nil)
  62          (full-prompt
  63           (format
  64            "%s (%s): "
  65            prompt
  66            (mapconcat
  67             (lambda (elem)
  68               (let* ((name (cadr elem))
  69                      (pos (seq-position name (car elem)))
  70                      (altered-name
  71                       (cond
  72                        ;; Not in the name string.
  73                        ((not pos)
  74                         (format "[%c] %s" (car elem) name))
  75                        ;; The prompt character is in the name, so highlight
  76                        ;; it on graphical terminals...
  77                        ((display-supports-face-attributes-p
  78                          '(:underline t) (window-frame))
  79                         (setq name (copy-sequence name))
  80                         (put-text-property pos (1+ pos)
  81                                            'face 'read-multiple-choice-face
  82                                            name)
  83                         name)
  84                        ;; And put it in [bracket] on non-graphical terminals.
  85                        (t
  86                         (concat
  87                          (substring name 0 pos)
  88                          "["
  89                          (upcase (substring name pos (1+ pos)))
  90                          "]"
  91                          (substring name (1+ pos)))))))
  92                 (push (cons (car elem) altered-name)
  93                       altered-names)
  94                 altered-name))
  95             (append choices '((?? "?")))
  96             ", ")))
  97          tchar buf wrong-char answer)
  98     (save-window-excursion
  99       (save-excursion
 100         (while (not tchar)
 101           (message "%s%s"
 102                    (if wrong-char
 103                        "Invalid choice.  "
 104                      "")
 105                    full-prompt)
 106           (setq tchar
 107                 (if (and (display-popup-menus-p)
 108                          last-input-event ; not during startup
 109                          (listp last-nonmenu-event)
 110                          use-dialog-box)
 111                     (x-popup-dialog
 112                      t
 113                      (cons prompt
 114                            (mapcar
 115                             (lambda (elem)
 116                               (cons (capitalize (cadr elem))
 117                                     (car elem)))
 118                             choices)))
 119                   (condition-case nil
 120                       (let ((cursor-in-echo-area t))
 121                         (read-char))
 122                     (error nil))))
 123           (setq answer (lookup-key query-replace-map (vector tchar) t))
 124           (setq tchar
 125                 (cond
 126                  ((eq answer 'recenter)
 127                   (recenter) t)
 128                  ((eq answer 'scroll-up)
 129                   (ignore-errors (scroll-up-command)) t)
 130                  ((eq answer 'scroll-down)
 131                   (ignore-errors (scroll-down-command)) t)
 132                  ((eq answer 'scroll-other-window)
 133                   (ignore-errors (scroll-other-window)) t)
 134                  ((eq answer 'scroll-other-window-down)
 135                   (ignore-errors (scroll-other-window-down)) t)
 136                  (t tchar)))
 137           (when (eq tchar t)
 138             (setq wrong-char nil
 139                   tchar nil))
 140           ;; The user has entered an invalid choice, so display the
 141           ;; help messages.
 142           (when (and (not (eq tchar nil))
 143                      (not (assq tchar choices)))
 144             (setq wrong-char (not (memq tchar '(?? ?\C-h)))
 145                   tchar nil)
 146             (when wrong-char
 147               (ding))
 148             (with-help-window (setq buf (get-buffer-create
 149                                          "*Multiple Choice Help*"))
 150               (with-current-buffer buf
 151                 (erase-buffer)
 152                 (pop-to-buffer buf)
 153                 (insert prompt "\n\n")
 154                 (let* ((columns (/ (window-width) 25))
 155                        (fill-column 21)
 156                        (times 0)
 157                        (start (point)))
 158                   (dolist (elem choices)
 159                     (goto-char start)
 160                     (unless (zerop times)
 161                       (if (zerop (mod times columns))
 162                           ;; Go to the next "line".
 163                           (goto-char (setq start (point-max)))
 164                         ;; Add padding.
 165                         (while (not (eobp))
 166                           (end-of-line)
 167                           (insert (make-string (max (- (* (mod times columns)
 168                                                           (+ fill-column 4))
 169                                                        (current-column))
 170                                                     0)
 171                                                ?\s))
 172                           (forward-line 1))))
 173                     (setq times (1+ times))
 174                     (let ((text
 175                            (with-temp-buffer
 176                              (insert (format
 177                                       "%c: %s\n"
 178                                       (car elem)
 179                                       (cdr (assq (car elem) altered-names))))
 180                              (fill-region (point-min) (point-max))
 181                              (when (nth 2 elem)
 182                                (let ((start (point)))
 183                                  (insert (nth 2 elem))
 184                                  (unless (bolp)
 185                                    (insert "\n"))
 186                                  (fill-region start (point-max))))
 187                              (buffer-string))))
 188                       (goto-char start)
 189                       (dolist (line (split-string text "\n"))
 190                         (end-of-line)
 191                         (if (bolp)
 192                             (insert line "\n")
 193                           (insert line))
 194                         (forward-line 1)))))))))))
 195     (when (buffer-live-p buf)
 196       (kill-buffer buf))
 197     (assq tchar choices)))
 198
 199 (provide 'rmc)
 200
 201 ;;; rmc.el ends here