From ba02a15a2bb9831e9ba169a6c6fdd3da06df268e Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Tue, 26 Mar 2024 23:03:43 +0100 Subject: [PATCH] Improve 'read-multiple-choice' Crucially, make it more suitable for dynamic sets of choices. --- lisp/emacs-lisp/rmc.el | 237 ++++++++++++++++++++++++++--------------- lisp/minibuffer.el | 1 + lisp/simple.el | 4 +- 3 files changed, 154 insertions(+), 88 deletions(-) diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index 378687c0326..41f168f70d8 100644 --- 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 59f991b97f4..121994f1a18 100644 --- 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 1b715bf7deb..f8ac9a549c0 100644 --- 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))))))) -- 2.39.5