;;; embark-consult.el --- Consult integration for Embark -*- lexical-binding: t; -*-

;; Copyright (C) 2021-2023  Free Software Foundation, Inc.

;; Author: Omar Antolín Camarena <omar@matem.unam.mx>
;; Maintainer: Omar Antolín Camarena <omar@matem.unam.mx>
;; Keywords: convenience
;; Version: 1.0
;; Homepage: https://github.com/oantolin/embark
;; Package-Requires: ((emacs "27.1") (compat "29.1.4.0") (embark "1.0") (consult "1.0"))

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This package provides integration between Embark and Consult.  The package
;; will be loaded automatically by Embark.

;; Some of the functionality here was previously contained in Embark
;; itself:

;; - Support for consult-buffer, so that you get the correct actions
;; for each type of entry in consult-buffer's list.

;; - Support for consult-line, consult-outline, consult-mark and
;; consult-global-mark, so that the insert and save actions don't
;; include a weird unicode character at the start of the line, and so
;; you can export from them to an occur buffer (where occur-edit-mode
;; works!).

;; Just load this package to get the above functionality, no further
;; configuration is necessary.

;; Additionally this package contains some functionality that has
;; never been in Embark: access to Consult preview from auto-updating
;; Embark Collect buffer that is associated to an active minibuffer
;; for a Consult command.  For information on Consult preview, see
;; Consult's info manual or its readme on GitHub.

;; If you always want the minor mode enabled whenever it possible use:

;; (add-hook 'embark-collect-mode-hook #'consult-preview-at-point-mode)

;; If you don't want the minor mode automatically on and prefer to
;; trigger the consult previews manually use this instead:

;; (keymap-set embark-collect-mode-map "C-j"
;;   #'consult-preview-at-point)

;;; Code:

(require 'embark)
(require 'consult)

(eval-when-compile
  (require 'cl-lib))

;;; Consult preview from Embark Collect buffers

(defun embark-consult--collect-candidate ()
  "Return candidate at point in collect buffer."
  (cadr (embark-target-collect-candidate)))

(add-hook 'consult--completion-candidate-hook #'embark-consult--collect-candidate)

;;; Support for consult-location

(defun embark-consult--strip (string)
  "Strip substrings marked with the `consult-strip' property from STRING."
  (if (text-property-not-all 0 (length string) 'consult-strip nil string)
      (let ((end (length string)) (pos 0) (chunks))
        (while (< pos end)
          (let ((next (next-single-property-change pos 'consult-strip string end)))
            (unless (get-text-property pos 'consult-strip string)
              (push (substring string pos next) chunks))
            (setq pos next)))
        (apply #'concat (nreverse chunks)))
    string))

(defun embark-consult--target-strip (type target)
  "Remove the unicode suffix character from a TARGET of TYPE."
  (cons type (embark-consult--strip target)))

(setf (alist-get 'consult-location embark-transformer-alist)
      #'embark-consult--target-strip)

(defun embark-consult-goto-location (target)
  "Jump to consult location TARGET."
  (consult--jump (car (consult--get-location target)))
  (pulse-momentary-highlight-one-line (point)))

(setf (alist-get 'consult-location embark-default-action-overrides)
      #'embark-consult-goto-location)

(defun embark-consult-export-occur (lines)
  "Create an occur mode buffer listing LINES.
The elements of LINES are assumed to be values of category `consult-line'."
  (let ((buf (generate-new-buffer "*Embark Export Occur*"))
        (mouse-msg "mouse-2: go to this occurrence")
        last-buf)
    (with-current-buffer buf
      (dolist (line lines)
        (pcase-let*
            ((`(,loc . ,num) (consult--get-location line))
             ;; the text properties added to the following strings are
             ;; taken from occur-engine
             (lineno (propertize (format "%7d:" num)
                                 'occur-prefix t
                                 ;; Allow insertion of text at the end
                                 ;; of the prefix (for Occur Edit mode).
                                 'front-sticky t
                                 'rear-nonsticky t
                                 'occur-target loc
                                 'follow-link t
                                 'help-echo mouse-msg))
             (contents (propertize (embark-consult--strip line)
                                   'occur-target loc
                                   'occur-match t
                                   'follow-link t
                                   'help-echo mouse-msg))
             (nl (propertize "\n" 'occur-target loc))
             (this-buf (marker-buffer loc)))
          (unless (eq this-buf last-buf)
            (insert (propertize
                     (format "lines from buffer: %s\n" this-buf)
                     'face list-matching-lines-buffer-name-face))
            (setq last-buf this-buf))
          (insert (concat lineno contents nl))))
      (goto-char (point-min))
      (occur-mode))
    (pop-to-buffer buf)))

(defun embark-consult--upgrade-markers ()
  "Upgrade consult-location cheap markers to real markers.
This function is meant to be added to `embark-collect-mode-hook'."
  (when (eq embark--type 'consult-location)
    (dolist (entry tabulated-list-entries)
      (when (car entry)
        (consult--get-location (car entry))))))

(setf (alist-get 'consult-location embark-exporters-alist)
      #'embark-consult-export-occur)
(cl-pushnew #'embark-consult--upgrade-markers embark-collect-mode-hook)

;;; Support for consult-grep

(defvar grep-mode-line-matches)
(defvar grep-num-matches-found)
(declare-function wgrep-setup "ext:wgrep")

(defvar-keymap embark-consult-revert-map
  :doc "A keymap with a binding for revert-buffer."
  :parent nil
  "g" #'revert-buffer)

(defun embark-consult--wgrep-prepare ()
  "Mark header as read-only."
  (goto-char (point-min))
  (forward-line 2)
  (add-text-properties (point-min) (point)
                       '(read-only t wgrep-header t front-sticky t)))

(defun embark-consult-export-grep (lines)
  "Create a grep mode buffer listing LINES."
  (let ((buf (generate-new-buffer "*Embark Export Grep*"))
        (count 0)
        prop)
    (with-current-buffer buf
      (insert (propertize "Exported grep results:\n\n" 'wgrep-header t))
      (dolist (line lines) (insert line "\n"))
      (goto-char (point-min))
      (while (setq prop (text-property-search-forward
                         'face 'consult-highlight-match t))
        (cl-incf count)
        (put-text-property (prop-match-beginning prop)
                           (prop-match-end prop)
                           'font-lock-face
                           'match))
      (goto-char (point-min))
      (grep-mode)
      (when (> count 0)
        (setq-local grep-num-matches-found count
                    mode-line-process grep-mode-line-matches))
      ;; Make this buffer current for next/previous-error
      (setq next-error-last-buffer buf)
      ;; Set up keymap before possible wgrep-setup, so that wgrep
      ;; restores our binding too when the user finishes editing.
      (use-local-map (make-composed-keymap
                      embark-consult-revert-map
                      (current-local-map)))
      ;; TODO Wgrep 3.0 and development versions use different names for the
      ;; parser variable.
      (defvar wgrep-header/footer-parser)
      (defvar wgrep-header&footer-parser)
      (setq-local wgrep-header/footer-parser #'embark-consult--wgrep-prepare
                  wgrep-header&footer-parser #'embark-consult--wgrep-prepare)
      (when (fboundp 'wgrep-setup) (wgrep-setup)))
    (pop-to-buffer buf)))

(defun embark-consult-goto-grep (location)
  "Go to LOCATION, which should be a string with a grep match."
  (consult--jump (consult--grep-position location))
  (pulse-momentary-highlight-one-line (point)))

(setf (alist-get 'consult-grep embark-default-action-overrides)
      #'embark-consult-goto-grep)
(setf (alist-get 'consult-grep embark-exporters-alist)
      #'embark-consult-export-grep)

;;; Support for consult-xref

(declare-function xref--show-xref-buffer "ext:xref")
(declare-function consult-xref "ext:consult-xref")
(defvar xref-auto-jump-to-first-xref)
(defvar consult-xref--fetcher)

(defun embark-consult-export-xref (items)
  "Create an xref buffer listing ITEMS."
  (cl-flet ((xref-items (items)
              (mapcar (lambda (item) (get-text-property 0 'consult-xref item))
                      items)))
    (let ((fetcher consult-xref--fetcher)
          (input (minibuffer-contents)))
      (set-buffer
       (xref--show-xref-buffer
        (lambda ()
          (let ((candidates (funcall fetcher)))
            (if (null (cdr candidates))
                candidates
              (catch 'xref-items
                (minibuffer-with-setup-hook
                    (lambda ()
                      (insert input)
                      (add-hook
                       'minibuffer-exit-hook
                       (lambda ()
                         (throw 'xref-items
                           (xref-items
                            (or
                             (plist-get
                              (embark--maybe-transform-candidates)
                              :candidates)
                             (user-error "No candidates for export")))))
                       nil t))
                  (consult-xref fetcher))))))
        `((fetched-xrefs . ,(xref-items items))
          (window . ,(embark--target-window))
          (auto-jump . ,xref-auto-jump-to-first-xref)
          (display-action)))))))

(setf (alist-get 'consult-xref embark-exporters-alist)
      #'embark-consult-export-xref)

;;; Support for consult-find and consult-locate

(setf (alist-get '(file . consult-find) embark-default-action-overrides
                 nil nil #'equal)
      #'find-file)

(setf (alist-get '(file . consult-locate) embark-default-action-overrides
                 nil nil #'equal)
      #'find-file)

;;; Support for consult-isearch-history

(setf (alist-get 'consult-isearch-history embark-transformer-alist)
      #'embark-consult--target-strip)

;;; Support for consult-man and consult-info

(defun embark-consult-man (cand)
  "Default action override for `consult-man', open CAND man page."
  (man (get-text-property 0 'consult-man cand)))

(setf (alist-get 'consult-man embark-default-action-overrides)
      #'embark-consult-man)

(declare-function consult-info--action "ext:consult-info")

(defun embark-consult-info (cand)
  "Default action override for `consult-info', open CAND info manual."
  (consult-info--action cand)
  (pulse-momentary-highlight-one-line (point)))

(setf (alist-get 'consult-info embark-default-action-overrides)
      #'embark-consult-info)

(setf (alist-get 'consult-info embark-transformer-alist)
      #'embark-consult--target-strip)

;;; Bindings for consult commands in embark keymaps

(keymap-set embark-become-file+buffer-map "C b" #'consult-buffer)
(keymap-set embark-become-file+buffer-map "C 4 b" #'consult-buffer-other-window)

;;; Support for Consult search commands

(defvar-keymap embark-consult-sync-search-map
  :doc "Keymap for Consult sync search commands"
  :parent nil
  "o" #'consult-outline
  "i" 'consult-imenu
  "I" 'consult-imenu-multi
  "l" #'consult-line
  "L" #'consult-line-multi)

(defvar-keymap embark-consult-async-search-map
  :doc "Keymap for Consult async search commands"
  :parent nil
  "g" #'consult-grep
  "r" #'consult-ripgrep
  "G" #'consult-git-grep
  "f" #'consult-find
  "F" #'consult-locate)

(defvar embark-consult-search-map
  (keymap-canonicalize
   (make-composed-keymap embark-consult-sync-search-map
                         embark-consult-async-search-map))
  "Keymap for all Consult search commands.")

(fset 'embark-consult-sync-search-map embark-consult-sync-search-map)
(keymap-set embark-become-match-map "C" 'embark-consult-sync-search-map)

(cl-pushnew 'embark-consult-async-search-map embark-become-keymaps)

(fset 'embark-consult-search-map embark-consult-search-map)
(keymap-set embark-general-map "C" 'embark-consult-search-map)

(map-keymap
 (lambda (_key cmd)
   (cl-pushnew 'embark--unmark-target
               (alist-get cmd embark-pre-action-hooks))
   (cl-pushnew 'embark--allow-edit
               (alist-get cmd embark-target-injection-hooks)))
 embark-consult-search-map)

(defun embark-consult--unique-match (&rest _)
  "If there is a unique matching candidate, accept it.
This is intended to be used in `embark-target-injection-hooks'."
  (let ((candidates (cdr (embark-minibuffer-candidates))))
    (if (or (null candidates) (cdr candidates))
        (embark--allow-edit)
      (delete-minibuffer-contents)
      (insert (car candidates)))))

(dolist (cmd '(consult-outline consult-imenu consult-imenu-multi))
  (setf (alist-get cmd embark-target-injection-hooks)
        (remq 'embark--allow-edit
              (alist-get cmd embark-target-injection-hooks)))
  (cl-pushnew #'embark-consult--unique-match
              (alist-get cmd embark-target-injection-hooks)))

(cl-defun embark-consult--async-search-dwim
    (&key action type target candidates &allow-other-keys)
  "DWIM when using a Consult async search command as an ACTION.
If the TYPE of the target(s) has a notion of associated
file (files, buffers, libraries and some bookmarks do), then run
the ACTION with `consult-project-function' set to nil, and search
only the files associated to the TARGET or CANDIDATES.  For other
types, run the ACTION with TARGET or CANDIDATES as initial input."
  (if-let ((file-fn (cdr (assq type embark--associated-file-fn-alist))))
      (let (consult-project-function)
        (funcall action
                 (delq nil (mapcar file-fn (or candidates (list target))))))
    (funcall action nil (or target (string-join candidates " ")))))

(map-keymap
 (lambda (_key cmd)
   (unless (eq cmd #'consult-locate)
     (cl-pushnew cmd embark-multitarget-actions)
     (cl-pushnew #'embark-consult--async-search-dwim
                 (alist-get cmd embark-around-action-hooks))))
 embark-consult-async-search-map)

;;; Tables of contents for buffers: imenu and outline candidate collectors

(defun embark-consult-outline-candidates ()
  "Collect all outline headings in the current buffer."
  (cons 'consult-location (consult--outline-candidates)))

(autoload 'consult-imenu--items "consult-imenu")

(defun embark-consult-imenu-candidates ()
  "Collect all imenu items in the current buffer."
  (cons 'imenu (mapcar #'car (consult-imenu--items))))

(declare-function consult-imenu--group "ext:consult-imenu")

(defun embark-consult--imenu-group-function (type prop)
  "Return a suitable group-function for imenu.
TYPE is the completion category.
PROP is the metadata property.
Meant as :after-until advice for `embark-collect--metadatum'."
  (when (and (eq type 'imenu) (eq prop 'group-function))
    (consult-imenu--group)))

(advice-add #'embark-collect--metadatum :after-until
            #'embark-consult--imenu-group-function)

(defun embark-consult-imenu-or-outline-candidates ()
  "Collect imenu items in prog modes buffer or outline headings otherwise."
  (if (derived-mode-p 'prog-mode)
      (embark-consult-imenu-candidates)
    (embark-consult-outline-candidates)))

(setf (alist-get 'imenu embark-default-action-overrides) 'consult-imenu)

(add-to-list 'embark-candidate-collectors
             #'embark-consult-imenu-or-outline-candidates
             'append)

(provide 'embark-consult)
;;; embark-consult.el ends here
