1 ;; Copyright (C) 2007-2008 Vesa Karvonen
3 ;; MLton is released under a BSD-style license.
4 ;; See the file MLton-LICENSE for details.
6 (require 'def-use-mode
)
10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 "MLton def-use info plugin for `def-use-mode'."
17 (defcustom esml-du-notify
'never
18 "Notify certain events, such as when a def-use -file has been
20 :type
'(choice (const :tag
"Never" never
)
21 (const :tag
"Always" always
))
24 (defcustom esml-du-dufs-auto-load nil
25 "Automatic loading of `esml-du-dufs-recent' at startup."
27 (const :tag
"Disabled" nil
)
28 (const :tag
"Enabled" t
))
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
36 (file :tag
"Def-Use file" :must-match t
))
39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
42 (defvar esml-du-mlton-history nil
)
44 (defun esml-du-mlton (&optional duf dont-save
)
45 "Gets def-use information from a def-use file produced by MLton."
50 (compat-read-file-name
51 "Specify def-use -file: " nil nil t nil
'esml-du-mlton-history
)
53 ((not (and (file-readable-p duf
)
54 (file-regular-p duf
)))
55 (compat-error "Specified file is not a regular readable file"))
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
)))
64 (esml-du-set-live-dufs (cons duf esml-du-live-dufs
) dont-save
)
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
)
74 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
77 (defun esml-du-character-class (c)
79 ((find c esml-sml-symbolic-chars
)
81 ((and c
(<= ?
0 c
) (<= c ?
9))
83 ((find c esml-sml-alphanumeric-chars
)
86 (defun esml-du-extract-following-symbol (chars)
88 (let ((start (point)))
89 (skip-chars-forward chars
)
90 (buffer-substring start
(point)))))
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))))
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
105 (skip-chars-backward esml-sml-alphanumeric-chars
))
106 ((and (eq bef
'symbolic
)
107 (or (eq aft
'numeric
)
109 (find (esml-du-extract-following-symbol
110 esml-sml-alphanumeric-chars
)
111 esml-sml-alphanumeric-keywords
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
))))
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
))))
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
))))
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
))))
136 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
139 (defun esml-du-title (ctx)
141 (esml-du-ctx-duf ctx
)
142 " [loaded " (int-to-string (esml-du-ctx-load-cnt ctx
)) " times]"))
144 (defun esml-du-sym-at-ref (ref 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
)))
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
))))))
156 (defun esml-du-sym-to-uses (sym ctx
)
158 (let ((file-to-poss (def-use-make-hash-table)))
159 ;; Process by buffer/file as it avoids repeated work
162 (puthash (def-use-ref-src ref
)
164 (gethash (def-use-ref-src ref
) file-to-poss
))
166 (gethash sym
(esml-du-ctx-sym-to-uses-table ctx
)))
167 ;; Remove references to modified buffers
170 (when (buffer-modified-p buffer
)
171 (remhash (def-use-buffer-file-truename buffer
)
174 ;; Remove references to modified files
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
))))
185 (defun esml-du-stop-parsing (ctx)
186 (let ((buffer (esml-du-ctx-buf ctx
)))
188 (kill-buffer buffer
))))
190 (defvar esml-du-live-dufs nil
)
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
200 (defun esml-du-finalize (ctx)
201 (esml-du-stop-parsing ctx
)
202 (let ((timer (esml-du-ctx-poll-timer ctx
)))
204 (compat-delete-timer timer
)
205 (esml-du-ctx-set-poll-timer nil ctx
)))
206 (let ((timer (esml-du-ctx-reload-timer ctx
)))
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
)
213 :test
(function equal
))))
215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
218 (defun esml-du-ctx (duf)
219 (vector (def-use-make-hash-table) (def-use-make-hash-table) duf nil nil nil
0
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))
231 (defun esml-du-ctx-inc-load-cnt (ctx)
232 (aset ctx
6 (1+ (aref ctx
6))))
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
))
239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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
)
249 (defun esml-du-read-opt-str ()
250 (when (= (char-after) ?
\")
252 (esml-du-read "^\"" "\"")))
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
)))
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?
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
277 (if (def-use-attr-changed?
278 (file-attributes (esml-du-ctx-duf ctx
))
281 (esml-du-ctx-set-reload-timer nil ctx
)
282 (esml-du-load ctx
))))
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
)
289 (while (= ?\
(char-after))
291 (esml-du-read-one-symbol ctx
)))
293 (defun esml-du-try-to-read-all-symbols-at-ref (ref ctx
)
296 (while (let ((sym (esml-du-try-to-read-symbol-at-ref-once ref ctx
)))
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
)))
307 (with-current-buffer buffer
308 (let ((syms (esml-du-try-to-read-all-symbols-at-ref ref ctx
)))
311 (let* ((sym (pop syms
))
313 (esml-du-try-to-read-all-symbols-at-ref
314 (def-use-sym-ref sym
) ctx
)))
316 (setq syms
(nconc more-syms syms
)))))
319 (defun esml-du-ref-to-appx-syntax (ref)
320 (let ((pos (def-use-ref-pos ref
)))
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
))))))
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
)
335 '("array" "bool" "char" "exn" "int" "list" "option" "order"
336 "real" "ref" "string" "substring" "unit" "vector" "word"))
338 .
,font-lock-builtin-face
)
339 ("\\('[a-zA-Z0-9_]+\\)"
340 .
,font-lock-variable-name-face
)))
342 (defun esml-du-highlight-type (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
)))
348 (while (string-match pat string start
)
354 (setq start
(match-end 0))))))
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
))))
375 (let ((old-sym (gethash ref ref-to-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
)))
388 (let ((old-uses (gethash old-sym sym-to-uses
)))
389 (remhash old-sym sym-to-uses
)
393 (puthash ref sym ref-to-sym
)))
395 (setq uses
(nconc uses old-uses
)))))
396 (puthash ref sym ref-to-sym
)
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
)
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
)
410 (setq buffer-read-only nil
)
411 (delete-char (1- (point-max))))
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
418 (lexical-let ((ctx ctx
))
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
)
427 (clrhash (esml-du-ctx-ref-to-sym-table ctx
))
428 (clrhash (esml-du-ctx-sym-to-uses-table ctx
))
430 (when (memq esml-du-notify
'(always))
431 (message "Loaded %s" (esml-du-ctx-duf ctx
)))
432 (esml-du-ctx-inc-load-cnt ctx
))
434 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
440 (when esml-du-dufs-auto-load
443 (when (and (file-readable-p file
)
444 (file-regular-p file
))
445 (esml-du-mlton file t
))))
446 esml-du-dufs-recent
)))))
448 (provide 'esml-du-mlton
)