Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | ;; Copyright (C) 2007-2008 Vesa Karvonen |
2 | ;; | |
3 | ;; MLton is released under a BSD-style license. | |
4 | ;; See the file MLton-LICENSE for details. | |
5 | ||
6 | (require 'def-use-mode) | |
7 | (require 'bg-job) | |
8 | (require 'esml-util) | |
9 | ||
10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
11 | ;; Customization | |
12 | ||
13 | (defgroup esml-du nil | |
14 | "MLton def-use info plugin for `def-use-mode'." | |
15 | :group 'sml) | |
16 | ||
17 | (defcustom esml-du-notify 'never | |
18 | "Notify certain events, such as when a def-use -file has been | |
19 | (re)loaded." | |
20 | :type '(choice (const :tag "Never" never) | |
21 | (const :tag "Always" always)) | |
22 | :group 'esml-du) | |
23 | ||
24 | (defcustom esml-du-dufs-auto-load nil | |
25 | "Automatic loading of `esml-du-dufs-recent' at startup." | |
26 | :type '(choice | |
27 | (const :tag "Disabled" nil) | |
28 | (const :tag "Enabled" t)) | |
29 | :group 'esml-du) | |
30 | ||
31 | (defcustom esml-du-dufs-recent '() | |
32 | "Automatically updated list of def-use -files currently or previously | |
33 | loaded. This customization variable is not usually manipulated directly | |
34 | by the user." | |
35 | :type '(repeat | |
36 | (file :tag "Def-Use file" :must-match t)) | |
37 | :group 'esml-du) | |
38 | ||
39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
40 | ;; Interface | |
41 | ||
42 | (defvar esml-du-mlton-history nil) | |
43 | ||
44 | (defun esml-du-mlton (&optional duf dont-save) | |
45 | "Gets def-use information from a def-use file produced by MLton." | |
46 | (interactive) | |
47 | (cond | |
48 | ((not duf) | |
49 | (esml-du-mlton | |
50 | (compat-read-file-name | |
51 | "Specify def-use -file: " nil nil t nil 'esml-du-mlton-history) | |
52 | dont-save)) | |
53 | ((not (and (file-readable-p duf) | |
54 | (file-regular-p duf))) | |
55 | (compat-error "Specified file is not a regular readable file")) | |
56 | ((run-with-idle-timer | |
57 | 0.5 nil | |
58 | (function | |
59 | (lambda (duf dont-save) | |
60 | (let ((duf (def-use-file-truename duf))) | |
61 | (unless (member duf esml-du-live-dufs) | |
62 | (let ((ctx (esml-du-ctx duf))) | |
63 | (esml-du-load ctx) | |
64 | (esml-du-set-live-dufs (cons duf esml-du-live-dufs) dont-save) | |
65 | (def-use-add-dus | |
66 | (function esml-du-title) | |
67 | (function esml-du-sym-at-ref) | |
68 | (function esml-du-sym-to-uses) | |
69 | (function esml-du-finalize) | |
70 | (function esml-du-ctx-attr) | |
71 | ctx)))))) | |
72 | duf dont-save)))) | |
73 | ||
74 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
75 | ;; Move to symbol | |
76 | ||
77 | (defun esml-du-character-class (c) | |
78 | (cond | |
79 | ((find c esml-sml-symbolic-chars) | |
80 | 'symbolic) | |
81 | ((and c (<= ?0 c) (<= c ?9)) | |
82 | 'numeric) | |
83 | ((find c esml-sml-alphanumeric-chars) | |
84 | 'alpha))) | |
85 | ||
86 | (defun esml-du-extract-following-symbol (chars) | |
87 | (save-excursion | |
88 | (let ((start (point))) | |
89 | (skip-chars-forward chars) | |
90 | (buffer-substring start (point))))) | |
91 | ||
92 | (defun esml-du-move-to-symbol-start () | |
93 | "Moves to the start of the SML symbol at point. If the point is between | |
94 | two symbols, one symbolic and other alphanumeric (e.g. !x) the symbol | |
95 | following the point is preferred. This ensures that the symbol does not | |
96 | change surprisingly after a jump." | |
97 | (let ((point (point))) | |
98 | (let ((bef (esml-du-character-class (char-before))) | |
99 | (aft (esml-du-character-class (char-after)))) | |
100 | (cond | |
101 | ((and (or (eq bef 'alpha) (eq bef 'numeric)) (eq aft 'symbolic) | |
102 | (find (esml-du-extract-following-symbol esml-sml-symbolic-chars) | |
103 | esml-sml-symbolic-keywords | |
104 | :test 'equal)) | |
105 | (skip-chars-backward esml-sml-alphanumeric-chars)) | |
106 | ((and (eq bef 'symbolic) | |
107 | (or (eq aft 'numeric) | |
108 | (and (eq aft 'alpha) | |
109 | (find (esml-du-extract-following-symbol | |
110 | esml-sml-alphanumeric-chars) | |
111 | esml-sml-alphanumeric-keywords | |
112 | :test 'equal)))) | |
113 | (skip-chars-backward esml-sml-symbolic-chars)) | |
114 | ((and (eq bef 'symbolic) (not (eq aft 'alpha))) | |
115 | (skip-chars-backward esml-sml-symbolic-chars)) | |
116 | ((and (or (eq bef 'alpha) (eq bef 'numeric)) (not (eq aft 'symbolic))) | |
117 | (skip-chars-backward esml-sml-alphanumeric-chars)))) | |
118 | (when (let ((c (char-after))) (and c (<= ?0 c) (<= c ?9))) | |
119 | (search-forward-regexp esml-sml-numeric-literal-regexp point t)))) | |
120 | ||
121 | (loop for mode in esml-sml-modes do | |
122 | (add-to-list 'def-use-mode-to-move-to-symbol-start-alist | |
123 | (cons mode (function esml-du-move-to-symbol-start)))) | |
124 | ||
125 | (defun esml-du-move-to-symbol-end () | |
126 | "Moves to the end of the SML symbol at point assuming that we are at the | |
127 | beginning of the symbol." | |
128 | (let ((limit (def-use-point-at-next-line))) | |
129 | (when (zerop (skip-chars-forward esml-sml-alphanumeric-chars limit)) | |
130 | (skip-chars-forward esml-sml-symbolic-chars limit)))) | |
131 | ||
132 | (loop for mode in esml-sml-modes do | |
133 | (add-to-list 'def-use-mode-to-move-to-symbol-end-alist | |
134 | (cons mode (function esml-du-move-to-symbol-end)))) | |
135 | ||
136 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
137 | ;; Methods | |
138 | ||
139 | (defun esml-du-title (ctx) | |
140 | (concat | |
141 | (esml-du-ctx-duf ctx) | |
142 | " [loaded " (int-to-string (esml-du-ctx-load-cnt ctx)) " times]")) | |
143 | ||
144 | (defun esml-du-sym-at-ref (ref ctx) | |
145 | (esml-du-reload ctx) | |
146 | (unless (or (let ((buffer (def-use-find-buffer-visiting-file | |
147 | (def-use-ref-src ref)))) | |
148 | (and buffer (buffer-modified-p buffer))) | |
149 | (def-use-attr-newer? | |
150 | (file-attributes (def-use-ref-src ref)) | |
151 | (esml-du-ctx-attr ctx))) | |
152 | (or (gethash ref (esml-du-ctx-ref-to-sym-table ctx)) | |
153 | (and (esml-du-try-to-read-symbol-at-ref ref ctx) | |
154 | (gethash ref (esml-du-ctx-ref-to-sym-table ctx)))))) | |
155 | ||
156 | (defun esml-du-sym-to-uses (sym ctx) | |
157 | (esml-du-reload ctx) | |
158 | (let ((file-to-poss (def-use-make-hash-table))) | |
159 | ;; Process by buffer/file as it avoids repeated work | |
160 | (mapc (function | |
161 | (lambda (ref) | |
162 | (puthash (def-use-ref-src ref) | |
163 | (cons ref | |
164 | (gethash (def-use-ref-src ref) file-to-poss)) | |
165 | file-to-poss))) | |
166 | (gethash sym (esml-du-ctx-sym-to-uses-table ctx))) | |
167 | ;; Remove references to modified buffers | |
168 | (mapc (function | |
169 | (lambda (buffer) | |
170 | (when (buffer-modified-p buffer) | |
171 | (remhash (def-use-buffer-file-truename buffer) | |
172 | file-to-poss)))) | |
173 | (buffer-list)) | |
174 | ;; Remove references to modified files | |
175 | (mapc (function | |
176 | (lambda (file) | |
177 | (when (def-use-attr-newer? | |
178 | (file-attributes file) | |
179 | (esml-du-ctx-attr ctx)) | |
180 | (remhash file file-to-poss)))) | |
181 | (def-use-hash-table-to-key-list file-to-poss)) | |
182 | (apply (function nconc) | |
183 | (def-use-hash-table-to-value-list file-to-poss)))) | |
184 | ||
185 | (defun esml-du-stop-parsing (ctx) | |
186 | (let ((buffer (esml-du-ctx-buf ctx))) | |
187 | (when buffer | |
188 | (kill-buffer buffer)))) | |
189 | ||
190 | (defvar esml-du-live-dufs nil) | |
191 | ||
192 | (defun esml-du-set-live-dufs (dufs &optional dont-save) | |
193 | (setq esml-du-live-dufs dufs) | |
194 | (when (and (not dont-save) | |
195 | esml-du-dufs-auto-load) | |
196 | (customize-save-variable | |
197 | 'esml-du-dufs-recent | |
198 | (copy-list dufs)))) | |
199 | ||
200 | (defun esml-du-finalize (ctx) | |
201 | (esml-du-stop-parsing ctx) | |
202 | (let ((timer (esml-du-ctx-poll-timer ctx))) | |
203 | (when timer | |
204 | (compat-delete-timer timer) | |
205 | (esml-du-ctx-set-poll-timer nil ctx))) | |
206 | (let ((timer (esml-du-ctx-reload-timer ctx))) | |
207 | (when timer | |
208 | (compat-delete-timer timer) | |
209 | (esml-du-ctx-set-reload-timer nil ctx))) | |
210 | (esml-du-set-live-dufs | |
211 | (remove* (esml-du-ctx-duf ctx) | |
212 | esml-du-live-dufs | |
213 | :test (function equal)))) | |
214 | ||
215 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
216 | ;; Context | |
217 | ||
218 | (defun esml-du-ctx (duf) | |
219 | (vector (def-use-make-hash-table) (def-use-make-hash-table) duf nil nil nil 0 | |
220 | nil nil)) | |
221 | ||
222 | (defun esml-du-ctx-reload-timer (ctx) (aref ctx 7)) | |
223 | (defun esml-du-ctx-load-cnt (ctx) (aref ctx 6)) | |
224 | (defun esml-du-ctx-poll-timer (ctx) (aref ctx 5)) | |
225 | (defun esml-du-ctx-buf (ctx) (aref ctx 4)) | |
226 | (defun esml-du-ctx-attr (ctx) (aref ctx 3)) | |
227 | (defun esml-du-ctx-duf (ctx) (aref ctx 2)) | |
228 | (defun esml-du-ctx-ref-to-sym-table (ctx) (aref ctx 1)) | |
229 | (defun esml-du-ctx-sym-to-uses-table (ctx) (aref ctx 0)) | |
230 | ||
231 | (defun esml-du-ctx-inc-load-cnt (ctx) | |
232 | (aset ctx 6 (1+ (aref ctx 6)))) | |
233 | ||
234 | (defun esml-du-ctx-set-reload-timer (timer ctx) (aset ctx 7 timer)) | |
235 | (defun esml-du-ctx-set-poll-timer (timer ctx) (aset ctx 5 timer)) | |
236 | (defun esml-du-ctx-set-buf (buf ctx) (aset ctx 4 buf)) | |
237 | (defun esml-du-ctx-set-attr (attr ctx) (aset ctx 3 attr)) | |
238 | ||
239 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
240 | ;; Parsing | |
241 | ||
242 | (defun esml-du-read (taking skipping) | |
243 | (let ((start (point))) | |
244 | (skip-chars-forward taking) | |
245 | (let ((result (buffer-substring start (point)))) | |
246 | (skip-chars-forward skipping) | |
247 | result))) | |
248 | ||
249 | (defun esml-du-read-opt-str () | |
250 | (when (= (char-after) ?\") | |
251 | (forward-char 1) | |
252 | (esml-du-read "^\"" "\""))) | |
253 | ||
254 | (defconst esml-du-classes ;; XXX Needs customization | |
255 | `((,(def-use-intern "variable") . ,font-lock-variable-name-face) | |
256 | (,(def-use-intern "type") . ,font-lock-variable-name-face) | |
257 | (,(def-use-intern "constructor") . ,font-lock-variable-name-face) | |
258 | (,(def-use-intern "structure") . ,font-lock-variable-name-face) | |
259 | (,(def-use-intern "signature") . ,font-lock-variable-name-face) | |
260 | (,(def-use-intern "functor") . ,font-lock-variable-name-face) | |
261 | (,(def-use-intern "exception") . ,font-lock-variable-name-face))) | |
262 | ||
263 | (defun esml-du-reload (ctx) | |
264 | "Schedules a reload of the def-use file if it has been modified." | |
265 | (let ((attrs (file-attributes (esml-du-ctx-duf ctx)))) | |
266 | (when (def-use-attr-changed? | |
267 | attrs | |
268 | (esml-du-ctx-attr ctx)) | |
269 | (when (esml-du-ctx-reload-timer ctx) | |
270 | (compat-delete-timer (esml-du-ctx-reload-timer ctx))) | |
271 | (esml-du-ctx-set-reload-timer | |
272 | (run-with-idle-timer | |
273 | 0.5 | |
274 | nil | |
275 | (function | |
276 | (lambda (ctx attrs) | |
277 | (if (def-use-attr-changed? | |
278 | (file-attributes (esml-du-ctx-duf ctx)) | |
279 | attrs) | |
280 | (esml-du-reload ctx) | |
281 | (esml-du-ctx-set-reload-timer nil ctx) | |
282 | (esml-du-load ctx)))) | |
283 | ctx attrs) | |
284 | ctx)))) | |
285 | ||
286 | (defun esml-du-try-to-read-symbol-at-ref-once (ref ctx) | |
287 | (when (search-forward (esml-du-ref-to-appx-syntax ref) nil t) | |
288 | (beginning-of-line) | |
289 | (while (= ?\ (char-after)) | |
290 | (forward-line -1)) | |
291 | (esml-du-read-one-symbol ctx))) | |
292 | ||
293 | (defun esml-du-try-to-read-all-symbols-at-ref (ref ctx) | |
294 | (let ((syms nil)) | |
295 | (goto-char 1) | |
296 | (while (let ((sym (esml-du-try-to-read-symbol-at-ref-once ref ctx))) | |
297 | (when sym | |
298 | (push sym syms)))) | |
299 | syms)) | |
300 | ||
301 | (defun esml-du-try-to-read-symbol-at-ref (ref ctx) | |
302 | "Tries to read the symbol at the specified ref from the duf. Returns | |
303 | non-nil if something was actually read." | |
304 | (let ((buffer (esml-du-ctx-buf ctx))) | |
305 | (when buffer | |
306 | (bury-buffer buffer) | |
307 | (with-current-buffer buffer | |
308 | (let ((syms (esml-du-try-to-read-all-symbols-at-ref ref ctx))) | |
309 | (when syms | |
310 | (while syms | |
311 | (let* ((sym (pop syms)) | |
312 | (more-syms | |
313 | (esml-du-try-to-read-all-symbols-at-ref | |
314 | (def-use-sym-ref sym) ctx))) | |
315 | (when more-syms | |
316 | (setq syms (nconc more-syms syms))))) | |
317 | t)))))) | |
318 | ||
319 | (defun esml-du-ref-to-appx-syntax (ref) | |
320 | (let ((pos (def-use-ref-pos ref))) | |
321 | (concat | |
322 | (file-name-nondirectory (def-use-ref-src ref)) " " | |
323 | (int-to-string (def-use-pos-line pos)) "." | |
324 | (int-to-string (1+ (def-use-pos-col pos)))))) | |
325 | ||
326 | (defconst esml-du-highlight-type-map ;; XXX Needs customization | |
327 | `(("\\([a-zA-Z0-9_]+\\)[:]" | |
328 | . ,font-lock-constant-face) | |
329 | ("\\([a-zA-Z0-9_]+\\)\\>\\(?:[^:]\\|$\\)" | |
330 | . ,font-lock-type-face) | |
331 | ("\\(\\<andalso\\>\\)" | |
332 | . ,font-lock-keyword-face) | |
333 | (,(concat "\\<\\(" | |
334 | (regexp-opt | |
335 | '("array" "bool" "char" "exn" "int" "list" "option" "order" | |
336 | "real" "ref" "string" "substring" "unit" "vector" "word")) | |
337 | "\\)\\>") | |
338 | . ,font-lock-builtin-face) | |
339 | ("\\('[a-zA-Z0-9_]+\\)" | |
340 | . ,font-lock-variable-name-face))) | |
341 | ||
342 | (defun esml-du-highlight-type (string) | |
343 | (when string | |
344 | (loop for pat-face in esml-du-highlight-type-map do | |
345 | (let ((pat (car pat-face)) | |
346 | (prop `(face ,(cdr pat-face))) | |
347 | (start 0)) | |
348 | (while (string-match pat string start) | |
349 | (add-text-properties | |
350 | (match-beginning 1) | |
351 | (match-end 1) | |
352 | prop | |
353 | string) | |
354 | (setq start (match-end 0)))))) | |
355 | string) | |
356 | ||
357 | (defun esml-du-read-one-symbol (ctx) | |
358 | "Reads one symbol from the current buffer starting at the current point. | |
359 | Returns the symbol read and deletes the read symbol from the buffer." | |
360 | (let* ((start (point)) | |
361 | (ref-to-sym (esml-du-ctx-ref-to-sym-table ctx)) | |
362 | (sym-to-uses (esml-du-ctx-sym-to-uses-table ctx)) | |
363 | (class (def-use-intern (esml-du-read "^ " " "))) | |
364 | (name (def-use-intern (esml-du-read "^ " " "))) | |
365 | (src (def-use-file-truename (esml-du-read "^ " " "))) | |
366 | (line (string-to-int (esml-du-read "^." "."))) | |
367 | (col (1- (string-to-int (esml-du-read "^ \n" " ")))) | |
368 | (msg (esml-du-highlight-type | |
369 | (def-use-intern (esml-du-read-opt-str)))) | |
370 | (pos (def-use-pos line col)) | |
371 | (ref (def-use-ref src pos)) | |
372 | (sym (def-use-sym class msg name ref | |
373 | (cdr (assoc class esml-du-classes)))) | |
374 | (uses nil)) | |
375 | (let ((old-sym (gethash ref ref-to-sym))) | |
376 | (when old-sym | |
377 | (setq sym old-sym)) | |
378 | (puthash ref sym ref-to-sym)) | |
379 | (skip-chars-forward "\n") | |
380 | (while (< 0 (skip-chars-forward " ")) | |
381 | (let* ((src (def-use-file-truename (esml-du-read "^ " " "))) | |
382 | (line (string-to-int (esml-du-read "^." "."))) | |
383 | (col (1- (string-to-int (esml-du-read "^\n" "\n")))) | |
384 | (pos (def-use-pos line col)) | |
385 | (ref (def-use-ref src pos))) | |
386 | (let ((old-sym (gethash ref ref-to-sym))) | |
387 | (when old-sym | |
388 | (let ((old-uses (gethash old-sym sym-to-uses))) | |
389 | (remhash old-sym sym-to-uses) | |
390 | (mapc | |
391 | (function | |
392 | (lambda (ref) | |
393 | (puthash ref sym ref-to-sym))) | |
394 | old-uses) | |
395 | (setq uses (nconc uses old-uses))))) | |
396 | (puthash ref sym ref-to-sym) | |
397 | (push ref uses))) | |
398 | (puthash sym uses sym-to-uses) | |
399 | (setq buffer-read-only nil) | |
400 | (delete-backward-char (- (point) start)) | |
401 | (setq buffer-read-only t) | |
402 | sym)) | |
403 | ||
404 | (defun esml-du-load (ctx) | |
405 | "Loads the def-use file to a buffer for performing queries." | |
406 | (esml-du-ctx-set-attr (file-attributes (esml-du-ctx-duf ctx)) ctx) | |
407 | (if (esml-du-ctx-buf ctx) | |
408 | (with-current-buffer (esml-du-ctx-buf ctx) | |
409 | (goto-char 1) | |
410 | (setq buffer-read-only nil) | |
411 | (delete-char (1- (point-max)))) | |
412 | (esml-du-ctx-set-buf | |
413 | (generate-new-buffer (concat "** " (esml-du-ctx-duf ctx) " **")) ctx) | |
414 | (with-current-buffer (esml-du-ctx-buf ctx) | |
415 | (buffer-disable-undo) | |
416 | (compat-add-local-hook | |
417 | 'kill-buffer-hook | |
418 | (lexical-let ((ctx ctx)) | |
419 | (function | |
420 | (lambda () | |
421 | (esml-du-ctx-set-buf nil ctx))))))) | |
422 | (bury-buffer (esml-du-ctx-buf ctx)) | |
423 | (with-current-buffer (esml-du-ctx-buf ctx) | |
424 | (insert-file-contents (esml-du-ctx-duf ctx)) | |
425 | (setq buffer-read-only t) | |
426 | (goto-char 1)) | |
427 | (clrhash (esml-du-ctx-ref-to-sym-table ctx)) | |
428 | (clrhash (esml-du-ctx-sym-to-uses-table ctx)) | |
429 | (garbage-collect) | |
430 | (when (memq esml-du-notify '(always)) | |
431 | (message "Loaded %s" (esml-du-ctx-duf ctx))) | |
432 | (esml-du-ctx-inc-load-cnt ctx)) | |
433 | ||
434 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
435 | ||
436 | (run-with-idle-timer | |
437 | 1.0 nil | |
438 | (function | |
439 | (lambda () | |
440 | (when esml-du-dufs-auto-load | |
441 | (mapc (function | |
442 | (lambda (file) | |
443 | (when (and (file-readable-p file) | |
444 | (file-regular-p file)) | |
445 | (esml-du-mlton file t)))) | |
446 | esml-du-dufs-recent))))) | |
447 | ||
448 | (provide 'esml-du-mlton) |