Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | ;; This code defines a few functions for invoking MLton's type checker and |
2 | ;; visiting the resulting errors. The intended use is: | |
3 | ;; | |
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. | |
7 | ;; | |
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. | |
11 | ||
12 | (setq mlton-command "mlton") | |
13 | (setq mlton-flags "") | |
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]+\\).") | |
19 | ||
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 | |
26 | source file." | |
27 | (if (not (get-buffer buffer)) | |
28 | (message "No errors.") | |
29 | (let ((errors ())) | |
30 | (set-buffer buffer) | |
31 | (goto-char 0) | |
32 | (condition-case () | |
33 | (while t | |
34 | (re-search-forward mlton-error-regexp) | |
35 | (let* ((match (lambda (i) | |
36 | (buffer-substring (match-beginning i) | |
37 | (match-end i)))) | |
38 | (file (funcall match 2)) | |
39 | (file (if (file-name-absolute-p file) | |
40 | 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 | |
45 | (find-file file) | |
46 | (goto-line line) | |
47 | (forward-char (- col 1)) | |
48 | (set-marker (make-marker) (point))))) | |
49 | (beginning-of-line) | |
50 | (forward-line) | |
51 | (setq errors (cons (cons (point) marker) errors)))) | |
52 | (error)) | |
53 | (setq mlton-errors (reverse errors))))) | |
54 | ||
55 | (defun mlton-next-error () | |
56 | (interactive) | |
57 | (if (or (not (get-buffer mlton-output-buffer)) | |
58 | (null mlton-errors)) | |
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)) | |
65 | (goto-char marker)))) | |
66 | ||
67 | (defun mlton-set-main () | |
68 | (interactive) | |
69 | (setq mlton-main-file (buffer-file-name))) | |
70 | ||
71 | (defvar sml-filename-regexp | |
72 | "\\(\\([-a-zA-Z0-9/.]\\)+\\)\\(\\.\\)\\(\\(cm\\)\\|\\(fun\\)\\|\\(grm\\)\\|\\(lex\\)\\|\\(mlb\\)\\|\\(sig\\)\\|\\(sml\\)\\|\\(ML\\)\\)") | |
73 | ||
74 | (defmacro save-buffer-excursion (&rest exps) | |
75 | `(let ((old-buffer (current-buffer))) | |
76 | (,@ exps) | |
77 | (set-buffer old-buffer))) | |
78 | ||
79 | (defun sml-save-buffers () | |
80 | (save-buffer-excursion | |
81 | (let ((l (buffer-list))) | |
82 | (while (not (null l)) | |
83 | (let* ((b (car l)) | |
84 | (n (buffer-name b))) | |
85 | (if (and n (string-match sml-filename-regexp n)) | |
86 | (progn | |
87 | (set-buffer b) | |
88 | (if (buffer-modified-p) (save-buffer))))) | |
89 | (setq l (cdr l)))))) | |
90 | ||
91 | (defun mlton-compile () | |
92 | (interactive) | |
93 | (let ((buffer (current-buffer))) | |
94 | (sml-save-buffers) | |
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 | |
99 | " " mlton-flags " " | |
100 | " -stop tc " | |
101 | (file-name-nondirectory mlton-main-file)) | |
102 | mlton-output-buffer) | |
103 | (mlton-parse-errors (file-name-directory mlton-main-file) | |
104 | mlton-output-buffer) | |
105 | (switch-to-buffer buffer) | |
106 | (mlton-next-error))) | |
107 | ||
108 | (defun mlton-parse-errors-this-buffer () | |
109 | (interactive) | |
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) | |
114 | (current-buffer))) | |
115 | ||
116 | (provide 'sml-mlton) |