Improve 'read-multiple-choice'

Crucially, make it more suitable for dynamic sets of choices.

diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el
index 378687c03263aefef89621f4dcd33952bd11f701..41f168f70d8608f83595f586c8368793a736d8fc 100644 (file)
--- a/lisp/emacs-lisp/rmc.el
+++ b/lisp/emacs-lisp/rmc.el
@@ -23,6 +23,10 @@
 
 ;;; Code:
 
+(defgroup read-multiple-choice nil
+  "Customizations for `read-multiple-choice'."
+  :group 'minibuffer)
+
 (defun rmc--add-key-description (elem)
   (let* ((char (car elem))
          (name (cadr elem))
@@ -59,10 +63,15 @@
              (substring name (1+ pos)))))))
     (cons char altered-name)))
 
+(defcustom read-multiple-choice-help-buffer-name "*Multiple Choice Help*"
+  "Name of the buffer showing help during `read-multiple-choice'."
+  :type 'string
+  :version "30.1")
+
 (defun rmc--show-help (prompt help-string show-help choices altered-names)
   (let* ((buf-name (if (stringp show-help)
                        show-help
-                     "*Multiple Choice Help*"))
+                     read-multiple-choice-help-buffer-name))
          (buf (get-buffer-create buf-name)))
     (if (stringp help-string)
         (with-help-window buf
@@ -122,6 +131,22 @@
                   (forward-line 1))))))))
     buf))
 
+(defvar read-multiple-choice-assign-key-function
+  #'read-multiple-choice-assign-key-default
+  "Default function to use for assigning keys to choices.")
+
+(defun read-multiple-choice-assign-key-default (name choices)
+  "Assign the first key in NAME that is free in CHOICES, or another single key."
+  (seq-find (lambda (c) (not (seq-some (lambda (elem)
+                                         (and (characterp (car elem))
+                                              (= c (car elem))))
+                                       choices)))
+            (concat name
+                    "abcdefghijklmnpqrstuvwxyz"
+                    "ABCDEFGHIJKLMNPQRSTUVWXYZ"
+                    "01234567890"
+                    " -=")))
+
 ;;;###autoload
 (defun read-multiple-choice (prompt choices &optional help-string show-help
                                     long-form)
@@ -156,10 +181,11 @@ scrolling, and then asks the question again.  If the user enters `edit',
 the function starts 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), and the command using this
-function was invoked via the mouse, this function pops up a GUI dialog
-to collect the user input, but only if Emacs is capable of using GUI
-dialogs.  Otherwise, the function will always use text-mode dialogs.
+When there are just a few CHOICES, `use-dialog-box' is t (the default),
+and the command using this function was invoked via the mouse, this
+function pops up a GUI dialog to collect the user input, but only if
+Emacs is capable of using GUI dialogs.  Otherwise, the function will
+always use text-mode dialogs.
 
 The return value is the matching entry from the CHOICES list.
 
@@ -174,96 +200,135 @@ Usage example:
                       \\='((?a \"always\")
                         (?s \"session only\")
                         (?n \"no\")))"
+  (while-let ((cell (seq-find (lambda (elem)
+                                (not (characterp (car elem))))
+                              choices)))
+    (setcar cell (funcall (or (car cell)
+                              read-multiple-choice-assign-key-function)
+                          (cadr cell) choices))
+    (unless (car cell)
+      (error "Failed to assign a key to choice \"%s\"" (cadr cell))))
   (if long-form
       (read-multiple-choice--long-answers prompt choices)
     (read-multiple-choice--short-answers
      prompt choices help-string show-help)))
 
+(defface read-multiple-choice-prompt
+  '((t :inherit minibuffer-prompt))
+  "Face for highlighting the `read-multiple-choice' prompt."
+  :version "30.1")
+
+(defun rmc--format-prompt-one-line (prompt options)
+  (format "%s %s"
+          (propertize prompt 'face 'read-multiple-choice-prompt)
+          (mapconcat #'identity options
+                     (propertize " | " 'face 'shadow))))
+
+(defun rmc--format-prompt-multi-line (prompt options)
+  (let* ((col-width (seq-max (mapcar #'string-width options)))
+         (total-width (frame-width))
+         (num-colms (/ total-width (+ col-width 3)))
+         (result (propertize prompt 'face 'read-multiple-choice-prompt))
+         (column 0))
+    (dolist (option options)
+      (setq result (concat
+                    result
+                    (if (zerop column) "\n" (propertize " | " 'face 'shadow))
+                    option
+                    (make-string (- col-width (string-width option)) ?\s))
+            column (mod (1+ column) num-colms)))
+    result))
+
+(defun rmc--format-prompt (prompt options)
+  (let ((one-line (rmc--format-prompt-one-line prompt options)))
+    (if (< (frame-text-width) (string-pixel-width one-line))
+        (rmc--format-prompt-multi-line prompt options)
+      one-line)))
+
 (defun read-multiple-choice--short-answers (prompt choices help-string show-help)
-  (let* ((dialog-p (use-dialog-box-p))
-         (prompt-choices
-          (if (or show-help dialog-p) choices (append choices '((?? "?")))))
-         (altered-names (mapcar #'rmc--add-key-description prompt-choices))
-         (full-prompt
-          (format
-           "%s (%s): "
-           prompt
-           (mapconcat (lambda (e) (cdr e)) altered-names ", ")))
-         tchar buf wrong-char answer)
-    (save-window-excursion
-      (save-excursion
-        (if show-help
-            (setq buf (rmc--show-help prompt help-string show-help
-                                      choices altered-names)))
-       (while (not tchar)
-          (unless dialog-p
-           (message "%s%s"
-                     (if wrong-char
-                         "Invalid choice.  "
-                       "")
-                     full-prompt))
-          (setq tchar
-                (if dialog-p
-                    (x-popup-dialog
-                     t
-                     (cons prompt
-                           (mapcar
-                            (lambda (elem)
-                              (cons (capitalize (cadr elem))
-                                    (car elem)))
-                            prompt-choices)))
+  (let* ((altered-names (mapcar #'rmc--add-key-description choices))
+         (full-prompt (rmc--format-prompt prompt (mapcar #'cdr altered-names)))
+         tchar buf result invalid-choice)
+    (when show-help (setq buf (rmc--show-help prompt help-string show-help
+                                              choices altered-names)))
+    (unwind-protect
+        (if (and (use-dialog-box-p)
+                 ;; Guard against "Too many dialog items" errors.
+                 (< (length choices) 9))
+            (x-popup-dialog
+             t
+             (cons prompt
+                   (mapcar
+                    (lambda (elem)
+                      (cons (capitalize (cadr elem)) elem))
+                    choices)))
+          (while (not result)
+            (when tchar
+              (pcase (lookup-key query-replace-map (vector tchar) t)
+                ('help
+                 (setq buf (rmc--show-help prompt help-string show-help
+                                           choices altered-names)))
+                ('recenter
+                 (let ((this-command 'recenter-top-bottom)
+                      (last-command 'recenter-top-bottom))
+                  (recenter-top-bottom)))
+                ('edit
+                 (save-match-data
+                   (save-excursion
+                     (save-window-excursion
+                       (message
+                        (substitute-command-keys
+                         "Recursive edit; \\[exit-recursive-edit] to resume"))
+                       (recursive-edit)))))
+                ('scroll-up
+                 (ignore-errors (scroll-up-command)))
+                ('scroll-down
+                 (ignore-errors (scroll-down-command)))
+                ('scroll-other-window
+                 (ignore-errors (scroll-other-window)))
+                ('scroll-other-window-down
+                 (ignore-errors (scroll-other-window-down)))
+                (_ (setq invalid-choice
+                         (concat "Invalid choice "
+                                 (propertize (key-description (vector tchar))
+                                             'face 'read-multiple-choice-face)
+                                 ", choose one of the following (or "
+                                 (propertize "C-h" 'face 'read-multiple-choice-face)
+                                 " for help, "
+                                 (propertize "C-g" 'face 'read-multiple-choice-face)
+                                 " to quit, "
+                                 (propertize "C-r" 'face 'read-multiple-choice-face)
+                                 " to pause):\n")))))
+            (message (concat invalid-choice full-prompt))
+            (setq tchar
                   (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; type \\[exit-recursive-edit] to return to help screen"))
-                      (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 (rmc--show-help prompt help-string show-help
-                                      choices altered-names))))))
-    (when (buffer-live-p buf)
-      (kill-buffer buf))
-    (assq tchar choices)))
+                      (let ((cursor-in-echo-area t)) (read-event))
+                    (error nil)))
+            (setq result (assq tchar choices)))
+          result)
+      (when-let ((win (and buf (get-buffer-window buf)))) (quit-window nil win)))))
 
 (defun read-multiple-choice--long-answers (prompt choices)
-  (let ((answer
-         (completing-read
-          (concat prompt " ("
-                  (mapconcat #'identity (mapcar #'cadr choices) "/")
-                  ") ")
-          (mapcar #'cadr choices) nil t)))
-    (seq-find (lambda (elem)
-                (equal (cadr elem) answer))
-              choices)))
+  (let* ((cands
+          (mapcar (lambda (elem)
+                    (concat (propertize (key-description (char-to-string
+                                                          (car elem)))
+                                        'face 'read-multiple-choice-face)
+                            " " (cadr elem)))
+                  choices))
+         (answer
+          (minibuffer-with-setup-hook #'minibuffer-completion-help
+            (completing-read
+             (format-prompt prompt cands)
+             (completion-table-with-metadata
+              cands
+              `((category . multiple-choice)
+                (annotation-function
+                 . ,(lambda (cand)
+                      (when-let ((desc (caddr (assq (aref cand 0) choices))))
+                        (concat " " desc))))))
+             nil t nil nil cands))))
+    (unless (string-empty-p answer) (assq (aref answer 0) choices))))
 
 (provide 'rmc)
 

diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 59f991b97f4327d27e98fcee82e1961568c81ec4..121994f1a18ce4e96c305ed95460ad3d506f6727 100644 (file)
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -1173,6 +1173,7 @@ styles for specific categories, such as files, buffers, etc."
     (xref-location (styles . (substring)))
     (info-menu (styles . (basic substring)))
     (symbol-help (styles . (basic shorthand substring)))
+    (multiple-choice (styles . (basic substring)) (sort-function . identity))
     (calendar-month (sort-function . identity)))
   "Default settings for specific completion categories.
 

diff --git a/lisp/simple.el b/lisp/simple.el
index 1b715bf7deb37fa6192e18c8a29209bc2d23cf66..f8ac9a549c094b02f246e9e092ec5b3f6dba48f9 100644 (file)
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -11189,8 +11189,8 @@ killed."
           (read-multiple-choice
            (format "Buffer %s modified; kill anyway?"
                    (buffer-name))
-           '((?y "yes" "kill buffer without saving")
-             (?n "no" "exit without doing anything")
+           '((?n "no" "exit without doing anything")
+             (?y "yes" "kill buffer without saving")
              (?s "save and then kill" "save the buffer and then kill it"))
            nil nil (and (not use-short-answers)
                         (not (use-dialog-box-p)))))))