bug#38076: Using minibuffer for y-or-n-p

[Juri Linkov]

X-Debbugs-CC: Stefan Monnier <monnier@iro.umontreal.ca>
Tags: patch

>> query-replace-map needs to be translated to another keymap
>> where the same characters from 'query-replace-map'
>> run real commands, not intermediate symbols.
>
> E.g.
>
>     (defvar foo-remapping-map
>       (let ((map (make-sparse-keymap)))
>         (define-key map [remap ask] '...)
>         ...
>         map))
>
> and then
>
>       ... (make-composed-keymap query-replace-map foo-remapping-map) ..

This also required adding the same feature that supported recentering/scrolling
in y-or-n-p to the minibuffer as well.  A large part of old implementation
of y-or-n-p handled recentering/scrolling.  Now the minibuffer supports
the same commands by using the new macro 'with-minibuffer-selected-window'.

window.c was changed to use the 'lambda' value for MINIBUF arg of 'next-window',
so minibuffer-scroll-other-window/minibuffer-scroll-other-window-down
doesn't try to scroll the minibuffer window.

A new history variable 'y-or-n-p-history-variable' is nil by default,
so no history is used in 'y-or-n-p' minibuffer.

This patch was tested with various commands that use 'y-or-n-p'
and seems to work fine:

diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 43dd277a2e..0c55954b02 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -2236,6 +2236,13 @@ completion-help-at-point
 (let ((map minibuffer-local-map))
   (define-key map "\C-g" 'abort-recursive-edit)
   (define-key map "\M-<" 'minibuffer-beginning-of-buffer)
+
+  (define-key map [remap recenter-top-bottom] 'minibuffer-recenter-top-bottom)
+  (define-key map [remap scroll-up-command] 'minibuffer-scroll-up-command)
+  (define-key map [remap scroll-down-command] 'minibuffer-scroll-down-command)
+  (define-key map [remap scroll-other-window] 'minibuffer-scroll-other-window)
+  (define-key map [remap scroll-other-window-down] 
'minibuffer-scroll-other-window-down)
+
   (define-key map "\r" 'exit-minibuffer)
   (define-key map "\n" 'exit-minibuffer))
 
@@ -3670,6 +3677,46 @@ minibuffer-beginning-of-buffer
   (when (and arg (not (consp arg)))
     (forward-line 1)))
 
+(defmacro with-minibuffer-selected-window (&rest body)
+  "Execute the forms in BODY from the minibuffer in its original window.
+When used in a minibuffer window, select the window selected just before
+minibuffer window was selected, and execute the forms."
+  (declare (indent 0) (debug t))
+  `(let ((window (minibuffer-selected-window)))
+     (when window
+       (with-selected-window window
+         ,@body))))
+
+(defun minibuffer-recenter-top-bottom (&optional arg)
+  "Run `recenter-top-bottom' from minibuffer in original window."
+  (interactive "P")
+  (with-minibuffer-selected-window
+    (recenter-top-bottom arg)))
+
+(defun minibuffer-scroll-up-command (&optional arg)
+  "Run `scroll-up-command' from minibuffer in original window."
+  (interactive "^P")
+  (with-minibuffer-selected-window
+    (scroll-up-command arg)))
+
+(defun minibuffer-scroll-down-command (&optional arg)
+  "Run `scroll-down-command' from minibuffer in original window."
+  (interactive "^P")
+  (with-minibuffer-selected-window
+    (scroll-down-command arg)))
+
+(defun minibuffer-scroll-other-window (&optional arg)
+  "Run `scroll-other-window' from minibuffer in original window."
+  (interactive "P")
+  (with-minibuffer-selected-window
+    (scroll-other-window arg)))
+
+(defun minibuffer-scroll-other-window-down (&optional arg)
+  "Run `scroll-other-window-down' from minibuffer in original window."
+  (interactive "^P")
+  (with-minibuffer-selected-window
+    (scroll-other-window-down arg)))
+
 (provide 'minibuffer)
 
 ;;; minibuffer.el ends here
diff --git a/lisp/subr.el b/lisp/subr.el
index 03cf3da278..0a8a505b70 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2668,6 +2668,66 @@ sit-for
 ;; Behind display-popup-menus-p test.
 (declare-function x-popup-dialog "menu.c" (position contents &optional header))
 
+(defvar y-or-n-p-history-variable nil
+  "History list symbol to add `y-or-n-p' answers to.")
+
+(defvar y-or-n-p-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map minibuffer-local-map)
+
+    (define-key map [remap act] 'y-or-n-p-insert-y)
+    (define-key map [remap act-and-show] 'y-or-n-p-insert-y)
+    (define-key map [remap act-and-exit] 'y-or-n-p-insert-y)
+    (define-key map [remap automatic] 'y-or-n-p-insert-y)
+
+    (define-key map [remap skip] 'y-or-n-p-insert-n)
+
+    (define-key map [remap help] 'y-or-n-p-insert-other)
+    (define-key map [remap backup] 'y-or-n-p-insert-other)
+    (define-key map [remap undo] 'y-or-n-p-insert-other)
+    (define-key map [remap undo-all] 'y-or-n-p-insert-other)
+    (define-key map [remap edit] 'y-or-n-p-insert-other)
+    (define-key map [remap edit-replacement] 'y-or-n-p-insert-other)
+    (define-key map [remap delete-and-edit] 'y-or-n-p-insert-other)
+    (define-key map [remap ignore] 'y-or-n-p-insert-other)
+    (define-key map [remap self-insert-command] 'y-or-n-p-insert-other)
+
+    (define-key map [remap recenter] 'minibuffer-recenter-top-bottom)
+
+    (define-key map [remap quit] 'abort-recursive-edit)
+    (define-key map [remap exit] 'abort-recursive-edit)
+    (define-key map [remap exit-prefix] 'abort-recursive-edit)
+    (define-key map [escape] 'abort-recursive-edit)
+
+    map)
+  "Keymap that defines additional bindings for `y-or-n-p' answers.")
+
+(defun y-or-n-p-insert-y ()
+  "Insert the answer \"y\" and exit the minibuffer of `y-or-n-p'.
+Discard all input in a minibuffer before inserting."
+  (interactive)
+  (delete-minibuffer-contents)
+  (insert "y")
+  (exit-minibuffer))
+
+(defun y-or-n-p-insert-n ()
+  "Insert the answer \"n\" and exit the minibuffer of `y-or-n-p'.
+Discard all input in a minibuffer before inserting."
+  (interactive)
+  (delete-minibuffer-contents)
+  (insert "n")
+  (exit-minibuffer))
+
+(defun y-or-n-p-insert-other ()
+  "Handle inserting of other answers in the minibuffer of `y-or-n-p'."
+  (interactive)
+  (delete-minibuffer-contents)
+  (ding)
+  (minibuffer-message "Please answer y or n.")
+  (sit-for 2))
+
+(defvar empty-history)
+
 (defun y-or-n-p (prompt)
   "Ask user a \"y or n\" question.
 Return t if answer is \"y\" and nil if it is \"n\".
@@ -2683,16 +2743,13 @@ y-or-n-p
 case, the useful bindings are `act', `skip', `recenter',
 `scroll-up', `scroll-down', and `quit'.
 An `act' response means yes, and a `skip' response means no.
-A `quit' response means to invoke `keyboard-quit'.
+A `quit' response means to invoke `abort-recursive-edit'.
 If the user enters `recenter', `scroll-up', or `scroll-down'
 responses, perform the requested window recentering or scrolling
 and ask again.
 
 Under a windowing system a dialog box will be used if `last-nonmenu-event'
 is nil and `use-dialog-box' is non-nil."
-  ;; ¡Beware! when I tried to edebug this code, Emacs got into a weird state
-  ;; where all the keys were unbound (i.e. it somehow got triggered
-  ;; within read-key, apparently).  I had to kill it.
   (let ((answer 'recenter)
        (padded (lambda (prompt &optional dialog)
                  (let ((l (length prompt)))
@@ -2718,36 +2775,13 @@ y-or-n-p
            answer (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip)))))
      (t
       (setq prompt (funcall padded prompt))
-      (while
-          (let* ((scroll-actions '(recenter scroll-up scroll-down
-                                  scroll-other-window 
scroll-other-window-down))
-                (key
-                  (let ((cursor-in-echo-area t))
-                    (when minibuffer-auto-raise
-                      (raise-frame (window-frame (minibuffer-window))))
-                    (read-key (propertize (if (memq answer scroll-actions)
-                                              prompt
-                                            (concat "Please answer y or n.  "
-                                                    prompt))
-                                          'face 'minibuffer-prompt)))))
-            (setq answer (lookup-key query-replace-map (vector key) t))
-            (cond
-            ((memq answer '(skip act)) nil)
-            ((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)
-            ((or (memq answer '(exit-prefix quit)) (eq key ?\e))
-             (signal 'quit nil) t)
-            (t t)))
-        (ding)
-        (discard-input))))
+      (let* ((empty-history '())
+             (str (read-from-minibuffer
+                   prompt nil
+                   (make-composed-keymap y-or-n-p-map query-replace-map)
+                   nil
+                   (or y-or-n-p-history-variable 'empty-history))))
+        (setq answer (if (member str '("y" "Y")) 'act 'skip)))))
     (let ((ret (eq answer 'act)))
       (unless noninteractive
         (message "%s%c" prompt (if ret ?y ?n)))
diff --git a/src/window.c b/src/window.c
index 0fa0bdf7b9..c01f5c4aa3 100644
--- a/src/window.c
+++ b/src/window.c
@@ -6253,12 +6253,12 @@ DEFUN ("other-window-for-scrolling", 
Fother_window_for_scrolling, Sother_window_
     {
       /* Nothing specified; look for a neighboring window on the same
         frame.  */
-      window = Fnext_window (selected_window, Qnil, Qnil);
+      window = Fnext_window (selected_window, Qlambda, Qnil);
 
       if (EQ (window, selected_window))
        /* That didn't get us anywhere; look for a window on another
            visible frame on the current terminal.  */
-        window = Fnext_window (window, Qnil, Qvisible);
+        window = Fnext_window (window, Qlambda, Qvisible);
     }
 
   CHECK_LIVE_WINDOW (window);