branch: externals/consult
commit a10d59436f087f1bc79b009cb4dfb155a7ad5dea
Author: Daniel Mendler <m...@daniel-mendler.de>
Commit: Daniel Mendler <m...@daniel-mendler.de>
consult-register: Use cl-defgeneric/cl-defmethod
---
README.org | 1 -
consult-register.el | 234 ++++++++++++++++++++++++++++++----------------------
2 files changed, 135 insertions(+), 100 deletions(-)
diff --git a/README.org b/README.org
index 21e2196e7c..cdf99d182c 100644
--- a/README.org
+++ b/README.org
@@ -952,7 +952,6 @@ configuration examples.
| consult-project-buffer-sources | List of virtual project buffer sources
|
| consult-project-root-function | Function which returns current project
root |
| consult-recent-file-filter | Filter for =consult-recent-file=
|
- | consult-register-narrow | Narrowing configuration for
=consult-register= |
| consult-register-prefix | Prefix string for register keys during
completion |
| consult-ripgrep-args | Command line arguments for ripgrep
|
| consult-themes | List of themes to be presented for
selection |
diff --git a/consult-register.el b/consult-register.el
index fe764d0845..4ac736fc66 100644
--- a/consult-register.el
+++ b/consult-register.el
@@ -30,21 +30,81 @@
:type '(choice (const nil) string)
:group 'consult)
-(defcustom consult-register-narrow
- `((?n "Number" ,#'numberp)
- (?s "String" ,#'stringp)
- (?p "Point" ,#'markerp)
- (?r "Rectangle" ,(lambda (x) (stringp (car-safe x))))
- ;; frameset-register-p and kmacro-register-p exists since 27.1
- (?t "Frameset" ,(lambda (x) (eq (type-of x) 'frameset-register)))
- (?k "Kmacro" ,(lambda (x) (eq (type-of x) 'kmacro-register)))
- (?f "File" ,(lambda (x) (memq (car-safe x) '(file file-query))))
- (?w "Window" ,(lambda (x) (window-configuration-p (car-safe x)))))
- "Register narrowing configuration.
-
-Each element of the list must have the form '(char name predicate)."
- :type '(repeat (list character string function))
- :group 'consult)
+(defvar consult-register--narrow
+ '((?n . "Number")
+ (?s . "String")
+ (?p . "Point")
+ (?r . "Rectangle")
+ (?t . "Frameset")
+ (?k . "Kmacro")
+ (?f . "File")
+ (?w . "Window"))
+ "Register type names.
+Each element of the list must have the form '(char . name).")
+
+(cl-defun consult-register--format-value (val)
+ "Format generic register VAL as string."
+ (with-output-to-string (register-val-describe val nil)))
+
+(cl-defgeneric consult-register--describe (val)
+ "Describe generic register VAL."
+ (list (consult-register--format-value val)))
+
+(cl-defmethod consult-register--describe ((val number))
+ "Describe numeric register VAL."
+ (list (consult-register--format-value val) 'consult--type ?n))
+
+(cl-defmethod consult-register--describe ((val string))
+ "Describe string register VAL."
+ (list val 'consult--type
+ (if (eq (car (get-text-property 0 'yank-handler val))
+ 'rectangle--insert-for-yank)
+ ?r ?s)))
+
+(cl-defmethod consult-register--describe ((val marker))
+ "Describe marker register VAL."
+ (with-current-buffer (marker-buffer val)
+ (save-restriction
+ (save-excursion
+ (widen)
+ (goto-char val)
+ (list
+ (consult--format-location
+ (buffer-name) (line-number-at-pos)
+ (consult--line-with-cursor val))
+ 'consult--type ?p)))))
+
+(cl-defmethod consult-register--describe ((val kmacro-register))
+ "Describe kmacro register VAL."
+ (list (consult-register--format-value val) 'consult--type ?k))
+
+(cl-defmethod consult-register--describe ((val (head file)))
+ "Describe file register VAL."
+ (list (propertize (abbreviate-file-name (cdr val)) 'face 'consult-file)
+ 'consult--type ?f 'multi-category `(file . ,(cdr val))))
+
+(cl-defmethod consult-register--describe ((val (head file-query)))
+ "Describe file-query register VAL."
+ (list (format "%s at position %d"
+ (propertize (abbreviate-file-name (cadr val))
+ 'face 'consult-file)
+ (caddr val))
+ 'consult--type ?f 'multi-category `(file . ,(cadr val))))
+
+(cl-defmethod consult-register--describe ((val cons))
+ "Describe rectangle or window-configuration register VAL."
+ (cond
+ ((stringp (car val))
+ (list (string-join val "\n") 'consult--type ?r))
+ ((window-configuration-p (car val))
+ (list (consult-register--format-value val)
+ 'consult--type ?w))
+ (t (list (consult-register--format-value val)))))
+
+(with-eval-after-load 'frameset
+ (cl-defmethod consult-register--describe ((val frameset-register))
+ "Describe frameset register VAL."
+ (list (consult-register--format-value val) 'consult--type ?t)))
;;;###autoload
(defun consult-register-window (buffer &optional show-empty)
@@ -78,41 +138,26 @@ SHOW-EMPTY must be t if the window should be shown for an
empty register list."
"Enhanced preview of register REG.
This function can be used as `register-preview-function'.
If COMPLETION is non-nil format the register for completion."
- (pcase-let ((`(,key . ,val) reg))
- (let* ((key-str (propertize (single-key-description key) 'face
'consult-key))
- (len (max 3 (length key-str))))
- (concat
- (and completion consult-register-prefix)
- key-str (make-string (- len (length key-str)) ?\s) " "
- ;; Special printing for certain register types
- (cond
- ;; Display full string
- ((or (stringp val) (stringp (car-safe val)))
- (when (consp val)
- (setq val (mapconcat #'identity val "\n")))
- (mapconcat #'identity
- (seq-take (split-string (string-trim val) "\n") 3)
- (concat "\n" (make-string len ?\s))))
- ;; Display 'file-query
- ((eq (car-safe val) 'file-query)
- (format "%s at position %d"
- (propertize (abbreviate-file-name (cadr val)) 'face
'consult-file)
- (caddr val)))
- ;; Display 'file
- ((eq (car-safe val) 'file)
- (propertize (abbreviate-file-name (cdr val)) 'face 'consult-file))
- ;; Display full line of buffer
- ((and (markerp val) (marker-buffer val))
- (with-current-buffer (marker-buffer val)
- (save-restriction
- (save-excursion
- (widen)
- (goto-char val)
- (consult--format-location (buffer-name) (line-number-at-pos)
- (consult--line-with-cursor val))))))
- ;; Default printing for the other types
- (t (register-describe-oneline key)))
- (and (not completion) "\n")))))
+ (pcase-let* ((`(,key . ,val) reg)
+ (key-str (propertize (single-key-description key) 'face
'consult-key))
+ (key-len (max 3 (length key-str)))
+ (`(,str . ,props) (consult-register--describe val)))
+ (when (string-match-p "\n" str)
+ (let* ((lines (seq-take (seq-remove #'string-blank-p (split-string str
"\n")) 3))
+ (space (apply #'min most-positive-fixnum
+ (mapcar (lambda (x) (string-match-p "[^ ]" x))
lines))))
+ (setq str (mapconcat (lambda (x) (substring x space))
+ lines (concat "\n" (make-string (1+ key-len)
?\s))))))
+ (setq str (concat
+ (and completion consult-register-prefix)
+ key-str (make-string (- key-len (length key-str)) ?\s) " "
+ str (and (not completion) "\n")))
+ (when completion
+ (add-text-properties
+ 0 (length str)
+ `(consult--candidate ,(car reg) ,@props)
+ str))
+ str))
(defun consult-register--alist (&optional noerror)
"Return sorted register list.
@@ -122,69 +167,59 @@ Raise an error if the list is empty and NOERROR is nil."
(or (sort (seq-filter #'cdr register-alist) #'car-less-than-car)
(and (not noerror) (user-error "All registers are empty"))))
-(defun consult-register--candidates ()
- "Return list of formatted register candidates."
- (mapcar (lambda (reg)
- (let ((str (consult-register-format reg 'completion)))
- (add-text-properties
- 0 (length str)
- (list 'consult--candidate (car reg)
- 'consult--type
- (car (seq-find (lambda (x) (funcall (caddr x) (cdr reg)))
- consult-register-narrow)))
- str)
- str))
- (consult-register--alist)))
-
;;;###autoload
(defun consult-register (&optional arg)
"Load register and either jump to location or insert the stored text.
-This command is useful to search the register contents. For quick access to
-registers it is still recommended to use the register functions
-`consult-register-load' and `consult-register-store' or the built-in built-in
-register access functions. The command supports narrowing, see
-`consult-register-narrow'. Marker positions are previewed. See
+This command is useful to search the register contents. For quick access
+to registers it is still recommended to use the register functions
+`consult-register-load' and `consult-register-store' or the built-in
+built-in register access functions. The command supports narrowing, see
+`consult-register--narrow'. Marker positions are previewed. See
`jump-to-register' and `insert-register' for the meaning of prefix ARG."
(interactive "P")
- (let ((narrow (mapcar (lambda (x) (cons (car x) (cadr x)))
- consult-register-narrow)))
- (consult-register-load
- (consult--read
- (consult-register--candidates)
- :prompt "Register: "
- :category 'consult-register
- :state
- (let ((preview (consult--jump-preview)))
- (lambda (cand restore)
- ;; Preview only markers
- (funcall preview
- (when-let (reg (get-register cand))
- (and (markerp reg) reg))
- restore)))
- :group (consult--type-group narrow)
- :narrow (consult--type-narrow narrow)
- :sort nil
- :require-match t
- :history t ;; disable history
- :lookup #'consult--lookup-candidate)
- arg)))
+ (consult-register-load
+ (consult--read
+ (mapcar (lambda (reg)
+ (consult-register-format reg 'completion))
+ (consult-register--alist))
+ :prompt "Register: "
+ :category 'multi-category
+ :state
+ (let ((preview (consult--jump-preview)))
+ (lambda (cand restore)
+ ;; Preview only markers
+ (funcall preview
+ (when-let (reg (get-register cand))
+ (and (markerp reg) reg))
+ restore)))
+ :group (consult--type-group consult-register--narrow)
+ :narrow (consult--type-narrow consult-register--narrow)
+ :sort nil
+ :require-match t
+ :history t ;; disable history
+ :lookup #'consult--lookup-candidate)
+ arg))
;;;###autoload
(defun consult-register-load (reg &optional arg)
"Do what I mean with a REG.
-For a window configuration, restore it. For a number or text, insert it. For a
-location, jump to it. See `jump-to-register' and `insert-register' for the
-meaning of prefix ARG."
+For a window configuration, restore it. For a number or text, insert it.
+For a location, jump to it. See `jump-to-register' and `insert-register'
+for the meaning of prefix ARG."
(interactive
(list
(and (consult-register--alist)
(register-read-with-preview "Load register: "))
current-prefix-arg))
- (condition-case nil
+ (condition-case err
(jump-to-register reg arg)
- (user-error (insert-register reg (not arg)))))
+ (user-error
+ (unless (string-match-p
+ "access aborted"
+ (error-message-string err) )
+ (insert-register reg (not arg))))))
(defun consult-register--action (action-list)
"Read register key and execute action from ACTION-LIST.
@@ -244,9 +279,10 @@ This function is derived from
`register-read-with-preview'."
(defun consult-register-store (arg)
"Store register dependent on current context, showing an action menu.
-With an active region, store/append/prepend the contents, optionally deleting
-the region when a prefix ARG is given. With a numeric prefix ARG, store/add the
-number. Otherwise store point, frameset, window or kmacro."
+With an active region, store/append/prepend the contents, optionally
+deleting the region when a prefix ARG is given. With a numeric prefix
+ARG, store or add the number. Otherwise store point, frameset, window or
+kmacro."
(interactive "P")
(consult-register--action
(cond
