branch: externals/consult
commit 963221cf868b2025f89dc05681972f4b6a4ee531
Author: Daniel Mendler <m...@daniel-mendler.de>
Commit: GitHub <nore...@github.com>
Add consult-info command (#727)
---
CHANGELOG.org | 1 +
README.org | 17 ++++--
consult-info.el | 165 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
consult.el | 13 ++---
4 files changed, 186 insertions(+), 10 deletions(-)
diff --git a/CHANGELOG.org b/CHANGELOG.org
index 30ff841cbc..9da6421ebd 100644
--- a/CHANGELOG.org
+++ b/CHANGELOG.org
@@ -4,6 +4,7 @@
* Development
+- Add =consult-info= command (#634, #727).
- =consult-buffer=: Always select the first candidate when narrowing (#714).
- Drop obsolete =consult-apropos=. Alternative: =describe-symbol= in
combination
with =embark-export=.
diff --git a/README.org b/README.org
index abdec42235..6e46a053a6 100644
--- a/README.org
+++ b/README.org
@@ -334,6 +334,16 @@ their descriptions.
- =consult-org-agenda=: Jump to an agenda heading. Supports
narrowing by heading level, priority and TODO state, as well as
live preview and recursive editing.
+** Help
+:properties:
+:description: Searching through help
+:end:
+
+#+findex: consult-info
+#+findex: consult-man
+- =consult-man=: Find Unix man page, via Unix =apropos= or =man -k=.
=consult-man= opens
+ the selected man page using the Emacs =man= command.
+- =consult-info=: Full text search through info pages.
** Miscellaneous
:properties:
@@ -342,11 +352,8 @@ their descriptions.
#+findex: consult-completion-in-region
#+findex: consult-theme
-#+findex: consult-man
#+findex: consult-preview-at-point
#+findex: consult-preview-at-point-mode
-- =consult-man=: Find Unix man page, via Unix =apropos= or =man -k=.
=consult-man= opens
- the selected man page using the Emacs =man= command.
- =consult-theme=: Select a theme and disable all currently enabled themes.
Supports live preview of the theme while scrolling through the candidates.
- =consult-preview-at-point= and =consult-preview-at-point-mode=: Command and
minor
@@ -750,9 +757,11 @@ configuration examples.
(use-package consult
;; Replace bindings. Lazily loaded due by `use-package'.
:bind (;; C-c bindings (mode-specific-map)
+ ("C-c M-x" . consult-mode-command)
("C-c h" . consult-history)
- ("C-c m" . consult-mode-command)
("C-c k" . consult-kmacro)
+ ("C-c m" . consult-man)
+ ("C-c i" . consult-info)
;; C-x bindings (ctl-x-map)
("C-x M-:" . consult-complex-command) ;; orig.
repeat-complex-command
("C-x b" . consult-buffer) ;; orig. switch-to-buffer
diff --git a/consult-info.el b/consult-info.el
new file mode 100644
index 0000000000..e641d4de12
--- /dev/null
+++ b/consult-info.el
@@ -0,0 +1,165 @@
+;;; consult-info.el --- Search through the info manuals -*- lexical-binding: t
-*-
+
+;; Copyright (C) 2021-2023 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; 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:
+
+;; Provides the command `consult-info'. This is an extra package,
+;; to allow lazy loading of info.el. The `consult-info' command
+;; is autoloaded.
+
+;;; Code:
+
+(require 'consult)
+(require 'info)
+
+(defvar consult-info--history nil)
+
+(defun consult-info--candidates (manuals input)
+ "Dynamically find lines in MANUALS matching INPUT."
+ (let (candidates)
+ (pcase-dolist (`(,manual . ,buffer) manuals)
+ (with-current-buffer buffer
+ (widen)
+ (goto-char (point-min))
+ (pcase-let ((`(,regexps . ,hl)
+ (funcall consult--regexp-compiler input 'emacs t)))
+ ;; TODO subfile support?!
+ (while (ignore-errors (re-search-forward (car regexps) nil t))
+ (let ((bol (pos-bol))
+ (eol (pos-eol))
+ (current-node nil))
+ (when
+ (save-excursion
+ (goto-char bol)
+ (and
+ (>= (- (point) 2) (point-min))
+ ;; Information separator character
+ (not (eq (char-after (- (point) 2)) ?\^_))
+ ;; Only printable characters on the line, [:cntrl:] does
+ ;; not work?!
+ (not (re-search-forward "[^[:print:]]" eol t))
+ ;; Matches all regexps
+ (seq-every-p
+ (lambda (r)
+ (goto-char bol)
+ (ignore-errors (re-search-forward r eol t)))
+ (cdr regexps))
+ ;; Find node beginning
+ (progn
+ (goto-char bol)
+ (if (search-backward "\n\^_" nil 'move)
+ (forward-line 2)
+ (when (looking-at "\^_")
+ (forward-line 1))))
+ ;; Node name
+ (re-search-forward "Node:[ \t]*" nil t)
+ (setq current-node
+ (buffer-substring-no-properties
+ (point)
+ (progn
+ (skip-chars-forward "^,\t\n")
+ (point))))))
+ (let* ((node (format "(%s)%s" manual current-node))
+ (cand (concat
+ node ":"
+ (funcall hl (buffer-substring-no-properties bol
eol)))))
+ (add-text-properties 0 (length node)
+ (list 'consult--info-position (cons
buffer bol)
+ 'face 'consult-file
+ 'consult--file-group node)
+ cand)
+ (push cand candidates))))))))
+ (nreverse candidates)))
+
+(defun consult-info--lookup (selected candidates &rest _)
+ "Lookup info position marker given SELECTED candidate from CANDIDATES list."
+ (when-let ((cand (car (member selected candidates)))
+ (pos (get-text-property 0 'consult--info-position cand))
+ (node (get-text-property 0 'consult--file-group cand))
+ (matches (consult--point-placement cand (1+ (length node)))))
+ (save-restriction
+ (widen)
+ (cons node
+ (cons
+ (set-marker (make-marker) (+ (cdr pos) (car matches)) (car pos))
+ (cdr matches))))))
+
+(defun consult-info--state ()
+ "Info manual preview state."
+ (let ((preview (consult--jump-preview)))
+ (lambda (action cand)
+ (if (not cand)
+ (funcall preview action nil)
+ (let* ((pos (get-text-property 0 'consult--info-position cand))
+ (node (get-text-property 0 'consult--file-group cand))
+ (matches (consult--point-placement cand (1+ (length node))))
+ (dest (+ (cdr pos) (car matches))))
+ (funcall preview action
+ (cons
+ (set-marker (make-marker) dest (car pos))
+ (cdr matches)))
+ (pcase action
+ ('preview
+ (let (Info-history Info-history-list Info-history-forward)
+ (ignore-errors (Info-select-node))))
+ ('return
+ (info node)
+ (widen)
+ (goto-char dest)
+ (Info-select-node)
+ (run-hooks 'consult-after-jump-hook))))))))
+
+;;;###autoload
+(defun consult-info (&rest manuals)
+ "Full text search through info MANUALS."
+ (interactive
+ (progn
+ (info-initialize)
+ (completing-read-multiple
+ "Info Manuals: "
+ (info--manual-names current-prefix-arg)
+ nil t)))
+ (let (buffers)
+ (unwind-protect
+ (progn
+ (dolist (manual manuals)
+ (with-current-buffer (generate-new-buffer (format "*info-preview:
%s*" manual))
+ (let (Info-history Info-history-list Info-history-forward)
+ (Info-mode)
+ (Info-find-node manual "Top")) ;; TODO noerror?
+ (push (cons manual (current-buffer)) buffers)))
+ (consult--read
+ (consult--dynamic-collection
+ (apply-partially #'consult-info--candidates buffers))
+ :state (consult-info--state)
+ :prompt (format "Info (%s): " (string-join manuals ", "))
+ :require-match t
+ :sort nil
+ :history '(:input consult-info--history)
+ :group #'consult--file-group
+ ;; TODO fix consult-man and consult-info embark integration
+ ;; We have to set (alist-get '(general . consult-man)
embark-default-action-overrides)
+ ;; and (alist-get '(general . consult-info)
embark-default-action-overrides)
+ :initial (consult--async-split-initial "")
+ :lookup #'consult--lookup-member))
+ (dolist (buf buffers)
+ (kill-buffer (cdr buf))))))
+
+(provide 'consult-info)
+;;; consult-info.el ends here
diff --git a/consult.el b/consult.el
index 90f9ad46c2..241d7c3930 100644
--- a/consult.el
+++ b/consult.el
@@ -4555,8 +4555,8 @@ BUILDER is the command argument builder."
(when highlight
(funcall highlight content))
(setq str (concat file sep line sep content))
- ;; Store file name in order to avoid allocations in
`consult--grep-group'
- (add-text-properties 0 file-len `(face consult-file
consult--grep-file ,file) str)
+ ;; Store file name in order to avoid allocations in
`consult--file-group'
+ (add-text-properties 0 file-len `(face consult-file
consult--file-group ,file) str)
(put-text-property (1+ file-len) (+ 1 file-len line-len)
'face 'consult-line-number str)
(when ctx
(add-face-text-property (+ 2 file-len line-len) (length
str) 'consult-grep-context 'append str))
@@ -4589,11 +4589,12 @@ FIND-FILE is the file open function, defaulting to
`find-file'."
cand
(and (not (eq action 'return)) open))))))
-(defun consult--grep-group (cand transform)
+;; TODO rename also in affe
+(defun consult--file-group (cand transform)
"Return title for CAND or TRANSFORM the candidate."
(if transform
- (substring cand (1+ (length (get-text-property 0 'consult--grep-file
cand))))
- (get-text-property 0 'consult--grep-file cand)))
+ (substring cand (1+ (length (get-text-property 0 'consult--file-group
cand))))
+ (get-text-property 0 'consult--file-group cand)))
(defun consult--grep-exclude-args ()
"Produce grep exclude arguments.
@@ -4624,7 +4625,7 @@ INITIAL is inital input."
:add-history (consult--async-split-thingatpt 'symbol)
:require-match t
:category 'consult-grep
- :group #'consult--grep-group
+ :group #'consult--file-group
:history '(:input consult--grep-history)
:sort nil)))
