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