embark-consult.el (19417B)
1 ;;; embark-consult.el --- Consult integration for Embark -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2021-2023 Free Software Foundation, Inc. 4 5 ;; Author: Omar Antolín Camarena <omar@matem.unam.mx> 6 ;; Maintainer: Omar Antolín Camarena <omar@matem.unam.mx> 7 ;; Keywords: convenience 8 ;; Package-Version: 20240919.1831 9 ;; Package-Revision: 718f0f293440 10 ;; Homepage: https://github.com/oantolin/embark 11 ;; Package-Requires: ((emacs "28.1") (compat "30") (embark "1.1") (consult "1.8")) 12 13 ;; This program is free software; you can redistribute it and/or modify 14 ;; it under the terms of the GNU General Public License as published by 15 ;; the Free Software Foundation, either version 3 of the License, or 16 ;; (at your option) any later version. 17 18 ;; This program is distributed in the hope that it will be useful, 19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 21 ;; GNU General Public License for more details. 22 23 ;; You should have received a copy of the GNU General Public License 24 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 25 26 ;;; Commentary: 27 28 ;; This package provides integration between Embark and Consult. The package 29 ;; will be loaded automatically by Embark. 30 31 ;; Some of the functionality here was previously contained in Embark 32 ;; itself: 33 34 ;; - Support for consult-buffer, so that you get the correct actions 35 ;; for each type of entry in consult-buffer's list. 36 37 ;; - Support for consult-line, consult-outline, consult-mark and 38 ;; consult-global-mark, so that the insert and save actions don't 39 ;; include a weird unicode character at the start of the line, and so 40 ;; you can export from them to an occur buffer (where occur-edit-mode 41 ;; works!). 42 43 ;; Just load this package to get the above functionality, no further 44 ;; configuration is necessary. 45 46 ;; Additionally this package contains some functionality that has 47 ;; never been in Embark: access to Consult preview from auto-updating 48 ;; Embark Collect buffer that is associated to an active minibuffer 49 ;; for a Consult command. For information on Consult preview, see 50 ;; Consult's info manual or its readme on GitHub. 51 52 ;; If you always want the minor mode enabled whenever it possible use: 53 54 ;; (add-hook 'embark-collect-mode-hook #'consult-preview-at-point-mode) 55 56 ;; If you don't want the minor mode automatically on and prefer to 57 ;; trigger the consult previews manually use this instead: 58 59 ;; (keymap-set embark-collect-mode-map "C-j" 60 ;; #'consult-preview-at-point) 61 62 ;;; Code: 63 64 (require 'embark) 65 (require 'consult) 66 67 (eval-when-compile 68 (require 'cl-lib)) 69 70 ;;; Consult preview from Embark Collect buffers 71 72 (defun embark-consult--collect-candidate () 73 "Return candidate at point in collect buffer." 74 (cadr (embark-target-collect-candidate))) 75 76 (add-hook 'consult--completion-candidate-hook #'embark-consult--collect-candidate) 77 78 ;;; Support for consult-location 79 80 (defun embark-consult--strip (string) 81 "Strip substrings marked with the `consult-strip' property from STRING." 82 (if (text-property-not-all 0 (length string) 'consult-strip nil string) 83 (let ((end (length string)) (pos 0) (chunks)) 84 (while (< pos end) 85 (let ((next (next-single-property-change pos 'consult-strip string end))) 86 (unless (get-text-property pos 'consult-strip string) 87 (push (substring string pos next) chunks)) 88 (setq pos next))) 89 (apply #'concat (nreverse chunks))) 90 string)) 91 92 (defun embark-consult--target-strip (type target) 93 "Remove the unicode suffix character from a TARGET of TYPE." 94 (cons type (embark-consult--strip target))) 95 96 (setf (alist-get 'consult-location embark-transformer-alist) 97 #'embark-consult--target-strip) 98 99 (defun embark-consult-goto-location (target) 100 "Jump to consult location TARGET." 101 (consult--jump (car (consult--get-location target))) 102 (pulse-momentary-highlight-one-line (point))) 103 104 (setf (alist-get 'consult-location embark-default-action-overrides) 105 #'embark-consult-goto-location) 106 107 (defun embark-consult-export-location-occur (lines) 108 "Create an occur mode buffer listing LINES. 109 The elements of LINES should be completion candidates with 110 category `consult-line'." 111 (let ((buf (generate-new-buffer "*Embark Export Occur*")) 112 (mouse-msg "mouse-2: go to this occurrence") 113 (inhibit-read-only t) 114 last-buf) 115 (with-current-buffer buf 116 (dolist (line lines) 117 (pcase-let* 118 ((`(,loc . ,num) (consult--get-location line)) 119 ;; the text properties added to the following strings are 120 ;; taken from occur-engine 121 (lineno (propertize 122 (format "%7d:" num) 123 'occur-prefix t 124 ;; Allow insertion of text at the end 125 ;; of the prefix (for Occur Edit mode). 126 'front-sticky t 127 'rear-nonsticky t 128 'read-only t 129 'occur-target loc 130 'follow-link t 131 'help-echo mouse-msg 132 'font-lock-face list-matching-lines-prefix-face 133 'mouse-face 'highlight)) 134 (contents (propertize (embark-consult--strip line) 135 'occur-target loc 136 'occur-match t 137 'follow-link t 138 'help-echo mouse-msg 139 'mouse-face 'highlight)) 140 (nl (propertize "\n" 'occur-target loc)) 141 (this-buf (marker-buffer loc))) 142 (unless (eq this-buf last-buf) 143 (insert (propertize 144 (format "lines from buffer: %s\n" this-buf) 145 'face list-matching-lines-buffer-name-face 146 'read-only t)) 147 (setq last-buf this-buf)) 148 (insert lineno contents nl))) 149 (goto-char (point-min)) 150 (occur-mode)) 151 (pop-to-buffer buf))) 152 153 (defun embark-consult-export-location-grep (lines) 154 "Create a grep mode buffer listing LINES. 155 Any LINES that come from a buffer which is not visiting a file 156 will be excluded from the grep buffer, since grep mode only works 157 with files. The elements of LINES should be completion 158 candidates with category `consult-location'. No matches will be 159 highlighted in the exported buffer, since the `consult-location' 160 candidates do not carry that information." 161 (let (non-file-buffers) 162 (embark-consult--export-grep 163 :header "Exported line search results (file-backed buffers only):\n\n" 164 :lines lines 165 :insert 166 (lambda (lines) 167 (let ((count 0)) 168 (dolist (line lines) 169 (pcase-let* ((`(,loc . ,num) (consult--get-location line)) 170 (lineno (format "%d" num)) 171 (contents (embark-consult--strip line)) 172 (buffer (marker-buffer loc)) 173 (file (buffer-file-name buffer))) 174 (if (null file) 175 (cl-pushnew buffer non-file-buffers) 176 (insert (file-relative-name file) ":" lineno ":" contents "\n") 177 (cl-incf count)))) 178 count)) 179 :footer 180 (lambda () 181 (when non-file-buffers 182 (let ((start (goto-char (point-max)))) 183 (insert "\nSome results were in buffers with no associated file" 184 " and are missing\nfrom the exported result:\n") 185 (dolist (buf non-file-buffers) 186 (insert "- " (buffer-name buf) "\n")) 187 (insert "\nEither save the buffers or use the" 188 " `embark-consult-export-location-occur'\nexporter.") 189 (message "This exporter does not support non-file buffers: %s" 190 non-file-buffers) 191 (add-text-properties 192 start (point-max) 193 '(read-only t wgrep-footer t front-sticky t)))))))) 194 195 (defun embark-consult--upgrade-markers () 196 "Upgrade consult-location cheap markers to real markers. 197 This function is meant to be added to `embark-collect-mode-hook'." 198 (when (eq embark--type 'consult-location) 199 (dolist (entry tabulated-list-entries) 200 (when (car entry) 201 (consult--get-location (car entry)))))) 202 203 ;; Set default `occur-mode' based exporter for consult-line, 204 ;; consult-line-multi, consult-outline and alike Another option is 205 ;; using grep-mode by using `embark-consult-export-location-grep' 206 (setf (alist-get 'consult-location embark-exporters-alist) 207 #'embark-consult-export-location-occur) 208 (cl-pushnew #'embark-consult--upgrade-markers embark-collect-mode-hook) 209 210 ;;; Support for consult-grep 211 212 (defvar grep-mode-line-matches) 213 (defvar grep-num-matches-found) 214 (declare-function wgrep-setup "ext:wgrep") 215 216 (defvar-keymap embark-consult-rerun-map 217 :doc "A keymap with a binding for `embark-rerun-collect-or-export'." 218 :parent nil 219 "g" #'embark-rerun-collect-or-export) 220 221 (cl-defun embark-consult--export-grep (&key header lines insert footer) 222 "Create a grep mode buffer listing LINES. 223 The HEADER string is inserted at the top of the buffer. The 224 function INSERT is called to insert the LINES and should return a 225 count of the matches (there may be more than one match per line). 226 The function FOOTER is called to insert a footer." 227 (let ((buf (generate-new-buffer "*Embark Export Grep*"))) 228 (with-current-buffer buf 229 (insert (propertize header 'wgrep-header t 'front-sticky t)) 230 (let ((count (funcall insert lines))) 231 (funcall footer) 232 (goto-char (point-min)) 233 (grep-mode) 234 (setq-local grep-num-matches-found count 235 mode-line-process grep-mode-line-matches)) 236 ;; Make this buffer current for next/previous-error 237 (setq next-error-last-buffer buf) 238 ;; Set up keymap before possible wgrep-setup, so that wgrep 239 ;; restores our binding too when the user finishes editing. 240 (use-local-map (make-composed-keymap 241 embark-consult-rerun-map 242 (current-local-map))) 243 ;; TODO Wgrep 3.0 and development versions use different names for the 244 ;; parser variable. 245 (defvar wgrep-header/footer-parser) 246 (defvar wgrep-header&footer-parser) 247 (setq-local wgrep-header/footer-parser #'ignore 248 wgrep-header&footer-parser #'ignore) 249 (when (fboundp 'wgrep-setup) (wgrep-setup))) 250 (pop-to-buffer buf))) 251 252 (defun embark-consult-export-grep (lines) 253 "Create a grep mode buffer listing LINES. 254 The elements of LINES should be completion candidates with 255 category `consult-grep'." 256 (embark-consult--export-grep 257 :header "Exported grep results:\n\n" 258 :lines lines 259 :insert 260 (lambda (lines) 261 (dolist (line lines) (insert line "\n")) 262 (goto-char (point-min)) 263 (let ((count 0) prop) 264 (while (setq prop (text-property-search-forward 265 'face 'consult-highlight-match t)) 266 (cl-incf count) 267 (put-text-property (prop-match-beginning prop) 268 (prop-match-end prop) 269 'font-lock-face 270 'match)) 271 count)) 272 :footer #'ignore)) 273 274 (defun embark-consult-goto-grep (location) 275 "Go to LOCATION, which should be a string with a grep match." 276 (consult--jump (consult--grep-position location)) 277 (pulse-momentary-highlight-one-line (point))) 278 279 (setf (alist-get 'consult-grep embark-default-action-overrides) 280 #'embark-consult-goto-grep) 281 (setf (alist-get 'consult-grep embark-exporters-alist) 282 #'embark-consult-export-grep) 283 284 ;;; Support for consult-xref 285 286 (declare-function consult-xref "ext:consult-xref") 287 (declare-function xref--show-xref-buffer "xref") 288 (declare-function xref-pop-to-location "xref") 289 (defvar xref-auto-jump-to-first-xref) 290 (defvar consult-xref--fetcher) 291 292 (defun embark-consult-export-xref (items) 293 "Create an xref buffer listing ITEMS." 294 (cl-flet ((xref-items (items) 295 (mapcar (lambda (item) (get-text-property 0 'consult-xref item)) 296 items))) 297 (let ((fetcher consult-xref--fetcher) 298 (input (minibuffer-contents))) 299 (set-buffer 300 (xref--show-xref-buffer 301 (lambda () 302 (let ((candidates (funcall fetcher))) 303 (if (null (cdr candidates)) 304 candidates 305 (catch 'xref-items 306 (minibuffer-with-setup-hook 307 (lambda () 308 (insert input) 309 (add-hook 310 'minibuffer-exit-hook 311 (lambda () 312 (throw 'xref-items 313 (xref-items 314 (or 315 (plist-get 316 (embark--maybe-transform-candidates) 317 :candidates) 318 (user-error "No candidates for export"))))) 319 nil t)) 320 (consult-xref fetcher)))))) 321 `((fetched-xrefs . ,(xref-items items)) 322 (window . ,(embark--target-window)) 323 (auto-jump . ,xref-auto-jump-to-first-xref) 324 (display-action))))))) 325 326 (setf (alist-get 'consult-xref embark-exporters-alist) 327 #'embark-consult-export-xref) 328 329 (defun embark-consult-xref (cand) 330 "Default action override for `consult-xref', open CAND xref location." 331 (xref-pop-to-location (get-text-property 0 'consult-xref cand))) 332 333 (setf (alist-get 'consult-xref embark-default-action-overrides) 334 #'embark-consult-xref) 335 336 ;;; Support for consult-find and consult-locate 337 338 (setf (alist-get '(file . consult-find) embark-default-action-overrides 339 nil nil #'equal) 340 #'find-file) 341 342 (setf (alist-get '(file . consult-locate) embark-default-action-overrides 343 nil nil #'equal) 344 #'find-file) 345 346 ;;; Support for consult-isearch-history 347 348 (setf (alist-get 'consult-isearch-history embark-transformer-alist) 349 #'embark-consult--target-strip) 350 351 ;;; Support for consult-man and consult-info 352 353 (defun embark-consult-man (cand) 354 "Default action override for `consult-man', open CAND man page." 355 (man (get-text-property 0 'consult-man cand))) 356 357 (setf (alist-get 'consult-man embark-default-action-overrides) 358 #'embark-consult-man) 359 360 (declare-function consult-info--action "ext:consult-info") 361 362 (defun embark-consult-info (cand) 363 "Default action override for `consult-info', open CAND info manual." 364 (consult-info--action cand) 365 (pulse-momentary-highlight-one-line (point))) 366 367 (setf (alist-get 'consult-info embark-default-action-overrides) 368 #'embark-consult-info) 369 370 (setf (alist-get 'consult-info embark-transformer-alist) 371 #'embark-consult--target-strip) 372 373 ;;; Bindings for consult commands in embark keymaps 374 375 (keymap-set embark-become-file+buffer-map "C b" #'consult-buffer) 376 (keymap-set embark-become-file+buffer-map "C 4 b" #'consult-buffer-other-window) 377 378 ;;; Support for Consult search commands 379 380 (defvar-keymap embark-consult-sync-search-map 381 :doc "Keymap for Consult sync search commands" 382 :parent nil 383 "o" #'consult-outline 384 "i" 'consult-imenu 385 "I" 'consult-imenu-multi 386 "l" #'consult-line 387 "L" #'consult-line-multi) 388 389 (defvar-keymap embark-consult-async-search-map 390 :doc "Keymap for Consult async search commands" 391 :parent nil 392 "g" #'consult-grep 393 "r" #'consult-ripgrep 394 "G" #'consult-git-grep 395 "f" #'consult-find 396 "F" #'consult-locate) 397 398 (defvar embark-consult-search-map 399 (keymap-canonicalize 400 (make-composed-keymap embark-consult-sync-search-map 401 embark-consult-async-search-map)) 402 "Keymap for all Consult search commands.") 403 404 (fset 'embark-consult-sync-search-map embark-consult-sync-search-map) 405 (keymap-set embark-become-match-map "C" 'embark-consult-sync-search-map) 406 407 (cl-pushnew 'embark-consult-async-search-map embark-become-keymaps) 408 409 (fset 'embark-consult-search-map embark-consult-search-map) 410 (keymap-set embark-general-map "C" 'embark-consult-search-map) 411 412 (map-keymap 413 (lambda (_key cmd) 414 (cl-pushnew 'embark--unmark-target 415 (alist-get cmd embark-pre-action-hooks)) 416 (cl-pushnew 'embark--allow-edit 417 (alist-get cmd embark-target-injection-hooks))) 418 embark-consult-search-map) 419 420 (defun embark-consult--unique-match (&rest _) 421 "If there is a unique matching candidate, accept it. 422 This is intended to be used in `embark-target-injection-hooks'." 423 (let ((candidates (cdr (embark-minibuffer-candidates)))) 424 (if (or (null candidates) (cdr candidates)) 425 (embark--allow-edit) 426 (delete-minibuffer-contents) 427 (insert (car candidates))))) 428 429 (dolist (cmd '(consult-outline consult-imenu consult-imenu-multi)) 430 (setf (alist-get cmd embark-target-injection-hooks) 431 (remq 'embark--allow-edit 432 (alist-get cmd embark-target-injection-hooks))) 433 (cl-pushnew #'embark-consult--unique-match 434 (alist-get cmd embark-target-injection-hooks))) 435 436 (cl-defun embark-consult--async-search-dwim 437 (&key action type target candidates &allow-other-keys) 438 "DWIM when using a Consult async search command as an ACTION. 439 If the TYPE of the target(s) has a notion of associated 440 file (files, buffers, libraries and some bookmarks do), then run 441 the ACTION with `consult-project-function' set to nil, and search 442 only the files associated to the TARGET or CANDIDATES. For other 443 types, run the ACTION with TARGET or CANDIDATES as initial input." 444 (if-let ((file-fn (cdr (assq type embark--associated-file-fn-alist)))) 445 (let (consult-project-function) 446 (funcall action 447 (delq nil (mapcar file-fn (or candidates (list target)))))) 448 (funcall action nil (or target (string-join candidates " "))))) 449 450 (map-keymap 451 (lambda (_key cmd) 452 (unless (eq cmd #'consult-locate) 453 (cl-pushnew cmd embark-multitarget-actions) 454 (cl-pushnew #'embark-consult--async-search-dwim 455 (alist-get cmd embark-around-action-hooks)))) 456 embark-consult-async-search-map) 457 458 ;;; Tables of contents for buffers: imenu and outline candidate collectors 459 460 (defun embark-consult-outline-candidates () 461 "Collect all outline headings in the current buffer." 462 (cons 'consult-location (consult--outline-candidates))) 463 464 (autoload 'consult-imenu--items "consult-imenu") 465 466 (defun embark-consult-imenu-candidates () 467 "Collect all imenu items in the current buffer." 468 (cons 'imenu (mapcar #'car (consult-imenu--items)))) 469 470 (declare-function consult-imenu--group "ext:consult-imenu") 471 472 (defun embark-consult--imenu-group-function (type prop) 473 "Return a suitable group-function for imenu. 474 TYPE is the completion category. 475 PROP is the metadata property. 476 Meant as :after-until advice for `embark-collect--metadatum'." 477 (when (and (eq type 'imenu) (eq prop 'group-function)) 478 (consult-imenu--group))) 479 480 (advice-add #'embark-collect--metadatum :after-until 481 #'embark-consult--imenu-group-function) 482 483 (defun embark-consult-imenu-or-outline-candidates () 484 "Collect imenu items in prog modes buffer or outline headings otherwise." 485 (if (derived-mode-p 'prog-mode) 486 (embark-consult-imenu-candidates) 487 (embark-consult-outline-candidates))) 488 489 (setf (alist-get 'imenu embark-default-action-overrides) 'consult-imenu) 490 491 (add-to-list 'embark-candidate-collectors 492 #'embark-consult-imenu-or-outline-candidates 493 'append) 494 495 (provide 'embark-consult) 496 ;;; embark-consult.el ends here