consult-register.el (13474B)
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 (apply #'min most-positive-fixnum 157 (mapcar (lambda (x) (string-match-p "[^ ]" x)) lines)))) 158 (setq str (mapconcat (lambda (x) (substring x space)) 159 lines (concat "\n" (make-string (1+ key-len) ?\s)))))) 160 (setq str (concat 161 (and completion consult-register-prefix) 162 key-str (make-string (- key-len (length key-str)) ?\s) " " 163 str (and (not completion) "\n"))) 164 (when completion 165 (add-text-properties 166 0 (length str) 167 `(consult--candidate ,(car reg) ,@props) 168 str)) 169 str)) 170 171 (defun consult-register--alist (&optional noerror filter) 172 "Return register list, sorted and filtered with FILTER. 173 Raise an error if the list is empty and NOERROR is nil." 174 (or (sort (seq-filter 175 ;; Sometimes, registers are made without a `cdr'. 176 ;; Such registers don't do anything, and can be ignored. 177 (lambda (x) (and (cdr x) (or (not filter) (funcall filter x)))) 178 register-alist) 179 #'car-less-than-car) 180 (and (not noerror) (user-error "All registers are empty")))) 181 182 (defun consult-register--candidates (&optional filter) 183 "Return formatted completion candidates, filtered with FILTER." 184 (mapcar (lambda (reg) (consult-register-format reg 'completion)) 185 (consult-register--alist nil filter))) 186 187 ;;;###autoload 188 (defun consult-register (&optional arg) 189 "Load register and either jump to location or insert the stored text. 190 191 This command is useful to search the register contents. For quick access 192 to registers it is still recommended to use the register functions 193 `consult-register-load' and `consult-register-store' or the built-in 194 built-in register access functions. The command supports narrowing, see 195 `consult-register--narrow'. Marker positions are previewed. See 196 `jump-to-register' and `insert-register' for the meaning of prefix ARG." 197 (interactive "P") 198 (consult-register-load 199 (consult--read 200 (consult-register--candidates) 201 :prompt "Register: " 202 :category 'multi-category 203 :state 204 (let ((preview (consult--jump-preview))) 205 (lambda (action cand) 206 ;; Preview only markers 207 (funcall preview action 208 (when-let (reg (get-register cand)) 209 (and (markerp reg) reg))))) 210 :group (consult--type-group consult-register--narrow) 211 :narrow (consult--type-narrow consult-register--narrow) 212 :sort nil 213 :require-match t 214 :history t ;; disable history 215 :lookup #'consult--lookup-candidate) 216 arg)) 217 218 ;;;###autoload 219 (defun consult-register-load (reg &optional arg) 220 "Do what I mean with a REG. 221 222 For a window configuration, restore it. For a number or text, insert it. 223 For a location, jump to it. See `jump-to-register' and `insert-register' 224 for the meaning of prefix ARG." 225 (interactive 226 (list 227 (and (consult-register--alist) 228 (register-read-with-preview "Load register: ")) 229 current-prefix-arg)) 230 (condition-case err 231 (jump-to-register reg arg) 232 (user-error 233 (unless (string-search "access aborted" (error-message-string err)) 234 (insert-register reg (not arg)))))) 235 236 (defun consult-register--action (action-list) 237 "Read register key and execute action from ACTION-LIST. 238 239 This function is derived from `register-read-with-preview'." 240 (let* ((buffer "*Register Preview*") 241 (prefix (car action-list)) 242 (action-list (cdr action-list)) 243 (action (car (nth 0 action-list))) 244 (preview 245 (lambda () 246 (unless (get-buffer-window buffer) 247 (register-preview buffer 'show-empty) 248 (when-let (win (get-buffer-window buffer)) 249 (with-selected-window win 250 (let ((inhibit-read-only t)) 251 (goto-char (point-max)) 252 (insert 253 (propertize (concat prefix ": ") 'face 'consult-help) 254 (mapconcat 255 (lambda (x) 256 (concat (propertize (format "M-%c" (car x)) 'face 'consult-key) 257 " " (propertize (cadr x) 'face 'consult-help))) 258 action-list " ")) 259 (fit-window-to-buffer))))))) 260 (timer (when (numberp register-preview-delay) 261 (run-at-time register-preview-delay nil preview))) 262 (help-chars (seq-remove #'get-register (cons help-char help-event-list))) 263 key reg) 264 (unwind-protect 265 (while (not reg) 266 (while (memq (setq key 267 (read-key (propertize (caddr (assq action action-list)) 268 'face 'minibuffer-prompt))) 269 help-chars) 270 (funcall preview)) 271 (setq key (if (and (eql key ?\e) (characterp last-input-event)) 272 ;; in terminal Emacs M-letter is read as two keys, ESC and the letter, 273 ;; use what would have been read in graphical Emacs 274 (logior #x8000000 last-input-event) 275 last-input-event)) 276 (cond 277 ((or (eq ?\C-g key) 278 (eq 'escape key) 279 (eq ?\C-\[ key)) 280 (keyboard-quit)) 281 ((and (numberp key) (assq (logxor #x8000000 key) action-list)) 282 (setq action (logxor #x8000000 key))) 283 ((characterp key) 284 (setq reg key)) 285 (t (user-error "Non-character input")))) 286 (when (timerp timer) 287 (cancel-timer timer)) 288 (let ((w (get-buffer-window buffer))) 289 (when (window-live-p w) 290 (delete-window w))) 291 (when (get-buffer buffer) 292 (kill-buffer buffer))) 293 (when reg 294 (funcall (cadddr (assq action action-list)) reg)))) 295 296 ;;;###autoload 297 (defun consult-register-store (arg) 298 "Store register dependent on current context, showing an action menu. 299 300 With an active region, store/append/prepend the contents, optionally 301 deleting the region when a prefix ARG is given. With a numeric prefix 302 ARG, store or add the number. Otherwise store point, frameset, window or 303 kmacro." 304 (interactive "P") 305 (consult-register--action 306 (cond 307 ((use-region-p) 308 (let ((beg (region-beginning)) 309 (end (region-end))) 310 `("Region" 311 (?c "copy" "Copy region to register: " ,(lambda (r) (copy-to-register r beg end arg t))) 312 (?a "append" "Append region to register: " ,(lambda (r) (append-to-register r beg end arg))) 313 (?p "prepend" "Prepend region to register: " ,(lambda (r) (prepend-to-register r beg end arg)))))) 314 ((numberp arg) 315 `(,(format "Number %s" arg) 316 (?s "store" ,(format "Store %s in register: " arg) ,(lambda (r) (number-to-register arg r))) 317 (?a "add" ,(format "Add %s to register: " arg) ,(lambda (r) (increment-register arg r))))) 318 (t 319 `("Store" 320 (?p "point" "Point to register: " ,#'point-to-register) 321 (?f "file" "File to register: " ,(lambda (r) (set-register r `(file . ,(buffer-file-name))))) 322 (?t "frameset" "Frameset to register: " ,#'frameset-to-register) 323 (?w "window" "Window to register: " ,#'window-configuration-to-register) 324 ,@(and last-kbd-macro `((?k "kmacro" "Kmacro to register: " ,#'kmacro-to-register)))))))) 325 326 (provide 'consult-register) 327 ;;; consult-register.el ends here