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 a list of (KEY NAME [DESCRIPTION]).  KEY is a
  34 character to be entered.  NAME is a short name for the entry to
  35 be displayed while prompting (if there's room, it might be
  36 shortened).  DESCRIPTION is an optional longer explanation that
  37 will be displayed in a help buffer if the user requests more
  38 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
  51 text 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