sml-mode.el

   1 ;;; sml-mode.el --- Major mode for editing (Standard) ML
   2
   3 ;; Copyright (C) 1999,2000,2004,2007,2010-2012  Stefan Monnier
   4 ;; Copyright (C) 1994-1997  Matthew J. Morley
   5 ;; Copyright (C) 1989       Lars Bo Nielsen
   6
   7 ;; Author: Lars Bo Nielsen
   8 ;;      Olin Shivers
   9 ;;      Fritz Knabe (?)
  10 ;;      Steven Gilmore (?)
  11 ;;      Matthew Morley <mjm@scs.leeds.ac.uk> (aka <matthew@verisity.com>)
  12 ;;      Matthias Blume <blume@cs.princeton.edu> (aka <blume@kurims.kyoto-u.ac.jp>)
  13 ;;      (Stefan Monnier) <monnier@iro.umontreal.ca>
  14 ;; Maintainer: (Stefan Monnier) <monnier@iro.umontreal.ca>
  15 ;; Keywords: SML
  16
  17 ;; This file is not part of GNU Emacs, but it is distributed under the
  18 ;; same conditions.
  19
  20 ;; This program is free software; you can redistribute it and/or
  21 ;; modify it under the terms of the GNU General Public License as
  22 ;; published by the Free Software Foundation; either version 3, or (at
  23 ;; your option) any later version.
  24
  25 ;; This program is distributed in the hope that it will be useful, but
  26 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  27 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  28 ;; General Public License for more details.
  29
  30 ;; You should have received a copy of the GNU General Public License
  31 ;; along with GNU Emacs; see the file COPYING. If not, write to the
  32 ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  33
  34 ;;; Commentary:
  35
  36 ;;; HISTORY
  37
  38 ;; Still under construction: History obscure, needs a biographer as
  39 ;; well as a M-x doctor. Change Log on request.
  40
  41 ;; Hacked by Olin Shivers for comint from Lars Bo Nielsen's sml.el.
  42
  43 ;; Hacked by Matthew Morley to incorporate Fritz Knabe's hilite and
  44 ;; font-lock patterns, some of Steven Gilmore's (reduced) easy-menus,
  45 ;; and numerous bugs and bug-fixes.
  46
  47 ;;; DESCRIPTION
  48
  49 ;; See accompanying info file: sml-mode.info
  50
  51 ;;; FOR YOUR .EMACS FILE
  52
  53 ;; If sml-mode.el lives in some non-standard directory, you must tell
  54 ;; emacs where to get it. This may or may not be necessary:
  55
  56 ;; (add-to-list 'load-path "~jones/lib/emacs/")
  57
  58 ;; Then to access the commands autoload sml-mode with that command:
  59
  60 ;; (load "sml-mode-startup")
  61
  62 ;; sml-mode-hook is run whenever a new sml-mode buffer is created.
  63
  64 ;; Finally, there are inferior-sml-{mode,load}-hooks -- see comments
  65 ;; in sml-proc.el. For much more information consult the mode's *info*
  66 ;; tree.
  67
  68 ;;; Code:
  69
  70 (eval-when-compile (require 'cl))
  71 (require 'sml-defs)
  72 (require 'smie nil 'noerror)
  73
  74 (condition-case nil (require 'skeleton) (error nil))
  75
  76 ;;; VARIABLES CONTROLLING INDENTATION
  77
  78 (defcustom sml-indent-level 4
  79   "Indentation of blocks in ML (see also `sml-indent-rule')."
  80   :group 'sml
  81   :type '(integer))
  82
  83 (defcustom sml-indent-args sml-indent-level
  84   "Indentation of args placed on a separate line."
  85   :group 'sml
  86   :type '(integer))
  87
  88 ;; (defvar sml-indent-align-args t
  89 ;;   "*Whether the arguments should be aligned.")
  90
  91 ;; (defvar sml-case-indent nil
  92 ;;   "*How to indent case-of expressions.
  93 ;;     If t:   case expr                     If nil:   case expr of
  94 ;;               of exp1 => ...                            exp1 => ...
  95 ;;                | exp2 => ...                          | exp2 => ...
  96
  97 ;; The first seems to be the standard in SML/NJ, but the second
  98 ;; seems nicer...")
  99
 100 (defcustom sml-electric-semi-mode nil
 101   "If non-nil, `\;' will self insert, reindent the line, and do a newline.
 102 If nil, just insert a `\;'.  (To insert while t, do: \\[quoted-insert] \;)."
 103   :group 'sml
 104   :type 'boolean)
 105 (when (fboundp 'electric-layout-mode)
 106   (make-obsolete-variable 'sml-electric-semi-mode
 107                           'electric-layout-mode "Emacs-24"))
 108
 109 (defcustom sml-rightalign-and t
 110   "If non-nil, right-align `and' with its leader.
 111 If nil:                                 If t:
 112         datatype a = A                          datatype a = A
 113         and b = B                                    and b = B"
 114   :group 'sml
 115   :type 'boolean)
 116
 117 ;;; OTHER GENERIC MODE VARIABLES
 118
 119 (defvar sml-mode-info "sml-mode"
 120   "*Where to find Info file for `sml-mode'.
 121 The default assumes the info file \"sml-mode.info\" is on Emacs' info
 122 directory path.  If it is not, either put the file on the standard path
 123 or set the variable `sml-mode-info' to the exact location of this file
 124
 125   (setq sml-mode-info \"/usr/me/lib/info/sml-mode\")
 126
 127 in your .emacs file. You can always set it interactively with the
 128 set-variable command.")
 129
 130 (defvar sml-mode-hook nil
 131   "*Run upon entering `sml-mode'.
 132 This is a good place to put your preferred key bindings.")
 133
 134 ;;; CODE FOR SML-MODE
 135
 136 (defun sml-mode-info ()
 137   "Command to access the TeXinfo documentation for `sml-mode'.
 138 See doc for the variable `sml-mode-info'."
 139   (interactive)
 140   (require 'info)
 141   (condition-case nil
 142       (info sml-mode-info)
 143     (error (progn
 144              (describe-variable 'sml-mode-info)
 145              (message "Can't find it... set this variable first!")))))
 146
 147
 148 ;;; Autoload functions -- no-doc is another idea cribbed from AucTeX!
 149
 150 (let ((sml-no-doc
 151        "This function is part of sml-proc, and has not yet been loaded.
 152 Full documentation will be available after autoloading the function."))
 153
 154   (autoload 'sml-compile        "sml-proc"   sml-no-doc t)
 155   (autoload 'sml-load-file      "sml-proc"   sml-no-doc t)
 156   (autoload 'switch-to-sml      "sml-proc"   sml-no-doc t)
 157   (autoload 'sml-send-region    "sml-proc"   sml-no-doc t)
 158   (autoload 'sml-send-buffer    "sml-proc"   sml-no-doc t))
 159
 160 ;; font-lock setup
 161
 162 (defconst sml-keywords-regexp
 163   (sml-syms-re '("abstraction" "abstype" "and" "andalso" "as" "before" "case"
 164                  "datatype" "else" "end" "eqtype" "exception" "do" "fn"
 165                  "fun" "functor" "handle" "if" "in" "include" "infix"
 166                  "infixr" "let" "local" "nonfix" "of" "op" "open" "orelse"
 167                  "overload" "raise" "rec" "sharing" "sig" "signature"
 168                  "struct" "structure" "then" "type" "val" "where" "while"
 169                  "with" "withtype" "o"))
 170   "A regexp that matches any and all keywords of SML.")
 171
 172 (defconst sml-tyvarseq-re
 173   "\\(\\('+\\(\\sw\\|\\s_\\)+\\|(\\([,']\\|\\sw\\|\\s_\\|\\s-\\)+)\\)\\s-+\\)?")
 174
 175 ;;; Font-lock settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 176
 177 (defcustom sml-font-lock-symbols nil
 178   "Display \\ and -> and such using symbols in fonts.
 179 This may sound like a neat trick, but be extra careful: it changes the
 180 alignment and can thus lead to nasty surprises w.r.t layout.
 181 If t, try to use whichever font is available.  Otherwise you can
 182 set it to a particular font of your preference among `japanese-jisx0208'
 183 and `unicode'."
 184   :type '(choice (const nil)
 185                  (const t)
 186                  (const unicode)
 187                  (const japanese-jisx0208)))
 188
 189 (defconst sml-font-lock-symbols-alist
 190   (append
 191    ;; The symbols can come from a JIS0208 font.
 192    (and (fboundp 'make-char) (charsetp 'japanese-jisx0208)
 193         (memq sml-font-lock-symbols '(t japanese-jisx0208))
 194         (list (cons "fn" (make-char 'japanese-jisx0208 38 75))
 195               (cons "andalso" (make-char 'japanese-jisx0208 34 74))
 196               (cons "orelse" (make-char 'japanese-jisx0208 34 75))
 197               ;; (cons "as" (make-char 'japanese-jisx0208 34 97))
 198               (cons "not" (make-char 'japanese-jisx0208 34 76))
 199               (cons "div" (make-char 'japanese-jisx0208 33 96))
 200               ;; (cons "*" (make-char 'japanese-jisx0208 33 95))
 201               (cons "->" (make-char 'japanese-jisx0208 34 42))
 202               (cons "=>" (make-char 'japanese-jisx0208 34 77))
 203               (cons "<-" (make-char 'japanese-jisx0208 34 43))
 204               (cons "<>" (make-char 'japanese-jisx0208 33 98))
 205               (cons ">=" (make-char 'japanese-jisx0208 33 102))
 206               (cons "<=" (make-char 'japanese-jisx0208 33 101))
 207               (cons "..." (make-char 'japanese-jisx0208 33 68))
 208               ;; Some greek letters for type parameters.
 209               (cons "'a" (make-char 'japanese-jisx0208 38 65))
 210               (cons "'b" (make-char 'japanese-jisx0208 38 66))
 211               (cons "'c" (make-char 'japanese-jisx0208 38 67))
 212               (cons "'d" (make-char 'japanese-jisx0208 38 68))
 213               ))
 214    ;; Or a unicode font.
 215    (and (fboundp 'decode-char)
 216         (memq sml-font-lock-symbols '(t unicode))
 217         (list (cons "fn" (decode-char 'ucs 955))
 218               (cons "andalso" (decode-char 'ucs 8896))
 219               (cons "orelse" (decode-char 'ucs 8897))
 220               ;; (cons "as" (decode-char 'ucs 8801))
 221               (cons "not" (decode-char 'ucs 172))
 222               (cons "div" (decode-char 'ucs 247))
 223               (cons "*" (decode-char 'ucs 215))
 224               (cons "o"  (decode-char 'ucs 9675))
 225               (cons "->" (decode-char 'ucs 8594))
 226               (cons "=>" (decode-char 'ucs 8658))
 227               (cons "<-" (decode-char 'ucs 8592))
 228               (cons "<>" (decode-char 'ucs 8800))
 229               (cons ">=" (decode-char 'ucs 8805))
 230               (cons "<=" (decode-char 'ucs 8804))
 231               (cons "..." (decode-char 'ucs 8943))
 232               ;; (cons "::" (decode-char 'ucs 8759))
 233               ;; Some greek letters for type parameters.
 234               (cons "'a" (decode-char 'ucs 945))
 235               (cons "'b" (decode-char 'ucs 946))
 236               (cons "'c" (decode-char 'ucs 947))
 237               (cons "'d" (decode-char 'ucs 948))
 238               ))))
 239
 240 (defun sml-font-lock-compose-symbol (alist)
 241   "Compose a sequence of ascii chars into a symbol.
 242 Regexp match data 0 points to the chars."
 243   ;; Check that the chars should really be composed into a symbol.
 244   (let* ((start (match-beginning 0))
 245          (end (match-end 0))
 246          (syntaxes (if (eq (char-syntax (char-after start)) ?w)
 247                        '(?w) '(?. ?\\))))
 248     (if (or (memq (char-syntax (or (char-before start) ?\ )) syntaxes)
 249             (memq (char-syntax (or (char-after end) ?\ )) syntaxes)
 250             (memq (get-text-property start 'face)
 251                   '(font-lock-doc-face font-lock-string-face
 252                     font-lock-comment-face)))
 253         ;; No composition for you.  Let's actually remove any composition
 254         ;; we may have added earlier and which is now incorrect.
 255         (remove-text-properties start end '(composition))
 256       ;; That's a symbol alright, so add the composition.
 257       (compose-region start end (cdr (assoc (match-string 0) alist)))))
 258   ;; Return nil because we're not adding any face property.
 259   nil)
 260
 261 (defun sml-font-lock-symbols-keywords ()
 262   (when (fboundp 'compose-region)
 263     (let ((alist nil))
 264       (dolist (x sml-font-lock-symbols-alist)
 265         (when (and (if (fboundp 'char-displayable-p)
 266                        (char-displayable-p (cdr x))
 267                      t)
 268                    (not (assoc (car x) alist))) ;Not yet in alist.
 269           (push x alist)))
 270       (when alist
 271         `((,(regexp-opt (mapcar 'car alist) t)
 272            (0 (sml-font-lock-compose-symbol ',alist))))))))
 273
 274 ;; The font lock regular expressions.
 275
 276 (defconst sml-font-lock-keywords
 277   `(;;(sml-font-comments-and-strings)
 278     (,(concat "\\<\\(fun\\|and\\)\\s-+" sml-tyvarseq-re "\\(\\sw+\\)\\s-+[^ \t\n=]")
 279      (1 font-lock-keyword-face)
 280      (6 font-lock-function-name-face))
 281     (,(concat "\\<\\(\\(data\\|abs\\|with\\|eq\\)?type\\)\\s-+" sml-tyvarseq-re "\\(\\sw+\\)")
 282      (1 font-lock-keyword-face)
 283      (7 font-lock-type-def-face))
 284     ("\\<\\(val\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
 285      (1 font-lock-keyword-face)
 286      ;;(6 font-lock-variable-def-face nil t)
 287      (3 font-lock-variable-name-face))
 288     ("\\<\\(structure\\|functor\\|abstraction\\)\\s-+\\(\\sw+\\)"
 289      (1 font-lock-keyword-face)
 290      (2 font-lock-module-def-face))
 291     ("\\<\\(signature\\)\\s-+\\(\\sw+\\)"
 292      (1 font-lock-keyword-face)
 293      (2 font-lock-interface-def-face))
 294
 295     (,sml-keywords-regexp . font-lock-keyword-face)
 296     ,@(sml-font-lock-symbols-keywords))
 297   "Regexps matching standard SML keywords.")
 298
 299 (defface font-lock-type-def-face
 300   '((t (:bold t)))
 301   "Font Lock mode face used to highlight type definitions."
 302   :group 'font-lock-highlighting-faces)
 303 (defvar font-lock-type-def-face 'font-lock-type-def-face
 304   "Face name to use for type definitions.")
 305
 306 (defface font-lock-module-def-face
 307   '((t (:bold t)))
 308   "Font Lock mode face used to highlight module definitions."
 309   :group 'font-lock-highlighting-faces)
 310 (defvar font-lock-module-def-face 'font-lock-module-def-face
 311   "Face name to use for module definitions.")
 312
 313 (defface font-lock-interface-def-face
 314   '((t (:bold t)))
 315   "Font Lock mode face used to highlight interface definitions."
 316   :group 'font-lock-highlighting-faces)
 317 (defvar font-lock-interface-def-face 'font-lock-interface-def-face
 318   "Face name to use for interface definitions.")
 319
 320 ;;
 321 ;; Code to handle nested comments and unusual string escape sequences
 322 ;;
 323
 324 (defvar sml-syntax-prop-table
 325   (let ((st (make-syntax-table)))
 326     (modify-syntax-entry ?\\ "." st)
 327     (modify-syntax-entry ?* "." st)
 328     st)
 329   "Syntax table for text-properties")
 330
 331 ;; For Emacsen that have no built-in support for nested comments
 332 (defun sml-get-depth-st ()
 333   (save-excursion
 334     (let* ((disp (if (eq (char-before) ?\)) (progn (backward-char) -1) nil))
 335            (_ (backward-char))
 336            (disp (if (eq (char-before) ?\() (progn (backward-char) 0) disp))
 337            (pt (point)))
 338       (when disp
 339         (let* ((depth
 340                 (save-match-data
 341                   (if (re-search-backward "\\*)\\|(\\*" nil t)
 342                       (+ (or (get-char-property (point) 'comment-depth) 0)
 343                          (case (char-after) (?\( 1) (?* 0))
 344                          disp)
 345                     0)))
 346                (depth (if (> depth 0) depth)))
 347           (put-text-property pt (1+ pt) 'comment-depth depth)
 348           (when depth sml-syntax-prop-table))))))
 349
 350 (defconst sml-font-lock-syntactic-keywords
 351   `(("^\\s-*\\(\\\\\\)" (1 ',sml-syntax-prop-table))
 352     ,@(unless sml-builtin-nested-comments-flag
 353         '(("(?\\(\\*\\))?" (1 (sml-get-depth-st)))))))
 354
 355 (defconst sml-font-lock-defaults
 356   '(sml-font-lock-keywords nil nil ((?_ . "w") (?' . "w")) nil
 357     (font-lock-syntactic-keywords . sml-font-lock-syntactic-keywords)))
 358
 359
 360 ;;; Indentation with SMIE
 361
 362 (defvar sml-use-smie t)
 363 (unless (and sml-use-smie (fboundp 'smie-setup))
 364   (require 'sml-oldindent))
 365
 366 (defconst sml-smie-grammar
 367   (when (fboundp 'smie-prec2->grammar)
 368     ;; We have several problem areas where SML's syntax can't be handled by an
 369     ;; operator precedence grammar:
 370     ;;
 371     ;; "= A before B" is "= A) before B" if this is the
 372     ;;   `boolean-=' but it is "= (A before B)" if it's the `definitional-='.
 373     ;;   We can work around the problem by tweaking the lexer to return two
 374     ;;   different tokens for the two different kinds of `='.
 375     ;; "of A | B" in a "case" we want "of (A | B, but in a `datatype'
 376     ;;   we want "of A) | B".
 377     ;; "= A | B" can be "= A ) | B" if the = is from a "fun" definition,
 378     ;;   but it is "= (A | B" if it is a `datatype' definition (of course, if
 379     ;;   the previous token introducing the = is `and', deciding whether
 380     ;;   it's a datatype or a function requires looking even further back).
 381     ;; "functor foo (...) where type a = b = ..." the first `=' looks very much
 382     ;;   like a `definitional-=' even tho it's just an equality constraint.
 383     ;;   Currently I don't even try to handle `where' at all.
 384     (smie-prec2->grammar
 385      (smie-merge-prec2s
 386       (smie-bnf->prec2
 387        '((exp ("if" exp "then" exp "else" exp)
 388               ("case" exp "of" branches)
 389               ("let" decls "in" cmds "end")
 390               ("struct" decls "end")
 391               ("sig" decls "end")
 392               (sexp)
 393               (sexp "handle" branches)
 394               ("fn" sexp "=>" exp))
 395          ;; "simple exp"s are the ones that can appear to the left of `handle'.
 396          (sexp (sexp ":" type) ("(" exps ")")
 397                (sexp "orelse" sexp)
 398                (marg ":>" type)
 399                (sexp "andalso" sexp))
 400          (cmds (cmds ";" cmds) (exp))
 401          (exps (exps "," exps) (exp))   ; (exps ";" exps)
 402          (branches (sexp "=>" exp) (branches "|" branches))
 403          ;; Operator precedence grammars handle separators much better then
 404          ;; starters/terminators, so let's pretend that let/fun are separators.
 405          (decls (sexp "d=" exp)
 406                 (sexp "d=" databranches)
 407                 (funbranches "|" funbranches)
 408                 (sexp "=of" type)       ;After "exception".
 409                 ;; FIXME: Just like PROCEDURE in Pascal and Modula-2, this
 410                 ;; interacts poorly with the other constructs since I
 411                 ;; can't make "local" a separator like fun/val/type/...
 412                 ("local" decls "in" decls "end")
 413                 ;; (decls "local" decls "in" decls "end")
 414                 (decls "functor" decls)
 415                 (decls "signature" decls)
 416                 (decls "structure" decls)
 417                 (decls "type" decls)
 418                 (decls "open" decls)
 419                 (decls "and" decls)
 420                 (decls "infix" decls)
 421                 (decls "infixr" decls)
 422                 (decls "nonfix" decls)
 423                 (decls "abstype" decls)
 424                 (decls "datatype" decls)
 425                 (decls "exception" decls)
 426                 (decls "fun" decls)
 427                 (decls "val" decls))
 428          (type (type "->" type)
 429                (type "*" type))
 430          (funbranches (sexp "d=" exp))
 431          (databranches (sexp "=of" type) (databranches "d|" databranches))
 432          ;; Module language.
 433          ;; (mexp ("functor" marg "d=" mexp)
 434          ;;       ("structure" marg "d=" mexp)
 435          ;;       ("signature" marg "d=" mexp))
 436          (marg (marg ":" type) (marg ":>" type))
 437          (toplevel (decls) (exp) (toplevel ";" toplevel)))
 438        ;; '(("local" . opener))
 439        ;; '((nonassoc "else") (right "handle"))
 440        '((nonassoc "of") (assoc "|")) ; "case a of b => case c of d => e | f"
 441        '((nonassoc "handle") (assoc "|")) ; Idem for "handle".
 442        '((assoc "->") (assoc "*"))
 443        '((assoc "val" "fun" "type" "datatype" "abstype" "open" "infix" "infixr"
 444                 "nonfix" "functor" "signature" "structure" "exception"
 445                 ;; "local"
 446                 )
 447          (assoc "and"))
 448        '((assoc "orelse") (assoc "andalso") (nonassoc ":"))
 449        '((assoc ";")) '((assoc ",")) '((assoc "d|")))
 450
 451       (smie-precs->prec2
 452        '((nonassoc "andalso")                     ;To anchor the prec-table.
 453          (assoc "before")                         ;0
 454          (assoc ":=" "o")                         ;3
 455          (nonassoc ">" ">=" "<>" "<" "<=" "=")    ;4
 456          (assoc "::" "@")                         ;5
 457          (assoc "+" "-" "^")                      ;6
 458          (assoc "/" "*" "quot" "rem" "div" "mod") ;7
 459          (nonassoc " -dummy- ")))                 ;Bogus anchor at the end.
 460       ))))
 461
 462 (defvar sml-indent-separator-outdent 2)
 463
 464 (defun sml-smie-rules (kind token)
 465   ;; I much preferred the pcase version of the code, especially while
 466   ;; edebugging the code.  But that will have to wait until we get rid of
 467   ;; support for Emacs-23.
 468   (case kind
 469     (:elem (case token
 470              (basic sml-indent-level)
 471              (args  sml-indent-args)))
 472     (:list-intro (member token '("fn")))
 473     (:after
 474      (cond
 475       ((equal token "struct") 0)
 476       ((equal token "=>") (if (smie-rule-hanging-p) 0 2))
 477       ((equal token "in") (if (smie-rule-parent-p "local") 0))
 478       ((equal token "of") 3)
 479       ((member token '("(" "{" "[")) (if (not (smie-rule-hanging-p)) 2))
 480       ((equal token "else") (if (smie-rule-hanging-p) 0)) ;; (:next "if" 0)
 481       ((member token '("|" "d|" ";" ",")) (smie-rule-separator kind))
 482       ((equal token "d=")
 483        (if (and (smie-rule-parent-p "val") (smie-rule-next-p "fn")) -3))))
 484     (:before
 485      (cond
 486       ((equal token "=>") (if (smie-rule-parent-p "fn") 3))
 487       ((equal token "of") 1)
 488       ;; In case the language is extended to allow a | directly after of.
 489       ((and (equal token "|") (smie-rule-prev-p "of")) 1)
 490       ((member token '("|" "d|" ";" ",")) (smie-rule-separator kind))
 491       ;; Treat purely syntactic block-constructs as being part of their parent,
 492       ;; when the opening statement is hanging.
 493       ((member token '("let" "(" "[" "{"))
 494        (if (smie-rule-hanging-p) (smie-rule-parent)))
 495       ;; Treat if ... else if ... as a single long syntactic construct.
 496       ;; Similarly, treat fn a => fn b => ... as a single construct.
 497       ((member token '("if" "fn"))
 498        (and (not (smie-rule-bolp))
 499             (smie-rule-prev-p (if (equal token "if") "else" "=>"))
 500             (smie-rule-parent)))
 501       ((equal token "and")
 502        ;; FIXME: maybe "and" (c|sh)ould be handled as an smie-separator.
 503        (cond
 504         ((smie-rule-parent-p "datatype") (if sml-rightalign-and 5 0))
 505         ((smie-rule-parent-p "fun" "val") 0)))
 506       ((equal token "d=")
 507        (cond
 508         ((smie-rule-parent-p "datatype") (if (smie-rule-bolp) 2))
 509         ((smie-rule-parent-p "structure" "signature") 0)))
 510       ;; Indent an expression starting with "local" as if it were starting
 511       ;; with "fun".
 512       ((equal token "local") (smie-indent-keyword "fun"))
 513       ;; FIXME: type/val/fun/... are separators but "local" is not, even though
 514       ;; it appears in the same list.  Try to fix up the problem by hand.
 515       ;; ((or (equal token "local")
 516       ;;      (equal (cdr (assoc token smie-grammar))
 517       ;;             (cdr (assoc "fun" smie-grammar))))
 518       ;;  (let ((parent (save-excursion (smie-backward-sexp))))
 519       ;;    (when (or (and (equal (nth 2 parent) "local")
 520       ;;                   (null (car parent)))
 521       ;;              (progn
 522       ;;                (setq parent (save-excursion (smie-backward-sexp "fun")))
 523       ;;                (eq (car parent) (nth 1 (assoc "fun" smie-grammar)))))
 524       ;;      (goto-char (nth 1 parent))
 525       ;;      (cons 'column (smie-indent-virtual)))))
 526       ))))
 527
 528 (defun sml-smie-definitional-equal-p ()
 529   "Figure out which kind of \"=\" this is.
 530 Assumes point is right before the = sign."
 531   ;; The idea is to look backward for the first occurrence of a token that
 532   ;; requires a definitional "=" and then see if there's such a definitional
 533   ;; equal between that token and ourselves (in which case we're not
 534   ;; a definitional = ourselves).
 535   ;; The "search for =" is naive and will match "=>" and "<=", but it turns
 536   ;; out to be OK in practice because such tokens very rarely (if ever) appear
 537   ;; between the =-starter and the corresponding definitional equal.
 538   ;; One known problem case is code like:
 539   ;; "functor foo (structure s : S) where type t = s.t ="
 540   ;; where the "type t = s.t" is mistaken for a type definition.
 541   (let ((re (concat "\\(" sml-=-starter-re "\\)\\|=")))
 542     (save-excursion
 543       (and (re-search-backward re nil t)
 544            (or (match-beginning 1)
 545                ;; If we first hit a "=", then that = is probably definitional
 546                ;; and  we're an equality, but not necessarily.  One known
 547                ;; problem case is code like:
 548                ;; "functor foo (structure s : S) where type t = s.t ="
 549                ;; where the first = is more like an equality (tho it doesn't
 550                ;; matter much) and the second is definitional.
 551                ;;
 552                ;; FIXME: The test below could be used to recognize that the
 553                ;; second = is not a mere equality, but that's not enough to
 554                ;; parse the construct properly: we'd need something
 555                ;; like a third kind of = token for structure definitions, in
 556                ;; order for the parser to be able to skip the "type t = s.t"
 557                ;; as a sub-expression.
 558                ;;
 559                ;; (and (not (looking-at "=>"))
 560                ;;      (not (eq ?< (char-before))) ;Not a <=
 561                ;;      (re-search-backward re nil t)
 562                ;;      (match-beginning 1)
 563                ;;      (equal "type" (buffer-substring (- (match-end 1) 4)
 564                ;;                                      (match-end 1))))
 565                )))))
 566
 567 (defun sml-smie-non-nested-of-p ()
 568   ;; FIXME: Maybe datatype-|-p makes this nested-of business unnecessary.
 569   "Figure out which kind of \"of\" this is.
 570 Assumes point is right before the \"of\" symbol."
 571   (save-excursion
 572     (and (re-search-backward (concat "\\(" sml-non-nested-of-starter-re
 573                                      "\\)\\|\\<case\\>") nil t)
 574          (match-beginning 1))))
 575
 576 (defun sml-smie-datatype-|-p ()
 577   "Figure out which kind of \"|\" this is.
 578 Assumes point is right before the | symbol."
 579   (save-excursion
 580     (forward-char 1)                    ;Skip the |.
 581     (let ((after-type-def
 582            '("|" "of" "in" "datatype" "and" "exception" "abstype" "infix"
 583              "infixr" "nonfix" "local" "val" "fun" "structure" "functor"
 584              "signature")))
 585       (or (member (sml-smie-forward-token-1) after-type-def) ;Skip the tag.
 586           (member (sml-smie-forward-token-1) after-type-def)))))
 587
 588 (defun sml-smie-forward-token-1 ()
 589   (forward-comment (point-max))
 590   (buffer-substring-no-properties
 591    (point)
 592    (progn
 593      (or (/= 0 (skip-syntax-forward "'w_"))
 594          (skip-syntax-forward ".'"))
 595      (point))))
 596
 597 (defun sml-smie-forward-token ()
 598   (let ((sym (sml-smie-forward-token-1)))
 599     (cond
 600      ((equal "op" sym)
 601       (concat "op " (sml-smie-forward-token-1)))
 602      ((member sym '("|" "of" "="))
 603       ;; The important lexer for indentation's performance is the backward
 604       ;; lexer, so for the forward lexer we delegate to the backward one.
 605       (save-excursion (sml-smie-backward-token)))
 606      (t sym))))
 607
 608 (defun sml-smie-backward-token-1 ()
 609   (forward-comment (- (point)))
 610   (buffer-substring-no-properties
 611    (point)
 612    (progn
 613      (or (/= 0 (skip-syntax-backward ".'"))
 614          (skip-syntax-backward "'w_"))
 615      (point))))
 616
 617 (defun sml-smie-backward-token ()
 618   (let ((sym (sml-smie-backward-token-1)))
 619     (unless (zerop (length sym))
 620       ;; FIXME: what should we do if `sym' = "op" ?
 621       (let ((point (point)))
 622         (if (equal "op" (sml-smie-backward-token-1))
 623             (concat "op " sym)
 624           (goto-char point)
 625           (cond
 626            ((string= sym "=") (if (sml-smie-definitional-equal-p) "d=" "="))
 627            ((string= sym "of") (if (sml-smie-non-nested-of-p) "=of" "of"))
 628            ((string= sym "|") (if (sml-smie-datatype-|-p) "d|" "|"))
 629            (t sym)))))))
 630
 631 ;;;;
 632 ;;;; Imenu support
 633 ;;;;
 634
 635 (defvar sml-imenu-regexp
 636   (concat "^[ \t]*\\(let[ \t]+\\)?"
 637           (regexp-opt (append sml-module-head-syms
 638                               '("and" "fun" "datatype" "abstype" "type")) t)
 639           "\\>"))
 640
 641 (defun sml-imenu-create-index ()
 642   (let (alist)
 643     (goto-char (point-max))
 644     (while (re-search-backward sml-imenu-regexp nil t)
 645       (save-excursion
 646         (let ((kind (match-string 2))
 647               (column (progn (goto-char (match-beginning 2)) (current-column)))
 648               (location
 649                (progn (goto-char (match-end 0))
 650                       (forward-comment (point-max))
 651                       (when (looking-at sml-tyvarseq-re)
 652                         (goto-char (match-end 0)))
 653                       (point)))
 654               (name (sml-smie-forward-token)))
 655           ;; Eliminate trivial renamings.
 656           (when (or (not (member kind '("structure" "signature")))
 657                     (progn (search-forward "=")
 658                            (forward-comment (point-max))
 659                            (looking-at "sig\\|struct")))
 660             (push (cons (concat (make-string (/ column 2) ?\ ) name) location)
 661                   alist)))))
 662     alist))
 663
 664 ;;; MORE CODE FOR SML-MODE
 665
 666 ;;;###autoload
 667 (add-to-list 'auto-mode-alist '("\\.s\\(ml\\|ig\\)\\'" . sml-mode))
 668
 669 (unless (fboundp 'prog-mode) (defalias 'prog-mode 'fundamental-mode))
 670 (defvar comment-quote-nested)
 671 (defvar electric-indent-chars)
 672 (defvar electric-layout-rules)
 673
 674 ;;;###autoload
 675 (define-derived-mode sml-mode prog-mode "SML"
 676   "\\<sml-mode-map>Major mode for editing ML code.
 677 This mode runs `sml-mode-hook' just before exiting.
 678 \\{sml-mode-map}"
 679   (set (make-local-variable 'font-lock-defaults) sml-font-lock-defaults)
 680   (set (make-local-variable 'outline-regexp) sml-outline-regexp)
 681   (set (make-local-variable 'imenu-create-index-function)
 682        'sml-imenu-create-index)
 683   (set (make-local-variable 'add-log-current-defun-function)
 684        'sml-current-fun-name)
 685   ;; Treat paragraph-separators in comments as paragraph-separators.
 686   (set (make-local-variable 'paragraph-separate)
 687        (concat "\\([ \t]*\\*)?\\)?\\(" paragraph-separate "\\)"))
 688   (set (make-local-variable 'require-final-newline) t)
 689   (set (make-local-variable 'electric-indent-chars)
 690        (cons ?\; (if (boundp 'electric-indent-chars)
 691                      electric-indent-chars '(?\n))))
 692   (set (make-local-variable 'electric-layout-rules)
 693        `((?\; . ,(lambda ()
 694                    (save-excursion
 695                      (skip-chars-backward " \t;")
 696                      (unless (or (bolp)
 697                                  (progn (skip-chars-forward " \t;")
 698                                         (eolp)))
 699                        'after))))))
 700   ;; For XEmacs
 701   (easy-menu-add sml-mode-menu)
 702   ;; Compatibility.  FIXME: we should use `-' in Emacs-CVS.
 703   (unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil))
 704   (sml-mode-variables))
 705
 706 (defun sml-mode-variables ()
 707   (set-syntax-table sml-mode-syntax-table)
 708   (setq local-abbrev-table sml-mode-abbrev-table)
 709   ;; Setup indentation and sexp-navigation.
 710   (when (fboundp 'smie-setup)
 711     (smie-setup sml-smie-grammar #'sml-smie-rules
 712                 :backward-token #'sml-smie-backward-token
 713                 :forward-token #'sml-smie-forward-token))
 714   (unless (and sml-use-smie (fboundp 'smie-setup))
 715     (set (make-local-variable 'forward-sexp-function) 'sml-user-forward-sexp)
 716     (set (make-local-variable 'indent-line-function) 'sml-indent-line))
 717   (set (make-local-variable 'parse-sexp-ignore-comments) t)
 718   (set (make-local-variable 'comment-start) "(* ")
 719   (set (make-local-variable 'comment-end) " *)")
 720   (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*")
 721   (set (make-local-variable 'comment-end-skip) "\\s-*\\*+)")
 722   ;; No need to quote nested comments markers.
 723   (set (make-local-variable 'comment-quote-nested) nil))
 724
 725 (defun sml-funname-of-and ()
 726   "Name of the function this `and' defines, or nil if not a function.
 727 Point has to be right after the `and' symbol and is not preserved."
 728   (forward-comment (point-max))
 729   (if (looking-at sml-tyvarseq-re) (goto-char (match-end 0)))
 730   (let ((sym (sml-smie-forward-token)))
 731     (forward-comment (point-max))
 732     (unless (or (member sym '(nil "d="))
 733                 (member (sml-smie-forward-token) '("d=")))
 734       sym)))
 735
 736 (defun sml-find-forward (re)
 737   (while (progn (forward-comment (point-max))
 738                 (not (looking-at re)))
 739     (or (ignore-errors (forward-sexp 1) t) (forward-char 1))))
 740
 741 (defun sml-electric-pipe ()
 742   "Insert a \"|\".
 743 Depending on the context insert the name of function, a \"=>\" etc."
 744   ;; FIXME: Make it a skeleton.
 745   (interactive)
 746   (unless (save-excursion (skip-chars-backward "\t ") (bolp)) (insert "\n"))
 747   (insert "| ")
 748   (let ((text
 749          (save-excursion
 750            (backward-char 2)            ;back over the just inserted "| "
 751            (let ((sym (sml-find-matching-starter sml-pipeheads
 752                                                  ;; (sml-op-prec "|" 'back)
 753                                                  )))
 754              (sml-smie-forward-token)
 755              (forward-comment (point-max))
 756              (cond
 757               ((string= sym "|")
 758                (let ((f (sml-smie-forward-token)))
 759                  (sml-find-forward "\\(=>\\|=\\||\\)\\S.")
 760                  (cond
 761                   ((looking-at "|") "")      ;probably a datatype
 762                   ((looking-at "=>") " => ") ;`case', or `fn' or `handle'
 763                   ((looking-at "=") (concat f "  = "))))) ;a function
 764               ((string= sym "and")
 765                ;; could be a datatype or a function
 766                (setq sym (sml-funname-of-and))
 767                (if sym (concat sym "  = ") ""))
 768               ;; trivial cases
 769               ((string= sym "fun")
 770                (while (and (setq sym (sml-smie-forward-token))
 771                            (string-match "^'" sym))
 772                  (forward-comment (point-max)))
 773                (concat sym "  = "))
 774               ((member sym '("case" "handle" "fn" "of")) " => ")
 775               ;;((member sym '("abstype" "datatype")) "")
 776               (t ""))))))
 777
 778     (insert text)
 779     (indent-according-to-mode)
 780     (beginning-of-line)
 781     (skip-chars-forward "\t |")
 782     (skip-syntax-forward "w")
 783     (skip-chars-forward "\t ")
 784     (when (eq ?= (char-after)) (backward-char))))
 785
 786 (defun sml-electric-semi ()
 787   "Insert a \;.
 788 If variable `sml-electric-semi-mode' is t, indent the current line, insert
 789 a newline, and indent."
 790   (interactive)
 791   (self-insert-command 1)
 792   (if sml-electric-semi-mode
 793       (reindent-then-newline-and-indent)))
 794
 795 ;;; INDENTATION !!!
 796
 797 (defun sml-mark-function ()
 798   "Synonym for `mark-paragraph' -- sorry.
 799 If anyone has a good algorithm for this..."
 800   (interactive)
 801   (mark-paragraph))
 802
 803 (defun sml-back-to-outer-indent ()
 804   "Unindents to the next outer level of indentation."
 805   (interactive)
 806   (save-excursion
 807     (beginning-of-line)
 808     (skip-chars-forward "\t ")
 809     (let ((start-column (current-column))
 810           (indent (current-column)))
 811       (if (> start-column 0)
 812           (progn
 813             (save-excursion
 814               (while (>= indent start-column)
 815                 (if (re-search-backward "^[^\n]" nil t)
 816                     (setq indent (current-indentation))
 817                   (setq indent 0))))
 818             (backward-delete-char-untabify (- start-column indent)))))))
 819
 820 (defun sml-smie-find-matching-starter (syms)
 821   (let ((halfsexp nil)
 822         tok)
 823     ;;(sml-smie-forward-token)
 824     (while (not (or (bobp)
 825                     (member (nth 2 (setq tok (smie-backward-sexp halfsexp)))
 826                             syms)))
 827       (cond
 828        ((null (car tok)) nil)
 829        ((numberp (car tok)) (setq halfsexp 'half))
 830        (t (goto-char (cadr tok)))))
 831     (if (nth 2 tok) (goto-char (cadr tok)))
 832     (nth 2 tok)))
 833
 834 (defun sml-find-matching-starter (syms)
 835   (cond
 836    ((and sml-use-smie (fboundp 'smie-backward-sexp))
 837     (sml-smie-find-matching-starter syms))
 838    ((fboundp 'sml-old-find-matching-starter)
 839     (sml-old-find-matching-starter syms))))
 840
 841 (defun sml-smie-skip-siblings ()
 842   (let (tok)
 843     (while (and (not (bobp))
 844                 (progn (setq tok (smie-backward-sexp 'half))
 845                        (cond
 846                         ((null (car tok)) t)
 847                         ((numberp (car tok)) t)
 848                         (t nil)))))
 849     (if (nth 2 tok) (goto-char (cadr tok)))
 850     (nth 2 tok)))
 851
 852 (defun sml-skip-siblings ()
 853   (cond
 854    ((and sml-use-smie (fboundp 'smie-backward-sexp))
 855     (sml-smie-skip-siblings))
 856    ((fboundp 'sml-old-skip-siblings)
 857     (sml-old-skip-siblings))
 858    (t (up-list -1))))
 859
 860 (defun sml-beginning-of-defun ()
 861   (let ((sym (sml-find-matching-starter sml-starters-syms)))
 862     (if (member sym '("fun" "and" "functor" "signature" "structure"
 863                       "abstraction" "datatype" "abstype"))
 864         (save-excursion (sml-smie-forward-token) (forward-comment (point-max))
 865                         (sml-smie-forward-token))
 866       ;; We're inside a "non function declaration": let's skip all other
 867       ;; declarations that we find at the same level and try again.
 868       (sml-skip-siblings)
 869       ;; Obviously, let's not try again if we're at bobp.
 870       (unless (bobp) (sml-beginning-of-defun)))))
 871
 872 (defcustom sml-max-name-components 3
 873   "Maximum number of components to use for the current function name."
 874   :group 'sml
 875   :type 'integer)
 876
 877 (defun sml-current-fun-name ()
 878   (save-excursion
 879     (let ((count sml-max-name-components)
 880           fullname name)
 881       (end-of-line)
 882       (while (and (> count 0)
 883                   (setq name (sml-beginning-of-defun)))
 884         (decf count)
 885         (setq fullname (if fullname (concat name "." fullname) name))
 886         ;; Skip all other declarations that we find at the same level.
 887         (sml-skip-siblings))
 888       fullname)))
 889
 890
 891 ;;; INSERTING PROFORMAS (COMMON SML-FORMS)
 892
 893 (defvar sml-forms-alist nil
 894   "*Alist of code templates.
 895 You can extend this alist to your heart's content.  For each additional
 896 template NAME in the list, declare a keyboard macro or function (or
 897 interactive command) called 'sml-form-NAME'.
 898 If 'sml-form-NAME' is a function it takes no arguments and should
 899 insert the template at point\; if this is a command it may accept any
 900 sensible interactive call arguments\; keyboard macros can't take
 901 arguments at all.  Apropos keyboard macros, see `name-last-kbd-macro'
 902 and `sml-addto-forms-alist'.
 903 `sml-forms-alist' understands let, local, case, abstype, datatype,
 904 signature, structure, and functor by default.")
 905
 906 (defmacro sml-def-skeleton (name interactor &rest elements)
 907   (when (fboundp 'define-skeleton)
 908     (let ((fsym (intern (concat "sml-form-" name))))
 909       ;; TODO: don't do the expansion in comments and strings.
 910       `(progn
 911          (add-to-list 'sml-forms-alist ',(cons name fsym))
 912          (condition-case err
 913              ;; Try to use the new `system' flag.
 914              (define-abbrev sml-mode-abbrev-table ,name "" ',fsym nil 'system)
 915            (wrong-number-of-arguments
 916             (define-abbrev sml-mode-abbrev-table ,name "" ',fsym)))
 917          (when (fboundp 'abbrev-put)
 918            (let ((abbrev (abbrev-symbol ,name sml-mode-abbrev-table)))
 919              (abbrev-put abbrev :case-fixed t)
 920              (abbrev-put abbrev :enable-function
 921                          (lambda () (not (nth 8 (syntax-ppss)))))))
 922          (define-skeleton ,fsym
 923            ,(format "SML-mode skeleton for `%s..' expressions" name)
 924            ,interactor
 925            ,(concat name " ") >
 926            ,@elements)))))
 927 (put 'sml-def-skeleton 'lisp-indent-function 2)
 928
 929 (sml-def-skeleton "let" nil
 930   @ "\nin " > _ "\nend" >)
 931
 932 (sml-def-skeleton "if" nil
 933   @ " then " > _ "\nelse " > _)
 934
 935 (sml-def-skeleton "local" nil
 936   @ "\nin" > _ "\nend" >)
 937
 938 (sml-def-skeleton "case" "Case expr: "
 939   str "\nof " > _ " => ")
 940
 941 (sml-def-skeleton "signature" "Signature name: "
 942   str " =\nsig" > "\n" > _ "\nend" >)
 943
 944 (sml-def-skeleton "structure" "Structure name: "
 945   str " =\nstruct" > "\n" > _ "\nend" >)
 946
 947 (sml-def-skeleton "functor" "Functor name: "
 948   str " () : =\nstruct" > "\n" > _ "\nend" >)
 949
 950 (sml-def-skeleton "datatype" "Datatype name and type params: "
 951   str " =" \n)
 952
 953 (sml-def-skeleton "abstype" "Abstype name and type params: "
 954   str " =" \n _ "\nwith" > "\nend" >)
 955
 956 ;;
 957
 958 (sml-def-skeleton "struct" nil
 959   _ "\nend" >)
 960
 961 (sml-def-skeleton "sig" nil
 962   _ "\nend" >)
 963
 964 (sml-def-skeleton "val" nil
 965   @ " = " > _)
 966
 967 (sml-def-skeleton "fn" nil
 968   @ " =>" > _)
 969
 970 (sml-def-skeleton "fun" nil
 971   @ " =" > _)
 972
 973 ;;
 974
 975 (defun sml-forms-menu (menu)
 976   (mapcar (lambda (x) (vector (car x) (cdr x) t))
 977           sml-forms-alist))
 978
 979 (defvar sml-last-form "let")
 980
 981 (defun sml-electric-space ()
 982   "Expand a symbol into an SML form, or just insert a space.
 983 If the point directly precedes a symbol for which an SML form exists,
 984 the corresponding form is inserted."
 985   (interactive)
 986   (let ((abbrev-mode (not abbrev-mode))
 987         (last-command-event ?\ )
 988         ;; Bind `this-command' to fool skeleton's special abbrev handling.
 989         (this-command 'self-insert-command))
 990     (call-interactively 'self-insert-command)))
 991
 992 (defun sml-insert-form (name newline)
 993   "Interactive short-cut to insert the NAME common ML form.
 994 If a prefix argument is given insert a NEWLINE and indent first, or
 995 just move to the proper indentation if the line is blank\; otherwise
 996 insert at point (which forces indentation to current column).
 997
 998 The default form to insert is 'whatever you inserted last time'
 999 \(just hit return when prompted\)\; otherwise the command reads with
1000 completion from `sml-forms-alist'."
1001   (interactive
1002    (list (completing-read
1003           (format "Form to insert: (default %s) " sml-last-form)
1004           sml-forms-alist nil t nil)
1005          current-prefix-arg))
1006   ;; default is whatever the last insert was...
1007   (if (string= name "") (setq name sml-last-form) (setq sml-last-form name))
1008   (unless (or (not newline)
1009               (save-excursion (beginning-of-line) (looking-at "\\s-*$")))
1010     (insert "\n"))
1011   (unless (/= ?w (char-syntax (preceding-char))) (insert " "))
1012   (let ((f (cdr (assoc name sml-forms-alist))))
1013     (cond
1014      ((commandp f) (command-execute f))
1015      (f (funcall f))
1016      (t (error "Undefined form: %s" name)))))
1017
1018 ;; See also macros.el in emacs lisp dir.
1019
1020 (defun sml-addto-forms-alist (name)
1021   "Assign a name to the last keyboard macro defined.
1022 Argument NAME is transmogrified to sml-form-NAME which is the symbol
1023 actually defined.
1024
1025 The symbol's function definition becomes the keyboard macro string.
1026
1027 If that works, NAME is added to `sml-forms-alist' so you'll be able to
1028 reinvoke the macro through \\[sml-insert-form].  You might want to save
1029 the macro to use in a later editing session -- see `insert-kbd-macro'
1030 and add these macros to your .emacs file.
1031
1032 See also `edit-kbd-macro' which is bound to \\[edit-kbd-macro]."
1033   (interactive "sName for last kbd macro (\"sml-form-\" will be added): ")
1034   (when (string= name "") (error "No command name given"))
1035   (let ((fsym (intern (concat "sml-form-" name))))
1036     (name-last-kbd-macro fsym)
1037     (message "Macro bound to %s" fsym)
1038     (add-to-list 'sml-forms-alist (cons name fsym))))
1039
1040 ;;;
1041 ;;; MLton support
1042 ;;;
1043
1044 (defvar sml-mlton-command "mlton"
1045   "Command to run MLton.   Can include arguments.")
1046
1047 (defvar sml-mlton-mainfile nil)
1048
1049 (defconst sml-mlton-error-regexp-alist
1050   ;; I wish they just changed MLton to use one of the standard
1051   ;; error formats.
1052   `(("^\\(?:Error\\|\\(Warning\\)\\): \\(.+\\) \\([0-9]+\\)\\.\\([0-9]+\\)\\.$"
1053      2 3 4
1054      ;; If subgroup 1 matched, then it's a warning, otherwise it's an error.
1055      ,@(if (fboundp 'compilation-fake-loc) '((1))))))
1056
1057 (defvar compilation-error-regexp-alist)
1058 (eval-after-load "compile"
1059   '(dolist (x sml-mlton-error-regexp-alist)
1060      (add-to-list 'compilation-error-regexp-alist x)))
1061
1062 (defun sml-mlton-typecheck (mainfile)
1063   "typecheck using MLton."
1064   (interactive
1065    (list (if (and mainfile (not current-prefix-arg))
1066              mainfile
1067            (read-file-name "Main file: "))))
1068   (save-some-buffers)
1069   (require 'compile)
1070   (dolist (x sml-mlton-error-regexp-alist)
1071     (add-to-list 'compilation-error-regexp-alist x))
1072   (with-current-buffer (find-file-noselect mainfile)
1073     (compile (concat sml-mlton-command
1074                      " -stop tc "       ;Stop right after type checking.
1075                      (shell-quote-argument
1076                       (file-relative-name buffer-file-name))))))
1077
1078 ;;;
1079 ;;; MLton's def-use info.
1080 ;;;
1081
1082 (defvar sml-defuse-file nil)
1083
1084 (defun sml-defuse-file ()
1085   (or sml-defuse-file (sml-defuse-set-file)))
1086
1087 (defun sml-defuse-set-file ()
1088   "Specify the def-use file to use."
1089   (interactive)
1090   (setq sml-defuse-file (read-file-name "Def-use file: ")))
1091
1092 (defun sml-defuse-symdata-at-point ()
1093   (save-excursion
1094     (sml-smie-forward-token)
1095     (let ((symname (sml-smie-backward-token)))
1096       (if (equal symname "op")
1097           (save-excursion (setq symname (sml-smie-forward-token))))
1098       (when (string-match "op " symname)
1099         (setq symname (substring symname (match-end 0)))
1100         (forward-word)
1101         (forward-comment (point-max)))
1102       (list symname
1103             ;; Def-use files seem to count chars, not columns.
1104             ;; We hope here that they don't actually count bytes.
1105             ;; Also they seem to start counting at 1.
1106             (1+ (- (point) (progn (beginning-of-line) (point))))
1107             (save-restriction
1108               (widen) (1+ (count-lines (point-min) (point))))
1109             buffer-file-name))))
1110
1111 (defconst sml-defuse-def-regexp
1112   "^[[:alpha:]]+ \\([^ \n]+\\) \\(.+\\) \\([0-9]+\\)\\.\\([0-9]+\\)$")
1113 (defconst sml-defuse-use-regexp-format "^    %s %d\\.%d $")
1114
1115 (defun sml-defuse-jump-to-def ()
1116   "Jump to the definition corresponding to the symbol at point."
1117   (interactive)
1118   (let ((symdata (sml-defuse-symdata-at-point)))
1119     (if (null (car symdata))
1120         (error "Not on a symbol")
1121       (with-current-buffer (find-file-noselect (sml-defuse-file))
1122         (goto-char (point-min))
1123         (unless (re-search-forward
1124                  (format sml-defuse-use-regexp-format
1125                          (concat "\\(?:"
1126                                  ;; May be an absolute file name.
1127                                  (regexp-quote (nth 3 symdata))
1128                                  "\\|"
1129                                  ;; Or a relative file name.
1130                                  (regexp-quote (file-relative-name
1131                                                 (nth 3 symdata)))
1132                                  "\\)")
1133                          (nth 2 symdata)
1134                          (nth 1 symdata))
1135                  nil t)
1136           ;; FIXME: This is typically due to editing: any minor editing will
1137           ;; mess everything up.  We should try to fail more gracefully.
1138           (error "Def-use info not found"))
1139         (unless (re-search-backward sml-defuse-def-regexp nil t)
1140           ;; This indicates a bug in this code.
1141           (error "Internal failure while looking up def-use"))
1142         (unless (equal (match-string 1) (nth 0 symdata))
1143           ;; FIXME: This again is most likely due to editing.
1144           (error "Incoherence in the def-use info found"))
1145         (let ((line (string-to-number (match-string 3)))
1146               (char (string-to-number (match-string 4))))
1147           (pop-to-buffer (find-file-noselect (match-string 2)))
1148           (goto-char (point-min))
1149           (forward-line (1- line))
1150           (forward-char (1- char)))))))
1151
1152 ;;;
1153 ;;; SML/NJ's Compilation Manager support
1154 ;;;
1155
1156 (defvar sml-cm-mode-syntax-table sml-mode-syntax-table)
1157 (defvar sml-cm-font-lock-keywords
1158  `(,(concat "\\<" (regexp-opt '("library" "group" "is" "structure"
1159                                 "functor" "signature" "funsig") t)
1160             "\\>")))
1161 ;;;###autoload
1162 (add-to-list 'completion-ignored-extensions ".cm/")
1163 ;; This was used with the old compilation manager.
1164 (add-to-list 'completion-ignored-extensions "CM/")
1165 ;;;###autoload
1166 (add-to-list 'auto-mode-alist '("\\.cm\\'" . sml-cm-mode))
1167 ;;;###autoload
1168 (define-derived-mode sml-cm-mode fundamental-mode "SML-CM"
1169   "Major mode for SML/NJ's Compilation Manager configuration files."
1170   (local-set-key "\C-c\C-c" 'sml-compile)
1171   (set (make-local-variable 'font-lock-defaults)
1172        '(sml-cm-font-lock-keywords nil t nil nil)))
1173
1174 ;;;
1175 ;;; ML-Lex support
1176 ;;;
1177
1178 (defvar sml-lex-font-lock-keywords
1179   (append
1180    '(("^%\\sw+" . font-lock-builtin-face)
1181      ("^%%" . font-lock-module-def-face))
1182    sml-font-lock-keywords))
1183 (defconst sml-lex-font-lock-defaults
1184   (cons 'sml-lex-font-lock-keywords (cdr sml-font-lock-defaults)))
1185
1186 ;;;###autoload
1187 (define-derived-mode sml-lex-mode sml-mode "SML-Lex"
1188   "Major Mode for editing ML-Lex files."
1189   (set (make-local-variable 'font-lock-defaults) sml-lex-font-lock-defaults))
1190
1191 ;;;
1192 ;;; ML-Yacc support
1193 ;;;
1194
1195 (defface sml-yacc-bnf-face
1196   '((t (:foreground "darkgreen")))
1197   "Face used to highlight (non)terminals in `sml-yacc-mode'.")
1198 (defvar sml-yacc-bnf-face 'sml-yacc-bnf-face)
1199
1200 (defcustom sml-yacc-indent-action 16
1201   "Indentation column of the opening paren of actions."
1202   :group 'sml
1203   :type 'integer)
1204
1205 (defcustom sml-yacc-indent-pipe nil
1206   "Indentation column of the pipe char in the BNF.
1207 If nil, align it with `:' or with previous cases."
1208   :group 'sml
1209   :type 'integer)
1210
1211 (defcustom sml-yacc-indent-term nil
1212   "Indentation column of the (non)term part.
1213 If nil, align it with previous cases."
1214   :group 'sml
1215   :type 'integer)
1216
1217 (defvar sml-yacc-font-lock-keywords
1218   (cons '("^\\(\\sw+\\s-*:\\|\\s-*|\\)\\(\\s-*\\sw+\\)*\\s-*\\(\\(%\\sw+\\)\\s-+\\sw+\\|\\)"
1219           (0 (save-excursion
1220                (save-match-data
1221                  (goto-char (match-beginning 0))
1222                  (unless (or (re-search-forward "\\<of\\>" (match-end 0) 'move)
1223                              (progn (forward-comment (point-max))
1224                                     (not (looking-at "("))))
1225                    sml-yacc-bnf-face))))
1226           (4 font-lock-builtin-face t t))
1227         sml-lex-font-lock-keywords))
1228 (defconst sml-yacc-font-lock-defaults
1229   (cons 'sml-yacc-font-lock-keywords (cdr sml-font-lock-defaults)))
1230
1231 (defun sml-yacc-indent-line ()
1232   "Indent current line of ML-Yacc code."
1233   (let ((savep (> (current-column) (current-indentation)))
1234         (indent (max (or (ignore-errors (sml-yacc-indentation)) 0) 0)))
1235     (if savep
1236         (save-excursion (indent-line-to indent))
1237       (indent-line-to indent))))
1238
1239 (defun sml-yacc-indentation ()
1240   (save-excursion
1241     (back-to-indentation)
1242     (or (and (looking-at "%\\|\\(\\sw\\|\\s_\\)+\\s-*:") 0)
1243         (when (save-excursion
1244                 (condition-case nil (progn (up-list -1) nil) (scan-error t)))
1245           ;; We're outside an action.
1246           (cond
1247            ;; Special handling of indentation inside %term and %nonterm
1248            ((save-excursion
1249               (and (re-search-backward "^%\\(\\sw+\\)" nil t)
1250                    (member (match-string 1) '("term" "nonterm"))))
1251             (if (numberp sml-yacc-indent-term) sml-yacc-indent-term
1252               (let ((offset (if (looking-at "|") -2 0)))
1253                 (forward-line -1)
1254                 (looking-at "\\s-*\\(%\\sw*\\||\\)?\\s-*")
1255                 (goto-char (match-end 0))
1256                 (+ offset (current-column)))))
1257            ((looking-at "(") sml-yacc-indent-action)
1258            ((looking-at "|")
1259             (if (numberp sml-yacc-indent-pipe) sml-yacc-indent-pipe
1260               (backward-sexp 1)
1261               (while (progn (forward-comment (- (point)))
1262                             (/= 0 (skip-syntax-backward "w_"))))
1263               (forward-comment (- (point)))
1264               (if (not (looking-at "\\s-$"))
1265                   (1- (current-column))
1266                 (skip-syntax-forward " ")
1267                 (- (current-column) 2))))))
1268         ;; default to SML rules
1269         (cond
1270          ((and sml-use-smie (fboundp 'smie-indent-calculate))
1271           (smie-indent-calculate))
1272          ((fboundp 'sml-calculate-indentation) (sml-calculate-indentation))))))
1273
1274 ;;;###autoload
1275 (add-to-list 'auto-mode-alist '("\\.grm\\'" . sml-yacc-mode))
1276 ;;;###autoload
1277 (define-derived-mode sml-yacc-mode sml-mode "SML-Yacc"
1278   "Major Mode for editing ML-Yacc files."
1279   (set (make-local-variable 'indent-line-function) 'sml-yacc-indent-line)
1280   (set (make-local-variable 'font-lock-defaults) sml-yacc-font-lock-defaults))
1281
1282 (provide 'sml-mode)
1283
1284 ;;; sml-mode.el ends here