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