From aed86852ea872d546e8a6fc25e830953e7a2545e Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Tue, 12 Dec 2023 18:26:40 +0100 Subject: [PATCH] Only show applicable registers in *Register preview* buffer * lisp/register.el (register-preview-default): Doc fix. (register-read-with-preview): Preserve 'last-input-event' when calling 'y-or-n-p'. New optional argument PRED, pass it to... (register-preview): New optional argument PRED. (register-jump-p, register-insert-p, register-increment-p): New func. (jump-to-register, increment-register, insert-register) (append-to-register, prepend-to-register): Update. * doc/lispref/text.texi (Registers): Update 'register-read-with-preview' documentation. * etc/NEWS: Announce it. --- doc/lispref/text.texi | 9 ++-- etc/NEWS | 19 ++++--- lisp/register.el | 121 +++++++++++++++++++++++++++++------------- 3 files changed, 102 insertions(+), 47 deletions(-) diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 9f9c7ed0783..d29def5f102 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -4713,7 +4713,7 @@ a rectangle (a list), currently useless things happen. This may be changed in the future. @end deffn -@defun register-read-with-preview prompt &optional confirm +@defun register-read-with-preview prompt &optional confirm pred @cindex register preview This function reads and returns a register name, prompting with @var{prompt} and possibly showing a preview of the existing registers @@ -4723,8 +4723,11 @@ if its value and @code{register-alist} are both non-@code{nil}. The preview is also shown if the user requests help (e.g., by typing the help character). If optional argument @var{confirm} is non-@code{nil}, this function asks for confirmation before returning a -register that is already in use. We recommend that all interactive -commands which read register names use this function. +register that is already in use. Optional argument @var{pred}, if +non-@code{nil}, is a function that takes the contents of a register +and returns non-@code{nil} if that register should appear in the +preview. We recommend that all interactive commands which read +register names use this function. @end defun @node Transposition diff --git a/etc/NEWS b/etc/NEWS index 93d8a70d55b..3a10e17d038 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -258,6 +258,19 @@ called in the '--eval' expression, which is useful when those arguments contain arbitrary characters that otherwise might require elaborate and error-prone escaping (to protect them from the shell). +** Registers + ++++ +*** New user option 'register-confirm-overwrite'. +Emacs now defaults to asking for confirmation before overwriting +registers with existing contents. To disable such confirmation, +customize this option to nil. + ++++ +*** Commands that use register contents now preview only relevant registers. +For example, 'jump-to-register' now only shows registers that you can +actually jump to in the *Register Preview* buffer. + * Editing Changes in Emacs 30.1 @@ -1115,12 +1128,6 @@ macros with many lines, such as from 'kmacro-edit-lossage'. ** Miscellaneous -+++ -*** New user option 'register-confirm-overwrite'. -Emacs now defaults to asking for confirmation before overwriting -registers with existing contents. To disable such confirmation, -customize this option to nil. - --- *** Webjump now assumes URIs are HTTPS instead of HTTP. For links in 'webjump-sites' without an explicit URI scheme, it was diff --git a/lisp/register.el b/lisp/register.el index 4e400fbff2c..3df5a5d5abc 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -124,7 +124,10 @@ See the documentation of the variable `register-alist' for possible VALUEs." d))) (defun register-preview-default (r) - "Function that is the default value of the variable `register-preview-function'." + "Return a string describing the register R. + +This function is the default value of +`register-preview-function', which see." (format "%s: %s\n" (single-key-description (car r)) (register-describe-oneline (car r)))) @@ -134,46 +137,59 @@ 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 highlight) +(defun register-preview (buffer &optional show-empty highlight pred) "Pop up a window showing the registers preview in BUFFER. If SHOW-EMPTY is non-nil, show the window even if no registers. -Optional argument HIGHLIGHT says to highlight the description of -a register with that name. Format of each entry is controlled by -the variable `register-preview-function'." +Third optional argument HIGHLIGHT says to highlight the +description of a register with that name. + +Fourth optional argument PRED, if non-nil, is a function that +takes the contents of a register and returns non-nil if the +corresponding register should appear in the preview (see +`register-preview' for the format of the register contents). + +The the variable `register-preview-function' controls the +format of each entry in the preview." (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 - (delete-region (point-min) (point-max)) - (setq cursor-in-non-selected-windows nil) - (mapc (lambda (elem) - (when-let ((name (car elem)) - (reg (get-register name)) - (desc (funcall register-preview-function elem))) - (when (equal highlight name) - (add-face-text-property 0 (length desc) 'match nil desc)) - (insert desc))) - register-alist))))) - -(defun register-read-with-preview (prompt &optional confirm) + buffer + (cons 'display-buffer-below-selected + '((window-height . fit-window-to-buffer) + (preserve-size . (nil . t)))) + nil + (with-current-buffer standard-output + (delete-region (point-min) (point-max)) + (setq cursor-in-non-selected-windows nil) + (mapc (lambda (elem) + (let ((hilit nil) + (name (car elem)) + (desc (funcall register-preview-function elem))) + (when (equal highlight name) + (add-face-text-property 0 (length desc) 'match nil desc) + (setq hilit t)) + (when (or hilit + (null pred) + (funcall pred (cdr elem))) + (insert desc)))) + register-alist))))) + +(defun register-read-with-preview (prompt &optional confirm pred) "Read and return a register name, possibly showing existing registers. -Prompt with the string PROMPT. Optional argument CONFIRM says to -ask for confirmation if the register is already in use and -`register-confirm-overwrite' is non-nil. If `register-alist' and -`register-preview-delay' are both non-nil, display a window +Prompt with the string PROMPT. Second optional argument CONFIRM +says to ask for confirmation if the register is already in use +and `register-confirm-overwrite' is non-nil. If `register-alist' +and `register-preview-delay' are both non-nil, display a window listing existing registers after `register-preview-delay' -seconds. If `help-char' (or a member of `help-event-list') is -pressed, display such a window regardless." +seconds, or immediately in response to `help-char' (or a member +of `help-event-list'). Third optional argument PRED is a +predicate that registers must satisfy to appear in the preview, +see `register-preview'." (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)))))) + (register-preview buffer nil nil pred)))))) (help-chars (cl-loop for c in (cons help-char help-event-list) when (not (get-register c)) collect c))) @@ -182,7 +198,7 @@ pressed, display such a window regardless." (while (memq (read-key (propertize prompt 'face 'minibuffer-prompt)) help-chars) (unless (get-buffer-window buffer) - (register-preview buffer 'show-empty))) + (register-preview buffer 'show-empty nil pred))) (cond ((or (eq ?\C-g last-input-event) (eq 'escape last-input-event) @@ -190,8 +206,8 @@ pressed, display such a window regardless." (keyboard-quit)) ((and (get-register last-input-event) confirm register-confirm-overwrite - (not (progn - (register-preview buffer nil last-input-event) + (not (let ((last-input-event last-input-event)) + (register-preview buffer nil last-input-event pred) (y-or-n-p (substitute-quotes (format "Overwrite register `%s'?" (single-key-description @@ -260,6 +276,21 @@ Interactively, prompt for REGISTER using `register-read-with-preview'." (make-obsolete 'frame-configuration-to-register 'frameset-to-register "24.4") +(declare-function frameset-register-p "frameset") + +(defun register-jump-p (contents) + "Return non-nil if \\[jump-to-register] can apply to register CONTENTS." + (or (and (registerv-p contents) (registerv-jump-func contents)) + (markerp contents) + (and (consp contents) + (let ((cont (car contents))) + (or (frame-configuration-p cont) + (window-configuration-p cont) + (eq cont 'file) + (eq cont 'buffer) + (eq cont 'file-query)))) + (and (featurep 'frameset) (frameset-register-p contents)))) + (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. @@ -277,7 +308,8 @@ 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: " + nil #'register-jump-p) current-prefix-arg)) (let ((val (get-register register))) (register-val-jump-to val delete))) @@ -352,6 +384,10 @@ Interactively, prompt for REGISTER using `register-read-with-preview'." (string-to-number (match-string 0))) 0)))) +(defun register-increment-p (contents) + "Return non-nil if \\[increment-register] can apply to register CONTENTS." + (or (numberp contents) (stringp contents))) + (defun increment-register (prefix register) "Augment contents of REGISTER using PREFIX. Interactively, PREFIX is the raw prefix argument. @@ -364,7 +400,8 @@ 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: " + nil #'register-increment-p))) (let ((register-val (get-register register))) (cond ((numberp register-val) @@ -500,6 +537,11 @@ Second argument VERBOSE means produce a more detailed description." (t (princ "the empty string"))))) +(defun register-insert-p (contents) + "Return non-nil if \\[insert-register] can apply to register CONTENTS." + (or (and (registerv-p contents) (registerv-insert-func contents)) + (stringp (car (ensure-list contents))))) + (defun insert-register (register &optional arg) "Insert contents of REGISTER at point. REGISTER is a character, the name of the register. @@ -511,7 +553,8 @@ 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: " + nil #'register-insert-p) (not current-prefix-arg)))) (push-mark) (let ((val (get-register register))) @@ -576,7 +619,8 @@ 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: " + nil #'stringp) (region-beginning) (region-end) current-prefix-arg)) @@ -602,7 +646,8 @@ 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: " + nil #'stringp) (region-beginning) (region-end) current-prefix-arg)) -- 2.39.5