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