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