embark-consult.el (16394B)
1 ;;; embark-consult.el --- Consult integration for Embark -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2021, 2022 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: 0.7 9 ;; Homepage: https://github.com/oantolin/embark 10 ;; Package-Requires: ((emacs "27.1") (embark "0.20") (consult "0.17")) 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 (defvar wgrep-header/footer-parser) 161 (declare-function wgrep-setup "ext:wgrep") 162 163 (defvar-keymap embark-consult-revert-map 164 :doc "A keymap with a binding for revert-buffer." 165 :parent nil 166 "g" #'revert-buffer) 167 168 (defun embark-consult-export-grep (lines) 169 "Create a grep mode buffer listing LINES." 170 (let ((buf (generate-new-buffer "*Embark Export Grep*")) 171 (count 0) 172 prop) 173 (with-current-buffer buf 174 (insert (propertize "Exported grep results:\n\n" 'wgrep-header t)) 175 (dolist (line lines) (insert line "\n")) 176 (goto-char (point-min)) 177 (while (setq prop (text-property-search-forward 178 'face 'consult-highlight-match t)) 179 (cl-incf count) 180 (put-text-property (prop-match-beginning prop) 181 (prop-match-end prop) 182 'font-lock-face 183 'match)) 184 (goto-char (point-min)) 185 (grep-mode) 186 (when (> count 0) 187 (setq-local grep-num-matches-found count 188 mode-line-process grep-mode-line-matches)) 189 ;; Make this buffer current for next/previous-error 190 (setq next-error-last-buffer buf) 191 ;; Set up keymap before possible wgrep-setup, so that wgrep 192 ;; restores our binding too when the user finishes editing. 193 (use-local-map (make-composed-keymap 194 embark-consult-revert-map 195 (current-local-map))) 196 (setq-local wgrep-header/footer-parser #'ignore) 197 (when (fboundp 'wgrep-setup) (wgrep-setup))) 198 (pop-to-buffer buf))) 199 200 (defun embark-consult-goto-grep (location) 201 "Go to LOCATION, which should be a string with a grep match." 202 ;; Actions are run in the target window, so in this case whatever 203 ;; window was selected when the command that produced the 204 ;; xref-location candidates ran. In particular, we inherit the 205 ;; default-directory of the buffer in that window, but we really 206 ;; want the default-directory of the minibuffer or collect window we 207 ;; call the action from, which is the previous window, since the 208 ;; location is given relative to that directory. 209 (let ((default-directory (with-selected-window (previous-window) 210 default-directory))) 211 (consult--jump (consult--grep-position location)) 212 (pulse-momentary-highlight-one-line (point)))) 213 214 (setf (alist-get 'consult-grep embark-default-action-overrides) 215 #'embark-consult-goto-grep) 216 (setf (alist-get 'consult-grep embark-exporters-alist) 217 #'embark-consult-export-grep) 218 219 ;;; Support for consult-xref 220 221 (declare-function xref--show-xref-buffer "ext:xref") 222 (declare-function consult-xref "ext:consult-xref") 223 (defvar xref-auto-jump-to-first-xref) 224 (defvar consult-xref--fetcher) 225 226 (defun embark-consult-export-xref (items) 227 "Create an xref buffer listing ITEMS." 228 (cl-flet ((xref-items (items) 229 (mapcar (lambda (item) (get-text-property 0 'consult-xref item)) 230 items))) 231 (let ((fetcher consult-xref--fetcher) 232 (input (minibuffer-contents))) 233 (set-buffer 234 (xref--show-xref-buffer 235 (lambda () 236 (let ((candidates (funcall fetcher))) 237 (if (null (cdr candidates)) 238 candidates 239 (catch 'xref-items 240 (minibuffer-with-setup-hook 241 (lambda () 242 (insert input) 243 (add-hook 244 'minibuffer-exit-hook 245 (lambda () 246 (throw 'xref-items 247 (xref-items 248 (or 249 (plist-get 250 (embark--maybe-transform-candidates) 251 :candidates) 252 (user-error "No candidates for export"))))) 253 nil t)) 254 (consult-xref fetcher)))))) 255 `((fetched-xrefs . ,(xref-items items)) 256 (window . ,(embark--target-window)) 257 (auto-jump . ,xref-auto-jump-to-first-xref) 258 (display-action))))))) 259 260 (setf (alist-get 'consult-xref embark-exporters-alist) 261 #'embark-consult-export-xref) 262 263 ;;; Support for consult-find and consult-locate 264 265 (setf (alist-get '(file . consult-find) embark-default-action-overrides) 266 #'find-file) 267 268 (setf (alist-get '(file . consult-locate) embark-default-action-overrides) 269 #'find-file) 270 271 ;;; Support for consult-isearch 272 273 (setf (alist-get 'consult-isearch embark-transformer-alist) 274 #'embark-consult--target-strip) 275 276 ;;; Support for consult-man and consult-info 277 278 (defun embark-consult-man (cand) 279 "Default action override for `consult-man', open CAND man page." 280 (man (get-text-property 0 'consult-man cand))) 281 282 (setf (alist-get 'consult-man embark-default-action-overrides) 283 #'embark-consult-man) 284 285 (declare-function consult-info--action "ext:consult-info") 286 287 (defun embark-consult-info (cand) 288 "Default action override for `consult-info', open CAND info manual." 289 (consult-info--action cand) 290 (pulse-momentary-highlight-one-line (point))) 291 292 (setf (alist-get 'consult-info embark-default-action-overrides) 293 #'embark-consult-info) 294 295 (setf (alist-get 'consult-info embark-transformer-alist) 296 #'embark-consult--target-strip) 297 298 ;;; Bindings for consult commands in embark keymaps 299 300 (keymap-set embark-become-file+buffer-map "C b" #'consult-buffer) 301 (keymap-set embark-become-file+buffer-map "C 4 b" #'consult-buffer-other-window) 302 303 ;;; Support for Consult search commands 304 305 (defvar-keymap embark-consult-sync-search-map 306 :doc "Keymap for Consult sync search commands" 307 :parent nil 308 "o" #'consult-outline 309 "i" 'consult-imenu 310 "I" 'consult-imenu-multi 311 "l" #'consult-line 312 "L" #'consult-line-multi) 313 314 (defvar-keymap embark-consult-async-search-map 315 :doc "Keymap for Consult async search commands" 316 :parent nil 317 "g" #'consult-grep 318 "r" #'consult-ripgrep 319 "G" #'consult-git-grep 320 "f" #'consult-find 321 "F" #'consult-locate) 322 323 (defvar embark-consult-search-map 324 (keymap-canonicalize 325 (make-composed-keymap embark-consult-sync-search-map 326 embark-consult-async-search-map)) 327 "Keymap for all Consult search commands.") 328 329 (fset 'embark-consult-sync-search-map embark-consult-sync-search-map) 330 (keymap-set embark-become-match-map "C" 'embark-consult-sync-search-map) 331 332 (cl-pushnew 'embark-consult-async-search-map embark-become-keymaps) 333 334 (fset 'embark-consult-search-map embark-consult-search-map) 335 (keymap-set embark-general-map "C" 'embark-consult-search-map) 336 337 (map-keymap 338 (lambda (_key cmd) 339 (cl-pushnew 'embark--allow-edit 340 (alist-get cmd embark-target-injection-hooks))) 341 embark-consult-search-map) 342 343 (defun embark-consult--unique-match (&rest _) 344 "If there is a unique matching candidate, accept it. 345 This is intended to be used in `embark-target-injection-hooks'." 346 (let ((candidates (cdr (embark-minibuffer-candidates)))) 347 (if (or (null candidates) (cdr candidates)) 348 (embark--allow-edit) 349 (delete-minibuffer-contents) 350 (insert (car candidates))))) 351 352 (dolist (cmd '(consult-outline consult-imenu consult-imenu-multi)) 353 (setf (alist-get cmd embark-target-injection-hooks) 354 (remq 'embark--allow-edit 355 (alist-get cmd embark-target-injection-hooks))) 356 (cl-pushnew #'embark-consult--unique-match 357 (alist-get cmd embark-target-injection-hooks))) 358 359 (cl-defun embark-consult--prep-async (&key type target &allow-other-keys) 360 "Either add Consult's async separator or ignore the TARGET depending on TYPE. 361 If the TARGET of the given TYPE has an associated notion of 362 directory, we don't want to search for the text of target, but 363 rather just start a search in the associated directory. 364 365 This is intended to be used in `embark-target-injection-hooks' 366 for any action that is a Consult async command." 367 (let* ((style (alist-get consult-async-split-style 368 consult-async-split-styles-alist)) 369 (initial (plist-get style :initial)) 370 (separator (plist-get style :separator)) 371 (directory (embark--associated-directory target type))) 372 (when directory 373 (delete-minibuffer-contents)) 374 (when initial 375 (goto-char (minibuffer-prompt-end)) 376 (insert initial) 377 (goto-char (point-max))) 378 (when (and separator (null directory)) 379 (goto-char (point-max)) 380 (insert separator)))) 381 382 (map-keymap 383 (lambda (_key cmd) 384 (cl-pushnew #'embark--cd (alist-get cmd embark-around-action-hooks)) 385 (cl-pushnew #'embark-consult--prep-async 386 (alist-get cmd embark-target-injection-hooks))) 387 embark-consult-async-search-map) 388 389 ;;; Tables of contents for buffers: imenu and outline candidate collectors 390 391 (defun embark-consult-outline-candidates () 392 "Collect all outline headings in the current buffer." 393 (cons 'consult-location (consult--outline-candidates))) 394 395 (autoload 'consult-imenu--items "consult-imenu") 396 397 (defun embark-consult-imenu-candidates () 398 "Collect all imenu items in the current buffer." 399 (cons 'imenu (mapcar #'car (consult-imenu--items)))) 400 401 (declare-function consult-imenu--group "ext:consult-imenu") 402 403 (defun embark-consult--imenu-group-function (type prop) 404 "Return a suitable group-function for imenu. 405 TYPE is the completion category. 406 PROP is the metadata property. 407 Meant as :after-until advice for `embark-collect--metadatum'." 408 (when (and (eq type 'imenu) (eq prop 'group-function)) 409 (consult-imenu--group))) 410 411 (advice-add #'embark-collect--metadatum :after-until 412 #'embark-consult--imenu-group-function) 413 414 (defun embark-consult-imenu-or-outline-candidates () 415 "Collect imenu items in prog modes buffer or outline headings otherwise." 416 (if (derived-mode-p 'prog-mode) 417 (embark-consult-imenu-candidates) 418 (embark-consult-outline-candidates))) 419 420 (setf (alist-get 'imenu embark-default-action-overrides) 'consult-imenu) 421 422 (add-to-list 'embark-candidate-collectors 423 #'embark-consult-imenu-or-outline-candidates 424 'append) 425 426 (provide 'embark-consult) 427 ;;; embark-consult.el ends here