Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | ;; Copyright (C) 2007 Vesa Karvonen |
2 | ;; | |
3 | ;; MLton is released under a BSD-style license. | |
4 | ;; See the file MLton-LICENSE for details. | |
5 | ||
6 | ;; This is a minor mode to support precisely identified definitions and | |
7 | ;; uses. See http://mlton.org/EmacsDefUseMode for further information. | |
8 | ||
9 | ;; XXX def-use-apropos | |
10 | ;; XXX mode specific on-off switching | |
11 | ;; XXX rename-variable | |
12 | ||
13 | (require 'def-use-data) | |
14 | ||
15 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
16 | ;; Prelude | |
17 | ||
18 | (defvar def-use-load-time t) | |
19 | ||
20 | (defun def-use-set-custom-and-update (sym val) | |
21 | (custom-set-default sym val) | |
22 | (unless def-use-load-time | |
23 | (def-use-update))) | |
24 | ||
25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
26 | ;; Customization | |
27 | ||
28 | (defgroup def-use nil | |
29 | "Minor mode to support precisely identified definitions and uses." | |
30 | :group 'matching) | |
31 | ||
32 | (defface def-use-def-face | |
33 | '((((class color)) (:background "darkseagreen3")) | |
34 | (t (:background "gray"))) | |
35 | "Face for highlighting definitions." | |
36 | :group 'faces | |
37 | :group 'def-use) | |
38 | ||
39 | (defface def-use-unused-def-face | |
40 | '((((class color)) (:background "pink")) | |
41 | (t (:background "gray"))) | |
42 | "Face for highlighting definitions that have no uses." | |
43 | :group 'faces | |
44 | :group 'def-use) | |
45 | ||
46 | (defface def-use-use-face | |
47 | '((((class color)) (:background "paleturquoise3")) | |
48 | (t (:background "gray"))) | |
49 | "Face for highlighting uses." | |
50 | :group 'faces | |
51 | :group 'def-use) | |
52 | ||
53 | (defface def-use-mark-face | |
54 | '((((class color)) (:background "orchid1")) | |
55 | (t (:background "gray"))) | |
56 | "Face for marking definitions and uses." | |
57 | :group 'faces | |
58 | :group 'def-use) | |
59 | ||
60 | (defface def-use-view-face | |
61 | '((((class color)) (:background "chocolate1")) | |
62 | (t (:background "gray"))) | |
63 | "Face for marking the definition or use currently being viewed." | |
64 | :group 'faces | |
65 | :group 'def-use) | |
66 | ||
67 | (defcustom def-use-delay 0.125 | |
68 | "Idle time in seconds to delay before updating highlighting or nil if | |
69 | you wish to disable highlighting. | |
70 | ||
71 | Note that because highlighting runs on an idle timer, it may take a while | |
72 | before highlighting is first applied after it has been enabled by changing | |
73 | this customization variable. " | |
74 | :type '(choice | |
75 | (const :tag "disable" nil) | |
76 | (number :tag "seconds")) | |
77 | :set (function def-use-set-custom-and-update) | |
78 | :group 'def-use) | |
79 | ||
80 | (defcustom def-use-priority 1000 | |
81 | "Priority of highlighting overlays." | |
82 | :type 'integer | |
83 | :group 'def-use) | |
84 | ||
85 | (defcustom def-use-marker-ring-length 16 | |
86 | "*Length of marker ring `def-use-marker-ring'." | |
87 | :type 'integer | |
88 | :set (function def-use-set-custom-and-update) | |
89 | :group 'def-use) | |
90 | ||
91 | (defcustom def-use-auto-show-symbol-messages t | |
92 | "Whether to show messages attached to symbols implicitly." | |
93 | :type '(choice | |
94 | (const :tag "disable" nil) | |
95 | (const :tag "enable" t)) | |
96 | :group 'def-use) | |
97 | ||
98 | (defcustom def-use-key-bindings | |
99 | '(("[(control c) (control d)]" . def-use-jump-to-def) | |
100 | ("[(control c) (control l)]" . def-use-list-all-refs) | |
101 | ("[(control c) (control m)]" . def-use-pop-ref-mark) | |
102 | ("[(control c) (control n)]" . def-use-jump-to-next) | |
103 | ("[(control c) (control p)]" . def-use-jump-to-prev) | |
104 | ("[(control c) (control s)]" . def-use-show-dus) | |
105 | ("[(control c) (control t)]" . def-use-show-msg) | |
106 | ("[(control c) (control v)]" . def-use-show-info)) | |
107 | "Key bindings for the def-use mode. The key specifications must be | |
108 | in a format accepted by the function `define-key'. Hint: You might | |
109 | want to type `M-x describe-function def-use <TAB>' to see the | |
110 | available commands." | |
111 | :type '(repeat (cons :tag "Key Binding" | |
112 | (string :tag "Key") | |
113 | (function :tag "Command"))) | |
114 | :set (function def-use-set-custom-and-update) | |
115 | :group 'def-use) | |
116 | ||
117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
118 | ;; High-level symbol lookup | |
119 | ||
120 | (defun def-use-sym-at-point (point &optional no-apology) | |
121 | "Returns symbol information for the symbol at the specified point." | |
122 | (let ((ref (def-use-ref-at-point point))) | |
123 | (when ref | |
124 | (def-use-sym-at-ref ref no-apology)))) | |
125 | ||
126 | (defun def-use-current-sym (&optional no-apology) | |
127 | "Returns symbol information for the symbol at the current point." | |
128 | (def-use-sym-at-point (point) no-apology)) | |
129 | ||
130 | (defun def-use-current-ref () | |
131 | "Returns a reference to the symbol at the current point." | |
132 | (def-use-ref-at-point (point))) | |
133 | ||
134 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
135 | ;; Navigation | |
136 | ||
137 | (defvar def-use-marker-ring (make-ring def-use-marker-ring-length) | |
138 | "Ring of markers which are locations from which \\[def-use-jump-to-def], | |
139 | \\[def-use-jump-to-next], or \\[def-use-jump-to-prev] was invoked.") | |
140 | ||
141 | (defun def-use-create-marker-ring () | |
142 | (setq def-use-marker-ring | |
143 | (make-ring def-use-marker-ring-length))) | |
144 | ||
145 | (defun def-use-pop-ref-mark () | |
146 | "Pop back to where \\[def-use-jump-to-def], \\[def-use-jump-to-next], or | |
147 | \\[def-use-jump-to-prev] was last invoked." | |
148 | (interactive) | |
149 | (if (ring-empty-p def-use-marker-ring) | |
150 | (compat-error "No previous jump locations for invocation")) | |
151 | (let ((marker (ring-remove def-use-marker-ring 0))) | |
152 | (switch-to-buffer | |
153 | (or (marker-buffer marker) | |
154 | (compat-error "The marked buffer has been deleted"))) | |
155 | (goto-char (marker-position marker)) | |
156 | (set-marker marker nil nil))) | |
157 | ||
158 | (defun def-use-jump-to-def (&optional other-window) | |
159 | "Jumps to the definition of the symbol under the cursor." | |
160 | (interactive "P") | |
161 | (let ((sym (def-use-current-sym))) | |
162 | (when sym | |
163 | (ring-insert def-use-marker-ring (point-marker)) | |
164 | (def-use-goto-ref (def-use-sym-ref sym) other-window)))) | |
165 | ||
166 | (defun def-use-jump-to-next (&optional other-window reverse) | |
167 | "Jumps to the next use (or def) of the symbol under the cursor." | |
168 | (interactive "P") | |
169 | (let* ((ref (def-use-current-ref)) | |
170 | (sym (def-use-sym-at-ref ref))) | |
171 | (when sym | |
172 | (let* ((refs (def-use-all-refs-sorted sym)) | |
173 | (refs (if reverse (reverse refs) refs)) | |
174 | (refs (append refs refs))) | |
175 | (while (not (equal (pop refs) ref))) | |
176 | (ring-insert def-use-marker-ring (point-marker)) | |
177 | (def-use-goto-ref (car refs) other-window))))) | |
178 | ||
179 | (defun def-use-jump-to-prev (&optional other-window) | |
180 | "Jumps to the prev use (or def) of the symbol under the cursor." | |
181 | (interactive "P") | |
182 | (def-use-jump-to-next other-window t)) | |
183 | ||
184 | (defun def-use-goto-ref (ref &optional other-window) | |
185 | "Finds the referenced source and moves point to the referenced | |
186 | position." | |
187 | (cond | |
188 | ((not (file-readable-p (def-use-ref-src ref))) | |
189 | (compat-error "Referenced file %s can not be read" (def-use-ref-src ref))) | |
190 | (other-window | |
191 | (def-use-find-file (def-use-ref-src ref) t)) | |
192 | ((not (equal (def-use-buffer-file-truename) (def-use-ref-src ref))) | |
193 | (def-use-find-file (def-use-ref-src ref)))) | |
194 | (def-use-goto-pos (def-use-ref-pos ref))) | |
195 | ||
196 | (defun def-use-goto-pos (pos) | |
197 | "Moves point to the specified position." | |
198 | (goto-char (def-use-pos-to-point pos))) | |
199 | ||
200 | (defun def-use-all-refs-sorted (sym) | |
201 | "Returns a sorted list of all references (including definition) to | |
202 | the symbol." | |
203 | (sort (cons (def-use-sym-ref sym) | |
204 | (copy-list (def-use-sym-to-uses sym))) | |
205 | (function def-use-ref<))) | |
206 | ||
207 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
208 | ;; List mode | |
209 | ||
210 | (defconst def-use-ref-regexp "\\([^ ]+\\):\\([0-9]+\\)\\.\\([0-9]+\\)") | |
211 | ||
212 | (defconst def-use-list-mode-map | |
213 | (let ((result (make-sparse-keymap))) | |
214 | (mapc (function | |
215 | (lambda (key-command) | |
216 | (define-key result | |
217 | (read (car key-command)) | |
218 | (cdr key-command)))) | |
219 | `(("[(b)]" . ,(function bury-buffer)) | |
220 | ("[(m)]" . ,(function def-use-list-view-mark-all)) | |
221 | ("[(u)]" . ,(function def-use-list-view-unmark-all)) | |
222 | ("[(q)]" . ,(function def-use-kill-current-buffer)) | |
223 | ("[(return)]" . ,(function def-use-list-view-ref)))) | |
224 | result)) | |
225 | ||
226 | (define-derived-mode def-use-list-mode fundamental-mode "Def-Use-List" | |
227 | "Major mode for browsing def-use lists." | |
228 | :group 'def-use-list) | |
229 | ||
230 | (defvar def-use-list-ref-to-overlay-alist nil) | |
231 | (defvar def-use-list-sym nil) | |
232 | ||
233 | (defun def-use-list-all-refs (&optional reverse) | |
234 | "Lists all references to the symbol under the cursor." | |
235 | (interactive "P") | |
236 | (let* ((ref (def-use-current-ref)) | |
237 | (sym (def-use-sym-at-ref ref))) | |
238 | (when sym | |
239 | (let* ((name (concat "<:" (def-use-format-sym sym) ":>")) | |
240 | (buffer (get-buffer name))) | |
241 | (if buffer | |
242 | (switch-to-buffer-other-window buffer) | |
243 | (setq buffer (get-buffer-create name)) | |
244 | (switch-to-buffer-other-window buffer) | |
245 | (buffer-disable-undo) | |
246 | (def-use-list-mode) | |
247 | (compat-add-local-hook | |
248 | 'kill-buffer-hook (function def-use-list-view-unmark-all)) | |
249 | (set (make-local-variable 'def-use-list-sym) | |
250 | sym) | |
251 | (insert (def-use-format-sym sym) "\n" | |
252 | "\n") | |
253 | (let* ((refs (def-use-all-refs-sorted sym)) | |
254 | (refs (if reverse (reverse refs) refs))) | |
255 | (set (make-local-variable 'def-use-list-ref-to-overlay-alist) | |
256 | (mapcar (function list) refs)) | |
257 | (mapc (function | |
258 | (lambda (ref) | |
259 | (insert (def-use-format-ref ref) "\n"))) | |
260 | refs)) | |
261 | (goto-line 3) | |
262 | (setq buffer-read-only t)))))) | |
263 | ||
264 | (defun def-use-list-view-ref () | |
265 | "Finds references on the current line and shows in another window." | |
266 | (interactive) | |
267 | (beginning-of-line) | |
268 | (let ((b (current-buffer)) | |
269 | (idx (- (def-use-current-line) 3))) | |
270 | (when (and (<= 0 idx) | |
271 | (< idx (length def-use-list-ref-to-overlay-alist))) | |
272 | (forward-line) | |
273 | (def-use-goto-ref (car (nth idx def-use-list-ref-to-overlay-alist)) t) | |
274 | (switch-to-buffer-other-window b)))) | |
275 | ||
276 | (defun def-use-list-view-mark-all () | |
277 | "Visits all the references and marks them." | |
278 | (interactive) | |
279 | (when (and def-use-list-ref-to-overlay-alist | |
280 | def-use-list-sym) | |
281 | (save-window-excursion | |
282 | (let ((length (length (def-use-sym-name def-use-list-sym)))) | |
283 | (mapc (function | |
284 | (lambda (ref-overlay) | |
285 | (unless (cdr ref-overlay) | |
286 | (def-use-goto-ref (car ref-overlay) t) | |
287 | (setcdr ref-overlay | |
288 | (def-use-create-overlay | |
289 | length | |
290 | (def-use-ref-pos (car ref-overlay)) | |
291 | (- def-use-priority 1) | |
292 | 'def-use-mark-face))))) | |
293 | def-use-list-ref-to-overlay-alist))))) | |
294 | ||
295 | (defun def-use-list-view-unmark-all () | |
296 | "Kills all the marks associated with the list view." | |
297 | (interactive) | |
298 | (when def-use-list-ref-to-overlay-alist | |
299 | (mapc (function | |
300 | (lambda (ref-overlay) | |
301 | (when (cdr ref-overlay) | |
302 | (delete-overlay (cdr ref-overlay)) | |
303 | (setcdr ref-overlay nil)))) | |
304 | def-use-list-ref-to-overlay-alist))) | |
305 | ||
306 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
307 | ;; Info | |
308 | ||
309 | (defun def-use-show-msg (&optional copy-to-kill-ring) | |
310 | "Shows the message for the symbol under the cursor. With a prefix | |
311 | argument the message is also inserted to the `kill-ring'." | |
312 | (interactive "P") | |
313 | (let ((sym (def-use-current-sym))) | |
314 | (when sym | |
315 | (message "%s" (or (def-use-sym-msg sym) | |
316 | "Sorry, no message attached to the symbol.")) | |
317 | (when (and (def-use-sym-msg sym)) | |
318 | (kill-new (def-use-sym-msg sym)))))) | |
319 | ||
320 | (defun def-use-show-info () | |
321 | "Shows info on the symbol under the cursor." | |
322 | (interactive) | |
323 | (let ((sym (def-use-current-sym))) | |
324 | (when sym | |
325 | (message "%s" (def-use-format-sym sym))))) | |
326 | ||
327 | (defun def-use-format-sym (sym) | |
328 | "Formats a string with some basic info on the symbol." | |
329 | (concat (def-use-format-sym-title sym) | |
330 | ", " | |
331 | (number-to-string (length (def-use-sym-to-uses sym))) | |
332 | " uses, defined at: " | |
333 | (def-use-format-ref (def-use-sym-ref sym)))) | |
334 | ||
335 | (defun def-use-format-sym-title (sym) | |
336 | "Formats a title for the symbol" | |
337 | (concat (def-use-add-face 'font-lock-keyword-face | |
338 | (copy-sequence (def-use-sym-class sym))) | |
339 | " " | |
340 | (def-use-add-face (def-use-sym-face sym) | |
341 | (copy-sequence (def-use-sym-name sym))) | |
342 | (if (def-use-sym-msg sym) | |
343 | (concat " : " (def-use-sym-msg sym)) | |
344 | ""))) | |
345 | ||
346 | (defun def-use-format-ref (ref) | |
347 | "Formats a references." | |
348 | (let ((pos (def-use-ref-pos ref))) | |
349 | (concat (def-use-ref-src ref) | |
350 | ":" | |
351 | (def-use-add-face 'font-lock-constant-face | |
352 | (number-to-string (def-use-pos-line pos))) | |
353 | "." | |
354 | (def-use-add-face 'font-lock-constant-face | |
355 | (number-to-string (def-use-pos-col pos)))))) | |
356 | ||
357 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
358 | ;; Highlighting | |
359 | ||
360 | (defvar def-use-highlighted-sym nil) | |
361 | (defvar def-use-highlighted-buffer-file-truename nil) | |
362 | (defvar def-use-highlighted-overlays nil) | |
363 | ||
364 | (defun def-use-delete-highlighting () | |
365 | (mapc (function delete-overlay) def-use-highlighted-overlays) | |
366 | (setq def-use-highlighted-overlays nil | |
367 | def-use-highlighted-sym nil | |
368 | def-use-highlighted-buffer-file-truename nil)) | |
369 | ||
370 | (defun def-use-highlight-ref (sym ref face-attr) | |
371 | (push (def-use-create-overlay sym ref def-use-priority face-attr) | |
372 | def-use-highlighted-overlays)) | |
373 | ||
374 | (defun def-use-create-overlay (length pos priority face-attr) | |
375 | (let* ((begin (def-use-pos-to-point pos)) | |
376 | (beyond (+ begin length)) | |
377 | (overlay (make-overlay begin beyond))) | |
378 | (overlay-put overlay 'priority priority) | |
379 | (overlay-put overlay 'face face-attr) | |
380 | overlay)) | |
381 | ||
382 | (defun def-use-highlight-sym (sym) | |
383 | "Highlights the specified symbol." | |
384 | (let ((buffer-file-truename (def-use-buffer-file-truename))) | |
385 | (unless (and (equal def-use-highlighted-sym sym) | |
386 | (equal def-use-highlighted-buffer-file-truename | |
387 | buffer-file-truename)) | |
388 | (def-use-delete-highlighting) | |
389 | (when sym | |
390 | (setq def-use-highlighted-sym sym | |
391 | def-use-highlighted-buffer-file-truename buffer-file-truename) | |
392 | (let ((length (length (def-use-sym-name sym))) | |
393 | (file-to-poss (def-use-make-hash-table))) | |
394 | (mapc (function | |
395 | (lambda (ref) | |
396 | (puthash (def-use-ref-src ref) | |
397 | (cons (def-use-ref-pos ref) | |
398 | (gethash (def-use-ref-src ref) file-to-poss)) | |
399 | file-to-poss))) | |
400 | (def-use-sym-to-uses sym)) | |
401 | (mapc (function | |
402 | (lambda (buffer) | |
403 | (set-buffer buffer) | |
404 | (mapc (function | |
405 | (lambda (pos) | |
406 | (def-use-highlight-ref | |
407 | length pos 'def-use-use-face))) | |
408 | (gethash | |
409 | (def-use-buffer-file-truename) file-to-poss)))) | |
410 | (buffer-list)) | |
411 | (let* ((ref (def-use-sym-ref sym)) | |
412 | (buffer | |
413 | (def-use-find-buffer-visiting-file (def-use-ref-src ref)))) | |
414 | (when buffer | |
415 | (set-buffer buffer) | |
416 | (def-use-highlight-ref | |
417 | length (def-use-ref-pos ref) | |
418 | (if (def-use-sym-to-uses sym) | |
419 | 'def-use-def-face | |
420 | 'def-use-unused-def-face))))) | |
421 | (when def-use-auto-show-symbol-messages | |
422 | (let ((msg (def-use-sym-msg sym))) | |
423 | (when msg | |
424 | (message "%s" msg)))))))) | |
425 | ||
426 | (defun def-use-highlight-current () | |
427 | "Highlights the symbol at the point." | |
428 | (interactive) | |
429 | (save-excursion | |
430 | (save-window-excursion | |
431 | (def-use-highlight-sym (def-use-current-sym t))))) | |
432 | ||
433 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
434 | ;; Highlighting timer | |
435 | ||
436 | (defvar def-use-highlight-timer nil) | |
437 | ||
438 | (defun def-use-delete-highlight-timer () | |
439 | (when def-use-highlight-timer | |
440 | (compat-delete-timer def-use-highlight-timer) | |
441 | (setq def-use-highlight-timer nil))) | |
442 | ||
443 | (defun def-use-create-highlight-timer () | |
444 | (def-use-delete-highlight-timer) | |
445 | (when (and def-use-delay | |
446 | (def-use-mode-enabled-in-some-buffer)) | |
447 | (setq def-use-highlight-timer | |
448 | (run-with-idle-timer | |
449 | def-use-delay t (function def-use-highlight-current))))) | |
450 | ||
451 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
452 | ;; Mode | |
453 | ||
454 | (defun def-use-mode-enabled-in-some-buffer () | |
455 | (loop for buffer in (buffer-list) do | |
456 | (if (with-current-buffer buffer | |
457 | def-use-mode) | |
458 | (return t)))) | |
459 | ||
460 | (defvar def-use-mode-map (make-sparse-keymap) | |
461 | "Keymap for Def-Use mode. This variable is updated by | |
462 | `def-use-build-mode-map'.") | |
463 | ||
464 | (defun def-use-build-mode-map () | |
465 | (let ((result (make-sparse-keymap))) | |
466 | (mapc (function | |
467 | (lambda (key-command) | |
468 | (define-key result (read (car key-command)) (cdr key-command)))) | |
469 | def-use-key-bindings) | |
470 | (setq def-use-mode-map result)) | |
471 | (let ((cons (assoc 'def-use-mode minor-mode-map-alist))) | |
472 | (when cons | |
473 | (setcdr cons def-use-mode-map)))) | |
474 | ||
475 | (define-minor-mode def-use-mode | |
476 | "Minor mode for highlighting and navigating definitions and uses. | |
477 | ||
478 | \\{def-use-mode-map} | |
479 | " | |
480 | :lighter " DU" | |
481 | :group 'def-use | |
482 | :global t | |
483 | (def-use-delete-highlighting) | |
484 | (def-use-create-highlight-timer)) | |
485 | ||
486 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
487 | ;; Finalization | |
488 | ||
489 | (setq def-use-load-time nil) | |
490 | ||
491 | (defun def-use-update () | |
492 | "Update data based on customization variables." | |
493 | (def-use-create-marker-ring) | |
494 | (def-use-create-highlight-timer) | |
495 | (def-use-build-mode-map)) | |
496 | ||
497 | (def-use-update) | |
498 | ||
499 | (provide 'def-use-mode) |