emacs/sml-mode.el

   1 ;;; sml-mode.el --- Major mode for editing (Standard) ML  -*- lexical-binding: t; coding: utf-8 -*-
   2
   3 ;; Copyright (C) 1989,1999,2000,2004,2007,2010-2012  Free Software Foundation, Inc.
   4
   5 ;; Maintainer: (Stefan Monnier) <monnier@iro.umontreal.ca>
   6 ;; Version: 6.1
   7 ;; Keywords: SML
   8 ;; Author:      Lars Bo Nielsen
   9 ;;              Olin Shivers
  10 ;;              Fritz Knabe (?)
  11 ;;              Steven Gilmore (?)
  12 ;;              Matthew Morley <mjm@scs.leeds.ac.uk>
  13 ;;              Matthias Blume <blume@cs.princeton.edu>
  14 ;;              (Stefan Monnier) <monnier@iro.umontreal.ca>
  15
  16 ;; This file is part of GNU Emacs.
  17
  18 ;; GNU Emacs is free software: you can redistribute it and/or modify
  19 ;; it under the terms of the GNU General Public License as published by
  20 ;; the Free Software Foundation, either version 3 of the License, or
  21 ;; (at your option) any later version.
  22
  23 ;; GNU Emacs is distributed in the hope that it will be useful,
  24 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  26 ;; GNU General Public License for more details.
  27
  28 ;; You should have received a copy of the GNU General Public License
  29 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  30
  31 ;;; Commentary:
  32
  33 ;; A major mode to edit Standard ML (SML) code.
  34 ;; Provides the following features, among others:
  35 ;; - Indentation.
  36 ;; - Syntax highlighting.
  37 ;; - Prettified display of ->, =>, fn, ...
  38 ;; - Imenu.
  39 ;; - which-function-mode.
  40 ;; - Skeletons/templates.
  41 ;; - Electric pipe key.
  42 ;; - outline-minor-mode (with some known problems).
  43 ;; - Interaction with a read-eval-print loop.
  44
  45 ;;;; Known bugs:
  46
  47 ;; - Indentation after "functor toto() where type foo = bar ="
  48 ;;   Because the last is treated as an equality comparison.
  49 ;; - indentation of a declaration after a long `datatype' can be slow.
  50
  51 ;;;; News:
  52
  53 ;;;;; Changes since 5.0:
  54
  55 ;; - sml-electric-pipe-mode to make the | key electric.
  56 ;; - Removal of a lot of compatibility code.  Requires Emacs-24.
  57 ;; - Integrate in GNU ELPA.
  58
  59 ;;;;; Changes since 4.1:
  60
  61 ;; - New indentation code using SMIE when available.
  62 ;; - `sml-back-to-outer-indent' is now on S-tab (aka `backtab') rather
  63 ;;   than M-tab.
  64 ;; - Support for electric-layout-mode and electric-indent-mode.
  65 ;; - `sml-mark-defun' tries to be more clever.
  66 ;; - A single file (sml-mode.el) is needed unless you want to use an
  67 ;;   interactive process like SML/NJ, or if your Emacs does not provide SMIE.
  68
  69 ;;;;; Changes since 4.0:
  70
  71 ;; - Switch to GPLv3+.
  72 ;; - When possible (i.e. running under Emacs>=23), be case-sensitive when
  73 ;;   expanding abbreviations, and don't expand them in comments and strings.
  74 ;; - When you `next-error' to a type error, highlight the actual parts of the
  75 ;;   types that differ.
  76 ;; - Flush the recorded errors not only upon sml-compile and friends, but also
  77 ;;   when typing commands directly at the prompt.
  78 ;; - New command sml-mlton-typecheck.
  79 ;; - Simple support to parse errors and warnings in MLton's output.
  80 ;; - Simple support for MLton's def-use files.
  81
  82 ;;;;; Changes since 3.9.5:
  83
  84 ;; - No need to add the dir to your load-path any more.
  85 ;;   The sml-mode-startup.el file does it for you.
  86 ;; - Symbols like -> can be displayed as real arrows.
  87 ;;   See sml-font-lock-symbols.
  88 ;; - Fix some incompatibilities with the upcoming Emacs-21.4.
  89 ;; - Indentation rules improved.  New customizable variable
  90 ;;   `sml-rightalign-and'.  Also `sml-symbol-indent' is now customizable.
  91
  92 ;;;;; Changes since 3.9.3:
  93
  94 ;; - New add-log support (try C-x 4 a from within an SML function).
  95 ;; - Imenu support
  96 ;; - sml-bindings has disappeared.
  97 ;; - The code skeletons are now abbrevs as well.
  98 ;; - A new *sml* process is sent the content of sml-config-file
  99 ;;   (~/.sml-proc.sml) if it exists.
 100 ;; - `sml-compile' works yet a bit differently.  The command can begin
 101 ;;   with `cd "path";' and it will be replaced by OS.FileSys.chDir.
 102 ;; - run-sml now pops up the new buffer.  It can also run the command on
 103 ;;   another machine.  And it always prompts for the command name.
 104 ;;   Use a prefix argument if you want to give args or to specify a host on
 105 ;;   which to run the command.
 106 ;; - mouse-2 to yank in *sml* should work again (but won't work for next-error
 107 ;;   any more).
 108 ;; - New major-modes sml-cm-mode, sml-lex-mode and sml-yacc-mode.
 109 ;; - sml-load-hook has disappeared as has inferior-sml-load-hook.
 110 ;; - sml-mode-startup.el is now automatically generated and you're supposed to
 111 ;;   `load' it from .emacs or site-start.el.
 112 ;; - Minor bug fixes.
 113
 114 ;;; Code:
 115
 116 (eval-when-compile (require 'cl))
 117 (require 'smie nil 'noerror)
 118 (require 'electric)
 119
 120 (defgroup sml ()
 121   "Editing SML code."
 122   :group 'languages)
 123
 124 (defcustom sml-indent-level 4
 125   "Basic indentation step for SML code."
 126   :type 'integer)
 127
 128 (defcustom sml-indent-args sml-indent-level
 129   "Indentation of args placed on a separate line."
 130   :type 'integer)
 131
 132 (defcustom sml-rightalign-and t
 133   "If non-nil, right-align `and' with its leader.
 134 If nil:                                 If t:
 135         datatype a = A                          datatype a = A
 136         and b = B                                    and b = B"
 137   :type 'boolean)
 138
 139 (defcustom sml-electric-pipe-mode t
 140   "If non-nil, automatically insert appropriate template when hitting |."
 141   :type 'boolean)
 142
 143 (defvar sml-mode-hook nil
 144   "Run upon entering `sml-mode'.
 145 This is a good place to put your preferred key bindings.")
 146
 147 ;; font-lock setup
 148
 149 (defvar sml-outline-regexp
 150   ;; `st' and `si' are to match structure and signature.
 151   "\f\\|s[ti]\\|[ \t]*\\(let[ \t]+\\)?\\(fun\\|and\\)\\_>"
 152   "Regexp matching a major heading.
 153 This actually can't work without extending `outline-minor-mode' with the
 154 notion of \"the end of an outline\".")
 155
 156 ;;
 157 ;; Internal defines
 158 ;;
 159
 160 (defvar sml-mode-map
 161   (let ((map (make-sparse-keymap)))
 162     ;; Text-formatting commands:
 163     (define-key map "\C-c\C-m" 'sml-insert-form)
 164     (define-key map "\M-|" 'sml-electric-pipe)
 165     (define-key map "\M-\ " 'sml-electric-space)
 166     (define-key map [backtab] 'sml-back-to-outer-indent)
 167     map)
 168   "The keymap used in `sml-mode'.")
 169
 170 (defvar sml-mode-syntax-table
 171   (let ((st (make-syntax-table)))
 172     (modify-syntax-entry ?\* ". 23n" st)
 173     (modify-syntax-entry ?\( "()1" st)
 174     (modify-syntax-entry ?\) ")(4" st)
 175     (mapc (lambda (c) (modify-syntax-entry c "_" st)) "._'")
 176     (mapc (lambda (c) (modify-syntax-entry c "." st)) ",;")
 177     ;; `!' is not really a prefix-char, oh well!
 178     (mapc (lambda (c) (modify-syntax-entry c "'"  st)) "~#!")
 179     (mapc (lambda (c) (modify-syntax-entry c "."  st)) "%&$+-/:<=>?@`^|")
 180     st)
 181   "The syntax table used in `sml-mode'.")
 182
 183
 184 (easy-menu-define sml-mode-menu sml-mode-map "Menu used in `sml-mode'."
 185   '("SML"
 186     ("Process"
 187      ["Start SML repl"          sml-run         t]
 188      ["-" nil nil]
 189      ["Compile the project"     sml-prog-proc-compile   t]
 190      ["Send file"               sml-prog-proc-load-file t]
 191      ["Switch to SML repl"      sml-prog-proc-switch-to t]
 192      ["--" nil nil]
 193      ["Send buffer"             sml-prog-proc-send-buffer       t]
 194      ["Send region"             sml-prog-proc-send-region       t]
 195      ["Send function"           sml-send-function t]
 196      ["Goto next error"         next-error      t])
 197     ["Insert SML form"          sml-insert-form t]
 198     ("Forms" :filter sml-forms-menu)
 199     ["Indent region"            indent-region t]
 200     ["Outdent line"             sml-back-to-outer-indent t]
 201     ["-----" nil nil]
 202     ["Customize SML-mode"  (customize-group 'sml)       t]
 203     ["SML mode help"       describe-mode t]))
 204
 205 ;;
 206 ;; Regexps
 207 ;;
 208
 209 (defun sml-syms-re (syms)
 210   (concat "\\_<" (regexp-opt syms t) "\\_>"))
 211
 212 ;;
 213
 214 (defconst sml-module-head-syms
 215   '("signature" "structure" "functor" "abstraction"))
 216
 217
 218 (defconst sml-=-starter-syms
 219   (list* "|" "val" "fun" "and" "datatype" "type" "abstype" "eqtype"
 220          sml-module-head-syms)
 221   "Symbols that can be followed by a `='.")
 222 (defconst sml-=-starter-re
 223   (concat "\\S.|\\S.\\|" (sml-syms-re (cdr sml-=-starter-syms)))
 224   "Symbols that can be followed by a `='.")
 225
 226 (defconst sml-non-nested-of-starter-re
 227   (sml-syms-re '("datatype" "abstype" "exception"))
 228   "Symbols that can introduce an `of' that shouldn't behave like a paren.")
 229
 230 (defconst sml-starters-syms
 231   (append sml-module-head-syms
 232           '("abstype" "datatype" "exception" "fun"
 233             "local" "infix" "infixr" "sharing" "nonfix"
 234             "open" "type" "val" "and"
 235             "withtype" "with"))
 236   "The starters of new expressions.")
 237
 238 (defconst sml-pipeheads
 239   '("|" "of" "fun" "fn" "and" "handle" "datatype" "abstype"
 240     "(" "{" "[")
 241    "A `|' corresponds to one of these.")
 242
 243 (defconst sml-keywords-regexp
 244   (sml-syms-re '("abstraction" "abstype" "and" "andalso" "as" "before" "case"
 245                  "datatype" "else" "end" "eqtype" "exception" "do" "fn"
 246                  "fun" "functor" "handle" "if" "in" "include" "infix"
 247                  "infixr" "let" "local" "nonfix" "o" "of" "op" "open" "orelse"
 248                  "overload" "raise" "rec" "sharing" "sig" "signature"
 249                  "struct" "structure" "then" "type" "val" "where" "while"
 250                  "with" "withtype"))
 251   "A regexp that matches any and all keywords of SML.")
 252
 253 (eval-and-compile
 254   (defconst sml-id-re "\\sw\\(?:\\sw\\|\\s_\\)*"))
 255
 256 (defconst sml-tyvarseq-re
 257   (concat "\\(?:\\(?:'+" sml-id-re "\\|(\\(?:[,']\\|" sml-id-re
 258           "\\|\\s-\\)+)\\)\\s-+\\)?"))
 259
 260 ;;; Font-lock settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 261
 262 (defcustom sml-font-lock-symbols nil
 263   "Display \\ and -> and such using symbols in fonts.
 264 This may sound like a neat trick, but be extra careful: it changes the
 265 alignment and can thus lead to nasty surprises w.r.t layout."
 266   :type 'boolean)
 267
 268 (defconst sml-font-lock-symbols-alist
 269   '(("fn" . ?λ)
 270     ("andalso" . ?∧) ;; ?⋀
 271     ("orelse"  . ?∨) ;; ?⋁
 272     ;; ("as" . ?≡)
 273     ("not" . ?¬)
 274     ("div" . ?÷)
 275     ("*"   . ?×)
 276     ("o"   . ?○)
 277     ("->"  . ?→)
 278     ("=>"  . ?⇒)
 279     ("<-"  . ?←)
 280     ("<>"  . ?≠)
 281     (">="  . ?≥)
 282     ("<="  . ?≤)
 283     ("..." . ?⋯)
 284     ;; ("::" . ?∷)
 285     ;; Some greek letters for type parameters.
 286     ("'a" . ?α)
 287     ("'b" . ?β)
 288     ("'c" . ?γ)
 289     ("'d" . ?δ)
 290     ))
 291
 292 (defun sml-font-lock-compose-symbol ()
 293   "Compose a sequence of ascii chars into a symbol.
 294 Regexp match data 0 points to the chars."
 295   ;; Check that the chars should really be composed into a symbol.
 296   (let* ((start (match-beginning 0))
 297          (end (match-end 0))
 298          (syntaxes (if (eq (char-syntax (char-after start)) ?w)
 299                        '(?w) '(?. ?\\))))
 300     (if (or (memq (char-syntax (or (char-before start) ?\ )) syntaxes)
 301             (memq (char-syntax (or (char-after end) ?\ )) syntaxes)
 302             (memq (get-text-property start 'face)
 303                   '(font-lock-doc-face font-lock-string-face
 304                     font-lock-comment-face)))
 305         ;; No composition for you.  Let's actually remove any composition
 306         ;; we may have added earlier and which is now incorrect.
 307         (remove-text-properties start end '(composition))
 308       ;; That's a symbol alright, so add the composition.
 309       (compose-region start end (cdr (assoc (match-string 0)
 310                                             sml-font-lock-symbols-alist)))))
 311   ;; Return nil because we're not adding any face property.
 312   nil)
 313
 314 (defun sml-font-lock-symbols-keywords ()
 315   (when sml-font-lock-symbols
 316     `((,(regexp-opt (mapcar 'car sml-font-lock-symbols-alist) t)
 317        (0 (sml-font-lock-compose-symbol))))))
 318
 319 ;; The font lock regular expressions.
 320
 321 (defconst sml-font-lock-keywords
 322   `(;;(sml-font-comments-and-strings)
 323     (,(concat "\\_<\\(fun\\|and\\)\\s-+" sml-tyvarseq-re
 324               "\\(" sml-id-re "\\)\\s-+[^ \t\n=]")
 325      (1 font-lock-keyword-face)
 326      (2 font-lock-function-name-face))
 327     (,(concat "\\_<\\(\\(?:data\\|abs\\|with\\|eq\\)?type\\)\\s-+"
 328               sml-tyvarseq-re "\\(" sml-id-re "\\)")
 329      (1 font-lock-keyword-face)
 330      (2 font-lock-type-def-face))
 331     (,(concat "\\_<\\(val\\)\\s-+\\(?:" sml-id-re "\\_>\\s-*\\)?\\("
 332               sml-id-re "\\)\\s-*[=:]")
 333      (1 font-lock-keyword-face)
 334      (2 font-lock-variable-name-face))
 335     (,(concat "\\_<\\(structure\\|functor\\|abstraction\\)\\s-+\\("
 336               sml-id-re "\\)")
 337      (1 font-lock-keyword-face)
 338      (2 font-lock-module-def-face))
 339     (,(concat "\\_<\\(signature\\)\\s-+\\(" sml-id-re "\\)")
 340      (1 font-lock-keyword-face)
 341      (2 font-lock-interface-def-face))
 342
 343     (,sml-keywords-regexp . font-lock-keyword-face)
 344     ,@(sml-font-lock-symbols-keywords))
 345   "Regexps matching standard SML keywords.")
 346
 347 (defface font-lock-type-def-face
 348   '((t (:bold t)))
 349   "Font Lock mode face used to highlight type definitions."
 350   :group 'font-lock-highlighting-faces)
 351 (defvar font-lock-type-def-face 'font-lock-type-def-face
 352   "Face name to use for type definitions.")
 353
 354 (defface font-lock-module-def-face
 355   '((t (:bold t)))
 356   "Font Lock mode face used to highlight module definitions."
 357   :group 'font-lock-highlighting-faces)
 358 (defvar font-lock-module-def-face 'font-lock-module-def-face
 359   "Face name to use for module definitions.")
 360
 361 (defface font-lock-interface-def-face
 362   '((t (:bold t)))
 363   "Font Lock mode face used to highlight interface definitions."
 364   :group 'font-lock-highlighting-faces)
 365 (defvar font-lock-interface-def-face 'font-lock-interface-def-face
 366   "Face name to use for interface definitions.")
 367
 368 ;;
 369 ;; Code to handle nested comments and unusual string escape sequences
 370 ;;
 371
 372 (defvar sml-syntax-prop-table
 373   (let ((st (make-syntax-table)))
 374     (modify-syntax-entry ?\\ "." st)
 375     (modify-syntax-entry ?* "." st)
 376     st)
 377   "Syntax table for text-properties.")
 378
 379 (defconst sml-font-lock-syntactic-keywords
 380   `(("^\\s-*\\(\\\\\\)" (1 ',sml-syntax-prop-table))))
 381
 382 (defconst sml-font-lock-defaults
 383   '(sml-font-lock-keywords nil nil nil nil
 384     (font-lock-syntactic-keywords . sml-font-lock-syntactic-keywords)))
 385
 386
 387 ;;; Indentation with SMIE
 388
 389 (defconst sml-smie-grammar
 390   ;; We have several problem areas where SML's syntax can't be handled by an
 391   ;; operator precedence grammar:
 392   ;;
 393   ;; "= A before B" is "= A) before B" if this is the
 394   ;;   `boolean-=' but it is "= (A before B)" if it's the `definitional-='.
 395   ;;   We can work around the problem by tweaking the lexer to return two
 396   ;;   different tokens for the two different kinds of `='.
 397   ;; "of A | B" in a "case" we want "of (A | B, but in a `datatype'
 398   ;;   we want "of A) | B".
 399   ;; "= A | B" can be "= A ) | B" if the = is from a "fun" definition,
 400   ;;   but it is "= (A | B" if it is a `datatype' definition (of course, if
 401   ;;   the previous token introducing the = is `and', deciding whether
 402   ;;   it's a datatype or a function requires looking even further back).
 403   ;; "functor foo (...) where type a = b = ..." the first `=' looks very much
 404   ;;   like a `definitional-=' even tho it's just an equality constraint.
 405   ;;   Currently I don't even try to handle `where' at all.
 406   (smie-prec2->grammar
 407    (smie-merge-prec2s
 408     (smie-bnf->prec2
 409      '((exp ("if" exp "then" exp "else" exp)
 410             ("case" exp "of" branches)
 411             ("let" decls "in" cmds "end")
 412             ("struct" decls "end")
 413             ("sig" decls "end")
 414             (sexp)
 415             (sexp "handle" branches)
 416             ("fn" sexp "=>" exp))
 417        ;; "simple exp"s are the ones that can appear to the left of `handle'.
 418        (sexp (sexp ":" type) ("(" exps ")")
 419              (sexp "orelse" sexp)
 420              (marg ":>" type)
 421              (sexp "andalso" sexp))
 422        (cmds (cmds ";" cmds) (exp))
 423        (exps (exps "," exps) (exp))     ; (exps ";" exps)
 424        (branches (sexp "=>" exp) (branches "|" branches))
 425        ;; Operator precedence grammars handle separators much better then
 426        ;; starters/terminators, so let's pretend that let/fun are separators.
 427        (decls (sexp "d=" exp)
 428               (sexp "d=" databranches)
 429               (funbranches "|" funbranches)
 430               (sexp "=of" type)         ;After "exception".
 431               ;; FIXME: Just like PROCEDURE in Pascal and Modula-2, this
 432               ;; interacts poorly with the other constructs since I
 433               ;; can't make "local" a separator like fun/val/type/...
 434               ("local" decls "in" decls "end")
 435               ;; (decls "local" decls "in" decls "end")
 436               (decls "functor" decls)
 437               (decls "signature" decls)
 438               (decls "structure" decls)
 439               (decls "type" decls)
 440               (decls "open" decls)
 441               (decls "and" decls)
 442               (decls "infix" decls)
 443               (decls "infixr" decls)
 444               (decls "nonfix" decls)
 445               (decls "abstype" decls)
 446               (decls "datatype" decls)
 447               (decls "exception" decls)
 448               (decls "fun" decls)
 449               (decls "val" decls))
 450        (type (type "->" type)
 451              (type "*" type))
 452        (funbranches (sexp "d=" exp))
 453        (databranches (sexp "=of" type) (databranches "d|" databranches))
 454        ;; Module language.
 455        ;; (mexp ("functor" marg "d=" mexp)
 456        ;;       ("structure" marg "d=" mexp)
 457        ;;       ("signature" marg "d=" mexp))
 458        (marg (marg ":" type) (marg ":>" type))
 459        (toplevel (decls) (exp) (toplevel ";" toplevel)))
 460      ;; '(("local" . opener))
 461      ;; '((nonassoc "else") (right "handle"))
 462      '((nonassoc "of") (assoc "|"))     ; "case a of b => case c of d => e | f"
 463      '((nonassoc "handle") (assoc "|")) ; Idem for "handle".
 464      '((assoc "->") (assoc "*"))
 465      '((assoc "val" "fun" "type" "datatype" "abstype" "open" "infix" "infixr"
 466               "nonfix" "functor" "signature" "structure" "exception"
 467               ;; "local"
 468               )
 469        (assoc "and"))
 470      '((assoc "orelse") (assoc "andalso") (nonassoc ":"))
 471      '((assoc ";")) '((assoc ",")) '((assoc "d|")))
 472
 473     (smie-precs->prec2
 474      '((nonassoc "andalso")                       ;To anchor the prec-table.
 475        (assoc "before")                           ;0
 476        (assoc ":=" "o")                           ;3
 477        (nonassoc ">" ">=" "<>" "<" "<=" "=")      ;4
 478        (assoc "::" "@")                           ;5
 479        (assoc "+" "-" "^")                        ;6
 480        (assoc "/" "*" "quot" "rem" "div" "mod")   ;7
 481        (nonassoc " -dummy- ")))                   ;Bogus anchor at the end.
 482     )))
 483
 484 (defvar sml-indent-separator-outdent 2)
 485
 486 (defun sml-smie-rules (kind token)
 487   ;; I much preferred the pcase version of the code, especially while
 488   ;; edebugging the code.  But that will have to wait until we get rid of
 489   ;; support for Emacs-23.
 490   (case kind
 491     (:elem (case token
 492              (basic sml-indent-level)
 493              (args  sml-indent-args)))
 494     (:list-intro (member token '("fn")))
 495     (:after
 496      (cond
 497       ((equal token "struct") 0)
 498       ((equal token "=>") (if (smie-rule-hanging-p) 0 2))
 499       ((equal token "in") (if (smie-rule-parent-p "local") 0))
 500       ((equal token "of") 3)
 501       ((member token '("(" "{" "[")) (if (not (smie-rule-hanging-p)) 2))
 502       ((equal token "else") (if (smie-rule-hanging-p) 0)) ;; (:next "if" 0)
 503       ((member token '("|" "d|" ";" ",")) (smie-rule-separator kind))
 504       ((equal token "d=")
 505        (if (and (smie-rule-parent-p "val") (smie-rule-next-p "fn")) -3))))
 506     (:before
 507      (cond
 508       ((equal token "=>") (if (smie-rule-parent-p "fn") 3))
 509       ((equal token "of") 1)
 510       ;; In case the language is extended to allow a | directly after of.
 511       ((and (equal token "|") (smie-rule-prev-p "of")) 1)
 512       ((member token '("|" "d|" ";" ",")) (smie-rule-separator kind))
 513       ;; Treat purely syntactic block-constructs as being part of their parent,
 514       ;; when the opening statement is hanging.
 515       ((member token '("let" "(" "[" "{"))
 516        (if (smie-rule-hanging-p) (smie-rule-parent)))
 517       ;; Treat if ... else if ... as a single long syntactic construct.
 518       ;; Similarly, treat fn a => fn b => ... as a single construct.
 519       ((member token '("if" "fn"))
 520        (and (not (smie-rule-bolp))
 521             (smie-rule-prev-p (if (equal token "if") "else" "=>"))
 522             (smie-rule-parent)))
 523       ((equal token "and")
 524        ;; FIXME: maybe "and" (c|sh)ould be handled as an smie-separator.
 525        (cond
 526         ((smie-rule-parent-p "datatype") (if sml-rightalign-and 5 0))
 527         ((smie-rule-parent-p "fun" "val") 0)))
 528       ((equal token "d=")
 529        (cond
 530         ((smie-rule-parent-p "datatype") (if (smie-rule-bolp) 2))
 531         ((smie-rule-parent-p "structure" "signature") 0)))
 532       ;; Indent an expression starting with "local" as if it were starting
 533       ;; with "fun".
 534       ((equal token "local") (smie-indent-keyword "fun"))
 535       ;; FIXME: type/val/fun/... are separators but "local" is not, even though
 536       ;; it appears in the same list.  Try to fix up the problem by hand.
 537       ;; ((or (equal token "local")
 538       ;;      (equal (cdr (assoc token smie-grammar))
 539       ;;             (cdr (assoc "fun" smie-grammar))))
 540       ;;  (let ((parent (save-excursion (smie-backward-sexp))))
 541       ;;    (when (or (and (equal (nth 2 parent) "local")
 542       ;;                   (null (car parent)))
 543       ;;              (progn
 544       ;;                (setq parent (save-excursion (smie-backward-sexp "fun")))
 545       ;;                (eq (car parent) (nth 1 (assoc "fun" smie-grammar)))))
 546       ;;      (goto-char (nth 1 parent))
 547       ;;      (cons 'column (smie-indent-virtual)))))
 548       ))))
 549
 550 (defun sml-smie-definitional-equal-p ()
 551   "Figure out which kind of \"=\" this is.
 552 Assumes point is right before the = sign."
 553   ;; The idea is to look backward for the first occurrence of a token that
 554   ;; requires a definitional "=" and then see if there's such a definitional
 555   ;; equal between that token and ourselves (in which case we're not
 556   ;; a definitional = ourselves).
 557   ;; The "search for =" is naive and will match "=>" and "<=", but it turns
 558   ;; out to be OK in practice because such tokens very rarely (if ever) appear
 559   ;; between the =-starter and the corresponding definitional equal.
 560   ;; One known problem case is code like:
 561   ;; "functor foo (structure s : S) where type t = s.t ="
 562   ;; where the "type t = s.t" is mistaken for a type definition.
 563   (let ((re (concat "\\(" sml-=-starter-re "\\)\\|=")))
 564     (save-excursion
 565       (and (re-search-backward re nil t)
 566            (or (match-beginning 1)
 567                ;; If we first hit a "=", then that = is probably definitional
 568                ;; and  we're an equality, but not necessarily.  One known
 569                ;; problem case is code like:
 570                ;; "functor foo (structure s : S) where type t = s.t ="
 571                ;; where the first = is more like an equality (tho it doesn't
 572                ;; matter much) and the second is definitional.
 573                ;;
 574                ;; FIXME: The test below could be used to recognize that the
 575                ;; second = is not a mere equality, but that's not enough to
 576                ;; parse the construct properly: we'd need something
 577                ;; like a third kind of = token for structure definitions, in
 578                ;; order for the parser to be able to skip the "type t = s.t"
 579                ;; as a sub-expression.
 580                ;;
 581                ;; (and (not (looking-at "=>"))
 582                ;;      (not (eq ?< (char-before))) ;Not a <=
 583                ;;      (re-search-backward re nil t)
 584                ;;      (match-beginning 1)
 585                ;;      (equal "type" (buffer-substring (- (match-end 1) 4)
 586                ;;                                      (match-end 1))))
 587                )))))
 588
 589 (defun sml-smie-non-nested-of-p ()
 590   ;; FIXME: Maybe datatype-|-p makes this nested-of business unnecessary.
 591   "Figure out which kind of \"of\" this is.
 592 Assumes point is right before the \"of\" symbol."
 593   (save-excursion
 594     (and (re-search-backward (concat "\\(" sml-non-nested-of-starter-re
 595                                      "\\)\\|\\_<case\\_>") nil t)
 596          (match-beginning 1))))
 597
 598 (defun sml-smie-datatype-|-p ()
 599   "Figure out which kind of \"|\" this is.
 600 Assumes point is right before the | symbol."
 601   (save-excursion
 602     (forward-char 1)                    ;Skip the |.
 603     (let ((after-type-def
 604            '("|" "of" "in" "datatype" "and" "exception" "abstype" "infix"
 605              "infixr" "nonfix" "local" "val" "fun" "structure" "functor"
 606              "signature")))
 607       (or (member (sml-smie-forward-token-1) after-type-def) ;Skip the tag.
 608           (member (sml-smie-forward-token-1) after-type-def)))))
 609
 610 (defun sml-smie-forward-token-1 ()
 611   (forward-comment (point-max))
 612   (buffer-substring-no-properties
 613    (point)
 614    (progn
 615      (or (/= 0 (skip-syntax-forward "'w_"))
 616          (skip-syntax-forward ".'"))
 617      (point))))
 618
 619 (defun sml-smie-forward-token ()
 620   (let ((sym (sml-smie-forward-token-1)))
 621     (cond
 622      ((equal "op" sym)
 623       (concat "op " (sml-smie-forward-token-1)))
 624      ((member sym '("|" "of" "="))
 625       ;; The important lexer for indentation's performance is the backward
 626       ;; lexer, so for the forward lexer we delegate to the backward one.
 627       (save-excursion (sml-smie-backward-token)))
 628      (t sym))))
 629
 630 (defun sml-smie-backward-token-1 ()
 631   (forward-comment (- (point)))
 632   (buffer-substring-no-properties
 633    (point)
 634    (progn
 635      (or (/= 0 (skip-syntax-backward ".'"))
 636          (skip-syntax-backward "'w_"))
 637      (point))))
 638
 639 (defun sml-smie-backward-token ()
 640   (let ((sym (sml-smie-backward-token-1)))
 641     (unless (zerop (length sym))
 642       ;; FIXME: what should we do if `sym' = "op" ?
 643       (let ((point (point)))
 644         (if (equal "op" (sml-smie-backward-token-1))
 645             (concat "op " sym)
 646           (goto-char point)
 647           (cond
 648            ((string= sym "=") (if (sml-smie-definitional-equal-p) "d=" "="))
 649            ((string= sym "of") (if (sml-smie-non-nested-of-p) "=of" "of"))
 650            ((string= sym "|") (if (sml-smie-datatype-|-p) "d|" "|"))
 651            (t sym)))))))
 652
 653 ;;;;
 654 ;;;; Imenu support
 655 ;;;;
 656
 657 (defvar sml-imenu-regexp
 658   (concat "^[ \t]*\\(let[ \t]+\\)?"
 659           (regexp-opt (append sml-module-head-syms
 660                               '("and" "fun" "datatype" "abstype" "type")) t)
 661           "\\_>"))
 662
 663 (defun sml-imenu-create-index ()
 664   (let (alist)
 665     (goto-char (point-max))
 666     (while (re-search-backward sml-imenu-regexp nil t)
 667       (save-excursion
 668         (let ((kind (match-string 2))
 669               (column (progn (goto-char (match-beginning 2)) (current-column)))
 670               (location
 671                (progn (goto-char (match-end 0))
 672                       (forward-comment (point-max))
 673                       (when (looking-at sml-tyvarseq-re)
 674                         (goto-char (match-end 0)))
 675                       (point)))
 676               (name (sml-smie-forward-token)))
 677           ;; Eliminate trivial renamings.
 678           (when (or (not (member kind '("structure" "signature")))
 679                     (progn (search-forward "=")
 680                            (forward-comment (point-max))
 681                            (looking-at "sig\\|struct")))
 682             (push (cons (concat (make-string (/ column 2) ?\ ) name) location)
 683                   alist)))))
 684     alist))
 685
 686 ;;; Generic prog-proc interaction.
 687
 688 (require 'comint)
 689 (require 'compile)
 690
 691 (defvar sml-prog-proc-mode-map
 692   (let ((map (make-sparse-keymap)))
 693     (define-key map [?\C-c ?\C-l] 'sml-prog-proc-load-file)
 694     (define-key map [?\C-c ?\C-c] 'sml-prog-proc-compile)
 695     (define-key map [?\C-c ?\C-z] 'sml-prog-proc-switch-to)
 696     (define-key map [?\C-c ?\C-r] 'sml-prog-proc-send-region)
 697     (define-key map [?\C-c ?\C-b] 'sml-prog-proc-send-buffer)
 698     ;; FIXME: Add
 699     ;; (define-key map [?\M-C-x] 'sml-prog-proc-send-defun)
 700     ;; (define-key map [?\C-x ?\C-e] 'sml-prog-proc-send-last-sexp)
 701     ;; FIXME: Add menu.  Now, that's trickier because keymap inheritance
 702     ;; doesn't play nicely with menus!
 703     map)
 704   "Keymap for `sml-prog-proc-mode'.")
 705
 706 (defvar sml-prog-proc--buffer nil
 707   "The inferior-process buffer to which to send code.")
 708 (make-variable-buffer-local 'sml-prog-proc--buffer)
 709
 710 (defstruct (sml-prog-proc-descriptor
 711             (:constructor sml-prog-proc-make)
 712             (:predicate nil)
 713             (:copier nil))
 714   (name nil :read-only t)
 715   (run nil :read-only t)
 716   (load-cmd nil :read-only t)
 717   (chdir-cmd nil :read-only t)
 718   (command-eol "\n" :read-only t)
 719   (compile-commands-alist nil :read-only t))
 720
 721 (defvar sml-prog-proc-descriptor nil
 722   "Struct containing the various functions to create a new process, ...")
 723
 724 (defmacro sml-prog-proc--prop (prop)
 725   `(,(intern (format "sml-prog-proc-descriptor-%s" prop))
 726     (or sml-prog-proc-descriptor
 727         ;; FIXME: Look for available ones and pick one.
 728         (error "Not a `sml-prog-proc' buffer"))))
 729 (defmacro sml-prog-proc--call (method &rest args)
 730   `(funcall (sml-prog-proc--prop ,method) ,@args))
 731
 732 ;; The inferior process and his buffer are basically interchangeable.
 733 ;; Currently the code takes sml-prog-proc--buffer as the main reference,
 734 ;; but all users should either use sml-prog-proc-proc or sml-prog-proc-buffer
 735 ;; to find the info.
 736
 737 (defun sml-prog-proc-proc ()
 738   "Return the inferior process for the code in current buffer."
 739   (or (and (buffer-live-p sml-prog-proc--buffer)
 740            (get-buffer-process sml-prog-proc--buffer))
 741       (when (derived-mode-p 'sml-prog-proc-mode 'sml-prog-proc-comint-mode)
 742         (setq sml-prog-proc--buffer (current-buffer))
 743         (get-buffer-process sml-prog-proc--buffer))
 744       (let ((ppd sml-prog-proc-descriptor)
 745             (buf (sml-prog-proc--call run)))
 746         (with-current-buffer buf
 747           (if (and ppd (null sml-prog-proc-descriptor))
 748               (set (make-local-variable 'sml-prog-proc-descriptor) ppd)))
 749         (setq sml-prog-proc--buffer buf)
 750         (get-buffer-process sml-prog-proc--buffer))))
 751
 752 (defun sml-prog-proc-buffer ()
 753   "Return the buffer of the inferior process."
 754   (process-buffer (sml-prog-proc-proc)))
 755
 756 (defun sml-prog-proc-switch-to ()
 757   "Switch to the buffer running the read-eval-print process."
 758   (pop-to-buffer (sml-prog-proc-buffer)))
 759
 760 (defun sml-prog-proc-send-string (proc str)
 761   "Send command STR to PROC, with an EOL terminator appended."
 762   (with-current-buffer (process-buffer proc)
 763     ;; FIXME: comint-send-string does not pass the string through
 764     ;; comint-input-filter-function, so we have to do it by hand.
 765     ;; Maybe we should insert the command into the buffer and then call
 766     ;; comint-send-input?
 767     (sml-prog-proc-comint-input-filter-function nil)
 768     (comint-send-string proc (concat str (sml-prog-proc--prop command-eol)))))
 769
 770 (defun sml-prog-proc-load-file (file &optional and-go)
 771   "Load FILE into the read-eval-print process.
 772 FILE is the file visited by the current buffer.
 773 If prefix argument AND-GO is used, then we additionally switch
 774 to the buffer where the process is running."
 775   (interactive
 776    (list (or buffer-file-name
 777              (read-file-name "File to load: " nil nil t))
 778          current-prefix-arg))
 779   (comint-check-source file)
 780   (let ((proc (sml-prog-proc-proc)))
 781     (sml-prog-proc-send-string proc (sml-prog-proc--call load-cmd file))
 782     (when and-go (pop-to-buffer (process-buffer proc)))))
 783
 784 (defvar sml-prog-proc--tmp-file nil)
 785
 786 (defun sml-prog-proc-send-region (start end &optional and-go)
 787   "Send the content of the region to the read-eval-print process.
 788 START..END delimit the region; AND-GO if non-nil indicate to additionally
 789 switch to the process's buffer."
 790   (interactive "r\nP")
 791   (if (> start end) (let ((tmp end)) (setq end start) (setq start tmp))
 792     (if (= start end) (error "Nothing to send: the region is empty")))
 793   (let ((proc (sml-prog-proc-proc))
 794         (tmp (make-temp-file "emacs-region")))
 795     (write-region start end tmp nil 'silently)
 796     (when sml-prog-proc--tmp-file
 797       (ignore-errors (delete-file (car sml-prog-proc--tmp-file)))
 798       (set-marker (cdr sml-prog-proc--tmp-file) nil))
 799     (setq sml-prog-proc--tmp-file (cons tmp (copy-marker start)))
 800     (sml-prog-proc-send-string proc (sml-prog-proc--call load-cmd tmp))
 801     (when and-go (pop-to-buffer (process-buffer proc)))))
 802
 803 (defun sml-prog-proc-send-buffer (&optional and-go)
 804   "Send the content of the current buffer to the read-eval-print process.
 805 AND-GO if non-nil indicate to additionally switch to the process's buffer."
 806   (interactive "P")
 807   (sml-prog-proc-send-region (point-min) (point-max) and-go))
 808
 809 (define-derived-mode sml-prog-proc-mode prog-mode "Sml-Prog-Proc"
 810   "Major mode for editing source code and interact with an interactive loop."
 811   )
 812
 813 ;;; Extended comint-mode for Sml-Prog-Proc.
 814
 815 (defun sml-prog-proc-chdir (dir)
 816   "Change the working directory of the inferior process to DIR."
 817   (interactive "DChange to directory: ")
 818   (let ((dir (expand-file-name dir))
 819         (proc (sml-prog-proc-proc)))
 820     (with-current-buffer (process-buffer proc)
 821       (sml-prog-proc-send-string proc (sml-prog-proc--call chdir-cmd dir))
 822       (setq default-directory (file-name-as-directory dir)))))
 823
 824 (defun sml-prog-proc-comint-input-filter-function (str)
 825   ;; `compile.el' doesn't know that file location info from errors should be
 826   ;; recomputed afresh (without using stale info from earlier compilations).
 827   (compilation-forget-errors)       ;Has to run before compilation-fake-loc.
 828   (if (and sml-prog-proc--tmp-file (marker-buffer (cdr sml-prog-proc--tmp-file)))
 829       (compilation-fake-loc (cdr sml-prog-proc--tmp-file)
 830                             (car sml-prog-proc--tmp-file)))
 831   str)
 832
 833 (defvar sml-prog-proc-comint-mode-map
 834   (let ((map (make-sparse-keymap)))
 835     (define-key map "\C-c\C-l" 'sml-prog-proc-load-file)
 836     map))
 837
 838 (define-derived-mode sml-prog-proc-comint-mode comint-mode "Sml-Prog-Proc-Comint"
 839   "Major mode for an inferior process used to run&compile source code."
 840   ;; Enable compilation-minor-mode, but only after the child mode is setup
 841   ;; since the child-mode might want to add rules to
 842   ;; compilation-error-regexp-alist.
 843   (add-hook 'after-change-major-mode-hook #'compilation-minor-mode nil t)
 844   ;; The keymap of compilation-minor-mode is too unbearable, so we
 845   ;; need to hide most of the bindings.
 846   (let ((map (make-sparse-keymap)))
 847     (dolist (keys '([menu-bar] [follow-link]))
 848       ;; Preserve some of the bindings.
 849       (define-key map keys (lookup-key compilation-minor-mode-map keys)))
 850     (add-to-list 'minor-mode-overriding-map-alist
 851                  (cons 'compilation-minor-mode map)))
 852
 853   (add-hook 'comint-input-filter-functions
 854             #'sml-prog-proc-comint-input-filter-function nil t))
 855
 856 (defvar sml-prog-proc--compile-command nil
 857   "The command used by default by `sml-prog-proc-compile'.")
 858
 859 (defun sml-prog-proc-compile (command &optional and-go)
 860   "Pass COMMAND to the read-eval-loop process to compile the current file.
 861
 862 You can then use the command \\[next-error] to find the next error message
 863 and move to the source code that caused it.
 864
 865 Interactively, prompts for the command if `compilation-read-command' is
 866 non-nil.  With prefix arg, always prompts.
 867
 868 Prefix arg AND-GO also means to switch to the read-eval-loop buffer afterwards."
 869   (interactive
 870    (let* ((dir default-directory)
 871           (cmd "cd \"."))
 872      ;; Look for files to determine the default command.
 873      (while (and (stringp dir)
 874                  (progn
 875                    (dolist (cf (sml-prog-proc--prop compile-commands-alist))
 876                      (when (file-exists-p (expand-file-name (cdr cf) dir))
 877                        (setq cmd (concat cmd "\"; " (car cf)))
 878                        (return nil)))
 879                    (not cmd)))
 880        (let ((newdir (file-name-directory (directory-file-name dir))))
 881          (setq dir (unless (equal newdir dir) newdir))
 882          (setq cmd (concat cmd "/.."))))
 883      (setq cmd
 884            (cond
 885             ((local-variable-p 'sml-prog-proc--compile-command)
 886              sml-prog-proc--compile-command)
 887             ((string-match "^\\s-*cd\\s-+\"\\.\"\\s-*;\\s-*" cmd)
 888              (substring cmd (match-end 0)))
 889             ((string-match "^\\s-*cd\\s-+\"\\(\\./\\)" cmd)
 890              (replace-match "" t t cmd 1))
 891             ((string-match ";" cmd) cmd)
 892             (t sml-prog-proc--compile-command)))
 893      ;; code taken from compile.el
 894      (list (if (or compilation-read-command current-prefix-arg)
 895                (read-from-minibuffer "Compile command: "
 896                                      cmd nil nil '(compile-history . 1))
 897              cmd))))
 898      ;; ;; now look for command's file to determine the directory
 899      ;; (setq dir default-directory)
 900      ;; (while (and (stringp dir)
 901      ;;             (dolist (cf (sml-prog-proc--prop compile-commands-alist) t)
 902      ;;               (when (and (equal cmd (car cf))
 903      ;;                          (file-exists-p (expand-file-name (cdr cf) dir)))
 904      ;;                 (return nil))))
 905      ;;   (let ((newdir (file-name-directory (directory-file-name dir))))
 906      ;;     (setq dir (unless (equal newdir dir) newdir))))
 907      ;; (setq dir (or dir default-directory))
 908      ;; (list cmd dir)))
 909   (set (make-local-variable 'sml-prog-proc--compile-command) command)
 910   (save-some-buffers (not compilation-ask-about-save) nil)
 911   (let ((dir default-directory))
 912     (when (string-match "^\\s-*cd\\s-+\"\\([^\"]+\\)\"\\s-*;" command)
 913       (setq dir (match-string 1 command))
 914       (setq command (replace-match "" t t command)))
 915     (setq dir (expand-file-name dir))
 916     (let ((proc (sml-prog-proc-proc))
 917           (eol (sml-prog-proc--prop command-eol)))
 918       (with-current-buffer (process-buffer proc)
 919         (setq default-directory dir)
 920         (sml-prog-proc-send-string
 921          proc (concat (sml-prog-proc--call chdir-cmd dir)
 922                       ;; Strip the newline, to avoid adding a prompt.
 923                       (if (string-match "\n\\'" eol)
 924                           (replace-match " " t t eol) eol)
 925                       command))
 926         (when and-go (pop-to-buffer (process-buffer proc)))))))
 927
 928
 929 ;;; SML Sml-Prog-Proc support.
 930
 931 (defcustom sml-program-name "sml"
 932   "Program to run as Standard SML read-eval-print loop."
 933   :type 'string)
 934
 935 (defcustom sml-default-arg ""
 936   "Default command line option to pass to `sml-program-name', if any."
 937   :type 'string)
 938
 939 (defcustom sml-host-name ""
 940   "Host on which to run `sml-program-name'."
 941   :type 'string)
 942
 943 (defcustom sml-config-file "~/.smlproc.sml"
 944   "File that should be fed to the SML process when started."
 945   :type 'string)
 946
 947
 948 (defcustom sml-prompt-regexp "^[-=>#] *"
 949   "Regexp used to recognise prompts in the inferior SML process."
 950   :type 'regexp)
 951
 952 (defcustom sml-compile-commands-alist
 953   '(("CMB.make()" . "all-files.cm")
 954     ("CMB.make()" . "pathconfig")
 955     ("CM.make()" . "sources.cm")
 956     ("use \"load-all\"" . "load-all"))
 957   "Commands used by default by `sml-sml-prog-proc-compile'.
 958 Each command is associated with its \"main\" file.
 959 It is perfectly OK to associate several files with a command or several
 960 commands with the same file.")
 961
 962 ;; FIXME: Try to auto-detect the process and set those vars accordingly.
 963
 964 (defvar sml-use-command "use \"%s\""
 965   "Template for loading a file into the inferior SML process.
 966 Set to \"use \\\"%s\\\"\" for SML/NJ or Edinburgh ML;
 967 set to \"PolyML.use \\\"%s\\\"\" for Poly/ML, etc.")
 968
 969 (defvar sml-cd-command "OS.FileSys.chDir \"%s\""
 970   "Command template for changing working directories under SML.
 971 Set this to nil if your compiler can't change directories.
 972
 973 The format specifier \"%s\" will be converted into the directory name
 974 specified when running the command \\[sml-cd].")
 975
 976 (defvar sml-error-regexp-alist
 977   `( ;; Poly/ML messages
 978     ("^\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
 979     ;; Moscow ML
 980     ("^File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
 981     ;; SML/NJ:  the file-pattern is anchored to avoid
 982     ;; pathological behavior with very long lines.
 983     ("^[-= ]*\\(.*[^\n)]\\)\\( (.*)\\)?:\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warnin\\(g\\)\\): .*" 1
 984      (3 . 6) (4 . 7) (9))
 985     ;; SML/NJ's exceptions:  see above.
 986     ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2
 987      (3 . 6) (4 . 7)))
 988   "Alist that specifies how to match errors in compiler output.
 989 See `compilation-error-regexp-alist' for a description of the format.")
 990
 991 (defconst sml-pp-functions
 992   (sml-prog-proc-make :name "SML"
 993                   :run (lambda () (call-interactively #'sml-run))
 994                   :load-cmd (lambda (file) (format sml-use-command file))
 995                   :chdir-cmd (lambda (dir) (format sml-cd-command dir))
 996                   :compile-commands-alist sml-compile-commands-alist
 997                   :command-eol ";\n"
 998                   ))
 999
1000 ;; font-lock support
1001 (defconst inferior-sml-font-lock-keywords
1002   `(;; prompt and following interactive command
1003     ;; FIXME: Actually, this should already be taken care of by comint.
1004     (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
1005      (1 font-lock-prompt-face)
1006      (2 font-lock-command-face keep))
1007     ;; CM's messages
1008     ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
1009     ;; SML/NJ's irritating GC messages
1010     ("^GC #.*" . font-lock-comment-face))
1011   "Font-locking specification for inferior SML mode.")
1012
1013 (defface font-lock-prompt-face
1014   '((t (:bold t)))
1015   "Font Lock mode face used to highlight prompts."
1016   :group 'font-lock-highlighting-faces)
1017 (defvar font-lock-prompt-face 'font-lock-prompt-face
1018   "Face name to use for prompts.")
1019
1020 (defface font-lock-command-face
1021   '((t (:bold t)))
1022   "Font Lock mode face used to highlight interactive commands."
1023   :group 'font-lock-highlighting-faces)
1024 (defvar font-lock-command-face 'font-lock-command-face
1025   "Face name to use for interactive commands.")
1026
1027 (defconst inferior-sml-font-lock-defaults
1028   '(inferior-sml-font-lock-keywords nil nil nil nil))
1029
1030 (defun sml--read-run-cmd ()
1031   (list
1032    (read-string "SML command: " sml-program-name)
1033    (if (or current-prefix-arg (> (length sml-default-arg) 0))
1034        (read-string "Any args: " sml-default-arg)
1035      sml-default-arg)
1036    (if (or current-prefix-arg (> (length sml-host-name) 0))
1037        (read-string "On host: " sml-host-name)
1038      sml-host-name)))
1039
1040 ;;;###autoload
1041 (defalias 'run-sml 'sml-run)
1042
1043 ;;;###autoload
1044 (defun sml-run (cmd arg &optional host)
1045   "Run the program CMD with given arguments ARG.
1046 The command is run in buffer *CMD* using mode `inferior-sml-mode'.
1047 If the buffer already exists and has a running process, then
1048 just go to this buffer.
1049
1050 If a prefix argument is used, the user is also prompted for a HOST
1051 on which to run CMD using `remote-shell-program'.
1052
1053 \(Type \\[describe-mode] in the process's buffer for a list of commands.)"
1054   (interactive (sml--read-run-cmd))
1055   (let* ((pname (file-name-nondirectory cmd))
1056          (args (split-string arg))
1057          (file (when (and sml-config-file (file-exists-p sml-config-file))
1058                  sml-config-file)))
1059     ;; And this -- to keep these as defaults even if
1060     ;; they're set in the mode hooks.
1061     (setq sml-program-name cmd)
1062     (setq sml-default-arg arg)
1063     (setq sml-host-name host)
1064     ;; For remote execution, use `remote-shell-program'
1065     (when (> (length host) 0)
1066       (setq args (list* host "cd" default-directory ";" cmd args))
1067       (setq cmd remote-shell-program))
1068     ;; Go for it.
1069     (save-current-buffer
1070       (let ((exec-path (if (and (file-name-directory cmd)
1071                                 (not (file-name-absolute-p cmd)))
1072                            ;; If the command has slashes, make sure we
1073                            ;; first look relative to the current directory.
1074                            ;; Emacs-21 does it for us, but not Emacs-20.
1075                            (cons default-directory exec-path) exec-path)))
1076         (pop-to-buffer (apply 'make-comint pname cmd file args)))
1077
1078       (inferior-sml-mode)
1079       (goto-char (point-max))
1080       (current-buffer))))
1081
1082 (defun sml-send-function (&optional and-go)
1083   "Send current paragraph to the inferior SML process.
1084 With a prefix argument AND-GO switch to the repl buffer as well."
1085   (interactive "P")
1086   (save-excursion
1087     (sml-mark-function)
1088     (sml-prog-proc-send-region (point) (mark)))
1089   (if and-go (sml-prog-proc-switch-to)))
1090
1091 (defvar inferior-sml-mode-map
1092   (let ((map (make-sparse-keymap)))
1093     (set-keymap-parent map comint-mode-map)
1094     (define-key map "\C-c\C-s" 'sml-run)
1095     (define-key map "\t" 'completion-at-point)
1096     map)
1097   "Keymap for inferior-sml mode.")
1098
1099
1100 (declare-function smerge-refine-subst "smerge-mode"
1101                   (beg1 end1 beg2 end2 props-c))
1102
1103 (defun inferior-sml-next-error-hook ()
1104   ;; Try to recognize SML/NJ type error message and to highlight finely the
1105   ;; difference between the two types (in case they're large, it's not
1106   ;; always obvious to spot it).
1107   ;;
1108   ;; Sample messages:
1109   ;;
1110   ;; Data.sml:31.9-33.33 Error: right-hand-side of clause doesn't agree with function result type [tycon mismatch]
1111   ;;   expression:  Hstring
1112   ;;   result type:  Hstring * int
1113   ;;   in declaration:
1114   ;;     des2hs = (fn SYM_ID hs => hs
1115   ;;                | SYM_OP hs => hs
1116   ;;                | SYM_CHR hs => hs)
1117   ;; Data.sml:35.44-35.63 Error: operator and operand don't agree [tycon mismatch]
1118   ;;   operator domain: Hstring * Hstring
1119   ;;   operand:         (Hstring * int) * (Hstring * int)
1120   ;;   in expression:
1121   ;;     HSTRING.ieq (h1,h2)
1122   ;; vparse.sml:1861.6-1922.14 Error: case object and rules don't agree [tycon mismatch]
1123   ;;   rule domain: STConstraints list list option
1124   ;;   object: STConstraints list option
1125   ;;   in expression:
1126   (save-current-buffer
1127     (when (and (derived-mode-p 'sml-mode 'inferior-sml-mode)
1128                (boundp 'next-error-last-buffer)
1129                (bufferp next-error-last-buffer)
1130                (set-buffer next-error-last-buffer)
1131                (derived-mode-p 'inferior-sml-mode)
1132                ;; The position of `point' is not guaranteed :-(
1133                (looking-at (concat ".*\\[tycon mismatch\\]\n"
1134                                    "  \\(operator domain\\|expression\\|rule domain\\): +")))
1135       (require 'smerge-mode)
1136       (save-excursion
1137         (let ((b1 (match-end 0))
1138               e1 b2 e2)
1139           (when (re-search-forward "\n  in \\(expression\\|declaration\\):\n"
1140                                    nil t)
1141             (setq e2 (match-beginning 0))
1142             (when (re-search-backward
1143                    "\n  \\(operand\\|result type\\|object\\): +"
1144                    b1 t)
1145               (setq e1 (match-beginning 0))
1146               (setq b2 (match-end 0))
1147               (smerge-refine-subst b1 e1 b2 e2
1148                                    '((face . smerge-refined-change))))))))))
1149
1150 (define-derived-mode inferior-sml-mode sml-prog-proc-comint-mode "Inferior-SML"
1151   "Major mode for interacting with an inferior SML process.
1152
1153 The following commands are available:
1154 \\{inferior-sml-mode-map}
1155
1156 An SML process can be fired up (again) with \\[sml].
1157
1158 Customisation: Entry to this mode runs the hooks on `comint-mode-hook'
1159 and `inferior-sml-mode-hook' (in that order).
1160
1161 Variables controlling behaviour of this mode are
1162
1163 `sml-program-name' (default \"sml\")
1164     Program to run as SML.
1165
1166 `sml-use-command' (default \"use \\\"%s\\\"\")
1167     Template for loading a file into the inferior SML process.
1168
1169 `sml-cd-command' (default \"System.Directory.cd \\\"%s\\\"\")
1170     SML command for changing directories in SML process (if possible).
1171
1172 `sml-prompt-regexp' (default \"^[\\-=] *\")
1173     Regexp used to recognise prompts in the inferior SML process.
1174
1175 You can send text to the inferior SML process from other buffers containing
1176 SML source.
1177     `switch-to-sml' switches the current buffer to the SML process buffer.
1178     `sml-send-function' sends the current *paragraph* to the SML process.
1179     `sml-send-region' sends the current region to the SML process.
1180
1181     Prefixing the sml-send-<whatever> commands with \\[universal-argument]
1182     causes a switch to the SML process buffer after sending the text.
1183
1184 For information on running multiple processes in multiple buffers, see
1185 documentation for variable `sml-buffer'.
1186
1187 Commands:
1188 RET after the end of the process' output sends the text from the
1189     end of process to point.
1190 RET before the end of the process' output copies the current line
1191     to the end of the process' output, and sends it.
1192 DEL converts tabs to spaces as it moves back.
1193 TAB file name completion, as in shell-mode, etc.."
1194   (setq comint-prompt-regexp sml-prompt-regexp)
1195   (sml-mode-variables)
1196
1197   ;; We have to install it globally, 'cause it's run in the *source* buffer :-(
1198   (add-hook 'next-error-hook 'inferior-sml-next-error-hook)
1199
1200   ;; Make TAB add a " rather than a space at the end of a file name.
1201   (set (make-local-variable 'comint-completion-addsuffix) '(?/ . ?\"))
1202
1203   (set (make-local-variable 'font-lock-defaults)
1204        inferior-sml-font-lock-defaults)
1205
1206   ;; Compilation support (used for `next-error').
1207   (set (make-local-variable 'compilation-error-regexp-alist)
1208        sml-error-regexp-alist)
1209   ;; FIXME: move it to sml-mode?
1210   (set (make-local-variable 'compilation-error-screen-columns) nil)
1211
1212   (setq mode-line-process '(": %s")))
1213
1214 ;;; MORE CODE FOR SML-MODE
1215
1216 ;;;###autoload
1217 (add-to-list 'auto-mode-alist '("\\.s\\(ml\\|ig\\)\\'" . sml-mode))
1218
1219 (defvar comment-quote-nested)
1220
1221 ;;;###autoload
1222 (define-derived-mode sml-mode sml-prog-proc-mode "SML"
1223   "\\<sml-mode-map>Major mode for editing Standard ML code.
1224 This mode runs `sml-mode-hook' just before exiting.
1225 See also (info \"(sml-mode)Top\").
1226 \\{sml-mode-map}"
1227   (set (make-local-variable 'sml-prog-proc-descriptor) sml-pp-functions)
1228   (set (make-local-variable 'font-lock-defaults) sml-font-lock-defaults)
1229   (set (make-local-variable 'outline-regexp) sml-outline-regexp)
1230   (set (make-local-variable 'imenu-create-index-function)
1231        'sml-imenu-create-index)
1232   (set (make-local-variable 'add-log-current-defun-function)
1233        'sml-current-fun-name)
1234   ;; Treat paragraph-separators in comments as paragraph-separators.
1235   (set (make-local-variable 'paragraph-separate)
1236        (concat "\\([ \t]*\\*)?\\)?\\(" paragraph-separate "\\)"))
1237   (set (make-local-variable 'require-final-newline) t)
1238   (set (make-local-variable 'electric-indent-chars)
1239        (cons ?\; (if (boundp 'electric-indent-chars)
1240                      electric-indent-chars '(?\n))))
1241   (set (make-local-variable 'electric-layout-rules)
1242        `((?\; . ,(lambda ()
1243                    (save-excursion
1244                      (skip-chars-backward " \t;")
1245                      (unless (or (bolp)
1246                                  (progn (skip-chars-forward " \t;")
1247                                         (eolp)))
1248                        'after))))))
1249   (when sml-electric-pipe-mode
1250     (add-hook 'post-self-insert-hook #'sml-post-self-insert-pipe nil t))
1251   (sml-mode-variables))
1252
1253 (defun sml-mode-variables ()
1254   (set-syntax-table sml-mode-syntax-table)
1255   (setq local-abbrev-table sml-mode-abbrev-table)
1256   ;; Setup indentation and sexp-navigation.
1257   (smie-setup sml-smie-grammar #'sml-smie-rules
1258               :backward-token #'sml-smie-backward-token
1259               :forward-token #'sml-smie-forward-token)
1260   (set (make-local-variable 'parse-sexp-ignore-comments) t)
1261   (set (make-local-variable 'comment-start) "(* ")
1262   (set (make-local-variable 'comment-end) " *)")
1263   (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*")
1264   (set (make-local-variable 'comment-end-skip) "\\s-*\\*+)")
1265   ;; No need to quote nested comments markers.
1266   (set (make-local-variable 'comment-quote-nested) nil))
1267
1268 (defun sml-funname-of-and ()
1269   "Name of the function this `and' defines, or nil if not a function.
1270 Point has to be right after the `and' symbol and is not preserved."
1271   (forward-comment (point-max))
1272   (if (looking-at sml-tyvarseq-re) (goto-char (match-end 0)))
1273   (let ((sym (sml-smie-forward-token)))
1274     (forward-comment (point-max))
1275     (unless (or (member sym '(nil "d="))
1276                 (member (sml-smie-forward-token) '("d=")))
1277       sym)))
1278
1279 (defun sml-find-forward (re)
1280   (while (progn (forward-comment (point-max))
1281                 (not (looking-at re)))
1282     (or (ignore-errors (forward-sexp 1) t) (forward-char 1))))
1283
1284 (defun sml-electric-pipe ()
1285   "Insert a \"|\".
1286 Depending on the context insert the name of function, a \"=>\" etc."
1287   (interactive)
1288   (unless (save-excursion (skip-chars-backward "\t ") (bolp)) (insert "\n"))
1289   (insert "| ")
1290   (unless (sml-post-self-insert-pipe (1- (point)))
1291     (indent-according-to-mode)))
1292
1293 (defun sml-post-self-insert-pipe (&optional acp)
1294   (when (or acp (and (eq ?| last-command-event)
1295                      (setq acp (electric--after-char-pos))))
1296     (let ((text
1297            (save-excursion
1298              (goto-char (1- acp))       ;Jump before the "|" we just inserted.
1299              (let ((sym (sml-find-matching-starter sml-pipeheads
1300                                                    ;; (sml-op-prec "|" 'back)
1301                                                    )))
1302                (sml-smie-forward-token)
1303                (forward-comment (point-max))
1304                (cond
1305                 ((string= sym "|")
1306                  (let ((f (sml-smie-forward-token)))
1307                    (sml-find-forward "\\(=>\\|=\\||\\)\\S.")
1308                    (cond
1309                     ((looking-at "|") nil)     ; A datatype or an OR pattern?
1310                     ((looking-at "=>") " => ") ;`case', or `fn' or `handle'.
1311                     ((looking-at "=")          ;A function.
1312                      (cons (concat f " ")" = ")))))
1313                 ((string= sym "and")
1314                  ;; Could be a datatype or a function.
1315                  (let ((funname (sml-funname-of-and)))
1316                    (if funname (cons (concat funname " ") " = ") nil)))
1317                 ((string= sym "fun")
1318                  (while (and (setq sym (sml-smie-forward-token))
1319                              (string-match "^'" sym))
1320                    (forward-comment (point-max)))
1321                  (cons (concat sym " ") " = "))
1322                 ((member sym '("case" "handle" "of")) " => ") ;; "fn"?
1323                 ;;((member sym '("abstype" "datatype")) "")
1324                 (t nil))))))
1325       (when text
1326         (save-excursion
1327           (goto-char (1- acp))
1328           (unless (save-excursion (skip-chars-backward "\t ") (bolp))
1329             (insert "\n")))
1330         (unless (memq (char-before) '(?\s ?\t)) (insert " "))
1331         (let ((use-region (and (use-region-p) (< (point) (mark)))))
1332           ;; (skeleton-proxy-new `(nil ,(if (consp text) (pop text)) _ ,text))
1333           (when (consp text) (insert (pop text)))
1334           (if (not use-region)
1335               (save-excursion (insert text))
1336             (goto-char (mark))
1337             (insert text)))
1338         (indent-according-to-mode)
1339         t))))
1340
1341
1342 ;;; Misc
1343
1344 (defun sml-mark-function ()
1345   "Mark the surrounding function.  Or try to at least."
1346   (interactive)
1347   ;; FIXME: Provide beginning-of-defun-function so mark-defun "just works".
1348   (let ((start (point)))
1349     (sml-beginning-of-defun)
1350     (let ((beg (point)))
1351       (smie-forward-sexp 'halfsexp)
1352       (if (or (< start beg) (> start (point)))
1353           (progn
1354             (goto-char start)
1355             (mark-paragraph))
1356         (push-mark nil t t)
1357         (goto-char beg)))))
1358
1359 (defun sml-back-to-outer-indent ()
1360   "Unindents to the next outer level of indentation."
1361   (interactive)
1362   (save-excursion
1363     (forward-line 0)
1364     (let ((start-column (current-indentation))
1365           indent)
1366       (when (> start-column 0)
1367         (save-excursion
1368           (while (>= (setq indent
1369                            (if (re-search-backward "^[ \t]*[^\n\t]" nil t)
1370                                (current-indentation)
1371                              0))
1372                      start-column))
1373           (skip-chars-forward " \t")
1374           (let ((pos (point)))
1375             (move-to-column start-column)
1376             (when (re-search-backward " \\([^ \t\n]\\)" pos t)
1377               (goto-char (match-beginning 1))
1378               (setq indent (current-column)))))
1379         (indent-line-to indent)))))
1380
1381 (defun sml-find-matching-starter (syms)
1382   (let ((halfsexp nil)
1383         tok)
1384     ;;(sml-smie-forward-token)
1385     (while (not (or (bobp)
1386                     (member (nth 2 (setq tok (smie-backward-sexp halfsexp)))
1387                             syms)))
1388       (cond
1389        ((null (car tok)) nil)
1390        ((numberp (car tok)) (setq halfsexp 'half))
1391        (t (goto-char (cadr tok)))))
1392     (if (nth 2 tok) (goto-char (cadr tok)))
1393     (nth 2 tok)))
1394
1395 (defun sml-skip-siblings ()
1396   (let (tok)
1397     (while (and (not (bobp))
1398                 (progn (setq tok (smie-backward-sexp 'half))
1399                        (cond
1400                         ((null (car tok)) t)
1401                         ((numberp (car tok)) t)
1402                         (t nil)))))
1403     (if (nth 2 tok) (goto-char (cadr tok)))
1404     (nth 2 tok)))
1405
1406 (defun sml-beginning-of-defun ()
1407   (let ((sym (sml-find-matching-starter sml-starters-syms)))
1408     (if (member sym '("fun" "and" "functor" "signature" "structure"
1409                       "abstraction" "datatype" "abstype"))
1410         (save-excursion (sml-smie-forward-token) (forward-comment (point-max))
1411                         (sml-smie-forward-token))
1412       ;; We're inside a "non function declaration": let's skip all other
1413       ;; declarations that we find at the same level and try again.
1414       (sml-skip-siblings)
1415       ;; Obviously, let's not try again if we're at bobp.
1416       (unless (bobp) (sml-beginning-of-defun)))))
1417
1418 (defcustom sml-max-name-components 3
1419   "Maximum number of components to use for the current function name."
1420   :type 'integer)
1421
1422 (defun sml-current-fun-name ()
1423   (save-excursion
1424     (let ((count sml-max-name-components)
1425           fullname name)
1426       (end-of-line)
1427       (while (and (> count 0)
1428                   (setq name (sml-beginning-of-defun)))
1429         (decf count)
1430         (setq fullname (if fullname (concat name "." fullname) name))
1431         ;; Skip all other declarations that we find at the same level.
1432         (sml-skip-siblings))
1433       fullname)))
1434
1435
1436 ;;; INSERTING PROFORMAS (COMMON SML-FORMS)
1437
1438 (defvar sml-forms-alist nil
1439   "Alist of code templates.
1440 You can extend this alist to your heart's content.  For each additional
1441 template NAME in the list, declare a keyboard macro or function (or
1442 interactive command) called 'sml-form-NAME'.
1443 If 'sml-form-NAME' is a function it takes no arguments and should
1444 insert the template at point\; if this is a command it may accept any
1445 sensible interactive call arguments\; keyboard macros can't take
1446 arguments at all.
1447 `sml-forms-alist' understands let, local, case, abstype, datatype,
1448 signature, structure, and functor by default.")
1449
1450 (defmacro sml-def-skeleton (name interactor &rest elements)
1451   (let ((fsym (intern (concat "sml-form-" name))))
1452     `(progn
1453        (add-to-list 'sml-forms-alist ',(cons name fsym))
1454        (define-abbrev sml-mode-abbrev-table ,name "" ',fsym nil 'system)
1455        (let ((abbrev (abbrev-symbol ,name sml-mode-abbrev-table)))
1456          (abbrev-put abbrev :case-fixed t)
1457          (abbrev-put abbrev :enable-function
1458                      (lambda () (not (nth 8 (syntax-ppss))))))
1459        (define-skeleton ,fsym
1460          ,(format "SML-mode skeleton for `%s..' expressions" name)
1461          ,interactor
1462          ,(concat name " ") >
1463          ,@elements))))
1464 (put 'sml-def-skeleton 'lisp-indent-function 2)
1465
1466 (sml-def-skeleton "let" nil
1467   @ "\nin " > _ "\nend" >)
1468
1469 (sml-def-skeleton "if" nil
1470   @ " then " > _ "\nelse " > _)
1471
1472 (sml-def-skeleton "local" nil
1473   @ "\nin" > _ "\nend" >)
1474
1475 (sml-def-skeleton "case" "Case expr: "
1476   str "\nof " > _ " => ")
1477
1478 (sml-def-skeleton "signature" "Signature name: "
1479   str " =\nsig" > "\n" > _ "\nend" >)
1480
1481 (sml-def-skeleton "structure" "Structure name: "
1482   str " =\nstruct" > "\n" > _ "\nend" >)
1483
1484 (sml-def-skeleton "functor" "Functor name: "
1485   str " () : =\nstruct" > "\n" > _ "\nend" >)
1486
1487 (sml-def-skeleton "datatype" "Datatype name and type params: "
1488   str " =" \n)
1489
1490 (sml-def-skeleton "abstype" "Abstype name and type params: "
1491   str " =" \n _ "\nwith" > "\nend" >)
1492
1493 ;;
1494
1495 (sml-def-skeleton "struct" nil
1496   _ "\nend" >)
1497
1498 (sml-def-skeleton "sig" nil
1499   _ "\nend" >)
1500
1501 (sml-def-skeleton "val" nil
1502   @ " = " > _)
1503
1504 (sml-def-skeleton "fn" nil
1505   @ " =>" > _)
1506
1507 (sml-def-skeleton "fun" nil
1508   @ " =" > _)
1509
1510 ;;
1511
1512 (defun sml-forms-menu (_menu)
1513   (mapcar (lambda (x) (vector (car x) (cdr x) t))
1514           sml-forms-alist))
1515
1516 (defvar sml-last-form "let")
1517
1518 (defun sml-electric-space ()
1519   "Expand a symbol into an SML form, or just insert a space.
1520 If the point directly precedes a symbol for which an SML form exists,
1521 the corresponding form is inserted."
1522   (interactive)
1523   (let ((abbrev-mode (not abbrev-mode))
1524         (last-command-event ?\s)
1525         ;; Bind `this-command' to fool skeleton's special abbrev handling.
1526         (this-command 'self-insert-command))
1527     (call-interactively 'self-insert-command)))
1528
1529 (defun sml-insert-form (name newline)
1530   "Interactive short-cut to insert the NAME common SML form.
1531 If a prefix argument is given insert a NEWLINE and indent first, or
1532 just move to the proper indentation if the line is blank\; otherwise
1533 insert at point (which forces indentation to current column).
1534
1535 The default form to insert is 'whatever you inserted last time'
1536 \(just hit return when prompted\)\; otherwise the command reads with
1537 completion from `sml-forms-alist'."
1538   (interactive
1539    (list (completing-read
1540           (format "Form to insert (default %s): " sml-last-form)
1541           sml-forms-alist nil t nil nil sml-forms-alist)
1542          current-prefix-arg))
1543   (setq sml-last-form name)
1544   (unless (or (not newline)
1545               (save-excursion (beginning-of-line) (looking-at "\\s-*$")))
1546     (insert "\n"))
1547   (when (memq (char-syntax (preceding-char)) '(?_ ?w)) (insert " "))
1548   (let ((f (cdr (assoc name sml-forms-alist))))
1549     (cond
1550      ((commandp f) (command-execute f))
1551      (f (funcall f))
1552      (t (error "Undefined SML form: %s" name)))))
1553
1554 ;;;
1555 ;;; MLton support
1556 ;;;
1557
1558 (defvar sml-mlton-command "mlton"
1559   "Command to run MLton.   Can include arguments.")
1560
1561 (defvar sml-mlton-mainfile nil)
1562
1563 (defconst sml-mlton-error-regexp-alist
1564   ;; I wish they just changed MLton to use one of the standard
1565   ;; error formats.
1566   `(("^\\(?:Error\\|\\(Warning\\)\\): \\(.+\\) \\([0-9]+\\)\\.\\([0-9]+\\)\\.$"
1567      2 3 4
1568      ;; If subgroup 1 matched, then it's a warning, otherwise it's an error.
1569      (1))))
1570
1571 (defvar compilation-error-regexp-alist)
1572 (eval-after-load "compile"
1573   '(dolist (x sml-mlton-error-regexp-alist)
1574      (add-to-list 'compilation-error-regexp-alist x)))
1575
1576 (defun sml-mlton-typecheck (mainfile)
1577   "Typecheck using MLton.
1578 MAINFILE is the top level file of the project."
1579   (interactive
1580    (list (if (and sml-mlton-mainfile (not current-prefix-arg))
1581              sml-mlton-mainfile
1582            (read-file-name "Main file: "))))
1583   (setq sml-mlton-mainfile mainfile)
1584   (save-some-buffers)
1585   (require 'compile)
1586   (dolist (x sml-mlton-error-regexp-alist)
1587     (add-to-list 'compilation-error-regexp-alist x))
1588   (with-current-buffer (find-file-noselect mainfile)
1589     (compile (concat sml-mlton-command
1590                      " -stop tc "       ;Stop right after type checking.
1591                      (shell-quote-argument
1592                       (file-relative-name buffer-file-name))))))
1593
1594 ;;;
1595 ;;; MLton's def-use info.
1596 ;;;
1597
1598 (defvar sml-defuse-file nil)
1599
1600 (defun sml-defuse-file ()
1601   (or sml-defuse-file (sml-defuse-set-file)))
1602
1603 (defun sml-defuse-set-file ()
1604   "Specify the def-use file to use."
1605   (interactive)
1606   (setq sml-defuse-file (read-file-name "Def-use file: ")))
1607
1608 (defun sml-defuse-symdata-at-point ()
1609   (save-excursion
1610     (sml-smie-forward-token)
1611     (let ((symname (sml-smie-backward-token)))
1612       (if (equal symname "op")
1613           (save-excursion (setq symname (sml-smie-forward-token))))
1614       (when (string-match "op " symname)
1615         (setq symname (substring symname (match-end 0)))
1616         (forward-word)
1617         (forward-comment (point-max)))
1618       (list symname
1619             ;; Def-use files seem to count chars, not columns.
1620             ;; We hope here that they don't actually count bytes.
1621             ;; Also they seem to start counting at 1.
1622             (1+ (- (point) (progn (beginning-of-line) (point))))
1623             (save-restriction
1624               (widen) (1+ (count-lines (point-min) (point))))
1625             buffer-file-name))))
1626
1627 (defconst sml-defuse-def-regexp
1628   "^[[:alpha:]]+ \\([^ \n]+\\) \\(.+\\) \\([0-9]+\\)\\.\\([0-9]+\\)$")
1629 (defconst sml-defuse-use-regexp-format "^    %s %d\\.%d $")
1630
1631 (defun sml-defuse-jump-to-def ()
1632   "Jump to the definition corresponding to the symbol at point."
1633   (interactive)
1634   (let ((symdata (sml-defuse-symdata-at-point)))
1635     (if (null (car symdata))
1636         (error "Not on a symbol")
1637       (with-current-buffer (find-file-noselect (sml-defuse-file))
1638         (goto-char (point-min))
1639         (unless (re-search-forward
1640                  (format sml-defuse-use-regexp-format
1641                          (concat "\\(?:"
1642                                  ;; May be an absolute file name.
1643                                  (regexp-quote (nth 3 symdata))
1644                                  "\\|"
1645                                  ;; Or a relative file name.
1646                                  (regexp-quote (file-relative-name
1647                                                 (nth 3 symdata)))
1648                                  "\\)")
1649                          (nth 2 symdata)
1650                          (nth 1 symdata))
1651                  nil t)
1652           ;; FIXME: This is typically due to editing: any minor editing will
1653           ;; mess everything up.  We should try to fail more gracefully.
1654           (error "Def-use info not found"))
1655         (unless (re-search-backward sml-defuse-def-regexp nil t)
1656           ;; This indicates a bug in this code.
1657           (error "Internal failure while looking up def-use"))
1658         (unless (equal (match-string 1) (nth 0 symdata))
1659           ;; FIXME: This again is most likely due to editing.
1660           (error "Incoherence in the def-use info found"))
1661         (let ((line (string-to-number (match-string 3)))
1662               (char (string-to-number (match-string 4))))
1663           (pop-to-buffer (find-file-noselect (match-string 2)))
1664           (goto-char (point-min))
1665           (forward-line (1- line))
1666           (forward-char (1- char)))))))
1667
1668 ;;;
1669 ;;; SML/NJ's Compilation Manager support
1670 ;;;
1671
1672 (defvar sml-cm-mode-syntax-table sml-mode-syntax-table)
1673 (defvar sml-cm-font-lock-keywords
1674  `(,(concat "\\_<" (regexp-opt '("library" "group" "is" "structure"
1675                                 "functor" "signature" "funsig") t)
1676             "\\_>")))
1677 ;;;###autoload
1678 (add-to-list 'completion-ignored-extensions ".cm/")
1679 ;; This was used with the old compilation manager.
1680 (add-to-list 'completion-ignored-extensions "CM/")
1681 ;;;###autoload
1682 (add-to-list 'auto-mode-alist '("\\.cm\\'" . sml-cm-mode))
1683 ;;;###autoload
1684 (define-derived-mode sml-cm-mode fundamental-mode "SML-CM"
1685   "Major mode for SML/NJ's Compilation Manager configuration files."
1686   (set (make-local-variable 'sml-prog-proc-descriptor) sml-pp-functions)
1687   (set (make-local-variable 'font-lock-defaults)
1688        '(sml-cm-font-lock-keywords nil t nil nil)))
1689
1690 ;;;
1691 ;;; ML-Lex support
1692 ;;;
1693
1694 (defvar sml-lex-font-lock-keywords
1695   (append
1696    `((,(concat "^%" sml-id-re) . font-lock-builtin-face)
1697      ("^%%" . font-lock-module-def-face))
1698    sml-font-lock-keywords))
1699 (defconst sml-lex-font-lock-defaults
1700   (cons 'sml-lex-font-lock-keywords (cdr sml-font-lock-defaults)))
1701
1702 ;;;###autoload
1703 (define-derived-mode sml-lex-mode sml-mode "SML-Lex"
1704   "Major Mode for editing ML-Lex files."
1705   (set (make-local-variable 'font-lock-defaults) sml-lex-font-lock-defaults))
1706
1707 ;;;
1708 ;;; ML-Yacc support
1709 ;;;
1710
1711 (defface sml-yacc-bnf-face
1712   '((t (:foreground "darkgreen")))
1713   "Face used to highlight (non)terminals in `sml-yacc-mode'.")
1714 (defvar sml-yacc-bnf-face 'sml-yacc-bnf-face)
1715
1716 (defcustom sml-yacc-indent-action 16
1717   "Indentation column of the opening paren of actions."
1718   :type 'integer)
1719
1720 (defcustom sml-yacc-indent-pipe nil
1721   "Indentation column of the pipe char in the BNF.
1722 If nil, align it with `:' or with previous cases."
1723   :type 'integer)
1724
1725 (defcustom sml-yacc-indent-term nil
1726   "Indentation column of the (non)term part.
1727 If nil, align it with previous cases."
1728   :type 'integer)
1729
1730 (defvar sml-yacc-font-lock-keywords
1731   (cons `((concat "^\\(" sml-id-re "\\s-*:\\|\\s-*|\\)\\(\\s-*" sml-id-re
1732                   "\\)*\\s-*\\(\\(%" sml-id-re "\\)\\s-+" sml-id-re "\\|\\)")
1733           (0 (save-excursion
1734                (save-match-data
1735                  (goto-char (match-beginning 0))
1736                  (unless (or (re-search-forward "\\_<of\\_>"
1737                                                 (match-end 0) 'move)
1738                              (progn (forward-comment (point-max))
1739                                     (not (looking-at "("))))
1740                    sml-yacc-bnf-face))))
1741           (4 font-lock-builtin-face t t))
1742         sml-lex-font-lock-keywords))
1743 (defconst sml-yacc-font-lock-defaults
1744   (cons 'sml-yacc-font-lock-keywords (cdr sml-font-lock-defaults)))
1745
1746 (defun sml-yacc-indent-line ()
1747   "Indent current line of ML-Yacc code."
1748   (let ((savep (> (current-column) (current-indentation)))
1749         (indent (max (or (ignore-errors (sml-yacc-indentation)) 0) 0)))
1750     (if savep
1751         (save-excursion (indent-line-to indent))
1752       (indent-line-to indent))))
1753
1754 (defun sml-yacc-indentation ()
1755   (save-excursion
1756     (back-to-indentation)
1757     (or (and (looking-at (eval-when-compile
1758                            (concat "%\\|" sml-id-re "\\s-*:")))
1759              0)
1760         (when (save-excursion
1761                 (condition-case nil (progn (up-list -1) nil) (scan-error t)))
1762           ;; We're outside an action.
1763           (cond
1764            ;; Special handling of indentation inside %term and %nonterm
1765            ((save-excursion
1766               (and (re-search-backward "^%\\(\\sw+\\)" nil t)
1767                    (member (match-string 1) '("term" "nonterm"))))
1768             (if (numberp sml-yacc-indent-term) sml-yacc-indent-term
1769               (let ((offset (if (looking-at "|") -2 0)))
1770                 (forward-line -1)
1771                 (looking-at "\\s-*\\(%\\sw*\\||\\)?\\s-*")
1772                 (goto-char (match-end 0))
1773                 (+ offset (current-column)))))
1774            ((looking-at "(") sml-yacc-indent-action)
1775            ((looking-at "|")
1776             (if (numberp sml-yacc-indent-pipe) sml-yacc-indent-pipe
1777               (backward-sexp 1)
1778               (while (progn (forward-comment (- (point)))
1779                             (/= 0 (skip-syntax-backward "w_"))))
1780               (forward-comment (- (point)))
1781               (if (not (looking-at "\\s-$"))
1782                   (1- (current-column))
1783                 (skip-syntax-forward " ")
1784                 (- (current-column) 2))))))
1785         ;; default to SML rules
1786         (smie-indent-calculate))))
1787
1788 ;;;###autoload
1789 (add-to-list 'auto-mode-alist '("\\.grm\\'" . sml-yacc-mode))
1790 ;;;###autoload
1791 (define-derived-mode sml-yacc-mode sml-mode "SML-Yacc"
1792   "Major Mode for editing ML-Yacc files."
1793   (set (make-local-variable 'indent-line-function) 'sml-yacc-indent-line)
1794   (set (make-local-variable 'font-lock-defaults) sml-yacc-font-lock-defaults))
1795
1796 \f
1797
1798 ;;;; ChangeLog:
1799
1800 ;; 2012-10-31  Stefan Monnier  <monnier@iro.umontreal.ca>
1801 ;;
1802 ;;      * sml-mode.el: Integrate BUGS&NEWS; re-add run-sml.
1803 ;;
1804 ;; 2012-10-22  Stefan Monnier  <monnier@iro.umontreal.ca>
1805 ;;
1806 ;;      Add SML-mode.
1807 ;;
1808 ;; 2012-10-22  Stefan Monnier  <monnier@iro.umontreal.ca>
1809 ;;
1810 ;;      Cleanup copyright; Merge prog-proc into sml-mode.el
1811 ;;
1812 ;; 2012-10-19  Stefan Monnier  <monnier@iro.umontreal.ca>
1813 ;;
1814 ;;      Move sml-compile to prog-proc.
1815 ;;
1816 ;; 2012-10-19  Stefan Monnier  <monnier@iro.umontreal.ca>
1817 ;;
1818 ;;      * sml-mode.el (sml-electric-pipe-mode): New var.
1819 ;;      (sml-pipeheads): Add (, {, and [ to more reliably detect cases where
1820 ;;      the pipe is not part of a case/fun/...
1821 ;;      (sml-tyvarseq-re): Use shy groups.
1822 ;;      (sml-font-lock-keywords): Adjust accordingly.
1823 ;;      (sml-compile): Avoid the 3rd part of dolist's spec.
1824 ;;      (sml-post-self-insert-pipe): New fun, extracted from sml-electric-pipe.
1825 ;;      (sml-mode): Use it to obey sml-electric-pipe-mode.
1826 ;;      (sml-electric-pipe): Use sml-post-self-insert-pipe.
1827 ;;      * makefile.pkg (ELFILES): Remove sml-proc.el.
1828 ;;      * prog-proc.el: Rename from sml-prog-proc.el.
1829 ;;
1830 ;; 2012-10-15  Stefan Monnier  <monnier@iro.umontreal.ca>
1831 ;;
1832 ;;      Add sml-compile back into sml-mode
1833 ;;
1834 ;; 2012-10-04  Stefan Monnier  <monnier@iro.umontreal.ca>
1835 ;;
1836 ;;      Move sml-proc to either prog-proc or sml-mode.
1837 ;;
1838 ;; 2012-10-04  Stefan Monnier  <monnier@iro.umontreal.ca>
1839 ;;
1840 ;;      Fix compilation
1841 ;;
1842 ;; 2012-10-03  Stefan Monnier  <monnier@iro.umontreal.ca>
1843 ;;
1844 ;;      Start preparing for the move to ELPA.
1845 ;;
1846 ;; 2012-04-11  Stefan Monnier  <monnier@iro.umontreal.ca>
1847 ;;
1848 ;;      Merge from trunk
1849 ;;
1850 ;; 2012-04-11  Stefan Monnier  <monnier@iro.umontreal.ca>
1851 ;;
1852 ;;      Merge sml-defs.el into sml-mode.el.
1853 ;;      * sml-mode.el: Merge code from sml-defs.el.
1854 ;;      Remove ":group 'sml" since they're now redundant.
1855 ;;      * makefile.pkg (ELFILES): Adjust.
1856 ;;
1857 ;; 2012-04-11  Stefan Monnier  <monnier@iro.umontreal.ca>
1858 ;;
1859 ;;      * sml-mode.el (sml-mark-function): New implementation using SMIE.
1860 ;;      * sml-defs.el (sml-mode-map): Use backtab.
1861 ;;      Remove leftover unused sml-drag-region binding.
1862 ;;
1863 ;; 2012-04-11  Stefan Monnier  <monnier@iro.umontreal.ca>
1864 ;;
1865 ;;      -
1866 ;;
1867 ;; 2012-04-11  Stefan Monnier  <monnier@iro.umontreal.ca>
1868 ;;
1869 ;;      Merge from trunk
1870 ;;
1871 ;; 2012-04-11  Stefan Monnier  <monnier@iro.umontreal.ca>
1872 ;;
1873 ;;      Use SMIE by default and make sml-oldindent optional.
1874 ;;      * sml-mode.el: Only load sml-oldindent if necessary.
1875 ;;      (sml-use-smie): Default to t.
1876 ;;      (sml-smie-datatype-|-p): Better handle incomplete datatype branch.
1877 ;;      (sml-mode): Use prog-mode.  Setup electric-layout and electric-indent.
1878 ;;      (sml-mode-variables): Always setup SMIE if possible.
1879 ;;      (sml-imenu-create-index, sml-funname-of-and, sml-electric-pipe)
1880 ;;      (sml-beginning-of-defun, sml-defuse-symdata-at-point)
1881 ;;      (sml-yacc-font-lock-keywords, sml-yacc-indentation):
1882 ;;      Avoid sml-oldindent functions.
1883 ;;      (sml-find-forward): Move from sml-oldindent and re-implement.
1884 ;;      (sml-electric-semi): Use self-insert-command so electric-layout and
1885 ;;      electric-indent can do their job.
1886 ;;      (sml-smie-find-matching-starter, sml-find-matching-starter)
1887 ;;      (sml-smie-skip-siblings, sml-skip-siblings): New functions.
1888 ;;      * sml-oldindent.el (sml-starters-indent-after, sml-exptrail-syms):
1889 ;;      Remove, unused.
1890 ;;      (sml-find-forward): Move back to sml-mode.el.
1891 ;;      (sml-old-find-matching-starter): Rename from sml-find-matching-starter.
1892 ;;      (sml-old-skip-siblings): Move&rename from sml-mode:sml-skip-siblings.
1893 ;;
1894 ;; 2012-04-11  Stefan Monnier  <monnier@iro.umontreal.ca>
1895 ;;
1896 ;;      Merge from trunk
1897 ;;
1898
1899 (provide 'sml-mode)
1900
1901 ;;; sml-mode.el ends here