consult-info.el (7175B)
1 ;;; consult-info.el --- Search through the info manuals -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2021-2024 Free Software Foundation, Inc. 4 5 ;; This file is part of GNU Emacs. 6 7 ;; This program is free software: you can redistribute it and/or modify 8 ;; it under the terms of the GNU General Public License as published by 9 ;; the Free Software Foundation, either version 3 of the License, or 10 ;; (at your option) any later version. 11 12 ;; This program is distributed in the hope that it will be useful, 13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;; GNU General Public License for more details. 16 17 ;; You should have received a copy of the GNU General Public License 18 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 19 20 ;;; Commentary: 21 22 ;; Provides the command `consult-info'. This is an extra package, 23 ;; to allow lazy loading of info.el. The `consult-info' command 24 ;; is autoloaded. 25 26 ;;; Code: 27 28 (require 'consult) 29 (require 'info) 30 31 (defvar consult-info--history nil) 32 33 (defun consult-info--candidates (manuals input) 34 "Dynamically find lines in MANUALS matching INPUT." 35 (pcase-let* ((`(,regexps . ,hl) 36 (funcall consult--regexp-compiler input 'emacs t)) 37 (re (concat "\\(\^_\n\\(?:.*Node:[ \t]*\\([^,\t\n]+\\)\\)?.*\n\\)\\|" (car regexps))) 38 (candidates nil) 39 (cand-idx 0) 40 (last-node nil) 41 (full-node nil)) 42 (pcase-dolist (`(,manual . ,buf) manuals) 43 (with-current-buffer buf 44 (setq last-node nil full-node nil) 45 (widen) 46 (goto-char (point-min)) 47 ;; TODO Info has support for subfiles, which is currently not supported 48 ;; by the `consult-info' search routine. Fortunately most (or all?) 49 ;; Emacs info files are generated with the --no-split option. See the 50 ;; comment in doc/emacs/Makefile.in. Given the computing powers these 51 ;; days split info files are probably also not necessary anymore. 52 ;; However it could happen that info files installed as part of the 53 ;; Linux distribution are split. 54 (while (and (not (eobp)) (re-search-forward re nil t)) 55 (if (match-end 1) 56 (progn 57 (if-let ((node (match-string 2))) 58 (unless (equal node last-node) 59 (setq full-node (concat "(" manual ")" node) 60 last-node node)) 61 (setq last-node nil full-node nil)) 62 (goto-char (1+ (pos-eol)))) 63 (let ((bol (pos-bol)) 64 (eol (pos-eol))) 65 (goto-char bol) 66 (when (and 67 full-node 68 ;; Information separator character 69 (>= (- (point) 2) (point-min)) 70 (not (eq (char-after (- (point) 2)) ?\^_)) 71 ;; Non-blank line, only printable characters on the line. 72 (not (looking-at-p "^\\s-*$")) 73 (looking-at-p "^[[:print:]]*$") 74 ;; Matches all regexps 75 (seq-every-p (lambda (r) 76 (goto-char bol) 77 (re-search-forward r eol t)) 78 (cdr regexps))) 79 (let ((cand (concat 80 (funcall hl (buffer-substring-no-properties bol eol)) 81 (consult--tofu-encode cand-idx)))) 82 (put-text-property 0 1 'consult--info (list full-node bol buf) cand) 83 (cl-incf cand-idx) 84 (push cand candidates))) 85 (goto-char (1+ eol))))))) 86 (nreverse candidates))) 87 88 (defun consult-info--position (cand) 89 "Return position information for CAND." 90 (when-let ((pos (and cand (get-text-property 0 'consult--info cand))) 91 (matches (consult--point-placement cand 0)) 92 (dest (+ (cadr pos) (car matches)))) 93 `( ,(cdr matches) ,dest . ,pos))) 94 95 (defun consult-info--action (cand) 96 "Jump to info CAND." 97 (pcase (consult-info--position cand) 98 (`( ,_matches ,pos ,node ,_bol ,_buf) 99 (info node) 100 (widen) 101 (goto-char pos) 102 (Info-select-node) 103 (run-hooks 'consult-after-jump-hook)))) 104 105 (defun consult-info--state () 106 "Info manual preview state." 107 (let ((preview (consult--jump-preview))) 108 (lambda (action cand) 109 (pcase action 110 ('preview 111 (setq cand (consult-info--position cand)) 112 (funcall preview 'preview 113 (pcase cand 114 (`(,matches ,pos ,_node ,_bol ,buf) 115 (cons (set-marker (make-marker) pos buf) matches)))) 116 (let (Info-history Info-history-list Info-history-forward) 117 (when cand (ignore-errors (Info-select-node))))) 118 ('return 119 (consult-info--action cand)))))) 120 121 (defun consult-info--group (cand transform) 122 "Return title for CAND or TRANSFORM the candidate." 123 (if transform cand 124 (car (get-text-property 0 'consult--info cand)))) 125 126 (defun consult-info--prepare-buffers (manuals fun) 127 "Prepare buffers for MANUALS and call FUN with buffers." 128 (declare (indent 1)) 129 (let (buffers) 130 (unwind-protect 131 (let ((reporter (make-progress-reporter "Preparing" 0 (length manuals)))) 132 (consult--with-increased-gc 133 (seq-do-indexed 134 (lambda (manual idx) 135 (push (cons manual (generate-new-buffer (format "*info-preview-%s*" manual))) 136 buffers) 137 (with-current-buffer (cdar buffers) 138 (let (Info-history Info-history-list Info-history-forward) 139 (Info-mode) 140 (Info-find-node manual "Top"))) 141 (progress-reporter-update reporter (1+ idx) manual)) 142 manuals)) 143 (progress-reporter-done reporter) 144 (funcall fun (reverse buffers))) 145 (dolist (buf buffers) 146 (kill-buffer (cdr buf)))))) 147 148 ;;;###autoload 149 (defun consult-info (&rest manuals) 150 "Full text search through info MANUALS." 151 (interactive 152 (if Info-current-file 153 (list (file-name-base Info-current-file)) 154 (info-initialize) 155 (completing-read-multiple 156 "Info Manuals: " 157 (info--manual-names current-prefix-arg) 158 nil t))) 159 (consult-info--prepare-buffers manuals 160 (lambda (buffers) 161 (consult--read 162 (consult--dynamic-collection 163 (apply-partially #'consult-info--candidates buffers)) 164 :state (consult-info--state) 165 :prompt 166 (format "Info (%s): " 167 (string-join (if (length> manuals 3) 168 `(,@(seq-take manuals 3) ,"…") 169 manuals) 170 ", ")) 171 :require-match t 172 :sort nil 173 :category 'consult-info 174 :history '(:input consult-info--history) 175 :group #'consult-info--group 176 :initial (consult--async-split-initial "") 177 :add-history (consult--async-split-thingatpt 'symbol) 178 :lookup #'consult--lookup-member)))) 179 180 (provide 'consult-info) 181 ;;; consult-info.el ends here