embark-consult.el (19059B)
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 "29.1.4.0") (embark "1.0") (consult "1.0")) 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 xref--show-xref-buffer "ext:xref") 286 (declare-function consult-xref "ext:consult-xref") 287 (defvar xref-auto-jump-to-first-xref) 288 (defvar consult-xref--fetcher) 289 290 (defun embark-consult-export-xref (items) 291 "Create an xref buffer listing ITEMS." 292 (cl-flet ((xref-items (items) 293 (mapcar (lambda (item) (get-text-property 0 'consult-xref item)) 294 items))) 295 (let ((fetcher consult-xref--fetcher) 296 (input (minibuffer-contents))) 297 (set-buffer 298 (xref--show-xref-buffer 299 (lambda () 300 (let ((candidates (funcall fetcher))) 301 (if (null (cdr candidates)) 302 candidates 303 (catch 'xref-items 304 (minibuffer-with-setup-hook 305 (lambda () 306 (insert input) 307 (add-hook 308 'minibuffer-exit-hook 309 (lambda () 310 (throw 'xref-items 311 (xref-items 312 (or 313 (plist-get 314 (embark--maybe-transform-candidates) 315 :candidates) 316 (user-error "No candidates for export"))))) 317 nil t)) 318 (consult-xref fetcher)))))) 319 `((fetched-xrefs . ,(xref-items items)) 320 (window . ,(embark--target-window)) 321 (auto-jump . ,xref-auto-jump-to-first-xref) 322 (display-action))))))) 323 324 (setf (alist-get 'consult-xref embark-exporters-alist) 325 #'embark-consult-export-xref) 326 327 ;;; Support for consult-find and consult-locate 328 329 (setf (alist-get '(file . consult-find) embark-default-action-overrides 330 nil nil #'equal) 331 #'find-file) 332 333 (setf (alist-get '(file . consult-locate) embark-default-action-overrides 334 nil nil #'equal) 335 #'find-file) 336 337 ;;; Support for consult-isearch-history 338 339 (setf (alist-get 'consult-isearch-history embark-transformer-alist) 340 #'embark-consult--target-strip) 341 342 ;;; Support for consult-man and consult-info 343 344 (defun embark-consult-man (cand) 345 "Default action override for `consult-man', open CAND man page." 346 (man (get-text-property 0 'consult-man cand))) 347 348 (setf (alist-get 'consult-man embark-default-action-overrides) 349 #'embark-consult-man) 350 351 (declare-function consult-info--action "ext:consult-info") 352 353 (defun embark-consult-info (cand) 354 "Default action override for `consult-info', open CAND info manual." 355 (consult-info--action cand) 356 (pulse-momentary-highlight-one-line (point))) 357 358 (setf (alist-get 'consult-info embark-default-action-overrides) 359 #'embark-consult-info) 360 361 (setf (alist-get 'consult-info embark-transformer-alist) 362 #'embark-consult--target-strip) 363 364 ;;; Bindings for consult commands in embark keymaps 365 366 (keymap-set embark-become-file+buffer-map "C b" #'consult-buffer) 367 (keymap-set embark-become-file+buffer-map "C 4 b" #'consult-buffer-other-window) 368 369 ;;; Support for Consult search commands 370 371 (defvar-keymap embark-consult-sync-search-map 372 :doc "Keymap for Consult sync search commands" 373 :parent nil 374 "o" #'consult-outline 375 "i" 'consult-imenu 376 "I" 'consult-imenu-multi 377 "l" #'consult-line 378 "L" #'consult-line-multi) 379 380 (defvar-keymap embark-consult-async-search-map 381 :doc "Keymap for Consult async search commands" 382 :parent nil 383 "g" #'consult-grep 384 "r" #'consult-ripgrep 385 "G" #'consult-git-grep 386 "f" #'consult-find 387 "F" #'consult-locate) 388 389 (defvar embark-consult-search-map 390 (keymap-canonicalize 391 (make-composed-keymap embark-consult-sync-search-map 392 embark-consult-async-search-map)) 393 "Keymap for all Consult search commands.") 394 395 (fset 'embark-consult-sync-search-map embark-consult-sync-search-map) 396 (keymap-set embark-become-match-map "C" 'embark-consult-sync-search-map) 397 398 (cl-pushnew 'embark-consult-async-search-map embark-become-keymaps) 399 400 (fset 'embark-consult-search-map embark-consult-search-map) 401 (keymap-set embark-general-map "C" 'embark-consult-search-map) 402 403 (map-keymap 404 (lambda (_key cmd) 405 (cl-pushnew 'embark--unmark-target 406 (alist-get cmd embark-pre-action-hooks)) 407 (cl-pushnew 'embark--allow-edit 408 (alist-get cmd embark-target-injection-hooks))) 409 embark-consult-search-map) 410 411 (defun embark-consult--unique-match (&rest _) 412 "If there is a unique matching candidate, accept it. 413 This is intended to be used in `embark-target-injection-hooks'." 414 (let ((candidates (cdr (embark-minibuffer-candidates)))) 415 (if (or (null candidates) (cdr candidates)) 416 (embark--allow-edit) 417 (delete-minibuffer-contents) 418 (insert (car candidates))))) 419 420 (dolist (cmd '(consult-outline consult-imenu consult-imenu-multi)) 421 (setf (alist-get cmd embark-target-injection-hooks) 422 (remq 'embark--allow-edit 423 (alist-get cmd embark-target-injection-hooks))) 424 (cl-pushnew #'embark-consult--unique-match 425 (alist-get cmd embark-target-injection-hooks))) 426 427 (cl-defun embark-consult--async-search-dwim 428 (&key action type target candidates &allow-other-keys) 429 "DWIM when using a Consult async search command as an ACTION. 430 If the TYPE of the target(s) has a notion of associated 431 file (files, buffers, libraries and some bookmarks do), then run 432 the ACTION with `consult-project-function' set to nil, and search 433 only the files associated to the TARGET or CANDIDATES. For other 434 types, run the ACTION with TARGET or CANDIDATES as initial input." 435 (if-let ((file-fn (cdr (assq type embark--associated-file-fn-alist)))) 436 (let (consult-project-function) 437 (funcall action 438 (delq nil (mapcar file-fn (or candidates (list target)))))) 439 (funcall action nil (or target (string-join candidates " "))))) 440 441 (map-keymap 442 (lambda (_key cmd) 443 (unless (eq cmd #'consult-locate) 444 (cl-pushnew cmd embark-multitarget-actions) 445 (cl-pushnew #'embark-consult--async-search-dwim 446 (alist-get cmd embark-around-action-hooks)))) 447 embark-consult-async-search-map) 448 449 ;;; Tables of contents for buffers: imenu and outline candidate collectors 450 451 (defun embark-consult-outline-candidates () 452 "Collect all outline headings in the current buffer." 453 (cons 'consult-location (consult--outline-candidates))) 454 455 (autoload 'consult-imenu--items "consult-imenu") 456 457 (defun embark-consult-imenu-candidates () 458 "Collect all imenu items in the current buffer." 459 (cons 'imenu (mapcar #'car (consult-imenu--items)))) 460 461 (declare-function consult-imenu--group "ext:consult-imenu") 462 463 (defun embark-consult--imenu-group-function (type prop) 464 "Return a suitable group-function for imenu. 465 TYPE is the completion category. 466 PROP is the metadata property. 467 Meant as :after-until advice for `embark-collect--metadatum'." 468 (when (and (eq type 'imenu) (eq prop 'group-function)) 469 (consult-imenu--group))) 470 471 (advice-add #'embark-collect--metadatum :after-until 472 #'embark-consult--imenu-group-function) 473 474 (defun embark-consult-imenu-or-outline-candidates () 475 "Collect imenu items in prog modes buffer or outline headings otherwise." 476 (if (derived-mode-p 'prog-mode) 477 (embark-consult-imenu-candidates) 478 (embark-consult-outline-candidates))) 479 480 (setf (alist-get 'imenu embark-default-action-overrides) 'consult-imenu) 481 482 (add-to-list 'embark-candidate-collectors 483 #'embark-consult-imenu-or-outline-candidates 484 'append) 485 486 (provide 'embark-consult) 487 ;;; embark-consult.el ends here