[Emacs-diffs] master afba4cc: New function read-answer (bug#30073)

[Juri Linkov]

branch: master
commit afba4ccb8b8c6347a44efd0b9f4d6fb85756f85b
Author: Juri Linkov <address@hidden>
Commit: Juri Linkov <address@hidden>

    New function read-answer (bug#30073)
    
    * lisp/emacs-lisp/map-ynp.el (read-answer): New function.
    (read-answer-short): New defcustom.
    
    * lisp/dired.el (dired-delete-file): Use read-answer.
    (dired--yes-no-all-quit-help): Remove function.
    (dired-delete-help): Remove defconst.
    
    * lisp/subr.el (assoc-delete-all): New function.
---
 etc/NEWS                     |   3 ++
 lisp/dired.el                |  41 +++------------
 lisp/emacs-lisp/map-ynp.el   | 122 +++++++++++++++++++++++++++++++++++++++++++
 lisp/subr.el                 |  15 ++++++
 test/lisp/dired-aux-tests.el |   2 +-
 test/lisp/dired-tests.el     |  22 ++++----
 6 files changed, 160 insertions(+), 45 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index ed07b10..d30f0b0 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -240,6 +240,9 @@ file name extensions.
 ** The ecomplete sorting has changed to a decay-based algorithm.  This
 can be controlled by the new `ecomplete-sort-predicate' variable.
 
+** The new function 'read-answer' accepts either long or short answers
+depending on the new customizable variable 'read-answer-short'.
+
 
 * Changes in Emacs 27.1 on Non-Free Operating Systems
 
diff --git a/lisp/dired.el b/lisp/dired.el
index b853d64..eebf836 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -2997,37 +2997,6 @@ Any other value means to ask for each directory."
 ;; Match anything but `.' and `..'.
 (defvar dired-re-no-dot "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")
 
-(defconst dired-delete-help
-  "Type:
-`yes' to delete recursively the current directory,
-`no' to skip to next,
-`all' to delete all remaining directories with no more questions,
-`quit' to exit,
-`help' to show this help message.")
-
-(defun dired--yes-no-all-quit-help (prompt &optional help-msg)
-  "Ask a question with valid answers: yes, no, all, quit, help.
-PROMPT must end with '? ', for instance, 'Delete it? '.
-If optional arg HELP-MSG is non-nil, then is a message to show when
-the user answers 'help'.  Otherwise, default to `dired-delete-help'."
-  (let ((valid-answers (list "yes" "no" "all" "quit"))
-        (answer "")
-        (input-fn (lambda ()
-                    (read-string
-                    (format "%s [yes, no, all, quit, help] " prompt)))))
-    (setq answer (funcall input-fn))
-    (when (string= answer "help")
-      (with-help-window "*Help*"
-        (with-current-buffer "*Help*"
-          (insert (or help-msg dired-delete-help)))))
-    (while (not (member answer valid-answers))
-      (unless (string= answer "help")
-        (beep)
-        (message "Please answer `yes' or `no' or `all' or `quit'")
-        (sleep-for 2))
-      (setq answer (funcall input-fn)))
-    answer))
-
 ;; Delete file, possibly delete a directory and all its files.
 ;; This function is useful outside of dired.  One could change its name
 ;; to e.g. recursive-delete-file and put it somewhere else.
@@ -3057,11 +3026,17 @@ TRASH non-nil means to trash the file instead of 
deleting, provided
                                    "trash"
                                  "delete")
                                (dired-make-relative file))))
-                   (pcase (dired--yes-no-all-quit-help prompt) ; Prompt user.
+                   (pcase (read-answer
+                           prompt
+                           '(("yes"  ?y "delete recursively the current 
directory")
+                             ("no"   ?n "skip to next")
+                             ("all"  ?! "delete all remaining directories with 
no more questions")
+                             ("quit" ?q "exit")))
                      ('"all" (setq recursive 'always dired-recursive-deletes 
recursive))
                      ('"yes" (if (eq recursive 'top) (setq recursive 'always)))
                      ('"no" (setq recursive nil))
-                     ('"quit" (keyboard-quit)))))
+                     ('"quit" (keyboard-quit))
+                     (_ (keyboard-quit))))) ; catch all unknown answers
              (setq recursive nil)) ; Empty dir or recursive is nil.
            (delete-directory file recursive trash))))
 
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index dd80524..61c04ff 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -252,4 +252,126 @@ C-g to quit (cancel the whole command);
     ;; Return the number of actions that were taken.
     actions))
 
+
+;; read-answer is a general-purpose question-asker that supports
+;; either long or short answers.
+
+;; For backward compatibility check if short y/n answers are preferred.
+(defcustom read-answer-short (eq (symbol-function 'yes-or-no-p) 'y-or-n-p)
+  "If non-nil, accept short answers to the question."
+  :type 'boolean
+  :version "27.1"
+  :group 'minibuffer)
+
+(defconst read-answer-map--memoize (make-hash-table :weakness 'key :test 
'equal))
+
+(defun read-answer (question answers)
+  "Read an answer either as a complete word or its character abbreviation.
+Ask user a question and accept an answer from the list of possible answers.
+
+QUESTION should end in a space; this function adds a list of answers to it.
+
+ANSWERS is an alist with elements in the following format:
+  (LONG-ANSWER SHORT-ANSWER HELP-MESSAGE)
+where
+  LONG-ANSWER is a complete answer,
+  SHORT-ANSWER is an abbreviated one-character answer,
+  HELP-MESSAGE is a string describing the meaning of the answer.
+
+Example:
+  \\='((\"yes\"  ?y \"perform the action\")
+    (\"no\"   ?n \"skip to the next\")
+    (\"all\"  ?! \"accept all remaining without more questions\")
+    (\"help\" ?h \"show help\")
+    (\"quit\" ?q \"exit\"))
+
+When `read-answer-short' is non-nil, accept short answers.
+
+Return a long answer even in case of accepting short ones.
+
+When `use-dialog-box' is t, pop up a dialog window to get user input."
+  (custom-reevaluate-setting 'read-answer-short)
+  (let* ((short read-answer-short)
+         (answers-with-help
+          (if (assoc "help" answers)
+              answers
+            (append answers '(("help" ?? "show this help message")))))
+         (answers-without-help
+          (assoc-delete-all "help" (copy-alist answers-with-help)))
+         (prompt
+          (format "%s(%s) " question
+                  (mapconcat (lambda (a)
+                               (if short
+                                   (format "%c" (nth 1 a))
+                                 (nth 0 a)))
+                             answers-with-help ", ")))
+         (message
+          (format "Please answer %s."
+                  (mapconcat (lambda (a)
+                               (format "`%s'" (if short
+                                                  (string (nth 1 a))
+                                                (nth 0 a))))
+                             answers-with-help " or ")))
+         (short-answer-map
+          (when short
+            (or (gethash answers read-answer-map--memoize)
+                (puthash answers
+                         (let ((map (make-sparse-keymap)))
+                           (set-keymap-parent map minibuffer-local-map)
+                           (dolist (a answers-with-help)
+                             (define-key map (vector (nth 1 a))
+                               (lambda ()
+                                 (interactive)
+                                 (delete-minibuffer-contents)
+                                 (insert (nth 0 a))
+                                 (exit-minibuffer))))
+                           (define-key map [remap self-insert-command]
+                             (lambda ()
+                               (interactive)
+                               (delete-minibuffer-contents)
+                               (beep)
+                               (message message)
+                               (sleep-for 2)))
+                           map)
+                         read-answer-map--memoize))))
+         answer)
+    (while (not (assoc (setq answer (downcase
+                                     (cond
+                                      ((and (display-popup-menus-p)
+                                            last-input-event ; not during 
startup
+                                            (listp last-nonmenu-event)
+                                            use-dialog-box)
+                                       (x-popup-dialog
+                                        t
+                                        (cons question
+                                              (mapcar (lambda (a)
+                                                        (cons (capitalize (nth 
0 a))
+                                                              (nth 0 a)))
+                                                      answers-with-help))))
+                                      (short
+                                       (read-from-minibuffer
+                                        prompt nil short-answer-map nil
+                                        'yes-or-no-p-history))
+                                      (t
+                                       (read-from-minibuffer
+                                        prompt nil nil nil
+                                        'yes-or-no-p-history)))))
+                       answers-without-help))
+      (if (string= answer "help")
+          (with-help-window "*Help*"
+            (with-current-buffer "*Help*"
+              (insert "Type:\n"
+                      (mapconcat
+                       (lambda (a)
+                         (format "`%s'%s to %s"
+                                 (if short (string (nth 1 a)) (nth 0 a))
+                                 (if short (format " (%s)" (nth 0 a)) "")
+                                 (nth 2 a)))
+                       answers-with-help ",\n")
+                      ".\n")))
+        (beep)
+        (message message)
+        (sleep-for 2)))
+    answer))
+
 ;;; map-ynp.el ends here
diff --git a/lisp/subr.el b/lisp/subr.el
index 46cf5a3..092850a 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -705,6 +705,21 @@ Non-strings in LIST are ignored."
     (setq list (cdr list)))
   list)
 
+(defun assoc-delete-all (key alist)
+  "Delete from ALIST all elements whose car is `equal' to KEY.
+Return the modified alist.
+Elements of ALIST that are not conses are ignored."
+  (while (and (consp (car alist))
+             (equal (car (car alist)) key))
+    (setq alist (cdr alist)))
+  (let ((tail alist) tail-cdr)
+    (while (setq tail-cdr (cdr tail))
+      (if (and (consp (car tail-cdr))
+              (equal (car (car tail-cdr)) key))
+         (setcdr tail (cdr tail-cdr))
+       (setq tail tail-cdr))))
+  alist)
+
 (defun assq-delete-all (key alist)
   "Delete from ALIST all elements whose car is `eq' to KEY.
 Return the modified alist.
diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el
index 89cb7b6..ab6d1cb 100644
--- a/test/lisp/dired-aux-tests.el
+++ b/test/lisp/dired-aux-tests.el
@@ -59,7 +59,7 @@
        (unwind-protect
            (if ,yes-or-no
                (cl-letf (((symbol-function 'yes-or-no-p)
-                          (lambda (prompt) (eq ,yes-or-no 'yes))))
+                          (lambda (_prompt) (eq ,yes-or-no 'yes))))
                  ,@body)
              ,@body)
          ;; clean up
diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el
index c024213..bb0e1bc 100644
--- a/test/lisp/dired-tests.el
+++ b/test/lisp/dired-tests.el
@@ -384,9 +384,9 @@
   (dired-test-with-temp-dirs
    'just-empty-dirs
    (let (asked)
-     (advice-add 'dired--yes-no-all-quit-help
+     (advice-add 'read-answer
                  :override
-                 (lambda (_) (setq asked t) "")
+                 (lambda (_q _a) (setq asked t) "")
                  '((name . dired-test-bug27940-advice)))
      (dired default-directory)
      (dired-toggle-marks)
@@ -395,44 +395,44 @@
          (progn
            (should-not asked)
            (should-not (dired-get-marked-files))) ; All dirs deleted.
-       (advice-remove 'dired--yes-no-all-quit-help 
'dired-test-bug27940-advice))))
+       (advice-remove 'read-answer 'dired-test-bug27940-advice))))
   ;; Answer yes
   (dired-test-with-temp-dirs
    nil
-   (advice-add 'dired--yes-no-all-quit-help :override (lambda (_) "yes")
+   (advice-add 'read-answer :override (lambda (_q _a) "yes")
                '((name . dired-test-bug27940-advice)))
    (dired default-directory)
    (dired-toggle-marks)
    (dired-do-delete nil)
    (unwind-protect
        (should-not (dired-get-marked-files)) ; All dirs deleted.
-     (advice-remove 'dired--yes-no-all-quit-help 'dired-test-bug27940-advice)))
+     (advice-remove 'read-answer 'dired-test-bug27940-advice)))
   ;; Answer no
   (dired-test-with-temp-dirs
    nil
-   (advice-add 'dired--yes-no-all-quit-help :override (lambda (_) "no")
+   (advice-add 'read-answer :override (lambda (_q _a) "no")
                '((name . dired-test-bug27940-advice)))
    (dired default-directory)
    (dired-toggle-marks)
    (dired-do-delete nil)
    (unwind-protect
        (should (= 5 (length (dired-get-marked-files)))) ; Just the empty dirs 
deleted.
-     (advice-remove 'dired--yes-no-all-quit-help 'dired-test-bug27940-advice)))
+     (advice-remove 'read-answer 'dired-test-bug27940-advice)))
   ;; Answer all
   (dired-test-with-temp-dirs
    nil
-   (advice-add 'dired--yes-no-all-quit-help :override (lambda (_) "all")
+   (advice-add 'read-answer :override (lambda (_q _a) "all")
                '((name . dired-test-bug27940-advice)))
    (dired default-directory)
    (dired-toggle-marks)
    (dired-do-delete nil)
    (unwind-protect
        (should-not (dired-get-marked-files)) ; All dirs deleted.
-     (advice-remove 'dired--yes-no-all-quit-help 'dired-test-bug27940-advice)))
+     (advice-remove 'read-answer 'dired-test-bug27940-advice)))
   ;; Answer quit
   (dired-test-with-temp-dirs
    nil
-   (advice-add 'dired--yes-no-all-quit-help :override (lambda (_) "quit")
+   (advice-add 'read-answer :override (lambda (_q _a) "quit")
                '((name . dired-test-bug27940-advice)))
    (dired default-directory)
    (dired-toggle-marks)
@@ -440,7 +440,7 @@
      (dired-do-delete nil))
    (unwind-protect
        (should (= 6 (length (dired-get-marked-files)))) ; All empty dirs but 
zeta-empty-dir deleted.
-     (advice-remove 'dired--yes-no-all-quit-help 
'dired-test-bug27940-advice))))
+     (advice-remove 'read-answer 'dired-test-bug27940-advice))))
 
 
 (provide 'dired-tests)