Subject: Re: bug#66394: 29.1; Make register-read-with-preview more useful

From: Thierry Volpiatto <[email-masked]>
Date: Tue, 12 Dec 2023 10:16:52 +0000

Thierry Volpiatto <[email-masked]> writes:

> Thierry Volpiatto <[email-masked]> writes:
>
>> Dmitry Gutov <[email-masked]> writes:
>>
>>> On 11/12/2023 19:32, Thierry Volpiatto wrote:
>>>> I made a little error in one of the patch when merging from a working
>>>> file for emacs-29.1, attaching here the two patches again with error
>>>> corrected (read `register-use-preview` instead of
>>>> `register-preview-use-preview`), sorry for this.
>>>
>>> JFYI, the second patch doesn't apply cleanly, which may make testing
>>> them a bit more difficult.
>>>
>>> It's because of commit 598ab9ca10d35d6 by Eli with documentation
>>> updates. When reverted, the second patch applies without problem.
>>
>> Dmitry thanks, here the patches again after rebasing.
>
> I found another (merge) error in patch 0001 with defmethod names (read
> register-command-info instead of register-preview-command-info), here
> the patches corrected.  Without this changes, and with
> register-use-preview == nil, confirmation is needed for copy-to-register
> and friends, now fixed.

Here a third patch that allows more precise configuration if needed.
For example if you have register-use-preview == nil, no confirmation
with RET is needed everywhere, even when overwriting a register.  If you
want to have a confirmation when overwriting but no confirmation when
jumping/inserting you can use this in addition of register-use-preview
== nil:

    (cl-defmethod register-command-info :after ((_command (eql copy-to-register)))
      (make-register-preview-info
       :types '(all)
       :msg "Copy to register `%s'"
       :act 'set))

You can modify other commands as well to your needs (point-to-register
etc...) with same method.

Sending here the serie of 3 patches to avoid errors when applying
patches.

I have also some minor errors (english in docstring, unnneded quotes
etc...) that I will fix later when polishing final patches.

-- 
Thierry
From c83e6132f33c1ab7f6baf63f85aed32f32e8177c Mon Sep 17 00:00:00 2001
From: Thierry Volpiatto <[email-masked]>
Date: Mon, 11 Dec 2023 07:02:40 +0100
Subject: [PATCH 1/3] Don't confirm with RET even when overwriting in register
 commands

This happen when register-use-preview is nil or never.
This reproduce what we had previously in 29.1 but with filtering in
the preview and default registers are provided for the commands of
type 'set'.

This is implemented with cl-defmethod to keep the code as much as
possible configurable.

* lisp/register.el (register-preview-info): New slot.
(register-command-info): Add new methods for copy-to-register,
point-to-register, number-to-register,
window-configuration-to-register, frameset-to-register and
copy-rectangle-to-register.
(register-read-with-preview): Bind noconfirm.
---
 lisp/register.el | 67 ++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 56 insertions(+), 11 deletions(-)

diff --git a/lisp/register.el b/lisp/register.el
index fa4bbcf483f..cc4770579ee 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -156,7 +156,7 @@ TYPES are the types of register supported.
 MSG is the minibuffer message to send when a register is selected.
 ACT is the type of action the command is doing on register.
 SMATCH accept a boolean value to say if command accept non matching register."
-  types msg act smatch)
+  types msg act smatch noconfirm)
 
 (cl-defgeneric register-command-info (command)
   "Returns a `register-preview-info' object storing data for COMMAND."
@@ -179,24 +179,66 @@ SMATCH accept a boolean value to say if command accept non matching register."
    :types '(all)
    :msg "View register `%s'"
    :act 'view
+   :noconfirm (memq register-use-preview '(nil never))
    :smatch t))
 (cl-defmethod register-command-info ((_command (eql append-to-register)))
   (make-register-preview-info
    :types '(string number)
    :msg "Append to register `%s'"
    :act 'modify
+   :noconfirm (memq register-use-preview '(nil never))
    :smatch t))
 (cl-defmethod register-command-info ((_command (eql prepend-to-register)))
   (make-register-preview-info
    :types '(string number)
    :msg "Prepend to register `%s'"
    :act 'modify
+   :noconfirm (memq register-use-preview '(nil never))
    :smatch t))
 (cl-defmethod register-command-info ((_command (eql increment-register)))
   (make-register-preview-info
    :types '(string number)
    :msg "Increment register `%s'"
    :act 'modify
+   :noconfirm (memq register-use-preview '(nil never))
+   :smatch t))
+(cl-defmethod register-command-info ((_command (eql copy-to-register)))
+  (make-register-preview-info
+   :types '(all)
+   :msg "Copy to register `%s'"
+   :act 'set
+   :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info ((_command (eql point-to-register)))
+  (make-register-preview-info
+   :types '(all)
+   :msg "Point to register `%s'"
+   :act 'set
+   :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info ((_command (eql number-to-register)))
+  (make-register-preview-info
+   :types '(all)
+   :msg "Number to register `%s'"
+   :act 'set
+   :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info
+    ((_command (eql window-configuration-to-register)))
+  (make-register-preview-info
+   :types '(all)
+   :msg "Window configuration to register `%s'"
+   :act 'set
+   :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info ((_command (eql frameset-to-register)))
+  (make-register-preview-info
+   :types '(all)
+   :msg "Frameset to register `%s'"
+   :act 'set
+   :noconfirm (memq register-use-preview '(nil never))))
+(cl-defmethod register-command-info ((_command (eql copy-rectangle-to-register)))
+  (make-register-preview-info
+   :types '(all)
+   :msg "Copy rectangle to register `%s'"
+   :act 'set
+   :noconfirm (memq register-use-preview '(nil never))
    :smatch t))
 
 (defun register-preview-forward-line (arg)
@@ -328,12 +370,13 @@ display such a window regardless."
                 m))
          (data (register-command-info this-command))
          (enable-recursive-minibuffers t)
-         types msg result timer act win strs smatch)
+         types msg result timer act win strs smatch noconfirm)
     (if data
-        (setq types  (register-preview-info-types data)
-              msg    (register-preview-info-msg   data)
-              act    (register-preview-info-act   data)
-              smatch (register-preview-info-smatch data))
+        (setq types     (register-preview-info-types data)
+              msg       (register-preview-info-msg   data)
+              act       (register-preview-info-act   data)
+              smatch    (register-preview-info-smatch data)
+              noconfirm (register-preview-info-noconfirm data))
       (setq types '(all)
             msg   "Overwrite register `%s'"
             act   'set))
@@ -400,13 +443,15 @@ display such a window regardless."
                                          "Register `%s' is empty" pat))))))
                             (unless (string= pat "")
                               (with-selected-window (minibuffer-window)
-                                (if (and (member pat strs) (memq act '(set modify)))
+                                (if (and (member pat strs)
+                                         (memq act '(set modify))
+                                         (null noconfirm))
                                     (with-selected-window (minibuffer-window)
                                       (minibuffer-message msg pat))
-                                  ;; An empty register or an existing
-                                  ;; one but the action is insert or
-                                  ;; jump, don't ask for confirmation
-                                  ;; and exit immediately (bug#66394).
+                                  ;; The action is insert or
+                                  ;; jump or noconfirm is specifed
+                                  ;; explicitely, don't ask for
+                                  ;; confirmation and exit immediately (bug#66394).
                                   (setq result pat)
                                   (exit-minibuffer)))))))))
              (setq result (read-from-minibuffer
-- 
2.34.1

From 08cecb72eea866933941036718eb7af7f8d05ee9 Mon Sep 17 00:00:00 2001
From: Thierry Volpiatto <[email-masked]>
Date: Tue, 12 Dec 2023 07:24:32 +0100
Subject: [PATCH 2/3] Provide emacs-29 behavior for register-preview

It is now the default with a value of register-use-preview eq to
basic.
To change this one have now to customize register-use-preview to
another value.

* lisp/register.el (register-preview-delay): Remove obsolescence.
(register--read-with-preview-function): New.
(register-use-preview): New option basic, it is now the default.
(register-preview-default-1): New the register-preview-default used by
`register-read-with-preview-fancy`.
(register-preview-default): Restored (same as Emacs-29).
(register--preview-function): Generic fn that return the right
function for register--preview-function.
(register-preview): Restored (same behavior as Emacs-29).
(register-preview-1): Used by `register-read-with-preview-fancy'.
(register-read-with-preview-basic): The old
register-read-with-preview.
(register-read-with-preview-fancy): The new
register-read-with-preview.
---
 lisp/register.el | 146 +++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 127 insertions(+), 19 deletions(-)

diff --git a/lisp/register.el b/lisp/register.el
index cc4770579ee..8dbddf1bc9a 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -100,25 +100,49 @@ If nil, do not show register previews, unless `help-char' (or a member of
   :version "24.4"
   :type '(choice number (const :tag "No preview unless requested" nil))
   :group 'register)
-(make-obsolete-variable 'register-preview-delay "No longer used." "30.1")
 
 (defcustom register-preview-default-keys (mapcar #'string (number-sequence ?a ?z))
   "Default keys for setting a new register."
-  :type '(repeat string))
-
-(defcustom register-use-preview t
-  "Whether to show preview of registers.
-
-If the value is t, show a preview buffer with navigation and highlighting.
-If the value is nil, show a basic preview buffer and exit minibuffer
-immediately after the register name is inserted into minibuffer.
-If the value is \\='never, behave as for nil, but with no preview buffer
-at all."
+  :type '(repeat string)
+  :version 30.1)
+
+(defvar register--read-with-preview-function nil
+  "The register read preview function to use.
+Two functions are provided, one that provide navigation and
+highlighting of the register selected, filtering of register
+according to command in use, defaults register to use when
+setting a new register, confirmation and notification when you
+are about to overwrite a register and generic functions to
+configure how each existing commands behave.  The other function
+provided is the same as what was used in Emacs-29, no filtering,
+no navigation, no defaults.")
+
+(defcustom register-use-preview 'basic
+  "Maybe show register preview.
+
+This have no effect when `register--read-with-preview-function' value
+is `register-read-with-preview-basic'.
+
+When set to `t' show a preview buffer with navigation and highlighting.
+When nil show a basic preview buffer and exit minibuffer
+immediately after insertion in minibuffer.
+When set to \\='never behave as above but with no preview buffer at
+all.
+When set to \\='basic provide a much more basic preview according to
+`register-preview-delay', it have the exact same behavior as in Emacs-29."
   :type '(choice
           (const :tag "Use preview" t)
           (const :tag "Use quick preview" nil)
-          (const :tag "Never use preview" never))
-  :version "30.1")
+          (const :tag "Never use preview" never)
+          (const :tag "Basic preview like Emacs-29" basic))
+  :version 30.1
+  :set (lambda (var val)
+         (set var val)
+         (setq register--read-with-preview-function
+               (if (eq val 'basic)
+                   #'register-read-with-preview-basic
+                 #'register-read-with-preview-fancy))
+         (setq register-preview-function nil)))
 
 (defun get-register (register)
   "Return contents of Emacs register named REGISTER, or nil if none."
@@ -138,17 +162,34 @@ See the documentation of the variable `register-alist' for possible VALUEs."
         (substring d (match-end 0))
       d)))
 
-(defun register-preview-default (r)
+(defun register-preview-default-1 (r)
   "Function that is the default value of the variable `register-preview-function'."
   (format "%s: %s\n"
 	  (propertize (string (car r))
                       'display (single-key-description (car r)))
 	  (register-describe-oneline (car r))))
 
-(defvar register-preview-function #'register-preview-default
+(defun register-preview-default (r)
+  "Function that is the default value of the variable `register-preview-function'."
+  (format "%s: %s\n"
+	  (single-key-description (car r))
+	  (register-describe-oneline (car r))))
+
+(defvar register-preview-function nil
   "Function to format a register for previewing.
 Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'.
-The function should return a string, the description of the argument.")
+The function should return a string, the description of the argument.
+It is set according to the value of `register--read-with-preview-function'.")
+
+(cl-defgeneric register--preview-function (read-preview-function)
+  "Returns a function to format a register for previewing.
+This accorfing to the value of read-preview-function.")
+(cl-defmethod register--preview-function ((read-preview-function
+                                           (eql 'register-read-with-preview-basic)))
+  #'register-preview-default)
+(cl-defmethod register--preview-function ((read-preview-function
+                                           (eql 'register-read-with-preview-fancy)))
+  #'register-preview-default-1)
 
 (cl-defstruct register-preview-info
   "Store data for a specific register command.
@@ -327,12 +368,39 @@ satisfy `cl-typep' otherwise the new type should be defined with
              when (memq (register-type register) types)
              collect register)))
 
-(defun register-preview (buffer &optional show-empty types)
+(defun register-preview (buffer &optional show-empty)
+  "Pop up a window showing the registers preview in BUFFER.
+If SHOW-EMPTY is non-nil, show the window even if no registers.
+Format of each entry is controlled by the variable `register-preview-function'."
+  (unless register-preview-function
+    (setq register-preview-function (register--preview-function
+                                     register--read-with-preview-function)))
+  (when (or show-empty (consp register-alist))
+    (with-current-buffer-window
+     buffer
+     (cons 'display-buffer-below-selected
+	   '((window-height . fit-window-to-buffer)
+	     (preserve-size . (nil . t))))
+     nil
+     (with-current-buffer standard-output
+       (setq cursor-in-non-selected-windows nil)
+       (mapc (lambda (elem)
+               (when (get-register (car elem))
+                 (insert (funcall register-preview-function elem))))
+             register-alist)))))
+
+(defun register-preview-1 (buffer &optional show-empty types)
   "Pop up a window showing the registers preview in BUFFER.
+
+This is the preview function use with
+`register-read-with-preview-fancy' function.
 If SHOW-EMPTY is non-nil, show the window even if no registers.
 Argument TYPES (a list) specify the types of register to show, when nil show all
 registers, see `register-type' for suitable types.
 Format of each entry is controlled by the variable `register-preview-function'."
+  (unless register-preview-function
+    (setq register-preview-function (register--preview-function
+                                     register--read-with-preview-function)))
   (let ((registers (register-of-type-alist (or types '(all)))))
     (when (or show-empty (consp registers))
       (with-current-buffer-window
@@ -360,6 +428,46 @@ Format of each entry is controlled by the variable `register-preview-function'."
   "Read and return a register name, possibly showing existing registers.
 Prompt with the string PROMPT.
 If `help-char' (or a member of `help-event-list') is pressed,
+display such a window regardless."
+  (funcall register--read-with-preview-function prompt))
+
+(defun register-read-with-preview-basic (prompt)
+  "Read and return a register name, possibly showing existing registers.
+Prompt with the string PROMPT.  If `register-alist' and
+`register-preview-delay' are both non-nil, display a window
+listing existing registers after `register-preview-delay' seconds.
+If `help-char' (or a member of `help-event-list') is pressed,
+display such a window regardless."
+  (let* ((buffer "*Register Preview*")
+	 (timer (when (numberp register-preview-delay)
+		  (run-with-timer register-preview-delay nil
+				  (lambda ()
+				    (unless (get-buffer-window buffer)
+				      (register-preview buffer))))))
+	 (help-chars (cl-loop for c in (cons help-char help-event-list)
+			      when (not (get-register c))
+			      collect c)))
+    (unwind-protect
+	(progn
+	  (while (memq (read-key (propertize prompt 'face 'minibuffer-prompt))
+		       help-chars)
+	    (unless (get-buffer-window buffer)
+	      (register-preview buffer 'show-empty)))
+          (when (or (eq ?\C-g last-input-event)
+                    (eq 'escape last-input-event)
+                    (eq ?\C-\[ last-input-event))
+            (keyboard-quit))
+	  (if (characterp last-input-event) last-input-event
+	    (error "Non-character input-event")))
+      (and (timerp timer) (cancel-timer timer))
+      (let ((w (get-buffer-window buffer)))
+        (and (window-live-p w) (delete-window w)))
+      (and (get-buffer buffer) (kill-buffer buffer)))))
+
+(defun register-read-with-preview-fancy (prompt)
+  "Read and return a register name, possibly showing existing registers.
+Prompt with the string PROMPT.
+If `help-char' (or a member of `help-event-list') is pressed,
 display such a window regardless."
   (let* ((buffer "*Register Preview*")
          (buffer1 "*Register quick preview*")
@@ -392,13 +500,13 @@ display such a window regardless."
                        ;; Do nothing when buffer1 is in use.
                        (unless (get-buffer-window buf)
                          (with-selected-window (minibuffer-selected-window)
-                           (register-preview buffer 'show-empty types))))))
+                           (register-preview-1 buffer 'show-empty types))))))
     (define-key map (kbd "<down>") 'register-preview-next)
     (define-key map (kbd "<up>")   'register-preview-previous)
     (define-key map (kbd "C-n")    'register-preview-next)
     (define-key map (kbd "C-p")    'register-preview-previous)
     (unless (or executing-kbd-macro (eq register-use-preview 'never))
-      (register-preview buf nil types))
+      (register-preview-1 buf nil types))
     (unwind-protect
          (progn
            (minibuffer-with-setup-hook
-- 
2.34.1

From 15839ea11879fb651314c2d45ea4558c5735dcb6 Mon Sep 17 00:00:00 2001
From: Thierry Volpiatto <[email-masked]>
Date: Tue, 12 Dec 2023 10:48:00 +0100
Subject: [PATCH 3/3] Allow users overriding register-use-preview behavior

This allows a more precise configuration if needed.
For example if one have register-use-preview == nil and want a
confirmation when overwriting a register he can use:

(cl-defmethod register-command-info :after ((_command (eql copy-to-register)))
  (make-register-preview-info
   :types '(all)
   :msg "Copy to register `%s'"
   :act 'set))

which disable the no confirmation when overwriting with such setting
of register-use-preview.

This is done by calling cl-call-next-method.

* lisp/register.el (register-command-info): Call next method where
  needed.
---
 lisp/register.el | 27 ++++++++++++++++++---------
 1 file changed, 18 insertions(+), 9 deletions(-)

diff --git a/lisp/register.el b/lisp/register.el
index 8dbddf1bc9a..2bb476cb34c 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -228,59 +228,68 @@ SMATCH accept a boolean value to say if command accept non matching register."
    :msg "Append to register `%s'"
    :act 'modify
    :noconfirm (memq register-use-preview '(nil never))
-   :smatch t))
+   :smatch t)
+  (cl-call-next-method))
 (cl-defmethod register-command-info ((_command (eql prepend-to-register)))
   (make-register-preview-info
    :types '(string number)
    :msg "Prepend to register `%s'"
    :act 'modify
    :noconfirm (memq register-use-preview '(nil never))
-   :smatch t))
+   :smatch t)
+  (cl-call-next-method))
 (cl-defmethod register-command-info ((_command (eql increment-register)))
   (make-register-preview-info
    :types '(string number)
    :msg "Increment register `%s'"
    :act 'modify
    :noconfirm (memq register-use-preview '(nil never))
-   :smatch t))
+   :smatch t)
+  (cl-call-next-method))
 (cl-defmethod register-command-info ((_command (eql copy-to-register)))
   (make-register-preview-info
    :types '(all)
    :msg "Copy to register `%s'"
    :act 'set
-   :noconfirm (memq register-use-preview '(nil never))))
+   :noconfirm (memq register-use-preview '(nil never)))
+  (cl-call-next-method))
 (cl-defmethod register-command-info ((_command (eql point-to-register)))
   (make-register-preview-info
    :types '(all)
    :msg "Point to register `%s'"
    :act 'set
-   :noconfirm (memq register-use-preview '(nil never))))
+   :noconfirm (memq register-use-preview '(nil never)))
+  (cl-call-next-method))
 (cl-defmethod register-command-info ((_command (eql number-to-register)))
   (make-register-preview-info
    :types '(all)
    :msg "Number to register `%s'"
    :act 'set
-   :noconfirm (memq register-use-preview '(nil never))))
+   :noconfirm (memq register-use-preview '(nil never)))
+  (cl-call-next-method))
 (cl-defmethod register-command-info
     ((_command (eql window-configuration-to-register)))
   (make-register-preview-info
    :types '(all)
    :msg "Window configuration to register `%s'"
    :act 'set
-   :noconfirm (memq register-use-preview '(nil never))))
+   :noconfirm (memq register-use-preview '(nil never)))
+  (cl-call-next-method))
 (cl-defmethod register-command-info ((_command (eql frameset-to-register)))
   (make-register-preview-info
    :types '(all)
    :msg "Frameset to register `%s'"
    :act 'set
-   :noconfirm (memq register-use-preview '(nil never))))
+   :noconfirm (memq register-use-preview '(nil never)))
+  (cl-call-next-method))
 (cl-defmethod register-command-info ((_command (eql copy-rectangle-to-register)))
   (make-register-preview-info
    :types '(all)
    :msg "Copy rectangle to register `%s'"
    :act 'set
    :noconfirm (memq register-use-preview '(nil never))
-   :smatch t))
+   :smatch t)
+  (cl-call-next-method))
 
 (defun register-preview-forward-line (arg)
   "Move to next or previous line in register preview buffer.
-- 
2.34.1