1 ;; This code defines a few functions for invoking MLton's type checker and
2 ;; visiting the resulting errors. The intended use is:
4 ;; 1. Call mlton-set-main while visiting your main .mlb file.
5 ;; 2. Call mlton-compile to invoke MLton and visit the first error.
6 ;; 3. Repeatedly call mlton-next-error to visit each error.
8 ;; Calling mlton-compile waits until MLton's type checker completes before
9 ;; visiting the first error. One nice thing is that mlton-parse-errors uses
10 ;; markers so that file edits don't interfere with locating subsequent errros.
12 (setq mlton-command
"mlton")
14 (setq mlton-main-file
"mlton-main-file undefined")
15 (setq mlton-output-buffer
"*mlton-output*")
16 (setq mlton-errors nil
)
17 (setq mlton-error-regexp
18 "^\\(Error\\|Warning\\): \\(.+\\) \\([0-9]+\\)\\.\\([0-9]+\\).")
20 (defun mlton-parse-errors (prefix buffer
)
21 "Parse a sequence of MLton error messages in buffer. prefix is the path
22 relative to which files in the error messages should be interpreted.
23 Returns a list of pairs of the form (pos . marker), where pos is a position
24 in buffer at the start of the second line of an error message (i.e. after the
25 file, line, and column info) and marker is at the point of the error in the
27 (if (not (get-buffer buffer
))
28 (message "No errors.")
34 (re-search-forward mlton-error-regexp
)
35 (let* ((match (lambda (i)
36 (buffer-substring (match-beginning i
)
38 (file (funcall match
2))
39 (file (if (file-name-absolute-p file
)
41 (concat prefix
(funcall match
2))))
42 (line (string-to-int (funcall match
3)))
43 (col (string-to-int (funcall match
4)))
44 (marker (save-excursion
47 (forward-char (- col
1))
48 (set-marker (make-marker) (point)))))
51 (setq errors
(cons (cons (point) marker
) errors
))))
53 (setq mlton-errors
(reverse errors
)))))
55 (defun mlton-next-error ()
57 (if (or (not (get-buffer mlton-output-buffer
))
59 (message "No more errors.")
60 (let ((error (caar mlton-errors
))
61 (marker (cdar mlton-errors
)))
62 (setq mlton-errors
(cdr mlton-errors
))
63 (set-window-start (display-buffer mlton-output-buffer
) error
)
64 (switch-to-buffer (marker-buffer marker
))
67 (defun mlton-set-main ()
69 (setq mlton-main-file
(buffer-file-name)))
71 (defvar sml-filename-regexp
72 "\\(\\([-a-zA-Z0-9/.]\\)+\\)\\(\\.\\)\\(\\(cm\\)\\|\\(fun\\)\\|\\(grm\\)\\|\\(lex\\)\\|\\(mlb\\)\\|\\(sig\\)\\|\\(sml\\)\\|\\(ML\\)\\)")
74 (defmacro save-buffer-excursion
(&rest exps
)
75 `(let ((old-buffer (current-buffer)))
77 (set-buffer old-buffer
)))
79 (defun sml-save-buffers ()
80 (save-buffer-excursion
81 (let ((l (buffer-list)))
85 (if (and n
(string-match sml-filename-regexp n
))
88 (if (buffer-modified-p) (save-buffer)))))
91 (defun mlton-compile ()
93 (let ((buffer (current-buffer)))
95 (if (get-buffer mlton-output-buffer
)
96 (kill-buffer mlton-output-buffer
))
97 (find-file mlton-main-file
)
98 (shell-command (concat mlton-command
101 (file-name-nondirectory mlton-main-file
))
103 (mlton-parse-errors (file-name-directory mlton-main-file
)
105 (switch-to-buffer buffer
)
108 (defun mlton-parse-errors-this-buffer ()
110 (if (get-buffer mlton-output-buffer
)
111 (kill-buffer mlton-output-buffer
))
112 (rename-buffer mlton-output-buffer
)
113 (mlton-parse-errors (file-name-directory mlton-main-file
)