Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | ;; Copyright (C) 2005-2007 Vesa Karvonen |
2 | ;; | |
3 | ;; MLton is released under a BSD-style license. | |
4 | ;; See the file MLton-LICENSE for details. | |
5 | ||
6 | (require 'esml-util) | |
7 | ||
8 | ;; Emacs mode for editing ML Basis files | |
9 | ;; | |
10 | ;; Installation | |
11 | ;; ============ | |
12 | ;; | |
13 | ;; - Push the path to this file (and `esml-util.el') to `load-path' and | |
14 | ;; either | |
15 | ;; (require 'esml-mlb-mode) | |
16 | ;; or | |
17 | ;; (autoload 'esml-mlb-mode "esml-mlb-mode") | |
18 | ;; (add-to-list 'auto-mode-alist '("\\.mlb\\'" . esml-mlb-mode)) | |
19 | ;; in your Emacs initialization file. | |
20 | ;; | |
21 | ;; Alternatively you could use `load-file'. | |
22 | ;; | |
23 | ;; Beware that (at least) Tuareg mode may already be associated to .mlb | |
24 | ;; files. You need to add ML Basis mode to `auto-mode-alist' after | |
25 | ;; Tuareg mode. | |
26 | ;; | |
27 | ;; - Check the `esml-mlb' customization group. | |
28 | ;; | |
29 | ;; Ideas for future development | |
30 | ;; ============================ | |
31 | ;; | |
32 | ;; - customisable indentation | |
33 | ;; - movement | |
34 | ;; - type-check / compile / compile-and-run | |
35 | ;; - find-structure / find-signature / find-functor | |
36 | ;; - highlight only binding occurances of basids | |
37 | ;; - find-binding-occurance (of a basid) | |
38 | ;; - support doc strings in mlb files | |
39 | ||
40 | ;; TBD: | |
41 | ;; - fix indentation bugs | |
42 | ;; - use something more robust than `shell-command' to run shell commands | |
43 | ||
44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
45 | ;; Prelude | |
46 | ||
47 | (defvar esml-mlb-load-time t) | |
48 | ||
49 | (defun esml-mlb-set-custom-and-update (sym val) | |
50 | (custom-set-default sym val) | |
51 | (unless esml-mlb-load-time | |
52 | (esml-mlb-update))) | |
53 | ||
54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
55 | ;; Customization | |
56 | ||
57 | (defgroup esml-mlb nil | |
58 | "Major mode for editing ML Basis files." | |
59 | :group 'sml) | |
60 | ||
61 | (defcustom esml-mlb-additional-annotations | |
62 | '() | |
63 | "Additional annotations accepted by your compiler(s). Note that ML | |
64 | Basis mode runs the `esml-mlb-show-annotations-command' to query available | |
65 | annotations automatically." | |
66 | :type '(repeat (cons :tag "Annotation" | |
67 | (string :tag "Name") | |
68 | (repeat :tag "Values starting with the default" | |
69 | string))) | |
70 | :set 'esml-mlb-set-custom-and-update | |
71 | :group 'esml-mlb) | |
72 | ||
73 | (defcustom esml-mlb-additional-path-variables | |
74 | '() | |
75 | "Additional path variables that can not be found in the path map files | |
76 | specified by `esml-mlb-mlb-path-map-files' or by running the command | |
77 | `esml-mlb-show-path-map-command'." | |
78 | :type '(repeat (cons (string :tag "Name") (string :tag "Value"))) | |
79 | :set 'esml-mlb-set-custom-and-update | |
80 | :group 'esml-mlb) | |
81 | ||
82 | (defcustom esml-mlb-completion-ignored-files-regexp "\\.[^.].*\\|CVS/\\|.*~" | |
83 | "Completion ignores files (and directories) whose names match this | |
84 | regexp." | |
85 | :type 'regexp | |
86 | :group 'esml-mlb) | |
87 | ||
88 | (defcustom esml-mlb-indentation-offset 3 | |
89 | "Basic offset for indentation." | |
90 | :type 'integer | |
91 | :group 'esml-mlb) | |
92 | ||
93 | (defcustom esml-mlb-key-bindings | |
94 | '(("[tab]" | |
95 | . esml-mlb-indent-line-or-complete) | |
96 | ("[(control c) (control f)]" | |
97 | . esml-mlb-find-file-at-point) | |
98 | ("[(control c) (control s)]" | |
99 | . esml-mlb-show-basis)) | |
100 | "Key bindings for the ML Basis mode. The key specifications must be in a | |
101 | format accepted by the function `define-key'. Hint: You might want to type | |
102 | `M-x describe-function esml-mlb <TAB>' to see the available commands." | |
103 | :type '(repeat (cons :tag "Key Binding" | |
104 | (string :tag "Key") | |
105 | (function :tag "Command"))) | |
106 | :group 'esml-mlb) | |
107 | ||
108 | (defcustom esml-mlb-mlb-path-map-files | |
109 | '("~/.mlton/mlb-path-map" | |
110 | "/usr/lib/mlton/mlb-path-map") | |
111 | "Files to search for definitions of path variables." | |
112 | :type '(repeat file) | |
113 | :set 'esml-mlb-set-custom-and-update | |
114 | :group 'esml-mlb) | |
115 | ||
116 | (defcustom esml-mlb-path-suffix-regexp "fun\\|mlb\\|sig\\|sml" | |
117 | "Regexp for matching valid path name suffices. Completion only considers | |
118 | files whose extension matches this regexp." | |
119 | :type 'regexp | |
120 | :set 'esml-mlb-set-custom-and-update | |
121 | :group 'esml-mlb) | |
122 | ||
123 | (defcustom esml-mlb-show-annotations-command | |
124 | "mlton -expert true -show anns" | |
125 | "Shell command used to query the available annotations." | |
126 | :type 'string | |
127 | :set 'esml-mlb-set-custom-and-update | |
128 | :group 'esml-mlb) | |
129 | ||
130 | (defcustom esml-mlb-show-basis-command | |
131 | "mlton -stop tc -show-basis %t %f" | |
132 | "Shell command used to pretty print the basis defined by an MLB file. | |
133 | `%t' is replaced by the name of a temporary file and `%f' is replaced by | |
134 | the name of the MLB file." | |
135 | :type 'string | |
136 | :group 'esml-mlb) | |
137 | ||
138 | (defcustom esml-mlb-show-path-map-command | |
139 | "mlton -expert true -show path-map" | |
140 | "Shell command used to query the available path variables." | |
141 | :type 'string | |
142 | :set 'esml-mlb-set-custom-and-update | |
143 | :group 'esml-mlb) | |
144 | ||
145 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
146 | ;; Faces | |
147 | ||
148 | (defface font-lock-interface-def-face | |
149 | '((t (:bold t))) | |
150 | "Font Lock mode face used to highlight interface definitions." | |
151 | :group 'font-lock-highlighting-faces) | |
152 | ||
153 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
154 | ;; Annotations | |
155 | ||
156 | (defvar esml-mlb-annotations nil | |
157 | "An association list of known annotations. This variable is updated by | |
158 | `esml-mlb-update'.") | |
159 | ||
160 | (defun esml-mlb-parse-annotations () | |
161 | (setq esml-mlb-annotations | |
162 | (remove-duplicates | |
163 | (sort (append | |
164 | esml-mlb-additional-annotations | |
165 | (when (not (string= "" esml-mlb-show-annotations-command)) | |
166 | (mapcar (function | |
167 | (lambda (s) | |
168 | (esml-split-string s "[ \t]*[{}|][ \t]*"))) | |
169 | (esml-split-string | |
170 | (with-temp-buffer | |
171 | (save-window-excursion | |
172 | (shell-command | |
173 | esml-mlb-show-annotations-command | |
174 | (current-buffer)) | |
175 | (buffer-string))) | |
176 | "[ \t]*\n+[ \t]*")))) | |
177 | (function | |
178 | (lambda (a b) | |
179 | (string-lessp (car a) (car b))))) | |
180 | :test (function | |
181 | (lambda (a b) | |
182 | (string= (car a) (car b))))))) | |
183 | ||
184 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
185 | ;; Path variables | |
186 | ||
187 | (defvar esml-mlb-path-variables nil | |
188 | "An association list of known path variables. This variable is updated | |
189 | by `esml-mlb-update'.") | |
190 | ||
191 | (defun esml-mlb-parse-path-variables-from-string (path-map-string) | |
192 | (mapcar (function | |
193 | (lambda (s) (apply (function cons) (esml-split-string s "[ \t]+")))) | |
194 | (esml-split-string path-map-string "[ \t]*\n+[ \t]*"))) | |
195 | ||
196 | (defun esml-mlb-parse-path-variables () | |
197 | (setq esml-mlb-path-variables | |
198 | (remove-duplicates | |
199 | (sort (append | |
200 | esml-mlb-additional-path-variables | |
201 | (esml-mlb-parse-path-variables-from-string | |
202 | (with-temp-buffer | |
203 | (save-window-excursion | |
204 | (shell-command | |
205 | esml-mlb-show-path-map-command | |
206 | (current-buffer)) | |
207 | (buffer-string)))) | |
208 | (loop for file in esml-mlb-mlb-path-map-files | |
209 | append (when (file-readable-p file) | |
210 | (esml-mlb-parse-path-variables-from-string | |
211 | (with-temp-buffer | |
212 | (insert-file-contents file) | |
213 | (buffer-string)))))) | |
214 | (function | |
215 | (lambda (a b) | |
216 | (string-lessp (car a) (car b))))) | |
217 | :test (function | |
218 | (lambda (a b) | |
219 | (string= (car a) (car b))))))) | |
220 | ||
221 | (defun esml-mlb-expand-path (path) | |
222 | "Expands path variable references in the given path." | |
223 | (let ((parts nil)) | |
224 | (with-temp-buffer | |
225 | (insert path) | |
226 | (goto-char 0) | |
227 | (while (not (eobp)) | |
228 | (if (looking-at "\\$(\\([^)]+\\))") | |
229 | (let* ((name (match-string 1)) | |
230 | (name-value (assoc name esml-mlb-path-variables))) | |
231 | (unless name-value | |
232 | (compat-error "Unknown path variable: %s" name)) | |
233 | (delete-char (length (match-string 0))) | |
234 | (insert (cdr name-value))) | |
235 | (forward-char 1) | |
236 | (skip-chars-forward "^$") | |
237 | (push (buffer-substring 1 (point)) | |
238 | parts) | |
239 | (delete-char (- 1 (point)))) | |
240 | (goto-char 0))) | |
241 | (apply (function concat) (reverse parts)))) | |
242 | ||
243 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
244 | ;; Syntax and highlighting | |
245 | ||
246 | (defconst esml-mlb-string-continue-regexp "\\(?:\\\\[ \t\n]+\\\\\\)") | |
247 | (defconst esml-mlb-string-char-regexp | |
248 | (concat "\\(?:" esml-mlb-string-continue-regexp | |
249 | "*\\(?:[^\n\"\\]\\|\\\\[^ \t\n]\\)\\)")) | |
250 | (defconst esml-mlb-inside-string-regexp | |
251 | (concat "\"" esml-mlb-string-char-regexp "*" | |
252 | esml-mlb-string-continue-regexp "*")) | |
253 | (defconst esml-mlb-string-regexp (concat esml-mlb-inside-string-regexp "\"")) | |
254 | (defconst esml-mlb-inside-comment-regexp "(\\*\\(?:[^*]\\|\\*[^)]\\)*") | |
255 | (defconst esml-mlb-comment-regexp | |
256 | (concat esml-mlb-inside-comment-regexp "\\*)")) | |
257 | (defconst esml-mlb-path-var-chars "A-Za-z0-9_") | |
258 | (defconst esml-mlb-unquoted-path-chars "-A-Za-z0-9_/.") | |
259 | (defconst esml-mlb-unquoted-path-or-ref-chars | |
260 | (concat esml-mlb-unquoted-path-chars "()$")) | |
261 | (defconst esml-mlb-compiler-ann-prefix | |
262 | (concat "\\(?:" esml-mlb-string-char-regexp "*:[ \t]*\\)")) | |
263 | ||
264 | (defun esml-mlb-<token>-to-regexp (<token>) | |
265 | (let* ((<token>-to-regexp | |
266 | '(("<longstrid>" . "[A-Za-z0-9_]*"))) | |
267 | (<token>-regexp (assoc <token> <token>-to-regexp))) | |
268 | (if <token>-regexp | |
269 | (cdr <token>-regexp) | |
270 | <token>))) | |
271 | ||
272 | (defconst esml-mlb-keywords | |
273 | '("and" "ann" "bas" "basis" "end" "functor" "in" "let" "local" "open" | |
274 | "signature" "structure") | |
275 | "Keywords of ML Basis syntax.") | |
276 | ||
277 | (defconst esml-mlb-keywords-usually-followed-by-space | |
278 | '("and" "functor" "open" "signature" "structure") | |
279 | "Keywords of ML Basis syntax that are under most circumstances followed | |
280 | by a space.") | |
281 | ||
282 | (defconst esml-mlb-mode-syntax-table | |
283 | (let ((table (make-syntax-table))) | |
284 | (mapc (function | |
285 | (lambda (char-flags) | |
286 | (modify-syntax-entry (car char-flags) (cdr char-flags) | |
287 | table))) | |
288 | '((?\( . "()1") | |
289 | (?\* . ". 23") | |
290 | (?\) . ")(4") | |
291 | (?\" . "$") ;; not '"' to allow custom highlighting of ann | |
292 | (?\\ . "/") ;; not '\' due to class of '"' | |
293 | (?/ . "_") | |
294 | (?- . "_") | |
295 | (?_ . "w") ;; not "_" due to variables regexp | |
296 | (?. . "_") | |
297 | (?$ . "_") | |
298 | (?\; . ".") | |
299 | (?= . "."))) | |
300 | table) | |
301 | "Syntax table for ML Basis mode.") | |
302 | ||
303 | (defvar esml-mlb-font-lock-table nil) | |
304 | ||
305 | (defun esml-mlb-build-font-lock-table () | |
306 | "Builds the font-lock table for ML Basis mode." | |
307 | (setq esml-mlb-font-lock-table | |
308 | `(;; quoted path names | |
309 | (,(concat esml-mlb-inside-string-regexp | |
310 | "\\.\\(" esml-mlb-path-suffix-regexp "\\)\"") | |
311 | . font-lock-constant-face) | |
312 | ;; annotations | |
313 | (,(apply | |
314 | (function concat) | |
315 | "\"[ \t]*" esml-mlb-compiler-ann-prefix "?\\(" | |
316 | (reduce | |
317 | (function | |
318 | (lambda (regexps name-values) | |
319 | (if (cdr regexps) | |
320 | (push "\\|" regexps)) | |
321 | (cons (if (cdr name-values) | |
322 | (concat | |
323 | (car name-values) "[ \t]+\\(" | |
324 | (reduce | |
325 | (function | |
326 | (lambda (r s) | |
327 | (concat r "\\|\\(" | |
328 | (esml-mlb-<token>-to-regexp s) | |
329 | "\\)"))) | |
330 | (cddr name-values) | |
331 | :initial-value (concat "\\(" | |
332 | (esml-mlb-<token>-to-regexp | |
333 | (cadr name-values)) | |
334 | "\\)")) | |
335 | "\\)") | |
336 | (car name-values)) | |
337 | regexps))) | |
338 | esml-mlb-annotations | |
339 | :initial-value '("\\)[ \t]*\""))) | |
340 | . font-lock-string-face) | |
341 | (,esml-mlb-string-regexp | |
342 | . font-lock-warning-face) | |
343 | ;; path variables | |
344 | (,(concat "\\$(\\(" | |
345 | (regexp-opt (mapcar 'car esml-mlb-path-variables)) | |
346 | "\\))") | |
347 | . font-lock-reference-face) | |
348 | ("\\$([^)]*?)" | |
349 | . font-lock-warning-face) | |
350 | ;; unquoted path names | |
351 | (,(concat "[-A-Za-z0-9_/.]*[.]\\(" | |
352 | esml-mlb-path-suffix-regexp | |
353 | "\\)[ \t\n]") | |
354 | . font-lock-constant-face) | |
355 | ("[.][-A-Za-z0-9_]+[ \t\n]" | |
356 | . font-lock-warning-face) | |
357 | ("[A-Za-z0-9_]*[-/.][-A-Za-z0-9_/]*" | |
358 | . font-lock-constant-face) | |
359 | ;; keywords | |
360 | (,(concat "\\<\\(" (regexp-opt esml-mlb-keywords) "\\)\\>") | |
361 | . font-lock-keyword-face) | |
362 | ;; basids | |
363 | ("[A-Za-z][A-Za-z0-9_']*" | |
364 | . font-lock-interface-def-face)))) | |
365 | ||
366 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
367 | ;; Indentation | |
368 | ||
369 | (defconst esml-mlb-indent-sync-keywords-regexp | |
370 | (concat "\\(" | |
371 | (regexp-opt '("ann" "bas" "basis" "end" "functor" "in" "let" | |
372 | "local" "open" "signature" "structure")) | |
373 | "\\)[ \t\n]") | |
374 | "Regexp for synchronizing indentation.") | |
375 | ||
376 | (defun esml-mlb-previous-indentation () | |
377 | "Finds the previous indentation level and evidence." | |
378 | (let ((result nil)) | |
379 | (save-excursion | |
380 | (beginning-of-line) | |
381 | (while (not (or (consp result) (bobp))) | |
382 | (forward-line -1) | |
383 | (beginning-of-line) | |
384 | (skip-chars-forward " \t;") | |
385 | (cond ((looking-at esml-mlb-indent-sync-keywords-regexp) | |
386 | (setq result (let ((start (point)) | |
387 | (indentation (current-column))) | |
388 | (forward-word 1) | |
389 | (cons indentation | |
390 | (intern (buffer-substring | |
391 | start | |
392 | (point))))))) | |
393 | ((looking-at "(\\*") | |
394 | (setq result (cons (current-column) '*))) | |
395 | (t | |
396 | (setq result (if result | |
397 | (min result (current-indentation)) | |
398 | (current-indentation))))))) | |
399 | (cond ((consp result) | |
400 | result) | |
401 | ((numberp result) | |
402 | (cons result 'min)) | |
403 | (t | |
404 | '(0 . min))))) | |
405 | ||
406 | (defun esml-mlb-indent-line () | |
407 | "Indent current line as ML Basis code." | |
408 | (interactive) | |
409 | (let* ((indent-evidence (esml-mlb-previous-indentation)) | |
410 | (indent (car indent-evidence)) | |
411 | (evidence (cdr indent-evidence))) | |
412 | (save-excursion | |
413 | (beginning-of-line) | |
414 | (skip-chars-forward " \t") | |
415 | (cond ((looking-at ";") | |
416 | (case evidence | |
417 | ((in bas) | |
418 | (indent-line-to | |
419 | (max 0 (+ indent -2 esml-mlb-indentation-offset)))) | |
420 | (t | |
421 | (indent-line-to (max 0 (- indent 2)))))) | |
422 | ((looking-at "end[ \t\n]") | |
423 | (case evidence | |
424 | ((ann bas in let local) | |
425 | (indent-line-to indent)) | |
426 | (t | |
427 | (indent-line-to | |
428 | (max 0 (- indent esml-mlb-indentation-offset)))))) | |
429 | ((looking-at "in[ \t\n]") | |
430 | (case evidence | |
431 | ((ann let local) | |
432 | (indent-line-to indent)) | |
433 | (t | |
434 | (indent-line-to (- indent esml-mlb-indentation-offset))))) | |
435 | ((looking-at "and[ \t\n]") | |
436 | (case evidence | |
437 | ((basis functor signature structure) | |
438 | (indent-line-to (+ indent -3 (length (symbol-name evidence))))) | |
439 | (t | |
440 | (indent-line-to indent)))) | |
441 | ((looking-at "\\*") | |
442 | (case evidence | |
443 | ((*) | |
444 | (indent-line-to (+ indent 1))) | |
445 | (t | |
446 | (indent-line-to indent)))) | |
447 | (t | |
448 | (case evidence | |
449 | ((ann bas in let local) | |
450 | (indent-line-to (+ indent esml-mlb-indentation-offset))) | |
451 | (t | |
452 | (indent-line-to indent)))))) | |
453 | (if (< (current-column) (current-indentation)) | |
454 | (forward-char (- (current-indentation) (current-column)))))) | |
455 | ||
456 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
457 | ;; Completion | |
458 | ||
459 | (defun esml-mlb-filter-file-completions (completions &optional allow-dots) | |
460 | "Removes the directories `./' and `../' as well as files whose suffix | |
461 | does not appear in `esml-mlb-path-suffix-regexp' from the list of file | |
462 | name completions." | |
463 | (let ((ignored-files-regexp | |
464 | (concat "^\\(" esml-mlb-completion-ignored-files-regexp "\\)$")) | |
465 | (valid-suffices-regexp | |
466 | (concat "^\\(" esml-mlb-path-suffix-regexp "\\)$"))) | |
467 | (remove* | |
468 | nil | |
469 | completions | |
470 | :test (function | |
471 | (lambda (_ x) | |
472 | (or (and (not allow-dots) | |
473 | (member x '("./" "../"))) | |
474 | (string-match ignored-files-regexp x) | |
475 | (not (or (file-name-directory x) | |
476 | (let ((ext (file-name-extension x))) | |
477 | (when ext | |
478 | (string-match | |
479 | valid-suffices-regexp ext))))))))))) | |
480 | ||
481 | (defun esml-mlb-complete () | |
482 | "Performs context sensitive completion at point." | |
483 | (interactive) | |
484 | (cond | |
485 | ;; no completion inside comments | |
486 | ((esml-point-preceded-by esml-mlb-inside-comment-regexp)) | |
487 | ||
488 | ;; annotation values | |
489 | ((esml-point-preceded-by | |
490 | (concat "\"[ \t\n]*" esml-mlb-compiler-ann-prefix "?\\(" | |
491 | (regexp-opt (mapcar 'car esml-mlb-annotations)) | |
492 | "\\)[ \t\n]+\\(" esml-mlb-string-char-regexp "*\\)")) | |
493 | (let* ((annot (assoc (match-string 1) esml-mlb-annotations)) | |
494 | (all-values (cdr annot)) | |
495 | (values (remove* nil all-values | |
496 | :test (function | |
497 | (lambda (_ s) | |
498 | (and (< 0 (length s)) | |
499 | (= ?< (aref s 0))))))) | |
500 | (value-prefix (match-string 2)) | |
501 | (value-completion | |
502 | (try-completion value-prefix (mapcar 'list values))) | |
503 | (value (if (eq t value-completion) value-prefix value-completion))) | |
504 | (message "Annotation: %s %s" (car annot) (if all-values all-values "")) | |
505 | (when (stringp value-completion) | |
506 | (esml-insert-or-skip-if-looking-at | |
507 | (substring value (length value-prefix)))) | |
508 | (when (and value | |
509 | (eq t (try-completion value (mapcar 'list values)))) | |
510 | (esml-insert-or-skip-if-looking-at "\"")))) | |
511 | ||
512 | ;; annotation names | |
513 | ((and (esml-point-preceded-by | |
514 | (concat "\\<ann[ \t\n]+\\([ \t\n]+\\|" esml-mlb-string-regexp | |
515 | "\\|" esml-mlb-comment-regexp "\\)*\"[^\"]*")) | |
516 | (esml-point-preceded-by | |
517 | (concat "\"[ \t\n]*" esml-mlb-compiler-ann-prefix "?\\(" | |
518 | esml-mlb-string-char-regexp "*\\)"))) | |
519 | (let* ((name-prefix (match-string 1)) | |
520 | (name-completion (try-completion name-prefix esml-mlb-annotations)) | |
521 | (name (if (eq t name-completion) name-prefix name-completion))) | |
522 | (if (not name-completion) | |
523 | (message "Annotations: %s" (mapcar 'car esml-mlb-annotations)) | |
524 | (when (stringp name-completion) | |
525 | (esml-insert-or-skip-if-looking-at | |
526 | (substring name (length name-prefix)))) | |
527 | (if (and name | |
528 | (eq t (try-completion name esml-mlb-annotations))) | |
529 | (let ((values (cdr (assoc name esml-mlb-annotations)))) | |
530 | (esml-insert-or-skip-if-looking-at (if values " " "\"")) | |
531 | (message "Annotation: %s %s" name (if values values ""))) | |
532 | (message "Annotations: %s" | |
533 | (all-completions name-prefix esml-mlb-annotations)))))) | |
534 | ||
535 | ;; path variables | |
536 | ((esml-point-preceded-by (concat "\\$(\\([" esml-mlb-path-var-chars "]*\\)")) | |
537 | (let* ((name-prefix (match-string 1)) | |
538 | (name-completion | |
539 | (try-completion name-prefix esml-mlb-path-variables)) | |
540 | (name (if (eq t name-completion) name-prefix name-completion))) | |
541 | (if (not name-completion) | |
542 | (message "Path variables: %s" (mapcar 'car esml-mlb-path-variables)) | |
543 | (when (stringp name-completion) | |
544 | (esml-insert-or-skip-if-looking-at | |
545 | (substring name (length name-prefix)))) | |
546 | (if (and name | |
547 | (eq t (try-completion name esml-mlb-path-variables))) | |
548 | (let* ((value (cdr (assoc name esml-mlb-path-variables))) | |
549 | (expanded (esml-mlb-expand-path value))) | |
550 | (esml-insert-or-skip-if-looking-at ")") | |
551 | (if (string= value expanded) | |
552 | (message "Path variable: %s [%s]" name value) | |
553 | (message "Path variable: %s [%s ==> %s]" name value expanded))) | |
554 | (message "Path variables: %s" | |
555 | (all-completions name-prefix esml-mlb-path-variables)))))) | |
556 | ||
557 | ;; filenames and keywords | |
558 | ((or (esml-point-preceded-by | |
559 | (concat "\\(\"\\)\\(" esml-mlb-string-char-regexp "+\\)")) | |
560 | (esml-point-preceded-by | |
561 | (concat "\\([ \t\n]\\|^\\)\\([" | |
562 | esml-mlb-unquoted-path-or-ref-chars | |
563 | "]+\\)"))) | |
564 | ;; TBD: escape sequences in quoted pathnames | |
565 | (let* ((quoted (string= "\"" (match-string 1))) | |
566 | (path-prefix (match-string 2)) | |
567 | (path-expanded (esml-mlb-expand-path path-prefix)) | |
568 | (dir (if (file-name-directory path-expanded) | |
569 | (file-name-directory path-expanded) | |
570 | "")) | |
571 | (nondir-prefix (file-name-nondirectory path-expanded)) | |
572 | (nondir-completions | |
573 | (mapcar 'list | |
574 | (let ((files (esml-mlb-filter-file-completions | |
575 | (file-name-all-completions nondir-prefix dir) | |
576 | t))) | |
577 | (if (string= "" dir) | |
578 | (if quoted | |
579 | files | |
580 | (append (all-completions | |
581 | nondir-prefix | |
582 | (mapcar 'list esml-mlb-keywords)) | |
583 | files)) | |
584 | (esml-mlb-filter-file-completions | |
585 | files | |
586 | (esml-string-matches-p "\\(\.\./\\)+" dir)))))) | |
587 | (nondir-completion (try-completion nondir-prefix nondir-completions)) | |
588 | (nondir (if (eq t nondir-completion) | |
589 | nondir-prefix | |
590 | nondir-completion))) | |
591 | (if (not nondir-completion) | |
592 | (if (string= path-prefix path-expanded) | |
593 | (message "No completions for %s" path-prefix) | |
594 | (message "No completions for %s ==> %s" path-prefix path-expanded)) | |
595 | (when (stringp nondir-completion) | |
596 | (esml-insert-or-skip-if-looking-at | |
597 | (substring nondir (length nondir-prefix)))) | |
598 | (if (eq t (try-completion nondir nondir-completions)) | |
599 | (cond | |
600 | ((file-name-directory nondir) | |
601 | (message "Completions: %s" | |
602 | (sort (let ((dir (concat dir nondir))) | |
603 | (esml-mlb-filter-file-completions | |
604 | (file-name-all-completions "" dir) | |
605 | (esml-string-matches-p "\\(\.\./\\)+" dir))) | |
606 | 'string-lessp))) | |
607 | ((member nondir esml-mlb-keywords) | |
608 | (esml-mlb-indent-line) | |
609 | (message "Keyword: %s" nondir) | |
610 | (when (member nondir esml-mlb-keywords-usually-followed-by-space) | |
611 | (esml-insert-or-skip-if-looking-at " "))) | |
612 | (t | |
613 | (message "Expanded path: %s%s" dir nondir))) | |
614 | (message "Completions: %s" | |
615 | (sort (mapcar 'car nondir-completions) | |
616 | 'string-lessp)))))))) | |
617 | ||
618 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
619 | ;; Commands | |
620 | ||
621 | (defun esml-mlb-indent-line-or-complete () | |
622 | "Indents the current line. If indentation does not change, attempts to | |
623 | perform context sensitive completion. This command is not idempotent." | |
624 | (interactive) | |
625 | (let ((old-indentation (current-indentation))) | |
626 | (esml-mlb-indent-line) | |
627 | (when (= old-indentation (current-indentation)) | |
628 | (esml-mlb-complete)))) | |
629 | ||
630 | (defun esml-mlb-find-file-at-point () | |
631 | "Grabs the path surrounding point and attempts to find the file." | |
632 | (interactive) | |
633 | (let ((file (esml-mlb-expand-path | |
634 | (save-excursion | |
635 | (if (and (not (bobp)) | |
636 | (= ?\" (char-before))) | |
637 | (let ((end (point))) | |
638 | (backward-sexp) | |
639 | (buffer-substring (+ (point) 1) (- end 1))) | |
640 | (skip-chars-backward esml-mlb-unquoted-path-or-ref-chars) | |
641 | (let ((start (point))) | |
642 | (skip-chars-forward esml-mlb-unquoted-path-or-ref-chars) | |
643 | (buffer-substring start (point)))))))) | |
644 | (if (file-readable-p file) | |
645 | (find-file file) | |
646 | (message (if (file-exists-p file) | |
647 | "Not readable: %s" | |
648 | "Does not exists: %s") | |
649 | file)))) | |
650 | ||
651 | (defconst esml-mlb-show-basis-process-name "*mlb-show-basis*") | |
652 | ||
653 | (defun esml-mlb-show-basis () | |
654 | "Shows the basis defined by the MLB file in the current buffer." | |
655 | (interactive) | |
656 | ;; TBD: find-error / error output mode | |
657 | (unless (eq major-mode 'esml-mlb-mode) | |
658 | (compat-error "show-basis is only meaningful on MLB files")) | |
659 | (when (get-process esml-mlb-show-basis-process-name) | |
660 | (compat-error "show-basis already running")) | |
661 | (save-some-buffers) | |
662 | (lexical-let ((tmp-file (concat | |
663 | (file-name-directory (buffer-file-name)) | |
664 | "." (file-name-nondirectory (buffer-file-name)) | |
665 | ".basis")) | |
666 | (buffer (get-buffer-create esml-mlb-show-basis-process-name))) | |
667 | (when (file-exists-p tmp-file) | |
668 | (compat-error "Temporary basis file already exists: %s" tmp-file)) | |
669 | (save-excursion | |
670 | (set-buffer buffer) | |
671 | (delete-region (point-min) (point-max))) | |
672 | (let ((process (start-process-shell-command | |
673 | esml-mlb-show-basis-process-name | |
674 | buffer | |
675 | (compat-replace-regexp-in-string | |
676 | (compat-replace-regexp-in-string | |
677 | esml-mlb-show-basis-command | |
678 | "%t" | |
679 | tmp-file) | |
680 | "%f" | |
681 | (buffer-file-name))))) | |
682 | (set-process-sentinel | |
683 | process | |
684 | (function | |
685 | (lambda (process event) | |
686 | (if (and (esml-string-matches-p "finished\n" event) | |
687 | (file-readable-p tmp-file)) | |
688 | (save-excursion | |
689 | (set-buffer (find-file-other-window tmp-file)) | |
690 | (toggle-read-only) | |
691 | (delete-file tmp-file)) | |
692 | (switch-to-buffer buffer)) | |
693 | (message "%S" event))))) | |
694 | (message "%s" "show-basis running..."))) | |
695 | ||
696 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
697 | ;; Key Map | |
698 | ||
699 | (defvar esml-mlb-mode-map (make-sparse-keymap) | |
700 | "Keymap for ML Basis mode. This variable is updated by | |
701 | `esml-mlb-update'.") | |
702 | ||
703 | (defun esml-mlb-build-mode-map () | |
704 | "Builds the key map for ML Basis mode." | |
705 | (let ((result (make-sparse-keymap))) | |
706 | (mapc (function | |
707 | (lambda (key-command) | |
708 | (define-key result | |
709 | (read (car key-command)) | |
710 | (cdr key-command)))) | |
711 | esml-mlb-key-bindings) | |
712 | (setq esml-mlb-mode-map result))) | |
713 | ||
714 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
715 | ;; Define mode | |
716 | ||
717 | (defvar esml-mlb-mode-hook nil | |
718 | "Hook run when entering ML Basis mode.") | |
719 | ||
720 | (define-derived-mode esml-mlb-mode fundamental-mode "MLB" | |
721 | "Major mode for editing ML Basis files. Provides syntax highlighting, | |
722 | indentation, and context sensitive completion. | |
723 | ||
724 | See the customization group `esml-mlb'." | |
725 | :group 'esml-mlb | |
726 | (set (make-local-variable 'font-lock-defaults) | |
727 | '(esml-mlb-font-lock-table)) | |
728 | (set (make-local-variable 'indent-line-function) | |
729 | 'esml-mlb-indent-line)) | |
730 | ||
731 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
732 | ;; Finalization | |
733 | ||
734 | (setq esml-mlb-load-time nil) | |
735 | ||
736 | (defun esml-mlb-update () | |
737 | "Updates data based on customization variables." | |
738 | (interactive) | |
739 | ;; Warning: order dependencies | |
740 | (esml-mlb-parse-path-variables) | |
741 | (esml-mlb-parse-annotations) | |
742 | (esml-mlb-build-font-lock-table) | |
743 | (esml-mlb-build-mode-map)) | |
744 | ||
745 | ;; We are finally ready to update everything the first time. | |
746 | (esml-mlb-update) | |
747 | ||
748 | (add-to-list 'auto-mode-alist '("\\.mlb\\'" . esml-mlb-mode)) | |
749 | (add-to-list 'auto-mode-alist '("\\.basis\\'" . sml-mode)) | |
750 | ||
751 | (provide 'esml-mlb-mode) |