From: Thierry Volpiatto Date: Sun, 19 Nov 2023 19:42:56 +0000 (+0100) Subject: Improve register-preview (Fix bug#66394) X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=589e6ae1fb983bfba42f20906773555037246e45;p=emacs.git Improve register-preview (Fix bug#66394) A minibuffer is used now instead of read-key. Registers in preview buffer are now filtered according to type of registers the current command requires. Navigation with C-n/p or up/down is now provided and update minibuffer. Current register is highlighted in preview buffer. * lisp/register.el: (register-preview-default-keys) (register-use-preview): New user variables. (register-preview-info): New structure to store various info for preview. (register-command-info): New generic. (register-preview-forward-line): New, provide navigation in preview buffer. (register-preview-next, register-preview-previous): New, navigation. (register-type): New, returns register type. (register--type): Generic fn, new, returns register type according to value. (register-of-type-alist): New, filter register-alist according to type. (register-preview): Signature changed, use TYPES now. (register-preview-get-defaults): New generic, compute defauts according to action. (register-read-with-preview): Now use read-from-minibuffer and minibuffer-setup-hook. * lisp/emacs-lisp/cl-generic.el: Add a call to 'cl--generic-prefill-dispatchers' to fix a build error. --- diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 56eb83e6f75..0ef0d1e192a 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1379,6 +1379,7 @@ See the full list and their hierarchy in `cl--typeof-types'." (cl--generic-prefill-dispatchers 0 integer) (cl--generic-prefill-dispatchers 1 integer) (cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer) +(cl--generic-prefill-dispatchers 0 (eql 'x) integer) ;;; Dispatch on major mode. diff --git a/lisp/register.el b/lisp/register.el index ca6de450993..61bef503f91 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 (buffer &optional show-empty types) "Pop up a window showing the registers preview in BUFFER. If SHOW-EMPTY is non-nil, show the window even if no registers. +Argument TYPES (a list) specify the types of register to show, when nil show all +registers, see `register-type' for suitable types. Format of each entry is controlled by the variable `register-preview-function'." - (when (or show-empty (consp register-alist)) - (with-current-buffer-window - buffer - (cons 'display-buffer-below-selected - '((window-height . fit-window-to-buffer) - (preserve-size . (nil . t)))) - nil - (with-current-buffer standard-output - (setq cursor-in-non-selected-windows nil) - (mapc (lambda (elem) - (when (get-register (car elem)) - (insert (funcall register-preview-function elem)))) - register-alist))))) + (let ((registers (register-of-type-alist (or types '(all))))) + (when (or show-empty (consp registers)) + (with-current-buffer-window + buffer + (cons 'display-buffer-below-selected + '((window-height . fit-window-to-buffer) + (preserve-size . (nil . t)))) + nil + (with-current-buffer standard-output + (setq cursor-in-non-selected-windows nil) + (mapc (lambda (elem) + (when (get-register (car elem)) + (insert (funcall register-preview-function elem)))) + registers)))))) + +(cl-defgeneric register-preview-get-defaults (action) + "Returns default registers according to ACTION." + (ignore action)) +(cl-defmethod register-preview-get-defaults ((_action (eql set))) + (cl-loop for s in register-preview-default-keys + unless (assoc (string-to-char s) register-alist) + collect s)) (defun register-read-with-preview (prompt) "Read and return a register name, possibly showing existing registers. -Prompt with the string PROMPT. If `register-alist' and -`register-preview-delay' are both non-nil, display a window -listing existing registers after `register-preview-delay' seconds. +Prompt with the string PROMPT. If `help-char' (or a member of `help-event-list') is pressed, display such a window regardless." (let* ((buffer "*Register Preview*") - (timer (when (numberp register-preview-delay) - (run-with-timer register-preview-delay nil - (lambda () - (unless (get-buffer-window buffer) - (register-preview buffer)))))) - (help-chars (cl-loop for c in (cons help-char help-event-list) - when (not (get-register c)) - collect c))) + (pat "") + (map (let ((m (make-sparse-keymap))) + (set-keymap-parent m minibuffer-local-map) + m)) + (data (register-command-info this-command)) + types msg result timer act win strs smatch) + (if data + (setq types (register-preview-info-types data) + msg (register-preview-info-msg data) + act (register-preview-info-act data) + smatch (register-preview-info-smatch data)) + (setq types '(all) + msg "Overwrite register `%s'" + act 'set)) + (setq strs (mapcar (lambda (x) + (string (car x))) + (register-of-type-alist types))) + (when (and (memq act '(insert jump view)) (null strs)) + (error "No register suitable for `%s'" act)) + (dolist (k (cons help-char help-event-list)) + (define-key map + (vector k) (lambda () + (interactive) + (unless (get-buffer-window buffer) + (with-selected-window (minibuffer-selected-window) + (register-preview buffer 'show-empty types)))))) + (define-key map (kbd "") '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 (null register-use-preview)) + (register-preview buffer nil types)) (unwind-protect - (progn - (while (memq (read-key (propertize prompt 'face 'minibuffer-prompt)) - help-chars) - (unless (get-buffer-window buffer) - (register-preview buffer 'show-empty))) - (when (or (eq ?\C-g last-input-event) - (eq 'escape last-input-event) - (eq ?\C-\[ last-input-event)) - (keyboard-quit)) - (if (characterp last-input-event) last-input-event - (error "Non-character input-event"))) - (and (timerp timer) (cancel-timer timer)) + (progn + (minibuffer-with-setup-hook + (lambda () + (setq timer + (run-with-idle-timer + 0.01 'repeat + (lambda () + (with-selected-window (minibuffer-window) + (let ((input (minibuffer-contents))) + (when (> (length input) 1) + (let ((new (substring input 1)) + (old (substring input 0 1))) + (setq input (if (or (null smatch) + (member new strs)) + new old)) + (delete-minibuffer-contents) + (insert input))) + (when (and smatch (not (string= input "")) + (not (member input strs))) + (setq input "") + (delete-minibuffer-contents) + (minibuffer-message "Not matching")) + (when (not (string= input pat)) + (setq pat input)))) + (if (setq win (get-buffer-window buffer)) + (with-selected-window win + (let ((ov (make-overlay (point-min) (point-min)))) + (goto-char (point-min)) + (remove-overlays) + (unless (string= pat "") + (if (re-search-forward (concat "^" pat) nil t) + (progn (move-overlay + ov + (match-beginning 0) (pos-eol)) + (overlay-put ov 'face 'match) + (when msg + (with-selected-window (minibuffer-window) + (minibuffer-message msg pat)))) + (with-selected-window (minibuffer-window) + (minibuffer-message + "Register `%s' is empty" pat)))))) + (unless (string= pat "") + (if (member pat strs) + (with-selected-window (minibuffer-window) + (minibuffer-message msg pat)) + (with-selected-window (minibuffer-window) + (minibuffer-message + "Register `%s' is empty" pat))))))))) + (setq result (read-from-minibuffer + prompt nil map nil nil (register-preview-get-defaults act)))) + (cl-assert (and result (not (string= result ""))) + nil "No register specified") + (string-to-char result)) + (when timer (cancel-timer timer)) (let ((w (get-buffer-window buffer))) (and (window-live-p w) (delete-window w))) (and (get-buffer buffer) (kill-buffer buffer)))))