ide/emacs/esml-mlb-mode.el

   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)