From e760e580191dd82890f8653f5538a2a7378ff26d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 29 Apr 2025 22:50:30 -0400 Subject: [PATCH 01/14] lisp/register.el: Minor cosmetics Remove redundant `:group` arguments. Prefer #' to quote function names. Fix some markup on symbol names in docstrings. --- lisp/register.el | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index cdb769991f4..c5a150c8f25 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -90,7 +90,6 @@ A list of the form (FRAME-CONFIGURATION POSITION) When collecting text with \\[append-to-register] (or \\[prepend-to-register]), contents of this register is added to the beginning (or end, respectively) of the marked text." - :group 'register :type '(choice (const :tag "None" nil) (character :tag "Use register" :value ?+))) @@ -100,10 +99,9 @@ If nil, do not show register previews, unless `help-char' (or a member of `help-event-list') is pressed. This variable has no effect when `register-use-preview' is set to any -value except \\='traditional." +value except `traditional'." :version "24.4" - :type '(choice number (const :tag "No preview unless requested" nil)) - :group 'register) + :type '(choice number (const :tag "No preview unless requested" nil))) (defcustom register-preview-default-keys (mapcar #'string (number-sequence ?a ?z)) "Default keys for setting a new register." @@ -193,7 +191,7 @@ when `register-use-preview' is set to t or nil." (defun register-preview-default (r) "Function used to format a register for traditional preview. This is the default value of the variable `register-preview-function', -and is used when `register-use-preview' is set to \\='traditional." +and is used when `register-use-preview' is set to `traditional'." (format "%s: %s\n" (single-key-description (car r)) (register-describe-oneline (car r)))) @@ -474,7 +472,7 @@ If `help-char' (or a member of `help-event-list') is pressed, display preview window unconditionally. This function is used as the value of `register--read-with-preview-function' -when `register-use-preview' is set to \\='traditional." +when `register-use-preview' is set to `traditional'." (let* ((buffer "*Register Preview*") (timer (when (numberp register-preview-delay) (run-with-timer register-preview-delay nil @@ -509,8 +507,8 @@ If `help-char' (or a member of `help-event-list') is pressed, display preview window regardless. This function is used as the value of `register--read-with-preview-function' -when `register-use-preview' is set to any value other than \\='traditional -or \\='never." +when `register-use-preview' is set to any value other than `traditional' +or `never'." (let* ((buffer "*Register Preview*") (buffer1 "*Register quick preview*") (buf (if register-use-preview buffer buffer1)) @@ -543,14 +541,14 @@ or \\='never." (unless (get-buffer-window buf) (with-selected-window (minibuffer-selected-window) (register-preview-1 buffer 'show-empty types)))))) - (define-key map (kbd "") 'register-preview-next) - (define-key map (kbd "") 'register-preview-previous) - (define-key map (kbd "C-n") 'register-preview-next) - (define-key map (kbd "C-p") 'register-preview-previous) + (define-key map (kbd "") #'register-preview-next) + (define-key map (kbd "") #'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-1 buf nil types)) (unwind-protect - (let ((setup + (let ((setup ;; FIXME: Weird name for a `post-command-hook' function. (lambda () (with-selected-window (minibuffer-window) (let ((input (minibuffer-contents))) @@ -639,7 +637,7 @@ Interactively, prompt for REGISTER using `register-read-with-preview'." "Point to register: ")) current-prefix-arg)) ;; Turn the marker into a file-ref if the buffer is killed. - (add-hook 'kill-buffer-hook 'register-swap-out nil t) + (add-hook 'kill-buffer-hook #'register-swap-out nil t) (set-register register ;; FIXME: How does this `current-frame-configuration' differ ;; in practice with what `frameset-to-register' does? @@ -683,7 +681,7 @@ Interactively, prompt for REGISTER using `register-read-with-preview'." (make-obsolete 'frame-configuration-to-register 'frameset-to-register "24.4") -(defalias 'register-to-point 'jump-to-register) +(defalias 'register-to-point #'jump-to-register) (defun jump-to-register (register &optional delete) "Go to location stored in REGISTER, or restore configuration stored there. Push the mark if going to the location moves point, unless called in succession. From 30b9694f2af20ccb25b4994a71b805f597448630 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 30 Apr 2025 07:41:03 -0400 Subject: [PATCH 02/14] register.el: Fix some inconsistencies in the code * lisp/frameset.el (register-val-jump-to): Fix `:cleanup-frames`. The code did not obey its documented behavior and matched against the wrong symbols. * lisp/register.el (register-command-info) , : Remove `number` from the `:types` argument since those operations fail on numbers. --- lisp/frameset.el | 6 +++--- lisp/register.el | 10 +++++++--- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/lisp/frameset.el b/lisp/frameset.el index 9de16750c44..cbdbc1ac239 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -1412,15 +1412,15 @@ All keyword parameters default to nil." :reuse-frames (if arg t 'match) :cleanup-frames (if arg ;; delete frames - nil + t ;; iconify frames (lambda (frame action) (pcase action - ('rejected (iconify-frame frame)) + (:rejected (iconify-frame frame)) ;; In the unexpected case that a frame was a candidate ;; (matching frame id) and yet not restored, remove it ;; because it is in fact a duplicate. - ('ignored (delete-frame frame)))))) + (:ignored (delete-frame frame)))))) ;; Restore selected frame, buffer and point. (let ((frame (frameset-frame-with-id (frameset-register-frame-id data))) diff --git a/lisp/register.el b/lisp/register.el index c5a150c8f25..8fa141a4ec6 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -220,6 +220,8 @@ If NOCONFIRM is non-nil, request confirmation of register name by RET." (ignore command)) (cl-defmethod register-command-info ((_command (eql insert-register))) (make-register-preview-info + ;; FIXME: This should not be hardcoded but computed based on whether + ;; a given register type implements `register-val-insert'. :types '(string number) :msg "Insert register `%s'" :act 'insert @@ -227,6 +229,8 @@ If NOCONFIRM is non-nil, request confirmation of register name by RET." :noconfirm (memq register-use-preview '(nil never)))) (cl-defmethod register-command-info ((_command (eql jump-to-register))) (make-register-preview-info + ;; FIXME: This should not be hardcoded but computed based on whether + ;; a given register type implements `register-val-jump-to'. :types '(window frame marker kmacro file buffer file-query) :msg "Jump to register `%s'" @@ -242,21 +246,21 @@ If NOCONFIRM is non-nil, request confirmation of register name by RET." :smatch t)) (cl-defmethod register-command-info ((_command (eql append-to-register))) (make-register-preview-info - :types '(string number) + :types '(string) ;; FIXME: Fails on rectangles! :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) + :types '(string) ;;FIXME: Fails on rectangles! :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) + :types '(string number) ;;FIXME: Fails on rectangles! :msg "Increment register `%s'" :act 'modify :noconfirm (memq register-use-preview '(nil never)) From 44069711e87c3a56f36a917ee46d673f77e0c733 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 30 Apr 2025 12:22:25 -0400 Subject: [PATCH 03/14] (register-read-with-preview-fancy): Fix handling of control chars The code assumed that the string returned by `register-preview-function` has the register name as the first char. This was an incompatible change which broke packages that set this var, such as `calculator.el` and others. Remove this assumption by recording the register names in the preview buffer on a new `register--name` text property. While at it, fix a few other problems where control chars were not pretty printed. * lisp/register.el (register-preview-1): Remember the raw register name in the `register--name` text property. (register-preview-forward-line): Use the `register--name` text property. (register--find-preview): New function. (register-read-with-preview-fancy): Use it. If the last command inserted more than one char, only keep the first of the new chars. Make sure control chars are pretty printed in the minibuffer. including minibuffer messages. --- lisp/register.el | 55 ++++++++++++++++++++++++++++++------------------ 1 file changed, 35 insertions(+), 20 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index 8fa141a4ec6..8a71fd70a79 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -326,8 +326,7 @@ Do nothing when defining or executing kmacros." (let ((fn (if (> arg 0) #'eobp #'bobp)) (posfn (if (> arg 0) #'point-min - (lambda () (1- (point-max))))) - str) + (lambda () (1- (point-max)))))) (with-current-buffer "*Register Preview*" (let ((ovs (overlays-in (point-min) (point-max))) pos) @@ -339,12 +338,11 @@ Do nothing when defining or executing kmacros." (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))))))) + (let ((reg (get-text-property (pos-bol) 'register--name))) + (remove-overlays) + (with-selected-window (minibuffer-window) + (delete-minibuffer-contents) + (insert (string reg))))))))) (defun register-preview-next () "Go to next line in the register preview buffer." @@ -444,10 +442,19 @@ Format of each entry is controlled by the variable `register-preview-function'." 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)))))) + (dolist (elem registers) + (when (cdr elem) + (let ((beg (point))) + (insert (funcall register-preview-function elem)) + (put-text-property beg (point) + 'register--name (car elem)))))))))) + +(defun register--find-preview (regname) + (goto-char (point-min)) + (while (not (or (eobp) + (eql regname (get-text-property (point) 'register--name)))) + (forward-line 1)) + (not (eobp))) (cl-defgeneric register-preview-get-defaults (action) "Return default registers according to ACTION." @@ -557,7 +564,8 @@ or `never'." (with-selected-window (minibuffer-window) (let ((input (minibuffer-contents))) (when (> (length input) 1) - (let ((new (substring input 1)) + ;; Only keep the first of the new chars. + (let ((new (substring input 1 2)) (old (substring input 0 1))) (setq input (if (or (null smatch) (member new strs)) @@ -576,6 +584,12 @@ or `never'." (minibuffer-message "Not matching")) (when (not (string= input pat)) (setq pat input)))) + (unless (or (string= pat "") + (get-text-property (minibuffer-prompt-end) + 'display)) + (put-text-property (minibuffer-prompt-end) + (1+ (minibuffer-prompt-end)) + 'display (key-description pat))) (if (setq win (get-buffer-window buffer)) (with-selected-window win (when (or (eq noconfirm t) ; Using insist @@ -594,24 +608,25 @@ or `never'." (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)) + (if (register--find-preview (aref pat 0)) + (progn (move-overlay ov (point) (pos-eol)) (overlay-put ov 'face 'match) (when msg (with-selected-window (minibuffer-window) - (minibuffer-message msg pat)))) + (minibuffer-message + msg (key-description pat))))) (with-selected-window (minibuffer-window) (minibuffer-message - "Register `%s' is empty" pat)))))) + "Register `%s' is empty" + (key-description pat))))))) (unless (string= pat "") (with-selected-window (minibuffer-window) (if (and (member pat strs) (null noconfirm)) (with-selected-window (minibuffer-window) - (minibuffer-message msg pat)) + (minibuffer-message + msg (key-description pat))) ;; `:noconfirm' is specified explicitly, don't ask for ;; confirmation and exit immediately (bug#66394). (setq result pat) From fcaec1ff0d6be18d4fa3682401ced30741be6243 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 29 Apr 2025 22:48:33 -0400 Subject: [PATCH 04/14] (register-preview-function): Use a single default again * lisp/register.el (register-preview-function): Revert to Emacs<30 value. (register-use-preview, register-preview, register-preview-1): Don't touch it. (register-preview-default): Merge it with `register-preview-default-1`. (register--preview-function): Delete function. --- lisp/register.el | 41 +++++++---------------------------------- 1 file changed, 7 insertions(+), 34 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index 8a71fd70a79..a1bffb5529b 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -120,12 +120,11 @@ provided function, `register-read-with-preview-traditional', behaves the same as in Emacs 29 and before: no filtering, no navigation, and no defaults.") -(defvar register-preview-function nil +(defvar register-preview-function #'register-preview-default "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 to use is set according -to the value of `register--read-with-preview-function'.") +description of the argument.") (defcustom register-use-preview 'traditional "Whether register commands show preview of registers with non-nil values. @@ -158,8 +157,7 @@ behavior of Emacs 29 and before." (setq register--read-with-preview-function (if (eq val 'traditional) #'register-read-with-preview-traditional - #'register-read-with-preview-fancy)) - (setq register-preview-function nil))) + #'register-read-with-preview-fancy)))) (defun get-register (register) "Return contents of Emacs register named REGISTER, or nil if none." @@ -179,32 +177,13 @@ See the documentation of the variable `register-alist' for possible VALUEs." (substring d (match-end 0)) d))) -(defun register-preview-default-1 (r) - "Function used to format a register for fancy previewing. -This is used as the value of the variable `register-preview-function' -when `register-use-preview' is set to t or nil." - (format "%s: %s\n" - (propertize (string (car r)) - 'display (single-key-description (car r))) - (register-describe-oneline (car r)))) - (defun register-preview-default (r) - "Function used to format a register for traditional preview. -This is the default value of the variable `register-preview-function', -and is used when `register-use-preview' is set to `traditional'." + "Function used to format a register for previewing. +This is the default value of the variable `register-preview-function'." (format "%s: %s\n" (single-key-description (car r)) (register-describe-oneline (car r)))) -(cl-defgeneric register--preview-function (read-preview-function) - "Return a function to format registers for previewing by READ-PREVIEW-FUNCTION.") -(cl-defmethod register--preview-function ((_read-preview-function - (eql register-read-with-preview-traditional))) - #'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. TYPES are the supported types of registers. @@ -332,7 +311,7 @@ Do nothing when defining or executing kmacros." pos) (goto-char (if ovs (overlay-start (car ovs)) - (point-min))) + (point-min))) (setq pos (point)) (and ovs (forward-line arg)) (when (and (funcall fn) @@ -401,9 +380,6 @@ satisfy `cl-typep', otherwise the new type should be defined with "Pop up a window showing the preview of registers in BUFFER. If SHOW-EMPTY is non-nil, show the preview 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 register-preview-display-buffer-alist @@ -431,9 +407,6 @@ If SHOW-EMPTY is non-nil, show the preview window even if no registers. Optional argument TYPES (a list) specifies the types of register to show; if it is nil, show all the 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 @@ -582,7 +555,7 @@ or `never'." (setq input "") (delete-minibuffer-contents) (minibuffer-message "Not matching")) - (when (not (string= input pat)) + (when (not (string= input pat)) ;; FIXME: Why this test? (setq pat input)))) (unless (or (string= pat "") (get-text-property (minibuffer-prompt-end) From 3bc1c13661a334fedd8967188715cf85ef2af992 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 29 Apr 2025 22:54:41 -0400 Subject: [PATCH 05/14] (register-preview-info): Delete `noconfirm` slot * lisp/register.el (register-preview-info): Remove `noconfirm` slot. (register-command-info): Delete `:noconfirm` args. (register-read-with-preview-fancy): Hardcode the `noconfirm` setting because it was always exactly the same anyway. --- lisp/register.el | 45 +++++++++++++++------------------------------ 1 file changed, 15 insertions(+), 30 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index a1bffb5529b..f8f6488fee4 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -190,9 +190,8 @@ TYPES are the supported types of registers. MSG is the minibuffer message to show 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 the command accepts non-matching -registers. -If NOCONFIRM is non-nil, request confirmation of register name by RET." - types msg act smatch noconfirm) +registers." + types msg act smatch) (cl-defgeneric register-command-info (command) "Return a `register-preview-info' object storing data for COMMAND." @@ -204,8 +203,7 @@ If NOCONFIRM is non-nil, request confirmation of register name by RET." :types '(string number) :msg "Insert register `%s'" :act 'insert - :smatch t - :noconfirm (memq register-use-preview '(nil never)))) + :smatch t)) (cl-defmethod register-command-info ((_command (eql jump-to-register))) (make-register-preview-info ;; FIXME: This should not be hardcoded but computed based on whether @@ -214,86 +212,73 @@ If NOCONFIRM is non-nil, request confirmation of register name by RET." file buffer file-query) :msg "Jump to register `%s'" :act 'jump - :smatch t - :noconfirm (memq register-use-preview '(nil never)))) + :smatch t)) (cl-defmethod register-command-info ((_command (eql view-register))) (make-register-preview-info :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) ;; FIXME: Fails on rectangles! :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) ;;FIXME: Fails on rectangles! :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) ;;FIXME: Fails on rectangles! :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)))) + :act 'set)) (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)))) + :act 'set)) (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)))) + :act 'set)) (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)))) + :act 'set)) (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)))) + :act 'set)) (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)) (cl-defmethod register-command-info ((_command (eql file-to-register))) (make-register-preview-info :types '(all) :msg "File to register `%s'" - :act 'set - :noconfirm (memq register-use-preview '(nil never)))) + :act 'set)) (cl-defmethod register-command-info ((_command (eql buffer-to-register))) (make-register-preview-info :types '(all) :msg "Buffer to register `%s'" - :act 'set - :noconfirm (memq register-use-preview '(nil never)))) + :act 'set)) (defun register-preview-forward-line (arg) "Move to next or previous line in register preview buffer. @@ -502,13 +487,13 @@ or `never'." m)) (data (register-command-info this-command)) (enable-recursive-minibuffers t) - types msg result act win strs smatch noconfirm) + types msg result act win strs smatch + (noconfirm (memq register-use-preview '(nil never)))) (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) - noconfirm (register-preview-info-noconfirm data)) + smatch (register-preview-info-smatch data)) (setq types '(all) msg "Overwrite register `%s'" act 'set)) @@ -600,7 +585,7 @@ or `never'." (with-selected-window (minibuffer-window) (minibuffer-message msg (key-description pat))) - ;; `:noconfirm' is specified explicitly, don't ask for + ;; `noconfirm' is specified explicitly, don't ask for ;; confirmation and exit immediately (bug#66394). (setq result pat) (exit-minibuffer)))))))) From 215246108e1d35f5172c76549c71ffae901ab840 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 29 Apr 2025 22:57:41 -0400 Subject: [PATCH 06/14] (register-preview-info): Delete `msg` slot * lisp/register.el (register-preview-info): Remove `msg` slot. (register-command-info): Delete `:msg` args. (register-read-with-preview-fancy): Compute `msg` from the `prompt`. --- lisp/register.el | 25 ++++++------------------- 1 file changed, 6 insertions(+), 19 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index f8f6488fee4..00f2e08e66e 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -187,11 +187,10 @@ This is the default value of the variable `register-preview-function'." (cl-defstruct register-preview-info "Store data for a specific register command. TYPES are the supported types of registers. -MSG is the minibuffer message to show 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 the command accepts non-matching registers." - types msg act smatch) + types act smatch) (cl-defgeneric register-command-info (command) "Return a `register-preview-info' object storing data for COMMAND." @@ -201,7 +200,6 @@ registers." ;; FIXME: This should not be hardcoded but computed based on whether ;; a given register type implements `register-val-insert'. :types '(string number) - :msg "Insert register `%s'" :act 'insert :smatch t)) (cl-defmethod register-command-info ((_command (eql jump-to-register))) @@ -210,74 +208,61 @@ registers." ;; a given register type implements `register-val-jump-to'. :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) ;; FIXME: Fails on rectangles! - :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) ;;FIXME: Fails on rectangles! - :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) ;;FIXME: Fails on rectangles! - :msg "Increment register `%s'" :act 'modify :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)) (cl-defmethod register-command-info ((_command (eql point-to-register))) (make-register-preview-info :types '(all) - :msg "Point to register `%s'" :act 'set)) (cl-defmethod register-command-info ((_command (eql number-to-register))) (make-register-preview-info :types '(all) - :msg "Number to register `%s'" :act 'set)) (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)) (cl-defmethod register-command-info ((_command (eql frameset-to-register))) (make-register-preview-info :types '(all) - :msg "Frameset to register `%s'" :act 'set)) (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 :smatch t)) (cl-defmethod register-command-info ((_command (eql file-to-register))) (make-register-preview-info :types '(all) - :msg "File to register `%s'" :act 'set)) (cl-defmethod register-command-info ((_command (eql buffer-to-register))) (make-register-preview-info :types '(all) - :msg "Buffer to register `%s'" :act 'set)) (defun register-preview-forward-line (arg) @@ -487,15 +472,17 @@ or `never'." m)) (data (register-command-info this-command)) (enable-recursive-minibuffers t) - types msg result act win strs smatch + types result act win strs smatch + (msg (if (string-match ":? *\\'" prompt) + (concat (substring prompt 0 (match-beginning 0)) + " `%s'") + "Using register `%s'")) (noconfirm (memq register-use-preview '(nil never)))) (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))) From 573b377e8c57d60ea4fa881641ed0f851858fe8e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 29 Apr 2025 23:36:23 -0400 Subject: [PATCH 07/14] (register-preview-info): Delete slot `smatch` Use the `types` slot to carry that info instead. Replace the list of types `(all)` with `(t)` since `t` is the usual name of the "supertype of all types". Use the type `null` to represent the fact that empty registers can be used. Allow an empty list of types to stand for `(t null)`, i.e. any register even empty ones. * lisp/register.el (register-preview-info): Delete slot `smatch`. (register-command-info): Delete arg `:smatch`. Adjust `:types` instead. Fix the `copy-rectangle-to-register` case, which disallowed using an empty register. (register-of-type-alist): Adjust handling of `types` accordingly. (register-preview-1): Simplify. (register-read-with-preview-fancy): Use types instead of `smatch`. Use it also in place of `act`. --- lisp/register.el | 68 ++++++++++++++++++------------------------------ 1 file changed, 26 insertions(+), 42 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index 00f2e08e66e..89d4a857cfc 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -186,11 +186,12 @@ This is the default value of the variable `register-preview-function'." (cl-defstruct register-preview-info "Store data for a specific register command. -TYPES are the supported types of registers. -ACT is the type of action the command is doing on register. -SMATCH accept a boolean value to say if the command accepts non-matching -registers." - types act smatch) +TYPES holds the list of supported types of registers. + If nil, means it can operate on any register, even empty ones. + The t type means it can operate on any non-empty register. + The `null' type stands for the type of empty registers. +ACT is the type of action the command is doing on register." + types act) (cl-defgeneric register-command-info (command) "Return a `register-preview-info' object storing data for COMMAND." @@ -200,69 +201,54 @@ registers." ;; FIXME: This should not be hardcoded but computed based on whether ;; a given register type implements `register-val-insert'. :types '(string number) - :act 'insert - :smatch t)) + :act 'insert)) (cl-defmethod register-command-info ((_command (eql jump-to-register))) (make-register-preview-info ;; FIXME: This should not be hardcoded but computed based on whether ;; a given register type implements `register-val-jump-to'. :types '(window frame marker kmacro file buffer file-query) - :act 'jump - :smatch t)) + :act 'jump)) (cl-defmethod register-command-info ((_command (eql view-register))) (make-register-preview-info - :types '(all) - :act 'view - :smatch t)) + :types '(t) + :act 'view)) (cl-defmethod register-command-info ((_command (eql append-to-register))) (make-register-preview-info - :types '(string) ;; FIXME: Fails on rectangles! - :act 'modify - :smatch t)) + :types '(string null) ;;FIXME: Fails on rectangles! + :act 'modify)) (cl-defmethod register-command-info ((_command (eql prepend-to-register))) (make-register-preview-info - :types '(string) ;;FIXME: Fails on rectangles! - :act 'modify - :smatch t)) + :types '(string null) ;;FIXME: Fails on rectangles! + :act 'modify)) (cl-defmethod register-command-info ((_command (eql increment-register))) (make-register-preview-info - :types '(string number) ;;FIXME: Fails on rectangles! - :act 'modify - :smatch t)) + :types '(string number null) ;;FIXME: Fails on rectangles! + :act 'modify)) (cl-defmethod register-command-info ((_command (eql copy-to-register))) (make-register-preview-info - :types '(all) :act 'set)) (cl-defmethod register-command-info ((_command (eql point-to-register))) (make-register-preview-info - :types '(all) :act 'set)) (cl-defmethod register-command-info ((_command (eql number-to-register))) (make-register-preview-info - :types '(all) :act 'set)) (cl-defmethod register-command-info ((_command (eql window-configuration-to-register))) (make-register-preview-info - :types '(all) :act 'set)) (cl-defmethod register-command-info ((_command (eql frameset-to-register))) (make-register-preview-info - :types '(all) :act 'set)) (cl-defmethod register-command-info ((_command (eql copy-rectangle-to-register))) (make-register-preview-info - :types '(all) - :act 'set - :smatch t)) + :act 'set)) (cl-defmethod register-command-info ((_command (eql file-to-register))) (make-register-preview-info - :types '(all) :act 'set)) (cl-defmethod register-command-info ((_command (eql buffer-to-register))) (make-register-preview-info - :types '(all) :act 'set)) (defun register-preview-forward-line (arg) @@ -340,7 +326,7 @@ satisfy `cl-typep', otherwise the new type should be defined with (defun register-of-type-alist (types) "Filter `register-alist' according to TYPES." - (if (memq 'all types) + (if (or (null types) (memq t types)) register-alist (cl-loop for register in register-alist when (memq (register-type register) types) @@ -375,9 +361,9 @@ This is the preview function used with the `register-read-with-preview-fancy' function. If SHOW-EMPTY is non-nil, show the preview window even if no registers. Optional argument TYPES (a list) specifies the types of register to show; -if it is nil, show all the registers. See `register-type' for suitable types. +if it is nil or t, show all the registers. See `register-type' for suitable types. Format of each entry is controlled by the variable `register-preview-function'." - (let ((registers (register-of-type-alist (or types '(all))))) + (let ((registers (register-of-type-alist types))) (when (or show-empty (consp registers)) (with-current-buffer-window buffer @@ -472,7 +458,7 @@ or `never'." m)) (data (register-command-info this-command)) (enable-recursive-minibuffers t) - types result act win strs smatch + types result act win strs (msg (if (string-match ":? *\\'" prompt) (concat (substring prompt 0 (match-beginning 0)) " `%s'") @@ -480,14 +466,12 @@ or `never'." (noconfirm (memq register-use-preview '(nil never)))) (if data (setq types (register-preview-info-types data) - act (register-preview-info-act data) - smatch (register-preview-info-smatch data)) - (setq types '(all) - act 'set)) + act (register-preview-info-act data)) + (setq act 'set)) (setq strs (mapcar (lambda (x) (string (car x))) (register-of-type-alist types))) - (when (and (memq act '(insert jump view)) (null strs)) + (when (and types (not (memq 'null types)) (null strs)) (error "No register suitable for `%s'" act)) (dolist (k (cons help-char help-event-list)) (define-key map (vector k) @@ -512,7 +496,7 @@ or `never'." ;; Only keep the first of the new chars. (let ((new (substring input 1 2)) (old (substring input 0 1))) - (setq input (if (or (null smatch) + (setq input (if (or (null types) (member new strs)) new old)) (delete-minibuffer-contents) @@ -522,7 +506,7 @@ or `never'." (when (and (string= new old) (eq register-use-preview 'insist)) (setq noconfirm t)))) - (when (and smatch (not (string= input "")) + (when (and types (not (string= input "")) (not (member input strs))) (setq input "") (delete-minibuffer-contents) From 3044d16b81b80e79339faf30560d4db4c59b3a97 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 29 Apr 2025 23:51:56 -0400 Subject: [PATCH 08/14] (register-preview-info): Delete slot `act` * lisp/register.el (register-preview-info): Delete slot `act`. (register-command-info): Delete arg `:act`. (register--preview-get-defaults): Rename from `register--preview-get-defaults` and rewrite with, different args. (register-read-with-preview-fancy): Use it instead of `act`. --- lisp/register.el | 68 +++++++++++++++++++----------------------------- 1 file changed, 27 insertions(+), 41 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index 89d4a857cfc..104274c9d65 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -189,9 +189,8 @@ This is the default value of the variable `register-preview-function'." TYPES holds the list of supported types of registers. If nil, means it can operate on any register, even empty ones. The t type means it can operate on any non-empty register. - The `null' type stands for the type of empty registers. -ACT is the type of action the command is doing on register." - types act) + The `null' type stands for the type of empty registers." + types) (cl-defgeneric register-command-info (command) "Return a `register-preview-info' object storing data for COMMAND." @@ -200,56 +199,45 @@ ACT is the type of action the command is doing on register." (make-register-preview-info ;; FIXME: This should not be hardcoded but computed based on whether ;; a given register type implements `register-val-insert'. - :types '(string number) - :act 'insert)) + :types '(string number))) (cl-defmethod register-command-info ((_command (eql jump-to-register))) (make-register-preview-info ;; FIXME: This should not be hardcoded but computed based on whether ;; a given register type implements `register-val-jump-to'. :types '(window frame marker kmacro - file buffer file-query) - :act 'jump)) + file buffer file-query))) (cl-defmethod register-command-info ((_command (eql view-register))) (make-register-preview-info - :types '(t) - :act 'view)) + :types '(t))) (cl-defmethod register-command-info ((_command (eql append-to-register))) (make-register-preview-info :types '(string null) ;;FIXME: Fails on rectangles! - :act 'modify)) + )) (cl-defmethod register-command-info ((_command (eql prepend-to-register))) (make-register-preview-info :types '(string null) ;;FIXME: Fails on rectangles! - :act 'modify)) + )) (cl-defmethod register-command-info ((_command (eql increment-register))) (make-register-preview-info :types '(string number null) ;;FIXME: Fails on rectangles! - :act 'modify)) + )) (cl-defmethod register-command-info ((_command (eql copy-to-register))) - (make-register-preview-info - :act 'set)) + (make-register-preview-info)) (cl-defmethod register-command-info ((_command (eql point-to-register))) - (make-register-preview-info - :act 'set)) + (make-register-preview-info)) (cl-defmethod register-command-info ((_command (eql number-to-register))) - (make-register-preview-info - :act 'set)) + (make-register-preview-info)) (cl-defmethod register-command-info ((_command (eql window-configuration-to-register))) - (make-register-preview-info - :act 'set)) + (make-register-preview-info)) (cl-defmethod register-command-info ((_command (eql frameset-to-register))) - (make-register-preview-info - :act 'set)) + (make-register-preview-info)) (cl-defmethod register-command-info ((_command (eql copy-rectangle-to-register))) - (make-register-preview-info - :act 'set)) + (make-register-preview-info)) (cl-defmethod register-command-info ((_command (eql file-to-register))) - (make-register-preview-info - :act 'set)) + (make-register-preview-info)) (cl-defmethod register-command-info ((_command (eql buffer-to-register))) - (make-register-preview-info - :act 'set)) + (make-register-preview-info)) (defun register-preview-forward-line (arg) "Move to next or previous line in register preview buffer. @@ -385,13 +373,13 @@ Format of each entry is controlled by the variable `register-preview-function'." (forward-line 1)) (not (eobp))) -(cl-defgeneric register-preview-get-defaults (action) - "Return 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--preview-get-defaults (types strs) + "Return default registers according to TYPES and available registers. +STRS is the list of non-empty registers that match TYPES," + (unless types + (cl-loop for s in register-preview-default-keys + unless (member s strs) + collect s))) (defun register-read-with-preview (prompt) "Read register name, prompting with PROMPT; possibly show existing registers. @@ -458,21 +446,19 @@ or `never'." m)) (data (register-command-info this-command)) (enable-recursive-minibuffers t) - types result act win strs + types result win strs (msg (if (string-match ":? *\\'" prompt) (concat (substring prompt 0 (match-beginning 0)) " `%s'") "Using register `%s'")) (noconfirm (memq register-use-preview '(nil never)))) (if data - (setq types (register-preview-info-types data) - act (register-preview-info-act data)) - (setq act 'set)) + (setq types (register-preview-info-types data))) (setq strs (mapcar (lambda (x) (string (car x))) (register-of-type-alist types))) (when (and types (not (memq 'null types)) (null strs)) - (error "No register suitable for `%s'" act)) + (error "No suitable register")) (dolist (k (cons help-char help-event-list)) (define-key map (vector k) (lambda () @@ -564,7 +550,7 @@ or `never'." (lambda () (add-hook 'post-command-hook setup nil 'local)) (setq result (read-from-minibuffer prompt nil map nil nil - (register-preview-get-defaults act)))) + (register--preview-get-defaults types strs)))) (cl-assert (and result (not (string= result ""))) nil "No register specified") (string-to-char result)) From 1143a5273860fd6402aaf3fb6e1df39c31a3cc41 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 30 Apr 2025 07:51:12 -0400 Subject: [PATCH 09/14] (register-preview-info): Delete struct type * lisp/register.el (register-preview-info): Delete struct type. (register-command-info): Return a list of types, instead. (register-read-with-preview-fancy): Adjust accordingly. --- lisp/register.el | 65 ++++++++++++------------------------------------ 1 file changed, 16 insertions(+), 49 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index 104274c9d65..92026d6f2ff 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -184,60 +184,29 @@ This is the default value of the variable `register-preview-function'." (single-key-description (car r)) (register-describe-oneline (car r)))) -(cl-defstruct register-preview-info - "Store data for a specific register command. -TYPES holds the list of supported types of registers. - If nil, means it can operate on any register, even empty ones. - The t type means it can operate on any non-empty register. - The `null' type stands for the type of empty registers." - types) - (cl-defgeneric register-command-info (command) - "Return a `register-preview-info' object storing data for COMMAND." + "Return a list of types of registers to use for COMMAND." (ignore command)) (cl-defmethod register-command-info ((_command (eql insert-register))) - (make-register-preview-info ;; FIXME: This should not be hardcoded but computed based on whether ;; a given register type implements `register-val-insert'. - :types '(string number))) + '(string number)) (cl-defmethod register-command-info ((_command (eql jump-to-register))) - (make-register-preview-info ;; FIXME: This should not be hardcoded but computed based on whether ;; a given register type implements `register-val-jump-to'. - :types '(window frame marker kmacro - file buffer file-query))) + '(window frame marker kmacro + file buffer file-query)) (cl-defmethod register-command-info ((_command (eql view-register))) - (make-register-preview-info - :types '(t))) + '(t)) (cl-defmethod register-command-info ((_command (eql append-to-register))) - (make-register-preview-info - :types '(string null) ;;FIXME: Fails on rectangles! - )) + '(string null) ;;FIXME: Fails on rectangles! + ) (cl-defmethod register-command-info ((_command (eql prepend-to-register))) - (make-register-preview-info - :types '(string null) ;;FIXME: Fails on rectangles! - )) + '(string null) ;;FIXME: Fails on rectangles! + ) (cl-defmethod register-command-info ((_command (eql increment-register))) - (make-register-preview-info - :types '(string number null) ;;FIXME: Fails on rectangles! - )) -(cl-defmethod register-command-info ((_command (eql copy-to-register))) - (make-register-preview-info)) -(cl-defmethod register-command-info ((_command (eql point-to-register))) - (make-register-preview-info)) -(cl-defmethod register-command-info ((_command (eql number-to-register))) - (make-register-preview-info)) -(cl-defmethod register-command-info - ((_command (eql window-configuration-to-register))) - (make-register-preview-info)) -(cl-defmethod register-command-info ((_command (eql frameset-to-register))) - (make-register-preview-info)) -(cl-defmethod register-command-info ((_command (eql copy-rectangle-to-register))) - (make-register-preview-info)) -(cl-defmethod register-command-info ((_command (eql file-to-register))) - (make-register-preview-info)) -(cl-defmethod register-command-info ((_command (eql buffer-to-register))) - (make-register-preview-info)) + '(string number null) ;;FIXME: Fails on rectangles! + ) (defun register-preview-forward-line (arg) "Move to next or previous line in register preview buffer. @@ -444,19 +413,17 @@ or `never'." (map (let ((m (make-sparse-keymap))) (set-keymap-parent m minibuffer-local-map) m)) - (data (register-command-info this-command)) + (types (register-command-info this-command)) (enable-recursive-minibuffers t) - types result win strs + result win (msg (if (string-match ":? *\\'" prompt) (concat (substring prompt 0 (match-beginning 0)) " `%s'") "Using register `%s'")) - (noconfirm (memq register-use-preview '(nil never)))) - (if data - (setq types (register-preview-info-types data))) - (setq strs (mapcar (lambda (x) + (noconfirm (memq register-use-preview '(nil never))) + (strs (mapcar (lambda (x) (string (car x))) - (register-of-type-alist types))) + (register-of-type-alist types)))) (when (and types (not (memq 'null types)) (null strs)) (error "No suitable register")) (dolist (k (cons help-char help-event-list)) From 0fc6bd5c76a5e55401cf086e3b8fc6ed8eb32b94 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 30 Apr 2025 08:25:35 -0400 Subject: [PATCH 10/14] (register-read-with-preview): Add optional `pred` arg * lisp/register.el (register--read-with-preview-function): Improve docstring.. (register--type) <(eql nil)>: New method. (register-of-type-alist, register-preview-1) (register--preview-get-defaults): Replace `types` arg with `pred` arg. (register-read-with-preview, register-read-with-preview-traditional): Add `pred` arg. (register-read-with-preview-fancy): Add `pred` arg. Use it instead of the `types` info returned by `register-command-info`, when provided. --- lisp/register.el | 74 +++++++++++++++++++++++++++++------------------- 1 file changed, 45 insertions(+), 29 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index 92026d6f2ff..abe326f0713 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -110,7 +110,8 @@ value except `traditional'." (defvar register--read-with-preview-function nil "Function to use for reading a register name with preview. -Two functions are provided, one that provide navigation and highlighting +Should implement the behavior documented for `register-read-with-preview'. +Two functions are provided, one that provides navigation and highlighting of the selected register, 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 @@ -272,6 +273,7 @@ satisfy `cl-typep', otherwise the new type should be defined with "Return the type of register value REGVAL." (ignore regval)) +(cl-defmethod register--type ((_regval (eql nil))) 'null) (cl-defmethod register--type ((_regval string)) 'string) (cl-defmethod register--type ((_regval number)) 'number) (cl-defmethod register--type ((_regval marker)) 'marker) @@ -281,12 +283,12 @@ satisfy `cl-typep', otherwise the new type should be defined with (cl-defmethod register--type ((_regval window-configuration)) 'window) (cl-defmethod register--type ((regval oclosure)) (oclosure-type regval)) -(defun register-of-type-alist (types) - "Filter `register-alist' according to TYPES." - (if (or (null types) (memq t types)) +(defun register-of-type-alist (pred) + "Filter `register-alist' according to PRED." + (if (null pred) register-alist (cl-loop for register in register-alist - when (memq (register-type register) types) + when (funcall pred (cdr register)) collect register))) (defun register-preview (buffer &optional show-empty) @@ -311,16 +313,16 @@ Format of each entry is controlled by the variable `register-preview-function'." :type display-buffer--action-custom-type :version "30.1") -(defun register-preview-1 (buffer &optional show-empty types) +(defun register-preview-1 (buffer &optional show-empty pred) "Pop up a window showing the preview of registers in BUFFER. This is the preview function used with the `register-read-with-preview-fancy' function. If SHOW-EMPTY is non-nil, show the preview window even if no registers. -Optional argument TYPES (a list) specifies the types of register to show; -if it is nil or t, show all the registers. See `register-type' for suitable types. +Optional argument PRED specifies the types of register to show; +if it is nil, show all the registers. See `register-type' for suitable types. Format of each entry is controlled by the variable `register-preview-function'." - (let ((registers (register-of-type-alist types))) + (let ((registers (register-of-type-alist pred))) (when (or show-empty (consp registers)) (with-current-buffer-window buffer @@ -342,24 +344,30 @@ Format of each entry is controlled by the variable `register-preview-function'." (forward-line 1)) (not (eobp))) -(defun register--preview-get-defaults (types strs) - "Return default registers according to TYPES and available registers. -STRS is the list of non-empty registers that match TYPES," - (unless types +(defun register--preview-get-defaults (pred strs) + "Return default registers according to PRED and available registers. +STRS is the list of non-empty registers that match PRED," + (unless pred (cl-loop for s in register-preview-default-keys unless (member s strs) collect s))) -(defun register-read-with-preview (prompt) +(defun register-read-with-preview (prompt &optional pred) "Read register name, prompting with PROMPT; possibly show existing registers. This reads and returns the name of a register. PROMPT should be a string to prompt the user for the name. If `help-char' (or a member of `help-event-list') is pressed, display preview window unconditionally. -This calls the function specified by `register--read-with-preview-function'." - (funcall register--read-with-preview-function prompt)) -(defun register-read-with-preview-traditional (prompt) +PRED if non-nil should be a function specifying the kinds of registers that +can be used. It is called with one argument, a register value, and should +return non-nil if and only if that register value can be used. +The register value nil represents an empty register. + +This calls the function specified by `register--read-with-preview-function'." + (funcall register--read-with-preview-function prompt pred)) + +(defun register-read-with-preview-traditional (prompt &optional _pred) "Read register name, prompting with PROMPT; possibly show existing registers. This reads and returns the name of a register. PROMPT should be a string to prompt the user for the name. @@ -396,7 +404,7 @@ when `register-use-preview' is set to `traditional'." (and (window-live-p w) (delete-window w))) (and (get-buffer buffer) (kill-buffer buffer))))) -(defun register-read-with-preview-fancy (prompt) +(defun register-read-with-preview-fancy (prompt &optional pred) "Read register name, prompting with PROMPT; possibly show existing registers. This reads and returns the name of a register. PROMPT should be a string to prompt the user for the name. @@ -414,6 +422,11 @@ or `never'." (set-keymap-parent m minibuffer-local-map) m)) (types (register-command-info this-command)) + (pred (or pred + (when types + (lambda (regval) + ;; FIXME: Dummy ?d because of the API of `register-type' + (memq (register-type (cons ?d regval)) types))))) (enable-recursive-minibuffers t) result win (msg (if (string-match ":? *\\'" prompt) @@ -423,8 +436,8 @@ or `never'." (noconfirm (memq register-use-preview '(nil never))) (strs (mapcar (lambda (x) (string (car x))) - (register-of-type-alist types)))) - (when (and types (not (memq 'null types)) (null strs)) + (register-of-type-alist pred)))) + (when (and pred (not (funcall pred nil)) (null strs)) (error "No suitable register")) (dolist (k (cons help-char help-event-list)) (define-key map (vector k) @@ -433,13 +446,13 @@ or `never'." ;; Do nothing when buffer1 is in use. (unless (get-buffer-window buf) (with-selected-window (minibuffer-selected-window) - (register-preview-1 buffer 'show-empty types)))))) + (register-preview-1 buffer 'show-empty pred)))))) (define-key map (kbd "") #'register-preview-next) (define-key map (kbd "") #'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-1 buf nil types)) + (register-preview-1 buf nil pred)) (unwind-protect (let ((setup ;; FIXME: Weird name for a `post-command-hook' function. (lambda () @@ -447,10 +460,11 @@ or `never'." (let ((input (minibuffer-contents))) (when (> (length input) 1) ;; Only keep the first of the new chars. - (let ((new (substring input 1 2)) - (old (substring input 0 1))) - (setq input (if (or (null types) - (member new strs)) + (let* ((new (substring input 1 2)) + (old (substring input 0 1)) + (newreg (aref new 0)) + (regval (cdr (assq newreg register-alist)))) + (setq input (if (or (null pred) (funcall pred regval)) new old)) (delete-minibuffer-contents) (insert input) @@ -459,8 +473,10 @@ or `never'." (when (and (string= new old) (eq register-use-preview 'insist)) (setq noconfirm t)))) - (when (and types (not (string= input "")) - (not (member input strs))) + (when (and pred (not (string= input "")) + (let* ((reg (aref input 0)) + (regval (cdr (assq reg register-alist)))) + (not (funcall pred regval)))) (setq input "") (delete-minibuffer-contents) (minibuffer-message "Not matching")) @@ -517,7 +533,7 @@ or `never'." (lambda () (add-hook 'post-command-hook setup nil 'local)) (setq result (read-from-minibuffer prompt nil map nil nil - (register--preview-get-defaults types strs)))) + (register--preview-get-defaults pred strs)))) (cl-assert (and result (not (string= result ""))) nil "No register specified") (string-to-char result)) From c43964d27aacc05be9cd6f42a1d8295a9b661551 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 30 Apr 2025 08:40:00 -0400 Subject: [PATCH 11/14] (register-type): Change arg to be the "regval" * lisp/register.el (register-type): Change arg to be the "regval". (register-read-with-preview-fancy): Adjust call accordingly --- lisp/register.el | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index abe326f0713..6970907e84e 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -247,8 +247,8 @@ Do nothing when defining or executing kmacros." (interactive) (register-preview-forward-line -1)) -(defun register-type (register) - "Return REGISTER type. +(defun register-type (regval) + "Return register value REGVAL's type. Register type that can be returned is one of the following: - string - number @@ -264,10 +264,11 @@ One can add new types to a specific command by defining a new `cl-defmethod' matching that command. Predicates for type in new `cl-defmethod' should satisfy `cl-typep', otherwise the new type should be defined with `cl-deftype'." + (if (integerp (car-safe regval)) (setq regval (cdr regval))) ;; Call register--type against the register value. - (register--type (if (consp (cdr register)) - (cadr register) - (cdr register)))) + (register--type (if (consp regval) + (car regval) + regval))) (cl-defgeneric register--type (regval) "Return the type of register value REGVAL." @@ -425,8 +426,7 @@ or `never'." (pred (or pred (when types (lambda (regval) - ;; FIXME: Dummy ?d because of the API of `register-type' - (memq (register-type (cons ?d regval)) types))))) + (memq (register-type regval) types))))) (enable-recursive-minibuffers t) result win (msg (if (string-match ":? *\\'" prompt) From b2904e064d023c3a6d19af58ffd8ce21342c794c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 30 Apr 2025 08:50:59 -0400 Subject: [PATCH 12/14] (register-command-info): Delete function * lisp/register.el (register-command-info): Delete function. (register-read-with-preview-fancy): Don't use it any more. (jump-to-register, increment-register, view-register) (insert-register, append-to-register, prepend-to-register): Pass a `pred` arg instead. --- lisp/register.el | 66 +++++++++++++++++++++++------------------------- 1 file changed, 31 insertions(+), 35 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index 6970907e84e..7de364429e2 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -185,30 +185,6 @@ This is the default value of the variable `register-preview-function'." (single-key-description (car r)) (register-describe-oneline (car r)))) -(cl-defgeneric register-command-info (command) - "Return a list of types of registers to use for COMMAND." - (ignore command)) -(cl-defmethod register-command-info ((_command (eql insert-register))) - ;; FIXME: This should not be hardcoded but computed based on whether - ;; a given register type implements `register-val-insert'. - '(string number)) -(cl-defmethod register-command-info ((_command (eql jump-to-register))) - ;; FIXME: This should not be hardcoded but computed based on whether - ;; a given register type implements `register-val-jump-to'. - '(window frame marker kmacro - file buffer file-query)) -(cl-defmethod register-command-info ((_command (eql view-register))) - '(t)) -(cl-defmethod register-command-info ((_command (eql append-to-register))) - '(string null) ;;FIXME: Fails on rectangles! - ) -(cl-defmethod register-command-info ((_command (eql prepend-to-register))) - '(string null) ;;FIXME: Fails on rectangles! - ) -(cl-defmethod register-command-info ((_command (eql increment-register))) - '(string number null) ;;FIXME: Fails on rectangles! - ) - (defun register-preview-forward-line (arg) "Move to next or previous line in register preview buffer. If ARG is positive, go to next line; if negative, go to previous line. @@ -422,11 +398,6 @@ or `never'." (map (let ((m (make-sparse-keymap))) (set-keymap-parent m minibuffer-local-map) m)) - (types (register-command-info this-command)) - (pred (or pred - (when types - (lambda (regval) - (memq (register-type regval) types))))) (enable-recursive-minibuffers t) result win (msg (if (string-match ":? *\\'" prompt) @@ -614,7 +585,15 @@ to delete any existing frames that the frameset doesn't mention. ignored if the register contains anything but a frameset. Interactively, prompt for REGISTER using `register-read-with-preview'." - (interactive (list (register-read-with-preview "Jump to register: ") + (interactive (list (register-read-with-preview + "Jump to register: " + (lambda (regval) + (memq (register-type regval) + ;; FIXME: This should not be hardcoded but + ;; computed based on whether a given register + ;; type implements `register-val-jump-to'. + '(window frame marker kmacro + file buffer file-query)))) current-prefix-arg)) (let ((val (get-register register))) (register-val-jump-to val delete))) @@ -751,7 +730,10 @@ If REGISTER is empty or if it contains text, call Interactively, prompt for REGISTER using `register-read-with-preview'." (interactive (list current-prefix-arg - (register-read-with-preview "Increment register: "))) + (register-read-with-preview + "Increment register: " + (lambda (regval) + (or (numberp regval) (null regval) (stringp regval)))))) (let ((register-val (get-register register))) (cond ((numberp register-val) @@ -766,7 +748,8 @@ Interactively, prompt for REGISTER using `register-read-with-preview'." REGISTER is a character, the name of the register. Interactively, prompt for REGISTER using `register-read-with-preview'." - (interactive (list (register-read-with-preview "View register: "))) + (interactive (list (register-read-with-preview "View register: " + (lambda (regval) regval)))) (let ((val (get-register register))) (if (null val) (message "Register %s is empty" (single-key-description register)) @@ -898,7 +881,14 @@ and t otherwise. Interactively, prompt for REGISTER using `register-read-with-preview'." (interactive (progn (barf-if-buffer-read-only) - (list (register-read-with-preview "Insert register: ") + (list (register-read-with-preview + "Insert register: " + (lambda (regval) + (memq (register-type regval) + ;; FIXME: This should not be hardcoded but + ;; computed based on whether a given register + ;; type implements `register-val-insert'. + '(string number)))) (not current-prefix-arg)))) (push-mark) (let ((val (get-register register))) @@ -963,7 +953,10 @@ START and END are buffer positions indicating what to append. Interactively, prompt for REGISTER using `register-read-with-preview', and use mark and point as START and END." - (interactive (list (register-read-with-preview "Append to register: ") + (interactive (list (register-read-with-preview + "Append to register: " + (lambda (regval) + (or (null regval) (stringp regval)))) (region-beginning) (region-end) current-prefix-arg)) @@ -989,7 +982,10 @@ START and END are buffer positions indicating what to prepend. Interactively, prompt for REGISTER using `register-read-with-preview', and use mark and point as START and END." - (interactive (list (register-read-with-preview "Prepend to register: ") + (interactive (list (register-read-with-preview + "Prepend to register: " + (lambda (regval) + (or (null regval) (stringp regval)))) (region-beginning) (region-end) current-prefix-arg)) From 826a83112964189b6049e288dbe8344a7362f29c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 30 Apr 2025 08:55:17 -0400 Subject: [PATCH 13/14] (register-preview-1): Delete function * lisp/register.el (register-preview): Add `pred` arg. (register-preview-1): Delete function. (register-read-with-preview-fancy): Use `register-preview` instead. --- lisp/register.el | 42 ++++++++++++------------------------------ 1 file changed, 12 insertions(+), 30 deletions(-) diff --git a/lisp/register.el b/lisp/register.el index 7de364429e2..b01f2e12023 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -268,36 +268,11 @@ satisfy `cl-typep', otherwise the new type should be defined with when (funcall pred (cdr register)) collect register))) -(defun register-preview (buffer &optional show-empty) +(defun register-preview (buffer &optional show-empty pred) "Pop up a window showing the preview of registers in BUFFER. If SHOW-EMPTY is non-nil, show the preview window even if no registers. -Format of each entry is controlled by the variable `register-preview-function'." - (when (or show-empty (consp register-alist)) - (with-current-buffer-window buffer - register-preview-display-buffer-alist - 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))))) - -(defcustom register-preview-display-buffer-alist '(display-buffer-at-bottom - (window-height . fit-window-to-buffer) - (preserve-size . (nil . t))) - "Window configuration for the register preview buffer." - :type display-buffer--action-custom-type - :version "30.1") - -(defun register-preview-1 (buffer &optional show-empty pred) - "Pop up a window showing the preview of registers in BUFFER. - -This is the preview function used with the `register-read-with-preview-fancy' -function. -If SHOW-EMPTY is non-nil, show the preview window even if no registers. Optional argument PRED specifies the types of register to show; -if it is nil, show all the registers. See `register-type' for suitable types. +if it is nil, show all the registers. Format of each entry is controlled by the variable `register-preview-function'." (let ((registers (register-of-type-alist pred))) (when (or show-empty (consp registers)) @@ -321,6 +296,13 @@ Format of each entry is controlled by the variable `register-preview-function'." (forward-line 1)) (not (eobp))) +(defcustom register-preview-display-buffer-alist '(display-buffer-at-bottom + (window-height . fit-window-to-buffer) + (preserve-size . (nil . t))) + "Window configuration for the register preview buffer." + :type display-buffer--action-custom-type + :version "30.1") + (defun register--preview-get-defaults (pred strs) "Return default registers according to PRED and available registers. STRS is the list of non-empty registers that match PRED," @@ -417,13 +399,13 @@ or `never'." ;; Do nothing when buffer1 is in use. (unless (get-buffer-window buf) (with-selected-window (minibuffer-selected-window) - (register-preview-1 buffer 'show-empty pred)))))) + (register-preview buffer 'show-empty pred)))))) (define-key map (kbd "") #'register-preview-next) (define-key map (kbd "") #'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-1 buf nil pred)) + (register-preview buf nil pred)) (unwind-protect (let ((setup ;; FIXME: Weird name for a `post-command-hook' function. (lambda () @@ -464,7 +446,7 @@ or `never'." (when (or (eq noconfirm t) ; Using insist ;; Don't exit when noconfirm == (never) ;; If we are here user has pressed C-h - ;; calling `register-preview-1'. + ;; calling `register-preview'. (memq nil noconfirm)) ;; Happen only when ;; *-use-preview == insist. From 1284b6f1187be768e1af013339d7a228c6a8e84d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 30 Apr 2025 09:41:22 -0400 Subject: [PATCH 14/14] (register-type, register--type): Delete functions Automatically figure out which regval can be used for insertion and jump based on the presence of a matching method. * lisp/register.el (register-type, register--type): Delete functions. (register--get-method-type, register--jumpable-p) (register--insertable-p): New functions. (jump-to-register, insert-register): Use them. * lisp/frameset.el (register--type): Delete method. --- lisp/frameset.el | 5 --- lisp/register.el | 79 ++++++++++++++++++------------------------------ 2 files changed, 29 insertions(+), 55 deletions(-) diff --git a/lisp/frameset.el b/lisp/frameset.el index cbdbc1ac239..ee30f77c3ba 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -1444,11 +1444,6 @@ Called from `list-registers' and `view-register'. Internal use only." (if (= 1 ns) "" "s") (format-time-string "%c" (frameset-timestamp fs)))))) -(cl-defmethod register--type ((_regval frameset-register)) - ;; FIXME: Why `frame' rather than `frameset'? - ;; FIXME: We shouldn't need to touch an internal function. - 'frame) - ;;;###autoload (defun frameset-to-register (register) "Store the current frameset in register REGISTER. diff --git a/lisp/register.el b/lisp/register.el index b01f2e12023..a36d0e6648e 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -223,43 +223,6 @@ Do nothing when defining or executing kmacros." (interactive) (register-preview-forward-line -1)) -(defun register-type (regval) - "Return register value REGVAL's type. -Register type that can be returned is one of the following: - - 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 that command. Predicates for type in new `cl-defmethod' should -satisfy `cl-typep', otherwise the new type should be defined with -`cl-deftype'." - (if (integerp (car-safe regval)) (setq regval (cdr regval))) - ;; Call register--type against the register value. - (register--type (if (consp regval) - (car regval) - regval))) - -(cl-defgeneric register--type (regval) - "Return the type of register value REGVAL." - (ignore regval)) - -(cl-defmethod register--type ((_regval (eql nil))) 'null) -(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-defmethod register--type ((regval oclosure)) (oclosure-type regval)) - (defun register-of-type-alist (pred) "Filter `register-alist' according to PRED." (if (null pred) @@ -569,13 +532,7 @@ ignored if the register contains anything but a frameset. Interactively, prompt for REGISTER using `register-read-with-preview'." (interactive (list (register-read-with-preview "Jump to register: " - (lambda (regval) - (memq (register-type regval) - ;; FIXME: This should not be hardcoded but - ;; computed based on whether a given register - ;; type implements `register-val-jump-to'. - '(window frame marker kmacro - file buffer file-query)))) + #'register--jumpable-p) current-prefix-arg)) (let ((val (get-register register))) (register-val-jump-to val delete))) @@ -618,6 +575,24 @@ With a prefix argument, prompt for BUFFER as well." (add-hook 'kill-buffer-hook #'register-buffer-to-file-query nil t)) (set-register register (cons 'buffer buffer))) +(defun register--get-method-type (val genfun) + (let* ((type (cl-type-of val)) + (types (cl--class-allparents (cl-find-class type)))) + (while (and types (not (cl-find-method genfun nil (list (car types))))) + (setq types (cdr types))) + (car types))) + +(defun register--jumpable-p (regval) + "Return non-nil if `register-val-insert' is implemented for REGVAL." + (pcase (register--get-method-type regval 'register-val-jump-to) + ('t nil) + ('registerv (registerv-jump-func regval)) + ('cons + (or (frame-configuration-p (car regval)) + (window-configuration-p (car regval)) + (memq (car regval) '(file buffer file-query)))) + (type type))) + (cl-defgeneric register-val-jump-to (_val _arg) "Execute the \"jump\" operation of VAL. VAL is the contents of a register as returned by `get-register'. @@ -865,18 +840,22 @@ Interactively, prompt for REGISTER using `register-read-with-preview'." (barf-if-buffer-read-only) (list (register-read-with-preview "Insert register: " - (lambda (regval) - (memq (register-type regval) - ;; FIXME: This should not be hardcoded but - ;; computed based on whether a given register - ;; type implements `register-val-insert'. - '(string number)))) + #'register--insertable-p) (not current-prefix-arg)))) (push-mark) (let ((val (get-register register))) (register-val-insert val)) (if (not arg) (exchange-point-and-mark))) +(defun register--insertable-p (regval) + "Return non-nil if `register-val-insert' is implemented for REGVAL." + (pcase (register--get-method-type regval 'register-val-insert) + ;; Only rectangles are currently supported. + ('t nil) + ('registerv (registerv-insert-func regval)) + ('cons (stringp (car regval))) + (type type))) + (cl-defgeneric register-val-insert (_val) "Insert register value VAL in current buffer at point." (user-error "Register does not contain text"))