branch: externals/consult
commit e5f4f5cde390d7f5aaa6e4558d7cf7755aec0e54
Author: Daniel Mendler <m...@daniel-mendler.de>
Commit: Daniel Mendler <m...@daniel-mendler.de>
Improve file preview
- Fix https://github.com/oantolin/embark/issues/490
- Sources can have a :new function now to create new elements (See #539)
- consult--multi-lookup: Handle non-existing candidates by redirecting to
the
:new function
- Renamed consult--temporary-files to consult--previewed-files
- consult--previewed-files must be called with the nil argument, whenever
the
previewed source is changed, i.e, when the CAND argument is nil.
- Rename previewed file buffers (Prefix the name with "Preview:") and
dissassociate the buffers from the files, such that opening the previewed
buffer via `M-x embark-act RET` becomes possible if
embark-quit-after-action=nil.
---
README.org | 3 +-
consult-xref.el | 4 +-
consult.el | 150 +++++++++++++++++++++++++++++++++-----------------------
3 files changed, 93 insertions(+), 64 deletions(-)
diff --git a/README.org b/README.org
index 0d08443cbf..1491631aff 100644
--- a/README.org
+++ b/README.org
@@ -600,7 +600,8 @@ Optional source fields:
- =:annotate= Annotation function called for each candidate, returns string.
- =:history= Name of history variable to add selected candidate.
- =:default= Must be t if the first item of the source is the default value.
-- =:action= Action function called with the selected candidate.
+- =:action= Function called with the selected candidate.
+- =:new= Function called with new candidate name, only if =:require-match= is
nil.
- =:state= State constructor for the source, must return the state function.
- Other source fields can be added specifically to the use case.
diff --git a/consult-xref.el b/consult-xref.el
index 283781d201..5a80fd17df 100644
--- a/consult-xref.el
+++ b/consult-xref.el
@@ -51,10 +51,10 @@
(defun consult-xref--preview (display)
"Xref preview with DISPLAY function."
- (let ((open (consult--temporary-files))
+ (let ((open (consult--previewed-files))
(preview (consult--jump-preview)))
(lambda (action cand)
- (when (eq action 'exit)
+ (unless cand
(funcall open))
(let ((consult--buffer-display display))
(funcall preview action
diff --git a/consult.el b/consult.el
index b8551e8cdc..44055ee280 100644
--- a/consult.el
+++ b/consult.el
@@ -200,12 +200,12 @@ character, the *Completions* buffer and a few log
buffers."
:type '(repeat regexp))
(defcustom consult-buffer-sources
- '(consult--source-hidden-buffer
- consult--source-buffer
+ '(consult--source-buffer
consult--source-recent-file
consult--source-bookmark
consult--source-project-buffer
- consult--source-project-recent-file)
+ consult--source-project-recent-file
+ consult--source-hidden-buffer)
"Sources used by `consult-buffer'.
See also `consult-project-buffer-sources'.
See `consult--multi' for a description of the source data structure."
@@ -1127,9 +1127,8 @@ ORIG is the original function, HOOKS the arguments."
(apply orig hooks))
(apply orig hooks)))
-(defun consult--find-file-temporarily (name)
+(defun consult--find-file-for-preview (name)
"Open file NAME temporarily for preview."
- (setq name (abbreviate-file-name (expand-file-name name)))
;; file-attributes may throw permission denied error
(when-let* ((attrs (ignore-errors (file-attributes name)))
(size (file-attribute-size attrs)))
@@ -1162,10 +1161,10 @@ ORIG is the original function, HOOKS the arguments."
name (file-size-human-readable size))
nil)))
-(defun consult--temporary-files ()
+(defun consult--previewed-files ()
"Return a function to open files temporarily for preview."
(let ((dir default-directory)
- (hook (make-symbol "consult--temporary-files"))
+ (hook (make-symbol "consult--previewed-files"))
(orig-buffers (buffer-list))
temporary-buffers)
(fset hook
@@ -1173,44 +1172,60 @@ ORIG is the original function, HOOKS the arguments."
;; Fully initialize previewed files and keep them alive.
(unless (consult--completion-window-p)
(let (live-files)
- (dolist (buf temporary-buffers)
- (when-let ((file (buffer-file-name buf))
- (wins (and (buffer-live-p buf)
- (get-buffer-window-list buf))))
+ (pcase-dolist (`(,file . ,buf) temporary-buffers)
+ (when-let (wins (and (buffer-live-p buf)
+ (get-buffer-window-list buf)))
(push (cons file (mapcar
(lambda (win)
- (list (window-state-get win t) win))
+ (cons win (window-state-get win t)))
wins))
- live-files))
+ live-files)))
+ (pcase-dolist (`(,_ . ,buf) temporary-buffers)
(kill-buffer buf))
(setq temporary-buffers nil)
(pcase-dolist (`(,file . ,wins) live-files)
(when-let (buf (find-file-noselect file))
(push buf orig-buffers)
- (dolist (state wins)
- (apply #'window-state-put state))))))))
+ (pcase-dolist (`(,win . ,state) wins)
+ (setf (car (alist-get 'buffer state)) buf)
+ (window-state-put state win))))))))
(lambda (&optional name)
(if name
(let ((default-directory dir))
+ (setq name (abbreviate-file-name (expand-file-name name)))
+ (or
;; get-file-buffer is only a small optimization here. It
;; may not find the actual buffer, for directories it
;; returns nil instead of returning the Dired buffer.
- (or (get-file-buffer name)
- (when-let (buf (consult--find-file-temporarily name))
- ;; Only add new buffer if not already in the list
- (unless (or (memq buf temporary-buffers) (memq buf
orig-buffers))
- (add-hook 'window-selection-change-functions hook)
- (push buf temporary-buffers)
- (with-current-buffer buf
- (setq mode-name `("Preview:" ,mode-name)
- buffer-read-only t))
- ;; Only keep a few buffers alive
- (while (> (length temporary-buffers)
consult-preview-max-count)
- (kill-buffer (car (last temporary-buffers)))
- (setq temporary-buffers (nbutlast temporary-buffers))))
- buf)))
+ (get-file-buffer name)
+ (cdr (assoc name temporary-buffers))
+ (when-let (buf (consult--find-file-for-preview name))
+ ;; Only add new buffer if not already in the list
+ (unless (or (rassq buf temporary-buffers) (memq buf
orig-buffers))
+ (add-hook 'window-selection-change-functions hook)
+ (push (cons name buf) temporary-buffers)
+ (with-current-buffer buf
+ ;; Disassociate buffer from file by setting
+ ;; `buffer-file-name' to nil and rename the buffer.
+ ;; This lets us open an already previewed buffer with
+ ;; the Embark default action C-. RET. We cannot use
+ ;; (set-visited-file-name nil) since then the mode
+ ;; hooks will not run.
+ (rename-buffer
+ (format "Preview:%s"
+ (file-name-nondirectory (directory-file-name
name)))
+ 'unique)
+ (setq buffer-file-name nil
+ buffer-read-only t))
+ ;; Only keep a few buffers alive
+ (while (> (length temporary-buffers)
consult-preview-max-count)
+ (kill-buffer (cdar (last temporary-buffers)))
+ (setq temporary-buffers (nbutlast temporary-buffers))))
+ buf)))
(remove-hook 'window-selection-change-functions hook)
- (mapc #'kill-buffer temporary-buffers)))))
+ (pcase-dolist (`(,_ . ,buf) temporary-buffers)
+ (kill-buffer buf))
+ (setq temporary-buffers nil)))))
(defun consult--invisible-open-permanently ()
"Open overlays which hide the current line.
@@ -2283,16 +2298,23 @@ INHERIT-INPUT-METHOD, if non-nil the minibuffer
inherits the input method."
(defun consult--multi-lookup (sources _ candidates cand)
"Lookup CAND in CANDIDATES given SOURCES."
(unless (string-blank-p cand)
- (if (consult--tofu-p (aref cand (1- (length cand))))
- (cons (if-let (found (member cand candidates))
- (cdr (get-text-property 0 'multi-category (car found)))
- ;; Non-existing tofu'ed candidates can occur due an
- ;; interaction of Consult preview and Embark.
- ;; See https://github.com/oantolin/embark/issues/490.
- (substring cand 0 -1))
+ (if-let (found (member cand candidates))
+ (cons (cdr (get-text-property 0 'multi-category (car found)))
(consult--multi-source sources cand))
- ;; TODO return source with :new field, depending on current narrowing
- (list cand))))
+ (let* ((tofu (consult--tofu-p (aref cand (1- (length cand)))))
+ (source (if tofu
+ (consult--multi-source sources cand)
+ (aref sources 0))))
+ (cons (if tofu (substring cand 0 -1) cand)
+ `(:action
+ ,(or (plist-get source :new)
+ (apply-partially #'consult--multi-new-fallback
+ (plist-get source :category)))
+ ,@source))))))
+
+(defun consult--multi-new-fallback (cat cand)
+ "Fallback for new CAND of CAT for sources which do not specify a :new
function."
+ (message "Cannot create new %s `%s'" cat cand))
(defun consult--multi-candidates (sources)
"Return `consult--multi' candidates from SOURCES."
@@ -2390,7 +2412,8 @@ Optional source fields:
* :annotate - Annotation function called for each candidate, returns string.
* :history - Name of history variable to add selected candidate.
* :default - Must be t if the first item of the source is the default value.
-* :action - Action function called with the selected candidate.
+* :action - Function called with the selected candidate.
+* :new - Function called with new candidate name, only if :require-match is
nil.
* :state - State constructor for the source, must return the state function.
* Other source fields can be added specifically to the use case."
(let* ((sources (consult--multi-enabled-sources sources))
@@ -3389,10 +3412,10 @@ narrowing and the settings `consult-goto-line-numbers'
and
(defun consult--file-preview ()
"Create preview function for files."
- (let ((open (consult--temporary-files))
+ (let ((open (consult--previewed-files))
(preview (consult--buffer-preview)))
(lambda (action cand)
- (when (eq action 'exit)
+ (unless cand
(funcall open))
(funcall preview action
(and cand
@@ -3638,9 +3661,9 @@ There exists no equivalent of this command in Emacs 28."
(defun consult--bookmark-preview ()
"Create preview function for bookmarks."
(let ((preview (consult--jump-preview))
- (open (consult--temporary-files)))
+ (open (consult--previewed-files)))
(lambda (action cand)
- (when (eq action 'exit)
+ (unless cand
(funcall open))
(funcall
preview action
@@ -4199,8 +4222,14 @@ If NORECORD is non-nil, do not record the buffer switch
in the buffer list."
:face consult-file
:history file-name-history
:state ,#'consult--file-state
- :enabled ,(lambda () (and consult-project-function
- recentf-mode))
+ :new
+ ,(lambda (file)
+ (consult--file-action
+ (expand-file-name file (consult--project-root))))
+ :enabled
+ ,(lambda ()
+ (and consult-project-function
+ recentf-mode))
:items
,(lambda ()
(when-let (root (consult--project-root))
@@ -4239,6 +4268,7 @@ If NORECORD is non-nil, do not record the buffer switch
in the buffer list."
:face consult-buffer
:history buffer-name-history
:state ,#'consult--buffer-state
+ :new ,#'consult--buffer-action
:default t
:items
,(lambda () (consult--buffer-query :sort 'visibility
@@ -4252,6 +4282,7 @@ If NORECORD is non-nil, do not record the buffer switch
in the buffer list."
:face consult-file
:history file-name-history
:state ,#'consult--file-state
+ :new ,#'consult--file-action
:enabled ,(lambda () recentf-mode)
:items
,(lambda ()
@@ -4272,16 +4303,12 @@ keys. In order to determine the project-specific files
and buffers, the
default to `consult-buffer-sources'. See `consult--multi' for the
configuration of the virtual buffer sources."
(interactive)
- (when-let (buffer (consult--multi (or sources consult-buffer-sources)
- :require-match
- (confirm-nonexistent-file-or-buffer)
- :prompt "Switch to: "
- :history 'consult--buffer-history
- :sort nil))
- ;; When the buffer does not belong to a source,
- ;; create a new buffer with the name.
- (unless (cdr buffer)
- (consult--buffer-action (car buffer)))))
+ (consult--multi (or sources consult-buffer-sources)
+ :require-match
+ (confirm-nonexistent-file-or-buffer)
+ :prompt "Switch to: "
+ :history 'consult--buffer-history
+ :sort nil))
;; Populate `consult-project-buffer-sources'.
(setq consult-project-buffer-sources
@@ -4455,13 +4482,14 @@ FIND-FILE is the file open function, defaulting to
`find-file'."
(defun consult--grep-state ()
"Grep state function."
- (let ((open (consult--temporary-files))
+ (let ((open (consult--previewed-files))
(jump (consult--jump-state)))
(lambda (action cand)
- (when (eq action 'exit)
- (funcall open)
- (setq open nil))
- (funcall jump action (consult--grep-position cand open)))))
+ (unless cand
+ (funcall open))
+ (funcall jump action (consult--grep-position
+ cand
+ (and (not (eq action 'exit)) open))))))
(defun consult--grep-group (cand transform)
"Return title for CAND or TRANSFORM the candidate."
