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