[elpa] externals/consult a10d59436f 1/2: consult-register: Use cl-defgeneric/cl-defmethod

[ELPA Syncer]

branch: externals/consult
commit a10d59436f087f1bc79b009cb4dfb155a7ad5dea
Author: Daniel Mendler <mail@daniel-mendler.de>
Commit: Daniel Mendler <mail@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