consult-register.el (13628B)
1 ;;; consult-register.el --- Consult commands for registers -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2021-2024 Free Software Foundation, Inc. 4 5 ;; This file is part of GNU Emacs. 6 7 ;; This program is free software: you can redistribute it and/or modify 8 ;; it under the terms of the GNU General Public License as published by 9 ;; the Free Software Foundation, either version 3 of the License, or 10 ;; (at your option) any later version. 11 12 ;; This program is distributed in the hope that it will be useful, 13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;; GNU General Public License for more details. 16 17 ;; You should have received a copy of the GNU General Public License 18 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 19 20 ;;; Commentary: 21 22 ;; Provides register-related Consult commands. 23 24 ;;; Code: 25 26 (require 'consult) 27 (require 'kmacro) 28 29 (defcustom consult-register-prefix #("#" 0 1 (face consult-key)) 30 "Prepend prefix in front of register keys during completion." 31 :type '(choice (const nil) string) 32 :group 'consult) 33 34 (defvar consult-register--narrow 35 '((?n . "Number") 36 (?s . "String") 37 (?p . "Point") 38 (?r . "Rectangle") 39 (?t . "Frameset") 40 (?k . "Kmacro") 41 (?f . "File") 42 (?b . "Buffer") 43 (?w . "Window")) 44 "Register type names. 45 Each element of the list must have the form (char . name).") 46 47 (cl-defun consult-register--format-value (val) 48 "Format generic register VAL as string." 49 (with-output-to-string (register-val-describe val nil))) 50 51 (cl-defgeneric consult-register--describe (val) 52 "Describe generic register VAL." 53 (list (consult-register--format-value val))) 54 55 (cl-defmethod consult-register--describe ((val number)) 56 "Describe numeric register VAL." 57 (list (consult-register--format-value val) 'consult--type ?n)) 58 59 (cl-defmethod consult-register--describe ((val string)) 60 "Describe string register VAL." 61 (list val 'consult--type 62 (if (eq (car (get-text-property 0 'yank-handler val)) 63 'rectangle--insert-for-yank) 64 ?r ?s))) 65 66 (cl-defmethod consult-register--describe ((val marker)) 67 "Describe marker register VAL." 68 (with-current-buffer (marker-buffer val) 69 (save-excursion 70 (without-restriction 71 (goto-char val) 72 (let* ((line (line-number-at-pos)) 73 (str (propertize (consult--line-with-mark val) 74 'consult-location (cons val line)))) 75 (list (consult--format-file-line-match (buffer-name) line str) 76 'multi-category `(consult-location . ,str) 77 'consult--type ?p)))))) 78 79 (defmacro consult-register--describe-kmacro () 80 "Generate method which describes kmacro register." 81 `(cl-defmethod consult-register--describe ((val ,(if (< emacs-major-version 30) 'kmacro-register 'kmacro))) 82 (list (consult-register--format-value val) 'consult--type ?k))) 83 (consult-register--describe-kmacro) 84 85 (cl-defmethod consult-register--describe ((val (head file))) 86 "Describe file register VAL." 87 (list (propertize (abbreviate-file-name (cdr val)) 'face 'consult-file) 88 'consult--type ?f 'multi-category `(file . ,(cdr val)))) 89 90 (cl-defmethod consult-register--describe ((val (head buffer))) 91 "Describe buffer register VAL." 92 (list (propertize (cdr val) 'face 'consult-buffer) 93 'consult--type ?f 'multi-category `(buffer . ,(cdr val)))) 94 95 (cl-defmethod consult-register--describe ((val (head file-query))) 96 "Describe file-query register VAL." 97 (list (format "%s at position %d" 98 (propertize (abbreviate-file-name (cadr val)) 99 'face 'consult-file) 100 (caddr val)) 101 'consult--type ?f 'multi-category `(file . ,(cadr val)))) 102 103 (cl-defmethod consult-register--describe ((val cons)) 104 "Describe rectangle or window-configuration register VAL." 105 (cond 106 ((stringp (car val)) 107 (list (string-join val "\n") 'consult--type ?r)) 108 ((window-configuration-p (car val)) 109 (list (consult-register--format-value val) 110 'consult--type ?w)) 111 (t (list (consult-register--format-value val))))) 112 113 (with-eval-after-load 'frameset 114 (cl-defmethod consult-register--describe ((val frameset-register)) 115 "Describe frameset register VAL." 116 (list (consult-register--format-value val) 'consult--type ?t))) 117 118 ;;;###autoload 119 (defun consult-register-window (buffer &optional show-empty) 120 "Enhanced drop-in replacement for `register-preview'. 121 122 BUFFER is the window buffer. 123 SHOW-EMPTY must be t if the window should be shown for an empty register list." 124 (let ((regs (consult-register--alist 'noerror)) 125 (separator 126 (and (display-graphic-p) 127 (propertize #(" \n" 0 1 (display (space :align-to right))) 128 'face '(:inherit consult-separator :height 1 :underline t))))) 129 (when (or show-empty regs) 130 (with-current-buffer-window buffer 131 (cons 'display-buffer-at-bottom 132 '((window-height . fit-window-to-buffer) 133 (preserve-size . (nil . t)))) 134 nil 135 (setq-local cursor-in-non-selected-windows nil 136 mode-line-format nil 137 truncate-lines t 138 window-min-height 1 139 window-resize-pixelwise t) 140 (insert (mapconcat 141 (lambda (reg) 142 (concat (funcall register-preview-function reg) separator)) 143 regs nil)))))) 144 145 ;;;###autoload 146 (defun consult-register-format (reg &optional completion) 147 "Enhanced preview of register REG. 148 This function can be used as `register-preview-function'. 149 If COMPLETION is non-nil format the register for completion." 150 (pcase-let* ((`(,key . ,val) reg) 151 (key-str (propertize (single-key-description key) 'face 'consult-key)) 152 (key-len (max 3 (length key-str))) 153 (`(,str . ,props) (consult-register--describe val))) 154 (when (string-search "\n" str) 155 (let* ((lines (seq-take (seq-remove #'string-blank-p (split-string str "\n")) 3)) 156 (space (cl-loop for x in lines minimize (string-match-p "[^ ]" x)))) 157 (setq str (mapconcat (lambda (x) (substring x space)) 158 lines (concat "\n" (make-string (1+ key-len) ?\s)))))) 159 (setq str (concat 160 (and completion consult-register-prefix) 161 key-str (make-string (- key-len (length key-str)) ?\s) " " 162 str (and (not completion) "\n"))) 163 (when completion 164 (add-text-properties 165 0 (length str) 166 `(consult--candidate ,(car reg) ,@props) 167 str)) 168 str)) 169 170 (defun consult-register--alist (&optional noerror filter) 171 "Return register list, sorted and filtered with FILTER. 172 Raise an error if the list is empty and NOERROR is nil." 173 (or (sort (cl-loop for reg in register-alist 174 ;; Sometimes, registers are made without a `cdr' or with 175 ;; invalid markers. Such registers don't do anything, and 176 ;; can be ignored. 177 if (and (cdr reg) 178 (or (not (markerp (cdr reg))) (marker-buffer (cdr reg))) 179 (or (not filter) (funcall filter reg))) 180 collect reg) 181 #'car-less-than-car) 182 (and (not noerror) (user-error "All registers are empty")))) 183 184 (defun consult-register--candidates (&optional filter) 185 "Return formatted completion candidates, filtered with FILTER." 186 (mapcar (lambda (reg) (consult-register-format reg 'completion)) 187 (consult-register--alist nil filter))) 188 189 ;;;###autoload 190 (defun consult-register (&optional arg) 191 "Load register and either jump to location or insert the stored text. 192 193 This command is useful to search the register contents. For quick access 194 to registers it is still recommended to use the register functions 195 `consult-register-load' and `consult-register-store' or the built-in 196 built-in register access functions. The command supports narrowing, see 197 `consult-register--narrow'. Marker positions are previewed. See 198 `jump-to-register' and `insert-register' for the meaning of prefix ARG." 199 (interactive "P") 200 (consult-register-load 201 (consult--read 202 (consult-register--candidates) 203 :prompt "Register: " 204 :category 'multi-category 205 :state 206 (let ((preview (consult--jump-preview))) 207 (lambda (action cand) 208 ;; Preview only markers 209 (funcall preview action 210 (when-let (reg (get-register cand)) 211 (and (markerp reg) reg))))) 212 :group (consult--type-group consult-register--narrow) 213 :narrow (consult--type-narrow consult-register--narrow) 214 :sort nil 215 :require-match t 216 :history t ;; disable history 217 :lookup #'consult--lookup-candidate) 218 arg)) 219 220 ;;;###autoload 221 (defun consult-register-load (reg &optional arg) 222 "Do what I mean with a REG. 223 224 For a window configuration, restore it. For a number or text, insert it. 225 For a location, jump to it. See `jump-to-register' and `insert-register' 226 for the meaning of prefix ARG." 227 (interactive 228 (list 229 (and (consult-register--alist) 230 (register-read-with-preview "Load register: ")) 231 current-prefix-arg)) 232 (condition-case err 233 (jump-to-register reg arg) 234 (user-error 235 (unless (string-search "access aborted" (error-message-string err)) 236 (insert-register reg (not arg)))))) 237 238 (defun consult-register--action (action-list) 239 "Read register key and execute action from ACTION-LIST. 240 241 This function is derived from `register-read-with-preview'." 242 (let* ((buffer "*Register Preview*") 243 (prefix (car action-list)) 244 (action-list (cdr action-list)) 245 (action (car (nth 0 action-list))) 246 (preview 247 (lambda () 248 (unless (get-buffer-window buffer) 249 (register-preview buffer 'show-empty) 250 (when-let (win (get-buffer-window buffer)) 251 (with-selected-window win 252 (let ((inhibit-read-only t)) 253 (goto-char (point-max)) 254 (insert 255 (propertize (concat prefix ": ") 'face 'consult-help) 256 (mapconcat 257 (lambda (x) 258 (concat (propertize (format "M-%c" (car x)) 'face 'consult-key) 259 " " (propertize (cadr x) 'face 'consult-help))) 260 action-list " ")) 261 (fit-window-to-buffer))))))) 262 (timer (when (numberp register-preview-delay) 263 (run-at-time register-preview-delay nil preview))) 264 (help-chars (seq-remove #'get-register (cons help-char help-event-list))) 265 key reg) 266 (unwind-protect 267 (while (not reg) 268 (while (memq (setq key 269 (read-key (propertize (caddr (assq action action-list)) 270 'face 'minibuffer-prompt))) 271 help-chars) 272 (funcall preview)) 273 (setq key (if (and (eql key ?\e) (characterp last-input-event)) 274 ;; in terminal Emacs M-letter is read as two keys, ESC and the letter, 275 ;; use what would have been read in graphical Emacs 276 (logior #x8000000 last-input-event) 277 last-input-event)) 278 (cond 279 ((or (eq ?\C-g key) 280 (eq 'escape key) 281 (eq ?\C-\[ key)) 282 (keyboard-quit)) 283 ((and (numberp key) (assq (logxor #x8000000 key) action-list)) 284 (setq action (logxor #x8000000 key))) 285 ((characterp key) 286 (setq reg key)) 287 (t (user-error "Non-character input")))) 288 (when (timerp timer) 289 (cancel-timer timer)) 290 (let ((w (get-buffer-window buffer))) 291 (when (window-live-p w) 292 (delete-window w))) 293 (when (get-buffer buffer) 294 (kill-buffer buffer))) 295 (when reg 296 (funcall (cadddr (assq action action-list)) reg)))) 297 298 ;;;###autoload 299 (defun consult-register-store (arg) 300 "Store register dependent on current context, showing an action menu. 301 302 With an active region, store/append/prepend the contents, optionally 303 deleting the region when a prefix ARG is given. With a numeric prefix 304 ARG, store or add the number. Otherwise store point, frameset, window or 305 kmacro." 306 (interactive "P") 307 (consult-register--action 308 (cond 309 ((use-region-p) 310 (let ((beg (region-beginning)) 311 (end (region-end))) 312 `("Region" 313 (?c "copy" "Copy region to register: " ,(lambda (r) (copy-to-register r beg end arg t))) 314 (?a "append" "Append region to register: " ,(lambda (r) (append-to-register r beg end arg))) 315 (?p "prepend" "Prepend region to register: " ,(lambda (r) (prepend-to-register r beg end arg)))))) 316 ((numberp arg) 317 `(,(format "Number %s" arg) 318 (?s "store" ,(format "Store %s in register: " arg) ,(lambda (r) (number-to-register arg r))) 319 (?a "add" ,(format "Add %s to register: " arg) ,(lambda (r) (increment-register arg r))))) 320 (t 321 `("Store" 322 (?p "point" "Point to register: " ,#'point-to-register) 323 (?f "file" "File to register: " ,(lambda (r) (set-register r `(file . ,(buffer-file-name))))) 324 (?t "frameset" "Frameset to register: " ,#'frameset-to-register) 325 (?w "window" "Window to register: " ,#'window-configuration-to-register) 326 ,@(and last-kbd-macro `((?k "kmacro" "Kmacro to register: " ,#'kmacro-to-register)))))))) 327 328 (provide 'consult-register) 329 ;;; consult-register.el ends here