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

[Thierry Volpiatto]

Michael Heerdegen <michael_heerdegen@web.de> writes:

> Thierry Volpiatto <thievol@posteo.net> writes:
>
>> > Maybe in the future we might need to pass other predicates as well.
>> > What when a user wants to add another register command?
>>
>> You can with the current register-preview.el add a new command and
>> control filtering of this command.
>
> Cool, thanks.  Looks reasonable.
>
> In my perfect world, the `register-commands-data' would not be specified
> as a list but also using methods.  Maybe also
> `register-preview-get-defaults'.
>
> I will have a closer look tomorrow, had been a little busy so that I
> just now returned to this thread.

Here all the work done so far.

diff --git a/lisp/register.el b/lisp/register.el
index ca6de450993..78643d10c17 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -35,6 +35,8 @@
 
 ;; 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 +93,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 +102,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 +139,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-1 (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-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 (null register-use-preview))
+      (register-preview-1 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)))))

-- 
Thierry

signature.asc
Description: PGP signature