lisp/emacs-lisp/rmc.el

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