consult-info.el (8017B)
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 (eval-when-compile (require 'cl-lib)) 31 32 (defvar-local consult-info--manual nil) 33 (defvar consult-info--history nil) 34 35 (defun consult-info--candidates (buffers input) 36 "Dynamically find lines in BUFFERS matching INPUT." 37 (pcase-let* ((`(,regexps . ,hl) 38 (funcall consult--regexp-compiler input 'emacs t)) 39 (re (concat "\\(\^_\n\\(?:.*Node:[ \t]*\\([^,\t\n]+\\)\\)?.*\n\\)\\|" (car regexps))) 40 (candidates nil) 41 (cand-idx 0) 42 (last-node nil) 43 (full-node nil)) 44 (when regexps 45 (dolist (buf buffers) 46 (with-current-buffer buf 47 (setq last-node nil full-node nil) 48 (widen) 49 (goto-char (point-min)) 50 (while (and (not (eobp)) (re-search-forward re nil t)) 51 (if (match-end 1) 52 (progn 53 (if-let ((node (match-string 2))) 54 (unless (equal node last-node) 55 (setq full-node (concat consult-info--manual node) 56 last-node node)) 57 (setq last-node nil full-node nil)) 58 (goto-char (1+ (pos-eol)))) 59 (let ((bol (pos-bol)) 60 (eol (pos-eol))) 61 (goto-char bol) 62 (when (and 63 full-node 64 ;; Information separator character 65 (>= (- (point) 2) (point-min)) 66 (not (eq (char-after (- (point) 2)) ?\^_)) 67 ;; Non-blank line, only printable characters on the line. 68 (not (looking-at-p "^\\s-*$")) 69 (looking-at-p "^[[:print:]]*$") 70 ;; Matches all regexps 71 (seq-every-p (lambda (r) 72 (goto-char bol) 73 (re-search-forward r eol t)) 74 (cdr regexps))) 75 (let ((cand (concat 76 (funcall hl (buffer-substring-no-properties bol eol)) 77 (consult--tofu-encode cand-idx)))) 78 (put-text-property 0 1 'consult--info (list full-node bol buf) cand) 79 (cl-incf cand-idx) 80 (push cand candidates))) 81 (goto-char (1+ eol))))))) 82 (nreverse candidates)))) 83 84 (defun consult-info--position (cand) 85 "Return position information for CAND." 86 (when-let ((pos (and cand (get-text-property 0 'consult--info cand))) 87 (matches (consult--point-placement cand 0)) 88 (dest (+ (cadr pos) (car matches)))) 89 `( ,(cdr matches) ,dest . ,pos))) 90 91 (defun consult-info--action (cand) 92 "Jump to info CAND." 93 (pcase (consult-info--position cand) 94 (`( ,_matches ,pos ,node ,_bol ,_buf) 95 (info node) 96 (widen) 97 (goto-char pos) 98 (Info-select-node) 99 (run-hooks 'consult-after-jump-hook)))) 100 101 (defun consult-info--state () 102 "Info manual preview state." 103 (let ((preview (consult--jump-preview))) 104 (lambda (action cand) 105 (pcase action 106 ('preview 107 (setq cand (consult-info--position cand)) 108 (funcall preview 'preview 109 (pcase cand 110 (`(,matches ,pos ,_node ,_bol ,buf) 111 (cons (set-marker (make-marker) pos buf) matches)))) 112 (let (Info-history Info-history-list Info-history-forward) 113 (when cand (ignore-errors (Info-select-node))))) 114 ('return 115 (consult-info--action cand)))))) 116 117 (defun consult-info--group (cand transform) 118 "Return title for CAND or TRANSFORM the candidate." 119 (if transform cand 120 (car (get-text-property 0 'consult--info cand)))) 121 122 (defun consult-info--buffer (manual init) 123 "Make preview buffer for MANUAL and call INIT." 124 (let (buf) 125 (unwind-protect 126 (with-current-buffer (setq buf (generate-new-buffer 127 (format "*info-%s*" manual))) 128 (let (Info-history Info-history-list Info-history-forward) 129 (Info-mode) 130 (Info-find-node manual "Top") 131 (setq consult-info--manual (concat "(" manual ")")) 132 (and (ignore-errors (funcall init)) 133 (prog1 buf 134 (rename-buffer (concat " Preview:" (buffer-name))) 135 (setq buf nil))))) 136 (when buf (kill-buffer buf))))) 137 138 (defun consult-info--prepare-buffers (manuals fun) 139 "Prepare buffers for MANUALS and call FUN with buffers." 140 (declare (indent 1)) 141 (let (buffers) 142 (unwind-protect 143 (let ((reporter (make-progress-reporter "Preparing" 0 (length manuals)))) 144 (consult--with-increased-gc 145 (cl-loop 146 for idx from 0 for manual in manuals do 147 (push (consult-info--buffer manual #'always) buffers) 148 ;; Create a separate buffer if the info manual has subfiles. They 149 ;; are present on my system and have names like 150 ;; /usr/share/info/texinfo.info-2.gz. 151 (while-let 152 ((sub (buffer-local-value 'Info-current-subfile (car buffers))) 153 (pos (string-match-p "-\\([0-9]+\\)\\'" sub)) 154 (buf (consult-info--buffer 155 manual 156 (lambda () 157 (ignore-errors 158 (Info-read-subfile 159 (format "%s%s" (substring sub 0 pos) 160 (1- (string-to-number (substring sub pos))))) 161 (Info-select-node) 162 t))))) 163 (push buf buffers)) 164 (progress-reporter-update reporter (1+ idx) manual))) 165 (progress-reporter-done reporter) 166 (funcall fun (reverse buffers))) 167 (mapc #'kill-buffer buffers)))) 168 169 ;;;###autoload 170 (defun consult-info (&rest manuals) 171 "Full text search through info MANUALS." 172 (interactive 173 (if Info-current-file 174 (list (file-name-base Info-current-file)) 175 (info-initialize) 176 (completing-read-multiple 177 "Info Manuals: " 178 (info--manual-names current-prefix-arg) 179 nil t))) 180 (consult-info--prepare-buffers manuals 181 (lambda (buffers) 182 (consult--read 183 (consult--dynamic-collection 184 (apply-partially #'consult-info--candidates buffers)) 185 :state (consult-info--state) 186 :prompt 187 (format "Info (%s): " 188 (string-join (if (length> manuals 3) 189 `(,@(seq-take manuals 3) ,"…") 190 manuals) 191 ", ")) 192 :require-match t 193 :sort nil 194 :category 'consult-info 195 :history '(:input consult-info--history) 196 :group #'consult-info--group 197 :initial (consult--async-split-initial "") 198 :add-history (consult--async-split-thingatpt 'symbol) 199 :lookup #'consult--lookup-member)))) 200 201 (provide 'consult-info) 202 ;;; consult-info.el ends here