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