mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-05 22:20:24 -08:00
Code Issues Projects Releases Wiki Activity

'read-multiple-choice' now uses the minibuffer to read a char (bug#79664)

Browse source 
* doc/lispref/commands.texi (Reading One Event): Mention
'read-char-choice-use-read-key'.

* lisp/emacs-lisp/rmc.el (rmc--show-help): Show non-selected
resized Help window at bottom.  Inhibit useless message.
Remove unnecessary call to 'pop-to-buffer'.
(read-multiple-choice): Call 'read-multiple-choice--from-minibuffer'
when 'read-char-choice-use-read-key' is nil.
(read-multiple-choice--from-minibuffer): New function.

* test/lisp/emacs-lisp/rmc-tests.el (test-rmc--with-minibuffer-setup):
New macro.
(test-read-multiple-choice, test-read-multiple-choice-help):
Test both values of 'read-char-choice-use-read-key'.
This commit is contained in:
Juri Linkov 2025-11-01 20:21:09 +02:00
parent d2b0c78366
commit ab4a616b0b
4 changed files with 136 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

3
doc/lispref/commands.texi
View file

@ -3691,6 +3691,9 @@ will have to type in long-form answers (using @code{completing-read})
instead of hitting a single key. The answers must be among the second
elements of the values in the @var{choices} list.
If the variable @code{read-char-choice-use-read-key} is non-@code{nil},
this function uses @code{read-key} instead of @code{read-from-minibuffer}.
The return value is the matching value from @var{choices}.
@lisp

5
etc/NEWS
View file

@ -277,6 +277,11 @@ minibuffer window using the 'minibuffer-nonselected' face in case
when the minibuffer window is no longer selected, but the minibuffer
is still waiting for input.
+++
*** 'read-multiple-choice' now uses the minibuffer to read a character.
It still can use 'read-key' when the variable
'read-char-choice-use-read-key' is non-nil.
** Mouse
*** New mode 'mouse-shift-adjust-mode' extends selection with 'S-<mouse-1>'.

94
lisp/emacs-lisp/rmc.el
View file

@ -63,7 +63,15 @@
(let* ((buf-name (if (stringp show-help)
show-help
"*Multiple Choice Help*"))
(buf (get-buffer-create buf-name)))
(buf (get-buffer-create buf-name))
;; Show non-selected resized Help window at bottom.
(help-window-select nil)
(display-buffer-base-action
`(display-buffer--maybe-at-bottom
. ((window-height . ,#'fit-window-to-buffer))))
;; Inhibit useless message "Type q in help window to delete it".
(set-message-functions (cons 'inhibit-message set-message-functions))
(inhibit-message-regexps (cons "^Type " inhibit-message-regexps)))
(if (stringp help-string)
(with-help-window buf
(with-current-buffer buf
@ -71,7 +79,6 @@
(with-help-window buf
(with-current-buffer buf
(erase-buffer)
(pop-to-buffer buf)
(insert prompt "\n\n")
(let* ((columns (/ (window-width) 25))
(fill-column 21)
@ -145,11 +152,16 @@ If optional argument SHOW-HELP is non-nil, show the help screen
immediately, before any user input. If SHOW-HELP is a string,
use it as the name of the help buffer.
This function translates user input into responses by consulting
the bindings in `query-replace-map'; see the documentation of
that variable for more information. The relevant bindings for the
purposes of this function are `recenter', `scroll-up', `scroll-down',
and `edit'.
By default, this function uses the minibuffer to read the key
non-modally (see `read-from-minibuffer'). However, if
`read-char-choice-use-read-key' is non-nil, the modal `read-key'
function is used instead.
In case of using the modal `read-key', this function translates user
input into responses by consulting the bindings in `query-replace-map';
see the documentation of that variable for more information. The
relevant bindings for the purposes of this function are `recenter',
`scroll-up', `scroll-down', and `edit'.
If the user types the `recenter', `scroll-up', or `scroll-down'
responses, the function performs the requested window recentering or
scrolling, and then asks the question again. If the user enters `edit',
@ -174,10 +186,14 @@ Usage example:
\\='((?a \"always\")
(?s \"session only\")
(?n \"no\")))"
(if long-form
(read-multiple-choice--long-answers prompt choices)
(cond (long-form
(read-multiple-choice--long-answers prompt choices))
((or read-char-choice-use-read-key (use-dialog-box-p))
(read-multiple-choice--short-answers
prompt choices help-string show-help)))
prompt choices help-string show-help))
(t
(read-multiple-choice--from-minibuffer
prompt choices help-string show-help))))
(declare-function touch-screen-scroll "touch-screen.el")
(declare-function touch-screen-pinch "touch-screen.el")
@ -313,6 +329,64 @@ Usage example:
(equal (cadr elem) answer))
choices)))
(defun read-multiple-choice--from-minibuffer (prompt choices help-string show-help)
;; Read short answers from the minibuffer.
(let* ((prompt-choices
(if show-help choices (append choices '((?? "?")))))
(altered-names (mapcar #'rmc--add-key-description prompt-choices))
(full-prompt
(format
"%s (%s): "
prompt
(mapconcat #'cdr altered-names ", ")))
tchar buf
(map (make-sparse-keymap))
(cmd-char
(lambda ()
(interactive)
(setq tchar last-command-event)
(exit-minibuffer)))
(cmd-help
(lambda ()
(interactive)
(setq buf (rmc--show-help prompt help-string show-help
choices altered-names))))
(cmd-wrong
(lambda ()
(interactive)
(ding)
(setq buf (rmc--show-help prompt help-string show-help
choices altered-names))
(minibuffer-message "Invalid choice")
(sit-for 2)))
(this-command this-command)
(real-this-command real-this-command)
(enable-recursive-minibuffers t)
(overriding-text-conversion-style nil))
(unwind-protect
(progn
(when show-help
(setq buf (rmc--show-help prompt help-string show-help
choices altered-names)))
(set-keymap-parent map minibuffer-local-map)
(dolist (char choices)
(define-key map `[,(car char)] cmd-char))
(define-key map [help-char] cmd-help)
(unless show-help (define-key map [??] cmd-help))
(define-key map [remap self-insert-command] cmd-wrong)
(when (fboundp 'set-text-conversion-style)
(set-text-conversion-style text-conversion-style))
(read-from-minibuffer full-prompt nil map))
(when (buffer-live-p buf)
(let ((kill-buffer-quit-windows t))
(kill-buffer buf))))
(assq tchar choices)))
(provide 'rmc)
;;; rmc.el ends here

30
test/lisp/emacs-lisp/rmc-tests.el
View file

@ -62,35 +62,57 @@
(rmc--add-key-description '(?n "foo"))
`(?n . ,(concat (propertize "n" 'face 'help-key-binding) " foo"))))))
(defmacro test-rmc--with-minibuffer-setup (fun-call &rest body)
(declare (indent 1) (debug t))
`(minibuffer-with-setup-hook
(lambda ()
(let ((redisplay-skip-initial-frame nil)
(executing-kbd-macro nil)) ; Don't skip redisplay
(progn . ,body)))
(let ((executing-kbd-macro t)) ; Force the real minibuffer
,fun-call)))
(ert-deftest test-read-multiple-choice ()
(skip-when (display-graphic-p))
(dolist (read-char-choice-use-read-key '(t nil))
(dolist (char '(?y ?n))
(cl-letf* (((symbol-function #'read-key) (lambda () char))
(cl-letf* (((symbol-function #'exit-minibuffer) (lambda ()))
((symbol-function #'read-key) (lambda () char))
(str (if (eq char ?y) "yes" "no")))
(should (equal (list char str)
(read-multiple-choice "Do it? " '((?y "yes") (?n "no"))))))))
(test-rmc--with-minibuffer-setup
(read-multiple-choice "Do it? " '((?y "yes") (?n "no")))
(execute-kbd-macro (string char)))))))))
(ert-deftest test-read-multiple-choice-help ()
(skip-when (display-graphic-p))
(dolist (read-char-choice-use-read-key '(t nil))
(let ((chars '(?o ?a))
help)
(cl-letf* (((symbol-function #'read-key)
(cl-letf* (((symbol-function #'exit-minibuffer) (lambda ()))
((symbol-function #'ding) (lambda ()))
((symbol-function #'sit-for) (lambda (_)))
((symbol-function #'read-key)
(lambda ()
(message "chars %S" chars)
(when (= 1 (length chars))
(with-current-buffer "*Multiple Choice Help*"
(setq help (buffer-string))))
(pop chars))))
(test-rmc--with-minibuffer-setup
(read-multiple-choice
"Choose:"
'((?a "aaa")
(?b "bbb")
(?c "ccc" "a really long description of ccc")))
(execute-kbd-macro (string (car chars)))
(with-current-buffer "*Multiple Choice Help*"
(setq help (buffer-string))))
(should (equal help "Choose:
a: [A]aa b: [B]bb c: [C]cc
a really long
description of ccc
\n")))))
\n"))))))
;;; rmc-tests.el ends here