[elpa] externals/consult 963221cf86 1/3: Add consult-info command (#727)

[ELPA Syncer]

branch: externals/consult
commit 963221cf868b2025f89dc05681972f4b6a4ee531
Author: Daniel Mendler <mail@daniel-mendler.de>
Commit: GitHub <noreply@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)))