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

From: Thierry Volpiatto <[email-masked]>
Date: Mon, 20 Nov 2023 06:00:26 +0000

Here the full patch attached, the previous was not applying properly.

Ccing also Stefan monnier because for some reasons the patch when
applied doesn't compile (when compiling Emacs) unless we add on
top:

    (cl--generic-prefill-dispatchers 0 (eql 'x) integer)

following the advice of the compiler, but I am not sure it is the way to
do.

Compiling register.el manually without this works correctly.

From c794d62a45b4c83131e506699f465e54b7dae7b5 Mon Sep 17 00:00:00 2001
From: Thierry Volpiatto <[email-masked]>
Date: Sun, 19 Nov 2023 20:42:56 +0100
Subject: [PATCH] Improve register-preview (Fix bug#66394)

A minibuffer is used now instead of read-key.
Registers in preview buffer are now filtered according to type of
registers the current command requires.
Navigation with C-n/p or up/down is now provided and update
minibuffer.
Current register is highlighted in preview buffer.

* register.el:

* (register-preview-default-keys): new user var.
* (register-use-preview): Same.
* (register-preview-info): New structure to store various info for
  preview.
* (register-command-info): New generic.
* (register-preview-forward-line): New, provide navigation in preview
  buffer.
* (register-preview-next, register-preview-previous): New, navigation.
* (register-type): New, returns register type.
* (register--type): Generic fn, new, returns register type according
  to value.
* (register-of-type-alist): New, filter register-alist according to
  type.
* (register-preview): Signature changed, use TYPES now.
* (register-preview-get-defaults): New generic, compute defauts
  according to action.
* (register-read-with-preview): Now use read-from-minibuffer and
  minibuffer-setup-hook.
---
 lisp/register.el | 296 +++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 259 insertions(+), 37 deletions(-)

diff --git a/lisp/register.el b/lisp/register.el
index ca6de450993..47f0dfa389c 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -30,11 +30,14 @@
 ;; documented in the Emacs user's manual: (info "(emacs) Registers").
 
 (eval-when-compile (require 'cl-lib))
+(cl--generic-prefill-dispatchers 0 (eql 'x) integer)
 
 ;;; Code:
 
 ;; FIXME: Clean up namespace usage!
 
+(declare-function frameset-register-p "frameset")
+
 (cl-defstruct
   (registerv (:constructor nil)
 	     (:constructor registerv--make (&optional data print-func
@@ -91,6 +94,7 @@ of the marked text."
   :type '(choice (const :tag "None" nil)
 		 (character :tag "Use register" :value ?+)))
 
+;; FIXME: This is no more needed, remove it.
 (defcustom register-preview-delay 1
   "If non-nil, time to wait in seconds before popping up register preview window.
 If nil, do not show register previews, unless `help-char' (or a member of
@@ -99,6 +103,14 @@ If nil, do not show register previews, unless `help-char' (or a member of
   :type '(choice number (const :tag "No preview unless requested" nil))
   :group 'register)
 
+(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
+  "Always show register preview when non nil."
+  :type 'boolean)
+
 (defun get-register (register)
   "Return contents of Emacs register named REGISTER, or nil if none."
   (alist-get register register-alist))
@@ -128,53 +140,263 @@ See the documentation of the variable `register-alist' for possible VALUEs."
 Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'.
 The function should return a string, the description of the argument.")
 
-(defun register-preview (buffer &optional show-empty)
+(cl-defstruct register-preview-info
+  "Store data for a specific register command.
+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)
+
+(cl-defgeneric register-command-info (command)
+  "Returns a `register-preview-info' object storing data for COMMAND."
+  (ignore command))
+(cl-defmethod register-command-info ((_command (eql insert-register)))
+  (make-register-preview-info
+   :types '(string number)
+   :msg "Insert register `%s'"
+   :act 'insert
+   :smatch t))
+(cl-defmethod register-command-info ((_command (eql jump-to-register)))
+  (make-register-preview-info
+   :types  '(window frame marker kmacro
+             file buffer file-query)
+   :msg "Jump to register `%s'"
+   :act 'jump
+   :smatch t))
+(cl-defmethod register-command-info ((_command (eql view-register)))
+  (make-register-preview-info
+   :types '(all)
+   :msg "View register `%s'"
+   :act 'view
+   :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
+   :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
+   :smatch t))
+(cl-defmethod register-command-info ((_command (eql increment-register)))
+  (make-register-preview-info
+   :types '(string number)
+   :msg "Increment register `%s'"
+   :act 'modify
+   :smatch t))
+
+(defun register-preview-forward-line (arg)
+  "Move to next or previous line in register preview buffer.
+If ARG is positive goto next line, if negative to previous.
+Do nothing when defining or executing kmacros."
+  ;; Ensure user enter manually key in minibuffer when recording a macro.
+  (unless (or defining-kbd-macro executing-kbd-macro
+              (not (get-buffer-window "*Register Preview*" 'visible)))
+    (let ((fn (if (> arg 0) #'eobp #'bobp))
+          (posfn (if (> arg 0)
+                     #'point-min
+                     (lambda () (1- (point-max)))))
+          str)
+      (with-current-buffer "*Register Preview*"
+        (let ((ovs (overlays-in (point-min) (point-max)))
+              pos)
+          (goto-char (if ovs
+                         (overlay-start (car ovs))
+                         (point-min)))
+          (setq pos (point))
+          (and ovs (forward-line arg))
+          (when (and (funcall fn)
+                     (or (> arg 0) (eql pos (point))))
+            (goto-char (funcall posfn)))
+          (setq str (buffer-substring-no-properties
+                     (pos-bol) (1+ (pos-bol))))
+          (remove-overlays)
+          (with-selected-window (minibuffer-window)
+            (delete-minibuffer-contents)
+            (insert str)))))))
+
+(defun register-preview-next ()
+  "Goto next line in register preview buffer."
+  (interactive)
+  (register-preview-forward-line 1))
+
+(defun register-preview-previous ()
+  "Goto previous line in register preview buffer."
+  (interactive)
+  (register-preview-forward-line -1))
+
+(defun register-type (register)
+  "Return REGISTER type.
+Current register types actually returned are one of:
+- string
+- number
+- marker
+- buffer
+- file
+- file-query
+- window
+- frame
+- kmacro
+
+One can add new types to a specific command by defining a new `cl-defmethod'
+matching this command. Predicate for type in new `cl-defmethod' should
+satisfy `cl-typep' otherwise the new type should be defined with
+`cl-deftype'."
+  ;; Call register--type against the register value.
+  (register--type (if (consp (cdr register))
+                     (cadr register)
+                   (cdr register))))
+
+(cl-defgeneric register--type (regval)
+  "Returns type of register value REGVAL."
+  (ignore regval))
+
+(cl-defmethod register--type ((_regval string)) 'string)
+(cl-defmethod register--type ((_regval number)) 'number)
+(cl-defmethod register--type ((_regval marker)) 'marker)
+(cl-defmethod register--type ((_regval (eql 'buffer))) 'buffer)
+(cl-defmethod register--type ((_regval (eql 'file))) 'file)
+(cl-defmethod register--type ((_regval (eql 'file-query))) 'file-query)
+(cl-defmethod register--type ((_regval window-configuration)) 'window)
+(cl-deftype frame-register () '(satisfies frameset-register-p))
+(cl-defmethod register--type :extra "frame-register" (_regval) 'frame)
+(cl-deftype kmacro-register () '(satisfies kmacro-register-p))
+(cl-defmethod register--type :extra "kmacro-register" (_regval) 'kmacro)
+
+(defun register-of-type-alist (types)
+  "Filter `register-alist' according to TYPES."
+  (if (memq 'all types)
+      register-alist
+    (cl-loop for register in register-alist
+             when (memq (register-type register) types)
+             collect register)))
+
+(defun register-preview (buffer &optional show-empty types)
   "Pop up a window showing the registers preview in BUFFER.
 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'."
-  (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)))))
+  (let ((registers (register-of-type-alist (or types '(all)))))
+    (when (or show-empty (consp registers))
+      (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))))
+                registers))))))
+
+(cl-defgeneric register-preview-get-defaults (action)
+  "Returns default registers according to ACTION."
+  (ignore action))
+(cl-defmethod register-preview-get-defaults ((_action (eql set)))
+  (cl-loop for s in register-preview-default-keys
+           unless (assoc (string-to-char s) register-alist)
+           collect s))
 
 (defun register-read-with-preview (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.
+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*")
-	 (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)))
+         (pat "")
+         (map (let ((m (make-sparse-keymap)))
+                (set-keymap-parent m minibuffer-local-map)
+                m))
+         (data (register-command-info this-command))
+         types msg result timer act win strs smatch)
+    (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 '(all)
+            msg   "Overwrite register `%s'"
+            act   'set))
+    (setq strs (mapcar (lambda (x)
+                         (string (car x)))
+                       (register-of-type-alist types)))
+    (when (and (memq act '(insert jump view)) (null strs))
+      (error "No register suitable for `%s'" act))
+    (dolist (k (cons help-char help-event-list))
+      (define-key map
+          (vector k) (lambda ()
+                       (interactive)
+                       (unless (get-buffer-window buffer)
+                         (with-selected-window (minibuffer-selected-window)
+                           (register-preview 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 (null register-use-preview))
+      (register-preview buffer nil types))
     (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))
+         (progn
+           (minibuffer-with-setup-hook
+               (lambda ()
+                 (setq timer
+                       (run-with-idle-timer
+                        0.01 'repeat
+                        (lambda ()
+                          (with-selected-window (minibuffer-window)
+                            (let ((input (minibuffer-contents)))
+                              (when (> (length input) 1)
+                                (let ((new (substring input 1))
+                                      (old (substring input 0 1)))
+                                  (setq input (if (or (null smatch)
+                                                      (member new strs))
+                                                  new old))
+                                  (delete-minibuffer-contents)
+                                  (insert input)))
+                              (when (and smatch (not (string= input ""))
+                                         (not (member input strs)))
+                                (setq input "")
+                                (delete-minibuffer-contents)
+                                (minibuffer-message "Not matching"))
+                              (when (not (string= input pat))
+                                (setq pat input))))
+                          (if (setq win (get-buffer-window buffer))
+                              (with-selected-window win
+                                (let ((ov (make-overlay (point-min) (point-min))))
+                                  (goto-char (point-min))
+                                  (remove-overlays)
+                                  (unless (string= pat "")
+                                    (if (re-search-forward (concat "^" pat) nil t)
+                                        (progn (move-overlay
+                                                ov
+                                                (match-beginning 0) (pos-eol))
+                                               (overlay-put ov 'face 'match)
+                                               (when msg
+                                                 (with-selected-window (minibuffer-window)
+                                                   (minibuffer-message msg pat))))
+                                      (with-selected-window (minibuffer-window)
+                                        (minibuffer-message
+                                         "Register `%s' is empty" pat))))))
+                            (unless (string= pat "")
+                              (if (member pat strs)
+                                  (with-selected-window (minibuffer-window)
+                                    (minibuffer-message msg pat))
+                                (with-selected-window (minibuffer-window)
+                                  (minibuffer-message
+                                   "Register `%s' is empty" pat)))))))))
+             (setq result (read-from-minibuffer
+                           prompt nil map nil nil (register-preview-get-defaults act))))
+           (cl-assert (and result (not (string= result "")))
+                      nil "No register specified")
+           (string-to-char result))
+      (when 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)))))
-- 
2.34.1

-- 
Thierry