embark-consult.el (16292B)
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.0 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-occur (lines) 107 "Create an occur mode buffer listing LINES. 108 The elements of LINES are assumed to be values of category `consult-line'." 109 (let ((buf (generate-new-buffer "*Embark Export Occur*")) 110 (mouse-msg "mouse-2: go to this occurrence") 111 last-buf) 112 (with-current-buffer buf 113 (dolist (line lines) 114 (pcase-let* 115 ((`(,loc . ,num) (consult--get-location line)) 116 ;; the text properties added to the following strings are 117 ;; taken from occur-engine 118 (lineno (propertize (format "%7d:" num) 119 'occur-prefix t 120 ;; Allow insertion of text at the end 121 ;; of the prefix (for Occur Edit mode). 122 'front-sticky t 123 'rear-nonsticky t 124 'occur-target loc 125 'follow-link t 126 'help-echo mouse-msg)) 127 (contents (propertize (embark-consult--strip line) 128 'occur-target loc 129 'occur-match t 130 'follow-link t 131 'help-echo mouse-msg)) 132 (nl (propertize "\n" 'occur-target loc)) 133 (this-buf (marker-buffer loc))) 134 (unless (eq this-buf last-buf) 135 (insert (propertize 136 (format "lines from buffer: %s\n" this-buf) 137 'face list-matching-lines-buffer-name-face)) 138 (setq last-buf this-buf)) 139 (insert (concat lineno contents nl)))) 140 (goto-char (point-min)) 141 (occur-mode)) 142 (pop-to-buffer buf))) 143 144 (defun embark-consult--upgrade-markers () 145 "Upgrade consult-location cheap markers to real markers. 146 This function is meant to be added to `embark-collect-mode-hook'." 147 (when (eq embark--type 'consult-location) 148 (dolist (entry tabulated-list-entries) 149 (when (car entry) 150 (consult--get-location (car entry)))))) 151 152 (setf (alist-get 'consult-location embark-exporters-alist) 153 #'embark-consult-export-occur) 154 (cl-pushnew #'embark-consult--upgrade-markers embark-collect-mode-hook) 155 156 ;;; Support for consult-grep 157 158 (defvar grep-mode-line-matches) 159 (defvar grep-num-matches-found) 160 (declare-function wgrep-setup "ext:wgrep") 161 162 (defvar-keymap embark-consult-revert-map 163 :doc "A keymap with a binding for revert-buffer." 164 :parent nil 165 "g" #'revert-buffer) 166 167 (defun embark-consult--wgrep-prepare () 168 "Mark header as read-only." 169 (goto-char (point-min)) 170 (forward-line 2) 171 (add-text-properties (point-min) (point) 172 '(read-only t wgrep-header t front-sticky t))) 173 174 (defun embark-consult-export-grep (lines) 175 "Create a grep mode buffer listing LINES." 176 (let ((buf (generate-new-buffer "*Embark Export Grep*")) 177 (count 0) 178 prop) 179 (with-current-buffer buf 180 (insert (propertize "Exported grep results:\n\n" 'wgrep-header t)) 181 (dolist (line lines) (insert line "\n")) 182 (goto-char (point-min)) 183 (while (setq prop (text-property-search-forward 184 'face 'consult-highlight-match t)) 185 (cl-incf count) 186 (put-text-property (prop-match-beginning prop) 187 (prop-match-end prop) 188 'font-lock-face 189 'match)) 190 (goto-char (point-min)) 191 (grep-mode) 192 (when (> count 0) 193 (setq-local grep-num-matches-found count 194 mode-line-process grep-mode-line-matches)) 195 ;; Make this buffer current for next/previous-error 196 (setq next-error-last-buffer buf) 197 ;; Set up keymap before possible wgrep-setup, so that wgrep 198 ;; restores our binding too when the user finishes editing. 199 (use-local-map (make-composed-keymap 200 embark-consult-revert-map 201 (current-local-map))) 202 ;; TODO Wgrep 3.0 and development versions use different names for the 203 ;; parser variable. 204 (defvar wgrep-header/footer-parser) 205 (defvar wgrep-header&footer-parser) 206 (setq-local wgrep-header/footer-parser #'embark-consult--wgrep-prepare 207 wgrep-header&footer-parser #'embark-consult--wgrep-prepare) 208 (when (fboundp 'wgrep-setup) (wgrep-setup))) 209 (pop-to-buffer buf))) 210 211 (defun embark-consult-goto-grep (location) 212 "Go to LOCATION, which should be a string with a grep match." 213 (consult--jump (consult--grep-position location)) 214 (pulse-momentary-highlight-one-line (point))) 215 216 (setf (alist-get 'consult-grep embark-default-action-overrides) 217 #'embark-consult-goto-grep) 218 (setf (alist-get 'consult-grep embark-exporters-alist) 219 #'embark-consult-export-grep) 220 221 ;;; Support for consult-xref 222 223 (declare-function xref--show-xref-buffer "ext:xref") 224 (declare-function consult-xref "ext:consult-xref") 225 (defvar xref-auto-jump-to-first-xref) 226 (defvar consult-xref--fetcher) 227 228 (defun embark-consult-export-xref (items) 229 "Create an xref buffer listing ITEMS." 230 (cl-flet ((xref-items (items) 231 (mapcar (lambda (item) (get-text-property 0 'consult-xref item)) 232 items))) 233 (let ((fetcher consult-xref--fetcher) 234 (input (minibuffer-contents))) 235 (set-buffer 236 (xref--show-xref-buffer 237 (lambda () 238 (let ((candidates (funcall fetcher))) 239 (if (null (cdr candidates)) 240 candidates 241 (catch 'xref-items 242 (minibuffer-with-setup-hook 243 (lambda () 244 (insert input) 245 (add-hook 246 'minibuffer-exit-hook 247 (lambda () 248 (throw 'xref-items 249 (xref-items 250 (or 251 (plist-get 252 (embark--maybe-transform-candidates) 253 :candidates) 254 (user-error "No candidates for export"))))) 255 nil t)) 256 (consult-xref fetcher)))))) 257 `((fetched-xrefs . ,(xref-items items)) 258 (window . ,(embark--target-window)) 259 (auto-jump . ,xref-auto-jump-to-first-xref) 260 (display-action))))))) 261 262 (setf (alist-get 'consult-xref embark-exporters-alist) 263 #'embark-consult-export-xref) 264 265 ;;; Support for consult-find and consult-locate 266 267 (setf (alist-get '(file . consult-find) embark-default-action-overrides 268 nil nil #'equal) 269 #'find-file) 270 271 (setf (alist-get '(file . consult-locate) embark-default-action-overrides 272 nil nil #'equal) 273 #'find-file) 274 275 ;;; Support for consult-isearch-history 276 277 (setf (alist-get 'consult-isearch-history embark-transformer-alist) 278 #'embark-consult--target-strip) 279 280 ;;; Support for consult-man and consult-info 281 282 (defun embark-consult-man (cand) 283 "Default action override for `consult-man', open CAND man page." 284 (man (get-text-property 0 'consult-man cand))) 285 286 (setf (alist-get 'consult-man embark-default-action-overrides) 287 #'embark-consult-man) 288 289 (declare-function consult-info--action "ext:consult-info") 290 291 (defun embark-consult-info (cand) 292 "Default action override for `consult-info', open CAND info manual." 293 (consult-info--action cand) 294 (pulse-momentary-highlight-one-line (point))) 295 296 (setf (alist-get 'consult-info embark-default-action-overrides) 297 #'embark-consult-info) 298 299 (setf (alist-get 'consult-info embark-transformer-alist) 300 #'embark-consult--target-strip) 301 302 ;;; Bindings for consult commands in embark keymaps 303 304 (keymap-set embark-become-file+buffer-map "C b" #'consult-buffer) 305 (keymap-set embark-become-file+buffer-map "C 4 b" #'consult-buffer-other-window) 306 307 ;;; Support for Consult search commands 308 309 (defvar-keymap embark-consult-sync-search-map 310 :doc "Keymap for Consult sync search commands" 311 :parent nil 312 "o" #'consult-outline 313 "i" 'consult-imenu 314 "I" 'consult-imenu-multi 315 "l" #'consult-line 316 "L" #'consult-line-multi) 317 318 (defvar-keymap embark-consult-async-search-map 319 :doc "Keymap for Consult async search commands" 320 :parent nil 321 "g" #'consult-grep 322 "r" #'consult-ripgrep 323 "G" #'consult-git-grep 324 "f" #'consult-find 325 "F" #'consult-locate) 326 327 (defvar embark-consult-search-map 328 (keymap-canonicalize 329 (make-composed-keymap embark-consult-sync-search-map 330 embark-consult-async-search-map)) 331 "Keymap for all Consult search commands.") 332 333 (fset 'embark-consult-sync-search-map embark-consult-sync-search-map) 334 (keymap-set embark-become-match-map "C" 'embark-consult-sync-search-map) 335 336 (cl-pushnew 'embark-consult-async-search-map embark-become-keymaps) 337 338 (fset 'embark-consult-search-map embark-consult-search-map) 339 (keymap-set embark-general-map "C" 'embark-consult-search-map) 340 341 (map-keymap 342 (lambda (_key cmd) 343 (cl-pushnew 'embark--unmark-target 344 (alist-get cmd embark-pre-action-hooks)) 345 (cl-pushnew 'embark--allow-edit 346 (alist-get cmd embark-target-injection-hooks))) 347 embark-consult-search-map) 348 349 (defun embark-consult--unique-match (&rest _) 350 "If there is a unique matching candidate, accept it. 351 This is intended to be used in `embark-target-injection-hooks'." 352 (let ((candidates (cdr (embark-minibuffer-candidates)))) 353 (if (or (null candidates) (cdr candidates)) 354 (embark--allow-edit) 355 (delete-minibuffer-contents) 356 (insert (car candidates))))) 357 358 (dolist (cmd '(consult-outline consult-imenu consult-imenu-multi)) 359 (setf (alist-get cmd embark-target-injection-hooks) 360 (remq 'embark--allow-edit 361 (alist-get cmd embark-target-injection-hooks))) 362 (cl-pushnew #'embark-consult--unique-match 363 (alist-get cmd embark-target-injection-hooks))) 364 365 (cl-defun embark-consult--async-search-dwim 366 (&key action type target candidates &allow-other-keys) 367 "DWIM when using a Consult async search command as an ACTION. 368 If the TYPE of the target(s) has a notion of associated 369 file (files, buffers, libraries and some bookmarks do), then run 370 the ACTION with `consult-project-function' set to nil, and search 371 only the files associated to the TARGET or CANDIDATES. For other 372 types, run the ACTION with TARGET or CANDIDATES as initial input." 373 (if-let ((file-fn (cdr (assq type embark--associated-file-fn-alist)))) 374 (let (consult-project-function) 375 (funcall action 376 (delq nil (mapcar file-fn (or candidates (list target)))))) 377 (funcall action nil (or target (string-join candidates " "))))) 378 379 (map-keymap 380 (lambda (_key cmd) 381 (unless (eq cmd #'consult-locate) 382 (cl-pushnew cmd embark-multitarget-actions) 383 (cl-pushnew #'embark-consult--async-search-dwim 384 (alist-get cmd embark-around-action-hooks)))) 385 embark-consult-async-search-map) 386 387 ;;; Tables of contents for buffers: imenu and outline candidate collectors 388 389 (defun embark-consult-outline-candidates () 390 "Collect all outline headings in the current buffer." 391 (cons 'consult-location (consult--outline-candidates))) 392 393 (autoload 'consult-imenu--items "consult-imenu") 394 395 (defun embark-consult-imenu-candidates () 396 "Collect all imenu items in the current buffer." 397 (cons 'imenu (mapcar #'car (consult-imenu--items)))) 398 399 (declare-function consult-imenu--group "ext:consult-imenu") 400 401 (defun embark-consult--imenu-group-function (type prop) 402 "Return a suitable group-function for imenu. 403 TYPE is the completion category. 404 PROP is the metadata property. 405 Meant as :after-until advice for `embark-collect--metadatum'." 406 (when (and (eq type 'imenu) (eq prop 'group-function)) 407 (consult-imenu--group))) 408 409 (advice-add #'embark-collect--metadatum :after-until 410 #'embark-consult--imenu-group-function) 411 412 (defun embark-consult-imenu-or-outline-candidates () 413 "Collect imenu items in prog modes buffer or outline headings otherwise." 414 (if (derived-mode-p 'prog-mode) 415 (embark-consult-imenu-candidates) 416 (embark-consult-outline-candidates))) 417 418 (setf (alist-get 'imenu embark-default-action-overrides) 'consult-imenu) 419 420 (add-to-list 'embark-candidate-collectors 421 #'embark-consult-imenu-or-outline-candidates 422 'append) 423 424 (provide 'embark-consult) 425 ;;; embark-consult.el ends here