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