consult-imenu.el (10231B)
1 ;;; consult-imenu.el --- Consult commands for imenu -*- 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 imenu-related Consult commands. 23 24 ;;; Code: 25 26 (require 'consult) 27 (require 'imenu) 28 29 (defcustom consult-imenu-config 30 '((emacs-lisp-mode :toplevel "Functions" 31 :types ((?f "Functions" font-lock-function-name-face) 32 (?m "Macros" font-lock-function-name-face) 33 (?p "Packages" font-lock-constant-face) 34 (?t "Types" font-lock-type-face) 35 (?v "Variables" font-lock-variable-name-face)))) 36 "Imenu configuration, faces and narrowing keys used by `consult-imenu'. 37 38 For each type a narrowing key and a name must be specified. The 39 face is optional. The imenu representation provided by the 40 backend usually puts functions directly at the toplevel. 41 `consult-imenu' moves them instead under the type specified by 42 :toplevel." 43 :type '(repeat (cons symbol plist)) 44 :group 'consult) 45 46 (defface consult-imenu-prefix 47 '((t :inherit consult-key)) 48 "Face used to highlight imenu prefix in `consult-imenu'." 49 :group 'consult-faces) 50 51 (defvar consult-imenu--history nil) 52 (defvar-local consult-imenu--cache nil) 53 54 (defun consult-imenu--switch-buffer (name pos buf fn &rest args) 55 "Switch buffer before invoking special menu items. 56 NAME is the item name. 57 POS is the position. 58 BUF is the buffer. 59 FN is the original special item function. 60 ARGS are the arguments to the special item function." 61 (funcall consult--buffer-display buf) 62 (apply fn name pos args)) 63 64 (defun consult-imenu--normalize (pos) 65 "Return normalized imenu POS." 66 (pcase pos 67 ;; Create marker from integer item 68 ((pred integerp) (setq pos (copy-marker pos))) 69 ;; Semantic uses overlay for positions 70 ((pred overlayp) (setq pos (copy-marker (overlay-start pos)))) 71 ;; Wrap special item 72 (`(,pos ,fn . ,args) 73 (setq pos `(,pos ,#'consult-imenu--switch-buffer ,(current-buffer) 74 ,fn ,@args)))) 75 (if (or (consp pos) 76 (eq imenu-default-goto-function #'imenu-default-goto-function)) 77 pos 78 (list pos #'consult-imenu--switch-buffer (current-buffer) 79 imenu-default-goto-function))) 80 81 (defun consult-imenu--flatten (prefix face list types) 82 "Flatten imenu LIST. 83 PREFIX is prepended in front of all items. 84 FACE is the item face. 85 TYPES is the mode-specific types configuration." 86 (mapcan 87 (lambda (item) 88 (if (imenu--subalist-p item) 89 (let* ((name (concat (car item))) 90 (next-prefix name) 91 (next-face face)) 92 (add-face-text-property 0 (length name) 93 'consult-imenu-prefix 'append name) 94 (if prefix 95 (setq next-prefix (concat prefix "/" name)) 96 (when-let (type (cdr (assoc name types))) 97 (put-text-property 0 (length name) 'consult--type (car type) name) 98 (setq next-face (cadr type)))) 99 (consult-imenu--flatten next-prefix next-face (cdr item) types)) 100 (list (cons 101 (if prefix 102 (let ((key (concat prefix " " (car item)))) 103 (add-face-text-property (1+ (length prefix)) (length key) 104 face 'append key) 105 key) 106 (car item)) 107 (consult-imenu--normalize (cdr item)))))) 108 list)) 109 110 (defun consult-imenu--compute () 111 "Compute imenu candidates." 112 (consult--forbid-minibuffer) 113 (let* ((imenu-use-markers t) 114 ;; Generate imenu, see `imenu--make-index-alist'. 115 (items (imenu--truncate-items 116 (save-excursion 117 (without-restriction 118 (funcall imenu-create-index-function))))) 119 (config (cdr (seq-find (lambda (x) (derived-mode-p (car x))) consult-imenu-config)))) 120 ;; Fix toplevel items, e.g., emacs-lisp-mode toplevel items are functions 121 (when-let (toplevel (plist-get config :toplevel)) 122 (let ((tops (seq-remove (lambda (x) (listp (cdr x))) items)) 123 (rest (seq-filter (lambda (x) (listp (cdr x))) items))) 124 (setq items (nconc rest (and tops (list (cons toplevel tops))))))) 125 ;; Apply our flattening in order to ease searching the imenu. 126 (consult-imenu--flatten 127 nil nil items 128 (mapcar (pcase-lambda (`(,x ,y ,z)) (list y x z)) 129 (plist-get config :types))))) 130 131 (defun consult-imenu--deduplicate (items) 132 "Deduplicate imenu ITEMS by appending a counter." 133 ;; Some imenu backends generate duplicate items (e.g. for overloaded methods in java) 134 (let ((ht (make-hash-table :test #'equal :size (length items)))) 135 (dolist (item items) 136 (if-let (count (gethash (car item) ht)) 137 (setcar item (format "%s (%s)" (car item) 138 (puthash (car item) (1+ count) ht))) 139 (puthash (car item) 0 ht))))) 140 141 (defun consult-imenu--items () 142 "Return cached imenu candidates, may error." 143 (unless (equal (car consult-imenu--cache) (buffer-modified-tick)) 144 (setq consult-imenu--cache (cons (buffer-modified-tick) (consult-imenu--compute)))) 145 (cdr consult-imenu--cache)) 146 147 (defun consult-imenu--items-safe () 148 "Return cached imenu candidates, will not error." 149 (condition-case err 150 (consult-imenu--items) 151 (t (message "Cannot create Imenu for buffer %s (%s)" 152 (buffer-name) (error-message-string err)) 153 nil))) 154 155 (defun consult-imenu--multi-items (buffers) 156 "Return all imenu items from BUFFERS." 157 (consult--with-increased-gc 158 (let ((reporter (make-progress-reporter "Collecting" 0 (length buffers)))) 159 (prog1 160 (apply #'append 161 (seq-map-indexed (lambda (buf idx) 162 (with-current-buffer buf 163 (prog1 (consult-imenu--items-safe) 164 (progress-reporter-update 165 reporter (1+ idx) (buffer-name))))) 166 buffers)) 167 (progress-reporter-done reporter))))) 168 169 (defun consult-imenu--jump (item) 170 "Jump to imenu ITEM via `consult--jump'. 171 In contrast to the builtin `imenu' jump function, 172 this function can jump across buffers." 173 (pcase item 174 (`(,name ,pos ,fn . ,args) 175 (push-mark nil t) 176 (apply fn name pos args)) 177 (`(,_ . ,pos) 178 (consult--jump pos)) 179 (_ (error "Unknown imenu item: %S" item))) 180 (run-hooks 'imenu-after-jump-hook)) 181 182 (defun consult-imenu--narrow () 183 "Return narrowing configuration for the current buffer." 184 (mapcar (lambda (x) (cons (car x) (cadr x))) 185 (plist-get (cdr (seq-find (lambda (x) (derived-mode-p (car x))) 186 consult-imenu-config)) 187 :types))) 188 189 (defun consult-imenu--group () 190 "Create a imenu group function for the current buffer." 191 (when-let (narrow (consult-imenu--narrow)) 192 (lambda (cand transform) 193 (let ((type (get-text-property 0 'consult--type cand))) 194 (cond 195 ((and transform type) 196 (substring cand (1+ (next-single-property-change 0 'consult--type cand)))) 197 (transform cand) 198 (type (alist-get type narrow))))))) 199 200 (defun consult-imenu--select (prompt items) 201 "Select from imenu ITEMS given PROMPT string." 202 (consult-imenu--deduplicate items) 203 (consult-imenu--jump 204 (consult--read 205 (or items (user-error "Imenu is empty")) 206 :state 207 (let ((preview (consult--jump-preview))) 208 (lambda (action cand) 209 ;; Only preview simple menu items which are markers, 210 ;; in order to avoid any bad side effects. 211 (funcall preview action (and (markerp (cdr cand)) (cdr cand))))) 212 :narrow 213 (when-let (narrow (consult-imenu--narrow)) 214 (list :predicate 215 (lambda (cand) 216 (eq (get-text-property 0 'consult--type (car cand)) consult--narrow)) 217 :keys narrow)) 218 :group (consult-imenu--group) 219 :prompt prompt 220 :require-match t 221 :category 'imenu 222 :lookup #'consult--lookup-cons 223 :history 'consult-imenu--history 224 :add-history (thing-at-point 'symbol) 225 :sort nil))) 226 227 ;;;###autoload 228 (defun consult-imenu () 229 "Select item from flattened `imenu' using `completing-read' with preview. 230 231 The command supports preview and narrowing. See the variable 232 `consult-imenu-config', which configures the narrowing. 233 The symbol at point is added to the future history. 234 235 See also `consult-imenu-multi'." 236 (interactive) 237 (consult-imenu--select 238 "Go to item: " 239 (consult--slow-operation "Building Imenu..." 240 (consult-imenu--items)))) 241 242 ;;;###autoload 243 (defun consult-imenu-multi (&optional query) 244 "Select item from the imenus of all buffers from the same project. 245 246 In order to determine the buffers belonging to the same project, the 247 `consult-project-function' is used. Only the buffers with the 248 same major mode as the current buffer are used. See also 249 `consult-imenu' for more details. In order to search a subset of buffers, 250 QUERY can be set to a plist according to `consult--buffer-query'." 251 (interactive "P") 252 (unless (keywordp (car-safe query)) 253 (setq query (list :sort 'alpha :mode major-mode 254 :directory (and (not query) 'project)))) 255 (let ((buffers (consult--buffer-query-prompt "Go to item" query))) 256 (consult-imenu--select (car buffers) 257 (consult-imenu--multi-items (cdr buffers))))) 258 259 (provide 'consult-imenu) 260 ;;; consult-imenu.el ends here