-;;; sml-mode.el --- Major mode for editing (Standard) ML
+;;; sml-mode.el --- Major mode for editing (Standard) ML -*- lexical-binding: t; coding: utf-8 -*-
-;; Copyright (C) 1999,2000,2004,2007,2010 Stefan Monnier
+;; Copyright (C) 1999,2000,2004,2007,2010-2012 Stefan Monnier
;; Copyright (C) 1994-1997 Matthew J. Morley
;; Copyright (C) 1989 Lars Bo Nielsen
;; (Stefan Monnier) <monnier@iro.umontreal.ca>
;; Maintainer: (Stefan Monnier) <monnier@iro.umontreal.ca>
;; Keywords: SML
-;; $Revision$
-;; $Date$
;; This file is not part of GNU Emacs, but it is distributed under the
;; same conditions.
;;; Code:
(eval-when-compile (require 'cl))
-(require 'sml-util)
-(require 'sml-move)
-(require 'sml-defs)
-(condition-case nil (require 'skeleton) (error nil))
+(require 'smie nil 'noerror)
+(require 'electric)
+(require 'prog-proc)
-;;; VARIABLES CONTROLLING INDENTATION
+(defgroup sml ()
+ "Editing SML code."
+ :group 'languages)
(defcustom sml-indent-level 4
- "Indentation of blocks in ML (see also `sml-indent-rule')."
- :group 'sml
- :type '(integer))
+ "Basic indentation step for SML code."
+ :type 'integer)
(defcustom sml-indent-args sml-indent-level
- "*Indentation of args placed on a separate line."
- :group 'sml
- :type '(integer))
-
-;; (defvar sml-indent-align-args t
-;; "*Whether the arguments should be aligned.")
-
-;; (defvar sml-case-indent nil
-;; "*How to indent case-of expressions.
-;; If t: case expr If nil: case expr of
-;; of exp1 => ... exp1 => ...
-;; | exp2 => ... | exp2 => ...
-
-;; The first seems to be the standard in SML/NJ, but the second
-;; seems nicer...")
-
-(defcustom sml-electric-semi-mode nil
- "*If non-nil, `\;' will self insert, reindent the line, and do a newline.
-If nil, just insert a `\;'. (To insert while t, do: \\[quoted-insert] \;)."
- :group 'sml
- :type 'boolean)
+ "Indentation of args placed on a separate line."
+ :type 'integer)
(defcustom sml-rightalign-and t
"If non-nil, right-align `and' with its leader.
If nil: If t:
datatype a = A datatype a = A
and b = B and b = B"
- :group 'sml
:type 'boolean)
-;;; OTHER GENERIC MODE VARIABLES
-
-(defvar sml-mode-info "sml-mode"
- "*Where to find Info file for `sml-mode'.
-The default assumes the info file \"sml-mode.info\" is on Emacs' info
-directory path. If it is not, either put the file on the standard path
-or set the variable `sml-mode-info' to the exact location of this file
-
- (setq sml-mode-info \"/usr/me/lib/info/sml-mode\")
-
-in your .emacs file. You can always set it interactively with the
-set-variable command.")
+(defcustom sml-electric-pipe-mode t
+ "If non-nil, automatically insert appropriate template when hitting |."
+ :type 'boolean)
(defvar sml-mode-hook nil
- "*Run upon entering `sml-mode'.
+ "Run upon entering `sml-mode'.
This is a good place to put your preferred key bindings.")
-;;; CODE FOR SML-MODE
-
-(defun sml-mode-info ()
- "Command to access the TeXinfo documentation for `sml-mode'.
-See doc for the variable `sml-mode-info'."
- (interactive)
- (require 'info)
- (condition-case nil
- (info sml-mode-info)
- (error (progn
- (describe-variable 'sml-mode-info)
- (message "Can't find it... set this variable first!")))))
-
-
;;; Autoload functions -- no-doc is another idea cribbed from AucTeX!
-
+;; FIXME-copyright: probably include sml-proc.el in sml-mode.el.
(let ((sml-no-doc
"This function is part of sml-proc, and has not yet been loaded.
Full documentation will be available after autoloading the function."))
;; font-lock setup
+(defvar sml-outline-regexp
+ ;; `st' and `si' are to match structure and signature.
+ "\f\\|s[ti]\\|[ \t]*\\(let[ \t]+\\)?\\(fun\\|and\\)\\_>"
+ "Regexp matching a major heading.
+This actually can't work without extending `outline-minor-mode' with the
+notion of \"the end of an outline\".")
+
+;;
+;; Internal defines
+;;
+
+(defvar sml-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; Text-formatting commands:
+ (define-key map "\C-c\C-m" 'sml-insert-form)
+ (define-key map "\M-|" 'sml-electric-pipe)
+ (define-key map "\M-\ " 'sml-electric-space)
+ (define-key map [backtab] 'sml-back-to-outer-indent)
+ map)
+ "The keymap used in `sml-mode'.")
+
+(defvar sml-mode-syntax-table
+ (let ((st (make-syntax-table)))
+ (modify-syntax-entry ?\* ". 23n" st)
+ (modify-syntax-entry ?\( "()1" st)
+ (modify-syntax-entry ?\) ")(4" st)
+ (mapc (lambda (c) (modify-syntax-entry c "_" st)) "._'")
+ (mapc (lambda (c) (modify-syntax-entry c "." st)) ",;")
+ ;; `!' is not really a prefix-char, oh well!
+ (mapc (lambda (c) (modify-syntax-entry c "'" st)) "~#!")
+ (mapc (lambda (c) (modify-syntax-entry c "." st)) "%&$+-/:<=>?@`^|")
+ st)
+ "The syntax table used in `sml-mode'.")
+
+
+(easy-menu-define sml-mode-menu sml-mode-map "Menu used in `sml-mode'."
+ '("SML"
+ ("Process" ;FIXME-copyright.
+ ["Start default ML compiler" run-sml t]
+ ["-" nil nil]
+ ["run CM.make" sml-compile t]
+ ["load ML source file" sml-load-file t]
+ ["switch to ML buffer" switch-to-sml t]
+ ["--" nil nil]
+ ["send buffer contents" sml-send-buffer t]
+ ["send region" sml-send-region t]
+ ["send function" sml-send-function t]
+ ["goto next error" next-error (featurep 'sml-proc)]
+ ["---" nil nil]
+ ["Help for Inferior ML" (describe-function 'inferior-sml-mode)
+ :active (featurep 'sml-proc)])
+ ["insert SML form" sml-insert-form t] ;FIXME-copyright.
+ ("Forms" :filter sml-forms-menu)
+ ("Format/Mode Variables" ;FIXME-copyright.
+ ["indent region" indent-region t]
+ ["outdent" sml-back-to-outer-indent t]
+ ;; ["-" nil nil]
+ ;; ["set indent-level" sml-indent-level t]
+ ;; ["set pipe-indent" sml-pipe-indent t]
+ ;; ["--" nil nil]
+ ;; ["toggle type-of-indent" sml-type-of-indent t]
+ ;; ["toggle nested-if-indent" sml-nested-if-indent t]
+ )
+ ["-----" nil nil]
+ ["SML mode help (brief)" describe-mode t])) ;FIXME-copyright.
+
+;;
+;; Regexps
+;;
+
+(defun sml-syms-re (syms)
+ (concat "\\_<" (regexp-opt syms t) "\\_>"))
+
+;;
+
+(defconst sml-module-head-syms
+ '("signature" "structure" "functor" "abstraction"))
+
+
+(defconst sml-=-starter-syms
+ (list* "|" "val" "fun" "and" "datatype" "type" "abstype" "eqtype"
+ sml-module-head-syms)
+ "Symbols that can be followed by a `='.")
+(defconst sml-=-starter-re
+ (concat "\\S.|\\S.\\|" (sml-syms-re (cdr sml-=-starter-syms)))
+ "Symbols that can be followed by a `='.")
+
+(defconst sml-non-nested-of-starter-re
+ (sml-syms-re '("datatype" "abstype" "exception"))
+ "Symbols that can introduce an `of' that shouldn't behave like a paren.")
+
+(defconst sml-starters-syms
+ (append sml-module-head-syms
+ '("abstype" "datatype" "exception" "fun"
+ "local" "infix" "infixr" "sharing" "nonfix"
+ "open" "type" "val" "and"
+ "withtype" "with"))
+ "The starters of new expressions.")
+
+(defconst sml-pipeheads
+ '("|" "of" "fun" "fn" "and" "handle" "datatype" "abstype"
+ "(" "{" "[")
+ "A `|' corresponds to one of these.")
+
(defconst sml-keywords-regexp
(sml-syms-re '("abstraction" "abstype" "and" "andalso" "as" "before" "case"
"datatype" "else" "end" "eqtype" "exception" "do" "fn"
"fun" "functor" "handle" "if" "in" "include" "infix"
- "infixr" "let" "local" "nonfix" "of" "op" "open" "orelse"
+ "infixr" "let" "local" "nonfix" "o" "of" "op" "open" "orelse"
"overload" "raise" "rec" "sharing" "sig" "signature"
"struct" "structure" "then" "type" "val" "where" "while"
- "with" "withtype" "o"))
+ "with" "withtype"))
"A regexp that matches any and all keywords of SML.")
+(eval-and-compile
+ (defconst sml-id-re "\\sw\\(?:\\sw\\|\\s_\\)*"))
+
(defconst sml-tyvarseq-re
- "\\(\\('+\\(\\sw\\|\\s_\\)+\\|(\\([,']\\|\\sw\\|\\s_\\|\\s-\\)+)\\)\\s-+\\)?")
+ (concat "\\(?:\\(?:'+" sml-id-re "\\|(\\(?:[,']\\|" sml-id-re
+ "\\|\\s-\\)+)\\)\\s-+\\)?"))
;;; Font-lock settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defcustom sml-font-lock-symbols nil
"Display \\ and -> and such using symbols in fonts.
This may sound like a neat trick, but be extra careful: it changes the
-alignment and can thus lead to nasty surprises w.r.t layout.
-If t, try to use whichever font is available. Otherwise you can
-set it to a particular font of your preference among `japanese-jisx0208'
-and `unicode'."
- :type '(choice (const nil)
- (const t)
- (const unicode)
- (const japanese-jisx0208)))
+alignment and can thus lead to nasty surprises w.r.t layout."
+ :type 'boolean)
(defconst sml-font-lock-symbols-alist
- (append
- ;; The symbols can come from a JIS0208 font.
- (and (fboundp 'make-char) (charsetp 'japanese-jisx0208)
- (memq sml-font-lock-symbols '(t japanese-jisx0208))
- (list (cons "fn" (make-char 'japanese-jisx0208 38 75))
- (cons "andalso" (make-char 'japanese-jisx0208 34 74))
- (cons "orelse" (make-char 'japanese-jisx0208 34 75))
- ;; (cons "as" (make-char 'japanese-jisx0208 34 97))
- (cons "not" (make-char 'japanese-jisx0208 34 76))
- (cons "div" (make-char 'japanese-jisx0208 33 96))
- ;; (cons "*" (make-char 'japanese-jisx0208 33 95))
- (cons "->" (make-char 'japanese-jisx0208 34 42))
- (cons "=>" (make-char 'japanese-jisx0208 34 77))
- (cons "<-" (make-char 'japanese-jisx0208 34 43))
- (cons "<>" (make-char 'japanese-jisx0208 33 98))
- (cons ">=" (make-char 'japanese-jisx0208 33 102))
- (cons "<=" (make-char 'japanese-jisx0208 33 101))
- (cons "..." (make-char 'japanese-jisx0208 33 68))
- ;; Some greek letters for type parameters.
- (cons "'a" (make-char 'japanese-jisx0208 38 65))
- (cons "'b" (make-char 'japanese-jisx0208 38 66))
- (cons "'c" (make-char 'japanese-jisx0208 38 67))
- (cons "'d" (make-char 'japanese-jisx0208 38 68))
- ))
- ;; Or a unicode font.
- (and (fboundp 'decode-char)
- (memq sml-font-lock-symbols '(t unicode))
- (list (cons "fn" (decode-char 'ucs 955))
- (cons "andalso" (decode-char 'ucs 8896))
- (cons "orelse" (decode-char 'ucs 8897))
- ;; (cons "as" (decode-char 'ucs 8801))
- (cons "not" (decode-char 'ucs 172))
- (cons "div" (decode-char 'ucs 247))
- (cons "*" (decode-char 'ucs 215))
- (cons "o" (decode-char 'ucs 9675))
- (cons "->" (decode-char 'ucs 8594))
- (cons "=>" (decode-char 'ucs 8658))
- (cons "<-" (decode-char 'ucs 8592))
- (cons "<>" (decode-char 'ucs 8800))
- (cons ">=" (decode-char 'ucs 8805))
- (cons "<=" (decode-char 'ucs 8804))
- (cons "..." (decode-char 'ucs 8943))
- ;; (cons "::" (decode-char 'ucs 8759))
- ;; Some greek letters for type parameters.
- (cons "'a" (decode-char 'ucs 945))
- (cons "'b" (decode-char 'ucs 946))
- (cons "'c" (decode-char 'ucs 947))
- (cons "'d" (decode-char 'ucs 948))
- ))))
-
-(defun sml-font-lock-compose-symbol (alist)
+ '(("fn" . ?λ)
+ ("andalso" . ?∧) ;; ?⋀
+ ("orelse" . ?∨) ;; ?⋁
+ ;; ("as" . ?≡)
+ ("not" . ?¬)
+ ("div" . ?÷)
+ ("*" . ?×)
+ ("o" . ?○)
+ ("->" . ?→)
+ ("=>" . ?⇒)
+ ("<-" . ?←)
+ ("<>" . ?≠)
+ (">=" . ?≥)
+ ("<=" . ?≤)
+ ("..." . ?⋯)
+ ;; ("::" . ?∷)
+ ;; Some greek letters for type parameters.
+ ("'a" . ?α)
+ ("'b" . ?β)
+ ("'c" . ?γ)
+ ("'d" . ?δ)
+ ))
+
+(defun sml-font-lock-compose-symbol ()
"Compose a sequence of ascii chars into a symbol.
Regexp match data 0 points to the chars."
;; Check that the chars should really be composed into a symbol.
;; we may have added earlier and which is now incorrect.
(remove-text-properties start end '(composition))
;; That's a symbol alright, so add the composition.
- (compose-region start end (cdr (assoc (match-string 0) alist)))))
+ (compose-region start end (cdr (assoc (match-string 0)
+ sml-font-lock-symbols-alist)))))
;; Return nil because we're not adding any face property.
nil)
(defun sml-font-lock-symbols-keywords ()
- (when (fboundp 'compose-region)
- (let ((alist nil))
- (dolist (x sml-font-lock-symbols-alist)
- (when (and (if (fboundp 'char-displayable-p)
- (char-displayable-p (cdr x))
- t)
- (not (assoc (car x) alist))) ;Not yet in alist.
- (push x alist)))
- (when alist
- `((,(regexp-opt (mapcar 'car alist) t)
- (0 (sml-font-lock-compose-symbol ',alist))))))))
+ (when sml-font-lock-symbols
+ `((,(regexp-opt (mapcar 'car sml-font-lock-symbols-alist) t)
+ (0 (sml-font-lock-compose-symbol))))))
;; The font lock regular expressions.
(defconst sml-font-lock-keywords
`(;;(sml-font-comments-and-strings)
- (,(concat "\\<\\(fun\\|and\\)\\s-+" sml-tyvarseq-re "\\(\\sw+\\)\\s-+[^ \t\n=]")
+ (,(concat "\\_<\\(fun\\|and\\)\\s-+" sml-tyvarseq-re
+ "\\(" sml-id-re "\\)\\s-+[^ \t\n=]")
(1 font-lock-keyword-face)
- (6 font-lock-function-name-face))
- (,(concat "\\<\\(\\(data\\|abs\\|with\\|eq\\)?type\\)\\s-+" sml-tyvarseq-re "\\(\\sw+\\)")
+ (2 font-lock-function-name-face))
+ (,(concat "\\_<\\(\\(?:data\\|abs\\|with\\|eq\\)?type\\)\\s-+"
+ sml-tyvarseq-re "\\(" sml-id-re "\\)")
(1 font-lock-keyword-face)
- (7 font-lock-type-def-face))
- ("\\<\\(val\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
+ (2 font-lock-type-def-face))
+ (,(concat "\\_<\\(val\\)\\s-+\\(?:" sml-id-re "\\_>\\s-*\\)?\\("
+ sml-id-re "\\)\\s-*[=:]")
(1 font-lock-keyword-face)
- ;;(6 font-lock-variable-def-face nil t)
- (3 font-lock-variable-name-face))
- ("\\<\\(structure\\|functor\\|abstraction\\)\\s-+\\(\\sw+\\)"
+ (2 font-lock-variable-name-face))
+ (,(concat "\\_<\\(structure\\|functor\\|abstraction\\)\\s-+\\("
+ sml-id-re "\\)")
(1 font-lock-keyword-face)
(2 font-lock-module-def-face))
- ("\\<\\(signature\\)\\s-+\\(\\sw+\\)"
+ (,(concat "\\_<\\(signature\\)\\s-+\\(" sml-id-re "\\)")
(1 font-lock-keyword-face)
(2 font-lock-interface-def-face))
;; Code to handle nested comments and unusual string escape sequences
;;
-(defsyntax sml-syntax-prop-table
- '((?\\ . ".") (?* . "."))
+(defvar sml-syntax-prop-table
+ (let ((st (make-syntax-table)))
+ (modify-syntax-entry ?\\ "." st)
+ (modify-syntax-entry ?* "." st)
+ st)
"Syntax table for text-properties")
-;; For Emacsen that have no built-in support for nested comments
-(defun sml-get-depth-st ()
- (save-excursion
- (let* ((disp (if (eq (char-before) ?\)) (progn (backward-char) -1) nil))
- (_ (backward-char))
- (disp (if (eq (char-before) ?\() (progn (backward-char) 0) disp))
- (pt (point)))
- (when disp
- (let* ((depth
- (save-match-data
- (if (re-search-backward "\\*)\\|(\\*" nil t)
- (+ (or (get-char-property (point) 'comment-depth) 0)
- (case (char-after) (?\( 1) (?* 0))
- disp)
- 0)))
- (depth (if (> depth 0) depth)))
- (put-text-property pt (1+ pt) 'comment-depth depth)
- (when depth sml-syntax-prop-table))))))
-
(defconst sml-font-lock-syntactic-keywords
- `(("^\\s-*\\(\\\\\\)" (1 ',sml-syntax-prop-table))
- ,@(unless sml-builtin-nested-comments-flag
- '(("(?\\(\\*\\))?" (1 (sml-get-depth-st)))))))
+ `(("^\\s-*\\(\\\\\\)" (1 ',sml-syntax-prop-table))))
(defconst sml-font-lock-defaults
- '(sml-font-lock-keywords nil nil ((?_ . "w") (?' . "w")) nil
+ '(sml-font-lock-keywords nil nil nil nil
(font-lock-syntactic-keywords . sml-font-lock-syntactic-keywords)))
+
+;;; Indentation with SMIE
+
+(defconst sml-smie-grammar
+ ;; We have several problem areas where SML's syntax can't be handled by an
+ ;; operator precedence grammar:
+ ;;
+ ;; "= A before B" is "= A) before B" if this is the
+ ;; `boolean-=' but it is "= (A before B)" if it's the `definitional-='.
+ ;; We can work around the problem by tweaking the lexer to return two
+ ;; different tokens for the two different kinds of `='.
+ ;; "of A | B" in a "case" we want "of (A | B, but in a `datatype'
+ ;; we want "of A) | B".
+ ;; "= A | B" can be "= A ) | B" if the = is from a "fun" definition,
+ ;; but it is "= (A | B" if it is a `datatype' definition (of course, if
+ ;; the previous token introducing the = is `and', deciding whether
+ ;; it's a datatype or a function requires looking even further back).
+ ;; "functor foo (...) where type a = b = ..." the first `=' looks very much
+ ;; like a `definitional-=' even tho it's just an equality constraint.
+ ;; Currently I don't even try to handle `where' at all.
+ (smie-prec2->grammar
+ (smie-merge-prec2s
+ (smie-bnf->prec2
+ '((exp ("if" exp "then" exp "else" exp)
+ ("case" exp "of" branches)
+ ("let" decls "in" cmds "end")
+ ("struct" decls "end")
+ ("sig" decls "end")
+ (sexp)
+ (sexp "handle" branches)
+ ("fn" sexp "=>" exp))
+ ;; "simple exp"s are the ones that can appear to the left of `handle'.
+ (sexp (sexp ":" type) ("(" exps ")")
+ (sexp "orelse" sexp)
+ (marg ":>" type)
+ (sexp "andalso" sexp))
+ (cmds (cmds ";" cmds) (exp))
+ (exps (exps "," exps) (exp)) ; (exps ";" exps)
+ (branches (sexp "=>" exp) (branches "|" branches))
+ ;; Operator precedence grammars handle separators much better then
+ ;; starters/terminators, so let's pretend that let/fun are separators.
+ (decls (sexp "d=" exp)
+ (sexp "d=" databranches)
+ (funbranches "|" funbranches)
+ (sexp "=of" type) ;After "exception".
+ ;; FIXME: Just like PROCEDURE in Pascal and Modula-2, this
+ ;; interacts poorly with the other constructs since I
+ ;; can't make "local" a separator like fun/val/type/...
+ ("local" decls "in" decls "end")
+ ;; (decls "local" decls "in" decls "end")
+ (decls "functor" decls)
+ (decls "signature" decls)
+ (decls "structure" decls)
+ (decls "type" decls)
+ (decls "open" decls)
+ (decls "and" decls)
+ (decls "infix" decls)
+ (decls "infixr" decls)
+ (decls "nonfix" decls)
+ (decls "abstype" decls)
+ (decls "datatype" decls)
+ (decls "exception" decls)
+ (decls "fun" decls)
+ (decls "val" decls))
+ (type (type "->" type)
+ (type "*" type))
+ (funbranches (sexp "d=" exp))
+ (databranches (sexp "=of" type) (databranches "d|" databranches))
+ ;; Module language.
+ ;; (mexp ("functor" marg "d=" mexp)
+ ;; ("structure" marg "d=" mexp)
+ ;; ("signature" marg "d=" mexp))
+ (marg (marg ":" type) (marg ":>" type))
+ (toplevel (decls) (exp) (toplevel ";" toplevel)))
+ ;; '(("local" . opener))
+ ;; '((nonassoc "else") (right "handle"))
+ '((nonassoc "of") (assoc "|")) ; "case a of b => case c of d => e | f"
+ '((nonassoc "handle") (assoc "|")) ; Idem for "handle".
+ '((assoc "->") (assoc "*"))
+ '((assoc "val" "fun" "type" "datatype" "abstype" "open" "infix" "infixr"
+ "nonfix" "functor" "signature" "structure" "exception"
+ ;; "local"
+ )
+ (assoc "and"))
+ '((assoc "orelse") (assoc "andalso") (nonassoc ":"))
+ '((assoc ";")) '((assoc ",")) '((assoc "d|")))
+
+ (smie-precs->prec2
+ '((nonassoc "andalso") ;To anchor the prec-table.
+ (assoc "before") ;0
+ (assoc ":=" "o") ;3
+ (nonassoc ">" ">=" "<>" "<" "<=" "=") ;4
+ (assoc "::" "@") ;5
+ (assoc "+" "-" "^") ;6
+ (assoc "/" "*" "quot" "rem" "div" "mod") ;7
+ (nonassoc " -dummy- "))) ;Bogus anchor at the end.
+ )))
+
+(defvar sml-indent-separator-outdent 2)
+
+(defun sml-smie-rules (kind token)
+ ;; I much preferred the pcase version of the code, especially while
+ ;; edebugging the code. But that will have to wait until we get rid of
+ ;; support for Emacs-23.
+ (case kind
+ (:elem (case token
+ (basic sml-indent-level)
+ (args sml-indent-args)))
+ (:list-intro (member token '("fn")))
+ (:after
+ (cond
+ ((equal token "struct") 0)
+ ((equal token "=>") (if (smie-rule-hanging-p) 0 2))
+ ((equal token "in") (if (smie-rule-parent-p "local") 0))
+ ((equal token "of") 3)
+ ((member token '("(" "{" "[")) (if (not (smie-rule-hanging-p)) 2))
+ ((equal token "else") (if (smie-rule-hanging-p) 0)) ;; (:next "if" 0)
+ ((member token '("|" "d|" ";" ",")) (smie-rule-separator kind))
+ ((equal token "d=")
+ (if (and (smie-rule-parent-p "val") (smie-rule-next-p "fn")) -3))))
+ (:before
+ (cond
+ ((equal token "=>") (if (smie-rule-parent-p "fn") 3))
+ ((equal token "of") 1)
+ ;; In case the language is extended to allow a | directly after of.
+ ((and (equal token "|") (smie-rule-prev-p "of")) 1)
+ ((member token '("|" "d|" ";" ",")) (smie-rule-separator kind))
+ ;; Treat purely syntactic block-constructs as being part of their parent,
+ ;; when the opening statement is hanging.
+ ((member token '("let" "(" "[" "{"))
+ (if (smie-rule-hanging-p) (smie-rule-parent)))
+ ;; Treat if ... else if ... as a single long syntactic construct.
+ ;; Similarly, treat fn a => fn b => ... as a single construct.
+ ((member token '("if" "fn"))
+ (and (not (smie-rule-bolp))
+ (smie-rule-prev-p (if (equal token "if") "else" "=>"))
+ (smie-rule-parent)))
+ ((equal token "and")
+ ;; FIXME: maybe "and" (c|sh)ould be handled as an smie-separator.
+ (cond
+ ((smie-rule-parent-p "datatype") (if sml-rightalign-and 5 0))
+ ((smie-rule-parent-p "fun" "val") 0)))
+ ((equal token "d=")
+ (cond
+ ((smie-rule-parent-p "datatype") (if (smie-rule-bolp) 2))
+ ((smie-rule-parent-p "structure" "signature") 0)))
+ ;; Indent an expression starting with "local" as if it were starting
+ ;; with "fun".
+ ((equal token "local") (smie-indent-keyword "fun"))
+ ;; FIXME: type/val/fun/... are separators but "local" is not, even though
+ ;; it appears in the same list. Try to fix up the problem by hand.
+ ;; ((or (equal token "local")
+ ;; (equal (cdr (assoc token smie-grammar))
+ ;; (cdr (assoc "fun" smie-grammar))))
+ ;; (let ((parent (save-excursion (smie-backward-sexp))))
+ ;; (when (or (and (equal (nth 2 parent) "local")
+ ;; (null (car parent)))
+ ;; (progn
+ ;; (setq parent (save-excursion (smie-backward-sexp "fun")))
+ ;; (eq (car parent) (nth 1 (assoc "fun" smie-grammar)))))
+ ;; (goto-char (nth 1 parent))
+ ;; (cons 'column (smie-indent-virtual)))))
+ ))))
+
+(defun sml-smie-definitional-equal-p ()
+ "Figure out which kind of \"=\" this is.
+Assumes point is right before the = sign."
+ ;; The idea is to look backward for the first occurrence of a token that
+ ;; requires a definitional "=" and then see if there's such a definitional
+ ;; equal between that token and ourselves (in which case we're not
+ ;; a definitional = ourselves).
+ ;; The "search for =" is naive and will match "=>" and "<=", but it turns
+ ;; out to be OK in practice because such tokens very rarely (if ever) appear
+ ;; between the =-starter and the corresponding definitional equal.
+ ;; One known problem case is code like:
+ ;; "functor foo (structure s : S) where type t = s.t ="
+ ;; where the "type t = s.t" is mistaken for a type definition.
+ (let ((re (concat "\\(" sml-=-starter-re "\\)\\|=")))
+ (save-excursion
+ (and (re-search-backward re nil t)
+ (or (match-beginning 1)
+ ;; If we first hit a "=", then that = is probably definitional
+ ;; and we're an equality, but not necessarily. One known
+ ;; problem case is code like:
+ ;; "functor foo (structure s : S) where type t = s.t ="
+ ;; where the first = is more like an equality (tho it doesn't
+ ;; matter much) and the second is definitional.
+ ;;
+ ;; FIXME: The test below could be used to recognize that the
+ ;; second = is not a mere equality, but that's not enough to
+ ;; parse the construct properly: we'd need something
+ ;; like a third kind of = token for structure definitions, in
+ ;; order for the parser to be able to skip the "type t = s.t"
+ ;; as a sub-expression.
+ ;;
+ ;; (and (not (looking-at "=>"))
+ ;; (not (eq ?< (char-before))) ;Not a <=
+ ;; (re-search-backward re nil t)
+ ;; (match-beginning 1)
+ ;; (equal "type" (buffer-substring (- (match-end 1) 4)
+ ;; (match-end 1))))
+ )))))
+
+(defun sml-smie-non-nested-of-p ()
+ ;; FIXME: Maybe datatype-|-p makes this nested-of business unnecessary.
+ "Figure out which kind of \"of\" this is.
+Assumes point is right before the \"of\" symbol."
+ (save-excursion
+ (and (re-search-backward (concat "\\(" sml-non-nested-of-starter-re
+ "\\)\\|\\_<case\\_>") nil t)
+ (match-beginning 1))))
+
+(defun sml-smie-datatype-|-p ()
+ "Figure out which kind of \"|\" this is.
+Assumes point is right before the | symbol."
+ (save-excursion
+ (forward-char 1) ;Skip the |.
+ (let ((after-type-def
+ '("|" "of" "in" "datatype" "and" "exception" "abstype" "infix"
+ "infixr" "nonfix" "local" "val" "fun" "structure" "functor"
+ "signature")))
+ (or (member (sml-smie-forward-token-1) after-type-def) ;Skip the tag.
+ (member (sml-smie-forward-token-1) after-type-def)))))
+
+(defun sml-smie-forward-token-1 ()
+ (forward-comment (point-max))
+ (buffer-substring-no-properties
+ (point)
+ (progn
+ (or (/= 0 (skip-syntax-forward "'w_"))
+ (skip-syntax-forward ".'"))
+ (point))))
+
+(defun sml-smie-forward-token ()
+ (let ((sym (sml-smie-forward-token-1)))
+ (cond
+ ((equal "op" sym)
+ (concat "op " (sml-smie-forward-token-1)))
+ ((member sym '("|" "of" "="))
+ ;; The important lexer for indentation's performance is the backward
+ ;; lexer, so for the forward lexer we delegate to the backward one.
+ (save-excursion (sml-smie-backward-token)))
+ (t sym))))
+
+(defun sml-smie-backward-token-1 ()
+ (forward-comment (- (point)))
+ (buffer-substring-no-properties
+ (point)
+ (progn
+ (or (/= 0 (skip-syntax-backward ".'"))
+ (skip-syntax-backward "'w_"))
+ (point))))
+
+(defun sml-smie-backward-token ()
+ (let ((sym (sml-smie-backward-token-1)))
+ (unless (zerop (length sym))
+ ;; FIXME: what should we do if `sym' = "op" ?
+ (let ((point (point)))
+ (if (equal "op" (sml-smie-backward-token-1))
+ (concat "op " sym)
+ (goto-char point)
+ (cond
+ ((string= sym "=") (if (sml-smie-definitional-equal-p) "d=" "="))
+ ((string= sym "of") (if (sml-smie-non-nested-of-p) "=of" "of"))
+ ((string= sym "|") (if (sml-smie-datatype-|-p) "d|" "|"))
+ (t sym)))))))
+
;;;;
;;;; Imenu support
;;;;
(concat "^[ \t]*\\(let[ \t]+\\)?"
(regexp-opt (append sml-module-head-syms
'("and" "fun" "datatype" "abstype" "type")) t)
- "\\>"))
+ "\\_>"))
(defun sml-imenu-create-index ()
(let (alist)
(column (progn (goto-char (match-beginning 2)) (current-column)))
(location
(progn (goto-char (match-end 0))
- (sml-forward-spaces)
+ (forward-comment (point-max))
(when (looking-at sml-tyvarseq-re)
(goto-char (match-end 0)))
(point)))
- (name (sml-forward-sym)))
+ (name (sml-smie-forward-token)))
;; Eliminate trivial renamings.
(when (or (not (member kind '("structure" "signature")))
(progn (search-forward "=")
- (sml-forward-spaces)
+ (forward-comment (point-max))
(looking-at "sig\\|struct")))
(push (cons (concat (make-string (/ column 2) ?\ ) name) location)
alist)))))
alist))
+;;; Prog-Proc support. ;FIXME-copyright.
+
+(defcustom sml-program-name "sml"
+ "Program to run as Standard ML read-eval-print loop."
+ :type 'string)
+
+(defcustom sml-default-arg ""
+ "Default command line option to pass to `sml-program-name', if any."
+ :type 'string)
+
+(defcustom sml-host-name ""
+ "Host on which to run `sml-program-name'."
+ :type 'string)
+
+(defcustom sml-config-file "~/.smlproc.sml"
+ "File that should be fed to the ML process when started."
+ :type 'string)
+
+
+(defcustom sml-prompt-regexp "^[-=>#] *"
+ "Regexp used to recognise prompts in the inferior ML process."
+ :type 'regexp)
+
+;; FIXME: Try to auto-detect the process and set those vars accordingly.
+
+(defvar sml-use-command "use \"%s\""
+ "Template for loading a file into the inferior ML process.
+Set to \"use \\\"%s\\\"\" for SML/NJ or Edinburgh ML;
+set to \"PolyML.use \\\"%s\\\"\" for Poly/ML, etc.")
+
+(defvar sml-cd-command "OS.FileSys.chDir \"%s\""
+ "Command template for changing working directories under ML.
+Set this to nil if your compiler can't change directories.
+
+The format specifier \"%s\" will be converted into the directory name
+specified when running the command \\[sml-cd].")
+
+(defvar sml-error-regexp-alist
+ `( ;; Poly/ML messages
+ ("^\\(Error\\|Warning:\\) in '\\(.+\\)', line \\([0-9]+\\)" 2 3)
+ ;; Moscow ML
+ ("^File \"\\([^\"]+\\)\", line \\([0-9]+\\)\\(-\\([0-9]+\\)\\)?, characters \\([0-9]+\\)-\\([0-9]+\\):" 1 2 5)
+ ;; SML/NJ: the file-pattern is anchored to avoid
+ ;; pathological behavior with very long lines.
+ ("^[-= ]*\\(.*[^\n)]\\)\\( (.*)\\)?:\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)? \\(Error\\|Warnin\\(g\\)\\): .*" 1
+ (3 . 6) (4 . 7) (9))
+ ;; SML/NJ's exceptions: see above.
+ ("^ +\\(raised at: \\)?\\(.+\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\([0-9]+\\)\\.\\([0-9]+\\)\\)" 2
+ (3 . 6) (4 . 7)))
+ "Alist that specifies how to match errors in compiler output.
+See `compilation-error-regexp-alist' for a description of the format.")
+
+(defconst sml-pp-functions
+ (prog-proc-make :name "SML"
+ :run (lambda () (call-interactively #'sml-run))
+ :load-cmd (lambda (file)
+ ;; `sml-use-command' was defined a long time
+ ;; ago not to include a final semi-colon.
+ (concat (format sml-use-command file) ";"))
+ :chdir-cmd (lambda (dir)
+ ;; `sml-cd-command' was defined a long time
+ ;; ago not to include a final semi-colon.
+ (concat (format sml-cd-command dir) ";"))))
+
+;; font-lock support
+(defconst inferior-sml-font-lock-keywords
+ `(;; prompt and following interactive command
+ ;; FIXME: Actually, this should already be taken care of by comint.
+ (,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
+ (1 font-lock-prompt-face)
+ (2 font-lock-command-face keep))
+ ;; CM's messages
+ ("^\\[\\(.*GC #.*\n\\)*.*\\]" . font-lock-comment-face)
+ ;; SML/NJ's irritating GC messages
+ ("^GC #.*" . font-lock-comment-face))
+ "Font-locking specification for inferior SML mode.")
+
+(defface font-lock-prompt-face
+ '((t (:bold t)))
+ "Font Lock mode face used to highlight prompts."
+ :group 'font-lock-highlighting-faces)
+(defvar font-lock-prompt-face 'font-lock-prompt-face
+ "Face name to use for prompts.")
+
+(defface font-lock-command-face
+ '((t (:bold t)))
+ "Font Lock mode face used to highlight interactive commands."
+ :group 'font-lock-highlighting-faces)
+(defvar font-lock-command-face 'font-lock-command-face
+ "Face name to use for interactive commands.")
+
+(defconst inferior-sml-font-lock-defaults
+ '(inferior-sml-font-lock-keywords nil nil nil nil))
+
+(defun sml--read-run-cmd ()
+ (list
+ (read-string "ML command: " sml-program-name)
+ (if (or current-prefix-arg (> (length sml-default-arg) 0))
+ (read-string "Any args: " sml-default-arg)
+ sml-default-arg)
+ (if (or current-prefix-arg (> (length sml-host-name) 0))
+ (read-string "On host: " sml-host-name)
+ sml-host-name)))
+
+(defun sml-run (cmd arg &optional host)
+ "Run the program CMD with given arguments ARG.
+The command is run in buffer *CMD* using mode `inferior-sml-mode'.
+If the buffer already exists and has a running process, then
+just go to this buffer.
+
+If a prefix argument is used, the user is also prompted for a HOST
+on which to run CMD using `remote-shell-program'.
+
+\(Type \\[describe-mode] in the process's buffer for a list of commands.)"
+ (interactive (sml--read-run-cmd))
+ (let* ((pname (file-name-nondirectory cmd))
+ (args (split-string arg))
+ (file (when (and sml-config-file (file-exists-p sml-config-file))
+ sml-config-file)))
+ ;; and this -- to keep these as defaults even if
+ ;; they're set in the mode hooks.
+ (setq sml-program-name cmd)
+ (setq sml-default-arg arg)
+ (setq sml-host-name host)
+ ;; For remote execution, use `remote-shell-program'
+ (when (> (length host) 0)
+ (setq args (list* host "cd" default-directory ";" cmd args))
+ (setq cmd remote-shell-program))
+ ;; Go for it.
+ (save-current-buffer
+ (let ((exec-path (if (and (file-name-directory cmd)
+ (not (file-name-absolute-p cmd)))
+ ;; If the command has slashes, make sure we
+ ;; first look relative to the current directory.
+ ;; Emacs-21 does it for us, but not Emacs-20.
+ (cons default-directory exec-path) exec-path)))
+ (pop-to-buffer (apply 'make-comint pname cmd file args)))
+
+ (inferior-sml-mode)
+ (goto-char (point-max))
+ (current-buffer))))
+
+(defvar inferior-sml-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map comint-mode-map)
+ (define-key map "\C-c\C-s" 'run-sml)
+ (define-key map "\C-c\C-l" 'sml-load-file)
+ (define-key map "\t" 'completion-at-point)
+ map)
+ "Keymap for inferior-sml mode")
+
+
+(declare-function smerge-refine-subst "smerge-mode"
+ (beg1 end1 beg2 end2 props-c))
+
+(defun inferior-sml-next-error-hook ()
+ ;; Try to recognize SML/NJ type error message and to highlight finely the
+ ;; difference between the two types (in case they're large, it's not
+ ;; always obvious to spot it).
+ ;;
+ ;; Sample messages:
+ ;;
+ ;; Data.sml:31.9-33.33 Error: right-hand-side of clause doesn't agree with function result type [tycon mismatch]
+ ;; expression: Hstring
+ ;; result type: Hstring * int
+ ;; in declaration:
+ ;; des2hs = (fn SYM_ID hs => hs
+ ;; | SYM_OP hs => hs
+ ;; | SYM_CHR hs => hs)
+ ;; Data.sml:35.44-35.63 Error: operator and operand don't agree [tycon mismatch]
+ ;; operator domain: Hstring * Hstring
+ ;; operand: (Hstring * int) * (Hstring * int)
+ ;; in expression:
+ ;; HSTRING.ieq (h1,h2)
+ ;; vparse.sml:1861.6-1922.14 Error: case object and rules don't agree [tycon mismatch]
+ ;; rule domain: STConstraints list list option
+ ;; object: STConstraints list option
+ ;; in expression:
+ (save-current-buffer
+ (when (and (derived-mode-p 'sml-mode 'inferior-sml-mode)
+ (boundp 'next-error-last-buffer)
+ (bufferp next-error-last-buffer)
+ (set-buffer next-error-last-buffer)
+ (derived-mode-p 'inferior-sml-mode)
+ ;; The position of `point' is not guaranteed :-(
+ (looking-at (concat ".*\\[tycon mismatch\\]\n"
+ " \\(operator domain\\|expression\\|rule domain\\): +")))
+ (require 'smerge-mode)
+ (save-excursion
+ (let ((b1 (match-end 0))
+ e1 b2 e2)
+ (when (re-search-forward "\n in \\(expression\\|declaration\\):\n"
+ nil t)
+ (setq e2 (match-beginning 0))
+ (when (re-search-backward
+ "\n \\(operand\\|result type\\|object\\): +"
+ b1 t)
+ (setq e1 (match-beginning 0))
+ (setq b2 (match-end 0))
+ (smerge-refine-subst b1 e1 b2 e2
+ '((face . smerge-refined-change))))))))))
+
+(define-derived-mode inferior-sml-mode prog-proc-comint-mode "Inferior-SML"
+ "Major mode for interacting with an inferior ML process.
+
+The following commands are available:
+\\{inferior-sml-mode-map}
+
+An ML process can be fired up (again) with \\[sml].
+
+Customisation: Entry to this mode runs the hooks on `comint-mode-hook'
+and `inferior-sml-mode-hook' (in that order).
+
+Variables controlling behaviour of this mode are
+
+`sml-program-name' (default \"sml\")
+ Program to run as ML.
+
+`sml-use-command' (default \"use \\\"%s\\\"\")
+ Template for loading a file into the inferior ML process.
+
+`sml-cd-command' (default \"System.Directory.cd \\\"%s\\\"\")
+ ML command for changing directories in ML process (if possible).
+
+`sml-prompt-regexp' (default \"^[\\-=] *\")
+ Regexp used to recognise prompts in the inferior ML process.
+
+You can send text to the inferior ML process from other buffers containing
+ML source.
+ `switch-to-sml' switches the current buffer to the ML process buffer.
+ `sml-send-function' sends the current *paragraph* to the ML process.
+ `sml-send-region' sends the current region to the ML process.
+
+ Prefixing the sml-send-<whatever> commands with \\[universal-argument]
+ causes a switch to the ML process buffer after sending the text.
+
+For information on running multiple processes in multiple buffers, see
+documentation for variable `sml-buffer'.
+
+Commands:
+RET after the end of the process' output sends the text from the
+ end of process to point.
+RET before the end of the process' output copies the current line
+ to the end of the process' output, and sends it.
+DEL converts tabs to spaces as it moves back.
+TAB file name completion, as in shell-mode, etc.."
+ (setq comint-prompt-regexp sml-prompt-regexp)
+ (sml-mode-variables)
+
+ ;; We have to install it globally, 'cause it's run in the *source* buffer :-(
+ (add-hook 'next-error-hook 'inferior-sml-next-error-hook)
+
+ ;; Make TAB add a " rather than a space at the end of a file name.
+ (set (make-local-variable 'comint-completion-addsuffix) '(?/ . ?\"))
+
+ (set (make-local-variable 'font-lock-defaults)
+ inferior-sml-font-lock-defaults)
+
+ ;; Compilation support (used for `next-error').
+ (set (make-local-variable 'compilation-error-regexp-alist)
+ sml-error-regexp-alist)
+ ;; FIXME: move it to sml-mode?
+ (set (make-local-variable 'compilation-error-screen-columns) nil)
+
+ (setq mode-line-process '(": %s")))
+
+(defcustom sml-compile-command "CM.make()"
+ "The command used by default by `sml-compile'.
+See also `sml-compile-commands-alist'.")
+
+(defcustom sml-compile-commands-alist
+ '(("CMB.make()" . "all-files.cm")
+ ("CMB.make()" . "pathconfig")
+ ("CM.make()" . "sources.cm")
+ ("use \"load-all\"" . "load-all"))
+ "Commands used by default by `sml-compile'.
+Each command is associated with its \"main\" file.
+It is perfectly OK to associate several files with a command or several
+commands with the same file.")
+
+(defun sml-compile (command &optional and-go)
+ "Pass a COMMAND to the SML process to compile the current program.
+
+You can then use the command \\[next-error] to find the next error message
+and move to the source code that caused it.
+
+Interactively, prompts for the command if `compilation-read-command' is
+non-nil. With prefix arg, always prompts.
+
+Prefix arg AND-GO also means to `switch-to-sml' afterwards."
+ (interactive
+ (let* ((dir default-directory)
+ (cmd "cd \"."))
+ ;; Look for files to determine the default command.
+ (while (and (stringp dir)
+ (progn
+ (dolist (cf sml-compile-commands-alist)
+ (when (file-exists-p (expand-file-name (cdr cf) dir))
+ (setq cmd (concat cmd "\"; " (car cf)))
+ (return nil)))
+ (not cmd)))
+ (let ((newdir (file-name-directory (directory-file-name dir))))
+ (setq dir (unless (equal newdir dir) newdir))
+ (setq cmd (concat cmd "/.."))))
+ (setq cmd
+ (cond
+ ((local-variable-p 'sml-compile-command) sml-compile-command)
+ ((string-match "^\\s-*cd\\s-+\"\\.\"\\s-*;\\s-*" cmd)
+ (substring cmd (match-end 0)))
+ ((string-match "^\\s-*cd\\s-+\"\\(\\./\\)" cmd)
+ (replace-match "" t t cmd 1))
+ ((string-match ";" cmd) cmd)
+ (t sml-compile-command)))
+ ;; code taken from compile.el
+ (if (or compilation-read-command current-prefix-arg)
+ (list (read-from-minibuffer "Compile command: "
+ cmd nil nil '(compile-history . 1)))
+ (list cmd))))
+ ;; ;; now look for command's file to determine the directory
+ ;; (setq dir default-directory)
+ ;; (while (and (stringp dir)
+ ;; (dolist (cf sml-compile-commands-alist t)
+ ;; (when (and (equal cmd (car cf))
+ ;; (file-exists-p (expand-file-name (cdr cf) dir)))
+ ;; (return nil))))
+ ;; (let ((newdir (file-name-directory (directory-file-name dir))))
+ ;; (setq dir (unless (equal newdir dir) newdir))))
+ ;; (setq dir (or dir default-directory))
+ ;; (list cmd dir)))
+ (set (make-local-variable 'sml-compile-command) command)
+ (save-some-buffers (not compilation-ask-about-save) nil)
+ (let ((dir default-directory))
+ (when (string-match "^\\s-*cd\\s-+\"\\([^\"]+\\)\"\\s-*;" command)
+ (setq dir (match-string 1 command))
+ (setq command (replace-match "" t t command)))
+ (setq dir (expand-file-name dir))
+ (with-current-buffer (sml-proc-buffer)
+ (setq default-directory dir)
+ (sml-send-string (concat (format sml-cd-command dir) "; " command)
+ t and-go))))
+
;;; MORE CODE FOR SML-MODE
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.s\\(ml\\|ig\\)\\'" . sml-mode))
+(defvar comment-quote-nested)
+
;;;###autoload
-(define-derived-mode sml-mode fundamental-mode "SML"
- "\\<sml-mode-map>Major mode for editing ML code.
+(define-derived-mode sml-mode prog-proc-mode "SML"
+ "\\<sml-mode-map>Major mode for editing Standard ML code.
This mode runs `sml-mode-hook' just before exiting.
+See also (info \"(sml-mode)Top\").
\\{sml-mode-map}"
+ (set (make-local-variable 'prog-proc-functions) sml-pp-functions)
(set (make-local-variable 'font-lock-defaults) sml-font-lock-defaults)
(set (make-local-variable 'outline-regexp) sml-outline-regexp)
(set (make-local-variable 'imenu-create-index-function)
(set (make-local-variable 'paragraph-separate)
(concat "\\([ \t]*\\*)?\\)?\\(" paragraph-separate "\\)"))
(set (make-local-variable 'require-final-newline) t)
- ;; forward-sexp-function is an experimental variable in my hacked Emacs.
- (set (make-local-variable 'forward-sexp-function) 'sml-user-forward-sexp)
- ;; For XEmacs
- (easy-menu-add sml-mode-menu)
- ;; Compatibility. FIXME: we should use `-' in Emacs-CVS.
- (unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil))
+ (set (make-local-variable 'electric-indent-chars)
+ (cons ?\; (if (boundp 'electric-indent-chars)
+ electric-indent-chars '(?\n))))
+ (set (make-local-variable 'electric-layout-rules)
+ `((?\; . ,(lambda ()
+ (save-excursion
+ (skip-chars-backward " \t;")
+ (unless (or (bolp)
+ (progn (skip-chars-forward " \t;")
+ (eolp)))
+ 'after))))))
+ (when sml-electric-pipe-mode
+ (add-hook 'post-self-insert-hook #'sml-post-self-insert-pipe nil t))
(sml-mode-variables))
(defun sml-mode-variables ()
(set-syntax-table sml-mode-syntax-table)
(setq local-abbrev-table sml-mode-abbrev-table)
- (set (make-local-variable 'indent-line-function) 'sml-indent-line)
+ ;; Setup indentation and sexp-navigation.
+ (smie-setup sml-smie-grammar #'sml-smie-rules
+ :backward-token #'sml-smie-backward-token
+ :forward-token #'sml-smie-forward-token)
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
(set (make-local-variable 'comment-start) "(* ")
(set (make-local-variable 'comment-end) " *)")
(set (make-local-variable 'comment-start-skip) "(\\*+\\s-*")
(defun sml-funname-of-and ()
"Name of the function this `and' defines, or nil if not a function.
Point has to be right after the `and' symbol and is not preserved."
- (sml-forward-spaces)
+ (forward-comment (point-max))
(if (looking-at sml-tyvarseq-re) (goto-char (match-end 0)))
- (let ((sym (sml-forward-sym)))
- (sml-forward-spaces)
+ (let ((sym (sml-smie-forward-token)))
+ (forward-comment (point-max))
(unless (or (member sym '(nil "d="))
- (member (sml-forward-sym) '("d=")))
+ (member (sml-smie-forward-token) '("d=")))
sym)))
+(defun sml-find-forward (re)
+ (while (progn (forward-comment (point-max))
+ (not (looking-at re)))
+ (or (ignore-errors (forward-sexp 1) t) (forward-char 1))))
+
(defun sml-electric-pipe ()
"Insert a \"|\".
Depending on the context insert the name of function, a \"=>\" etc."
(interactive)
- (sml-with-ist
- (unless (save-excursion (skip-chars-backward "\t ") (bolp)) (insert "\n"))
- (insert "| ")
- (let ((text
- (save-excursion
- (backward-char 2) ;back over the just inserted "| "
- (let ((sym (sml-find-matching-starter sml-pipeheads
- (sml-op-prec "|" 'back))))
- (sml-forward-sym)
- (sml-forward-spaces)
- (cond
- ((string= sym "|")
- (let ((f (sml-forward-sym)))
- (sml-find-forward "\\(=>\\|=\\||\\)\\S.")
- (cond
- ((looking-at "|") "") ;probably a datatype
- ((looking-at "=>") " => ") ;`case', or `fn' or `handle'
- ((looking-at "=") (concat f " = "))))) ;a function
- ((string= sym "and")
- ;; could be a datatype or a function
- (setq sym (sml-funname-of-and))
- (if sym (concat sym " = ") ""))
- ;; trivial cases
- ((string= sym "fun")
- (while (and (setq sym (sml-forward-sym))
- (string-match "^'" sym))
- (sml-forward-spaces))
- (concat sym " = "))
- ((member sym '("case" "handle" "fn" "of")) " => ")
- ;;((member sym '("abstype" "datatype")) "")
- (t ""))))))
-
- (insert text)
- (indent-according-to-mode)
- (beginning-of-line)
- (skip-chars-forward "\t |")
- (skip-syntax-forward "w")
- (skip-chars-forward "\t ")
- (when (eq ?= (char-after)) (backward-char)))))
-
-(defun sml-electric-semi ()
- "Insert a \;.
-If variable `sml-electric-semi-mode' is t, indent the current line, insert
-a newline, and indent."
- (interactive)
- (insert "\;")
- (if sml-electric-semi-mode
- (reindent-then-newline-and-indent)))
-
-;;; INDENTATION !!!
+ (unless (save-excursion (skip-chars-backward "\t ") (bolp)) (insert "\n"))
+ (insert "| ")
+ (unless (sml-post-self-insert-pipe (1- (point)))
+ (indent-according-to-mode)))
+
+(defun sml-post-self-insert-pipe (&optional acp)
+ (when (or acp (and (eq ?| last-command-event)
+ (setq acp (electric--after-char-pos))))
+ (let ((text
+ (save-excursion
+ (goto-char (1- acp)) ;Jump before the "|" we just inserted.
+ (let ((sym (sml-find-matching-starter sml-pipeheads
+ ;; (sml-op-prec "|" 'back)
+ )))
+ (sml-smie-forward-token)
+ (forward-comment (point-max))
+ (cond
+ ((string= sym "|")
+ (let ((f (sml-smie-forward-token)))
+ (sml-find-forward "\\(=>\\|=\\||\\)\\S.")
+ (cond
+ ((looking-at "|") nil) ; A datatype or an OR pattern?
+ ((looking-at "=>") " => ") ;`case', or `fn' or `handle'.
+ ((looking-at "=") ;A function.
+ (cons (concat f " ")" = ")))))
+ ((string= sym "and")
+ ;; Could be a datatype or a function.
+ (let ((funname (sml-funname-of-and)))
+ (if funname (cons (concat funname " ") " = ") nil)))
+ ((string= sym "fun")
+ (while (and (setq sym (sml-smie-forward-token))
+ (string-match "^'" sym))
+ (forward-comment (point-max)))
+ (cons (concat sym " ") " = "))
+ ((member sym '("case" "handle" "of")) " => ") ;; "fn"?
+ ;;((member sym '("abstype" "datatype")) "")
+ (t nil))))))
+ (when text
+ (save-excursion
+ (goto-char (1- acp))
+ (unless (save-excursion (skip-chars-backward "\t ") (bolp))
+ (insert "\n")))
+ (unless (memq (char-before) '(?\s ?\t)) (insert " "))
+ (let ((use-region (and (use-region-p) (< (point) (mark)))))
+ ;; (skeleton-proxy-new `(nil ,(if (consp text) (pop text)) _ ,text))
+ (when (consp text) (insert (pop text)))
+ (if (not use-region)
+ (save-excursion (insert text))
+ (goto-char (mark))
+ (insert text)))
+ (indent-according-to-mode)
+ t))))
+
+
+;;; Misc
(defun sml-mark-function ()
- "Synonym for `mark-paragraph' -- sorry.
-If anyone has a good algorithm for this..."
- (interactive)
- (mark-paragraph))
-
-(defun sml-indent-line ()
- "Indent current line of ML code."
+ "Mark the surrounding function. Or try to at least."
(interactive)
- (let ((savep (> (current-column) (current-indentation)))
- (indent (max (or (ignore-errors (sml-calculate-indentation)) 0) 0)))
- (if savep
- (save-excursion (indent-line-to indent))
- (indent-line-to indent))))
+ ;; FIXME: Provide beginning-of-defun-function so mark-defun "just works".
+ (let ((start (point)))
+ (sml-beginning-of-defun)
+ (let ((beg (point)))
+ (smie-forward-sexp 'halfsexp)
+ (if (or (< start beg) (> start (point)))
+ (progn
+ (goto-char start)
+ (mark-paragraph))
+ (push-mark nil t t)
+ (goto-char beg)))))
-(defun sml-back-to-outer-indent ()
+(defun sml-back-to-outer-indent () ;FIXME-copyright.
"Unindents to the next outer level of indentation."
(interactive)
(save-excursion
(progn
(save-excursion
(while (>= indent start-column)
- (if (re-search-backward "^[^\n]" nil t)
- (setq indent (current-indentation))
- (setq indent 0))))
+ (setq indent (if (re-search-backward "^[^\n]" nil t)
+ (current-indentation)
+ 0))))
(backward-delete-char-untabify (- start-column indent)))))))
-(defun sml-find-comment-indent ()
- (save-excursion
- (let ((depth 1))
- (while (> depth 0)
- (if (re-search-backward "(\\*\\|\\*)" nil t)
- (cond
- ;; FIXME: That's just a stop-gap.
- ((eq (get-text-property (point) 'face) 'font-lock-string-face))
- ((looking-at "*)") (incf depth))
- ((looking-at comment-start-skip) (decf depth)))
- (setq depth -1)))
- (if (= depth 0)
- (1+ (current-column))
- nil))))
-
-(defun sml-calculate-indentation ()
- (save-excursion
- (beginning-of-line) (skip-chars-forward "\t ")
- (sml-with-ist
- ;; Indentation for comments alone on a line, matches the
- ;; proper indentation of the next line.
- (when (looking-at "(\\*") (sml-forward-spaces))
- (let (data
- (sym (save-excursion (sml-forward-sym))))
- (or
- ;; Allow the user to override the indentation.
- (when (looking-at (concat ".*" (regexp-quote comment-start)
- "[ \t]*fixindent[ \t]*"
- (regexp-quote comment-end)))
- (current-indentation))
-
- ;; Continued comment.
- (and (looking-at "\\*") (sml-find-comment-indent))
-
- ;; Continued string ? (Added 890113 lbn)
- (and (looking-at "\\\\")
- (or (save-excursion (forward-line -1)
- (if (looking-at "[\t ]*\\\\")
- (current-indentation)))
- (save-excursion
- (if (re-search-backward "[^\\\\]\"" nil t)
- (1+ (current-column))
- 0))))
-
- ;; Closing parens. Could be handled below with `sml-indent-relative'?
- (and (looking-at "\\s)")
- (save-excursion
- (skip-syntax-forward ")")
- (backward-sexp 1)
- (if (sml-dangling-sym)
- (sml-indent-default 'noindent)
- (current-column))))
-
- (and (setq data (assoc sym sml-close-paren))
- (sml-indent-relative sym data))
-
- (and (member sym sml-starters-syms)
- (sml-indent-starter sym))
-
- (and (string= sym "|") (sml-indent-pipe))
-
- (sml-indent-arg)
- (sml-indent-default))))))
-
-(defsubst sml-bolp ()
- (save-excursion (skip-chars-backward " \t|") (bolp)))
-
-(defun sml-first-starter-p ()
- "Non-nil if starter at point is immediately preceded by let/local/in/..."
- (save-excursion
- (let ((sym (unless (save-excursion (sml-backward-arg))
- (sml-backward-spaces)
- (sml-backward-sym))))
- (if (member sym '(";" "d=")) (setq sym nil))
- sym)))
-
-
-(defun sml-indent-starter (orig-sym)
- "Return the indentation to use for a symbol in `sml-starters-syms'.
-Point should be just before the symbol ORIG-SYM and is not preserved."
- (let ((sym (unless (save-excursion (sml-backward-arg))
- (sml-backward-spaces)
- (sml-backward-sym))))
- (if (member sym '(";" "d=")) (setq sym nil))
- (if sym (sml-get-sym-indent sym)
- ;; FIXME: this can take a *long* time !!
- (setq sym (sml-find-matching-starter sml-starters-syms))
- (if (or (sml-first-starter-p)
- ;; Don't align with `and' because it might be specially indented.
- (and (or (equal orig-sym "and") (not (equal sym "and")))
- (sml-bolp)))
- (+ (current-column)
- (if (and sml-rightalign-and (equal orig-sym "and"))
- (- (length sym) 3) 0))
- (sml-indent-starter orig-sym)))))
-
-(defun sml-indent-relative (sym data)
- (save-excursion
- (sml-forward-sym) (sml-backward-sexp nil)
- (unless (second data) (sml-backward-spaces) (sml-backward-sym))
- (+ (or (cdr (assoc sym sml-symbol-indent)) 0)
- (sml-delegated-indent))))
-
-(defun sml-indent-pipe ()
- (let ((sym (sml-find-matching-starter sml-pipeheads
- (sml-op-prec "|" 'back))))
- (when sym
- (if (string= sym "|")
- (if (sml-bolp) (current-column) (sml-indent-pipe))
- (let ((pipe-indent (or (cdr (assoc "|" sml-symbol-indent)) -2)))
- (when (or (member sym '("datatype" "abstype"))
- (and (equal sym "and")
- (save-excursion
- (forward-word 1)
- (not (sml-funname-of-and)))))
- (re-search-forward "="))
- (sml-forward-sym)
- (sml-forward-spaces)
- (+ pipe-indent (current-column)))))))
-
-(defun sml-find-forward (re)
- (sml-forward-spaces)
- (while (and (not (looking-at re))
- (progn
- (or (ignore-errors (forward-sexp 1) t) (forward-char 1))
- (sml-forward-spaces)
- (not (looking-at re))))))
-
-(defun sml-indent-arg ()
- (and (save-excursion (ignore-errors (sml-forward-arg)))
- ;;(not (looking-at sml-not-arg-re))
- ;; looks like a function or an argument
- (sml-move-if (sml-backward-arg))
- ;; an argument
- (if (save-excursion (not (sml-backward-arg)))
- ;; a first argument
- (+ (current-column) sml-indent-args)
- ;; not a first arg
- (while (and (/= (current-column) (current-indentation))
- (sml-move-if (sml-backward-arg))))
- (unless (save-excursion (sml-backward-arg))
- ;; all earlier args are on the same line
- (sml-forward-arg) (sml-forward-spaces))
- (current-column))))
-
-(defun sml-get-indent (data sym)
- (let (d)
- (cond
- ((not (listp data)) data)
- ((setq d (member sym data)) (cadr d))
- ((and (consp data) (not (stringp (car data)))) (car data))
- (t sml-indent-level))))
-
-(defun sml-dangling-sym ()
- "Non-nil if the symbol after point is dangling.
-The symbol can be an SML symbol or an open-paren. \"Dangling\" means that
-it is not on its own line but is the last element on that line."
- (save-excursion
- (and (not (sml-bolp))
- (< (sml-point-after (end-of-line))
- (sml-point-after (or (sml-forward-sym) (skip-syntax-forward "("))
- (sml-forward-spaces))))))
-
-(defun sml-delegated-indent ()
- (if (sml-dangling-sym)
- (sml-indent-default 'noindent)
- (sml-move-if (backward-word 1)
- (looking-at sml-agglomerate-re))
- (current-column)))
-
-(defun sml-get-sym-indent (sym &optional style)
- "Find the indentation for the SYM we're `looking-at'.
-If indentation is delegated, point will move to the start of the parent.
-Optional argument STYLE is currently ignored."
- (assert (equal sym (save-excursion (sml-forward-sym))))
- (save-excursion
- (let ((delegate (and (not (equal sym "end")) (assoc sym sml-close-paren)))
- (head-sym sym))
- (when (and delegate (not (eval (third delegate))))
- ;;(sml-find-match-backward sym delegate)
- (sml-forward-sym) (sml-backward-sexp nil)
- (setq head-sym
- (if (second delegate)
- (save-excursion (sml-forward-sym))
- (sml-backward-spaces) (sml-backward-sym))))
-
- (let ((idata (assoc head-sym sml-indent-rule)))
- (when idata
- ;;(if (or style (not delegate))
- ;; normal indentation
- (let ((indent (sml-get-indent (cdr idata) sym)))
- (when indent (+ (sml-delegated-indent) indent)))
- ;; delgate indentation to the parent
- ;;(sml-forward-sym) (sml-backward-sexp nil)
- ;;(let* ((parent-sym (save-excursion (sml-forward-sym)))
- ;; (parent-indent (cdr (assoc parent-sym sml-indent-starters))))
- ;; check the special rules
- ;;(+ (sml-delegated-indent)
- ;; (or (sml-get-indent (cdr indent-data) 1 'strict)
- ;; (sml-get-indent (cdr parent-indent) 1 'strict)
- ;; (sml-get-indent (cdr indent-data) 0)
- ;; (sml-get-indent (cdr parent-indent) 0))))))))
- )))))
-
-(defun sml-indent-default (&optional noindent)
- (let* ((sym-after (save-excursion (sml-forward-sym)))
- (_ (sml-backward-spaces))
- (sym-before (sml-backward-sym))
- (sym-indent (and sym-before (sml-get-sym-indent sym-before)))
- (indent-after (or (cdr (assoc sym-after sml-symbol-indent)) 0)))
- (when (equal sym-before "end")
- ;; I don't understand what's really happening here, but when
- ;; it's `end' clearly, we need to do something special.
- (forward-word 1)
- (setq sym-before nil sym-indent nil))
- (cond
- (sym-indent
- ;; the previous sym is an indentation introducer: follow the rule
- (if noindent
- ;;(current-column)
- sym-indent
- (+ sym-indent indent-after)))
- ;; If we're just after a hanging open paren.
- ((and (eq (char-syntax (preceding-char)) ?\()
- (save-excursion (backward-char) (sml-dangling-sym)))
- (backward-char)
- (sml-indent-default))
- (t
- ;; default-default
- (let* ((prec-after (sml-op-prec sym-after 'back))
- (prec (or (sml-op-prec sym-before 'back) prec-after 100)))
- ;; go back until you hit a symbol that has a lower prec than the
- ;; "current one", or until you backed over a sym that has the same prec
- ;; but is at the beginning of a line.
- (while (and (not (sml-bolp))
- (while (sml-move-if (sml-backward-sexp (1- prec))))
- (not (sml-bolp)))
- (while (sml-move-if (sml-backward-sexp prec))))
- (if noindent
- ;; the `noindent' case does back over an introductory symbol
- ;; such as `fun', ...
- (progn
- (sml-move-if
- (sml-backward-spaces)
- (member (sml-backward-sym) sml-starters-syms))
- (current-column))
- ;; Use `indent-after' for cases such as when , or ; should be
- ;; outdented so that their following terms are aligned.
- (+ (if (progn
- (if (equal sym-after ";")
- (sml-move-if
- (sml-backward-spaces)
- (member (sml-backward-sym) sml-starters-syms)))
- (and sym-after (not (looking-at sym-after))))
- indent-after 0)
- (current-column))))))))
-
-
-;; maybe `|' should be set to word-syntax in our temp syntax table ?
-(defun sml-current-indentation ()
- (save-excursion
- (beginning-of-line)
- (skip-chars-forward " \t|")
- (current-column)))
-
-
-(defun sml-find-matching-starter (syms &optional prec)
- (let (sym)
- (ignore-errors
- (while
- (progn (sml-backward-sexp prec)
- (setq sym (save-excursion (sml-forward-sym)))
- (not (or (member sym syms) (bobp)))))
- (if (member sym syms) sym))))
+(defun sml-find-matching-starter (syms)
+ (let ((halfsexp nil)
+ tok)
+ ;;(sml-smie-forward-token)
+ (while (not (or (bobp)
+ (member (nth 2 (setq tok (smie-backward-sexp halfsexp)))
+ syms)))
+ (cond
+ ((null (car tok)) nil)
+ ((numberp (car tok)) (setq halfsexp 'half))
+ (t (goto-char (cadr tok)))))
+ (if (nth 2 tok) (goto-char (cadr tok)))
+ (nth 2 tok)))
(defun sml-skip-siblings ()
- (while (and (not (bobp)) (sml-backward-arg))
- (sml-find-matching-starter sml-starters-syms))
- (when (looking-at "in\\>\\|local\\>")
- ;;skip over `local...in' and continue
- (forward-word 1)
- (sml-backward-sexp nil)
- (sml-skip-siblings)))
+ (let (tok)
+ (while (and (not (bobp))
+ (progn (setq tok (smie-backward-sexp 'half))
+ (cond
+ ((null (car tok)) t)
+ ((numberp (car tok)) t)
+ (t nil)))))
+ (if (nth 2 tok) (goto-char (cadr tok)))
+ (nth 2 tok)))
(defun sml-beginning-of-defun ()
(let ((sym (sml-find-matching-starter sml-starters-syms)))
(if (member sym '("fun" "and" "functor" "signature" "structure"
"abstraction" "datatype" "abstype"))
- (save-excursion (sml-forward-sym) (sml-forward-spaces)
- (sml-forward-sym))
+ (save-excursion (sml-smie-forward-token) (forward-comment (point-max))
+ (sml-smie-forward-token))
;; We're inside a "non function declaration": let's skip all other
;; declarations that we find at the same level and try again.
(sml-skip-siblings)
(defcustom sml-max-name-components 3
"Maximum number of components to use for the current function name."
- :group 'sml
:type 'integer)
(defun sml-current-fun-name ()
;;; INSERTING PROFORMAS (COMMON SML-FORMS)
(defvar sml-forms-alist nil
- "*Alist of code templates.
+ "Alist of code templates.
You can extend this alist to your heart's content. For each additional
template NAME in the list, declare a keyboard macro or function (or
interactive command) called 'sml-form-NAME'.
signature, structure, and functor by default.")
(defmacro sml-def-skeleton (name interactor &rest elements)
- (when (fboundp 'define-skeleton)
- (let ((fsym (intern (concat "sml-form-" name))))
- ;; TODO: don't do the expansion in comments and strings.
- `(progn
- (add-to-list 'sml-forms-alist ',(cons name fsym))
- (condition-case err
- ;; Try to use the new `system' flag.
- (define-abbrev sml-mode-abbrev-table ,name "" ',fsym nil 'system)
- (wrong-number-of-arguments
- (define-abbrev sml-mode-abbrev-table ,name "" ',fsym)))
- (when (fboundp 'abbrev-put)
- (let ((abbrev (abbrev-symbol ,name sml-mode-abbrev-table)))
- (abbrev-put abbrev :case-fixed t)
- (abbrev-put abbrev :enable-function
- (lambda () (not (nth 8 (syntax-ppss)))))))
- (define-skeleton ,fsym
- ,(format "SML-mode skeleton for `%s..' expressions" name)
- ,interactor
- ,(concat name " ") >
- ,@elements)))))
+ (let ((fsym (intern (concat "sml-form-" name))))
+ `(progn
+ (add-to-list 'sml-forms-alist ',(cons name fsym))
+ (define-abbrev sml-mode-abbrev-table ,name "" ',fsym nil 'system)
+ (let ((abbrev (abbrev-symbol ,name sml-mode-abbrev-table)))
+ (abbrev-put abbrev :case-fixed t)
+ (abbrev-put abbrev :enable-function
+ (lambda () (not (nth 8 (syntax-ppss))))))
+ (define-skeleton ,fsym
+ ,(format "SML-mode skeleton for `%s..' expressions" name)
+ ,interactor
+ ,(concat name " ") >
+ ,@elements))))
(put 'sml-def-skeleton 'lisp-indent-function 2)
(sml-def-skeleton "let" nil
;;
-(defun sml-forms-menu (menu)
+(defun sml-forms-menu (_menu)
(mapcar (lambda (x) (vector (car x) (cdr x) t))
sml-forms-alist))
the corresponding form is inserted."
(interactive)
(let ((abbrev-mode (not abbrev-mode))
- (last-command-char ?\ )
+ (last-command-event ?\ )
;; Bind `this-command' to fool skeleton's special abbrev handling.
(this-command 'self-insert-command))
(call-interactively 'self-insert-command)))
-(defun sml-insert-form (name newline)
+(defun sml-insert-form (name newline) ;FIXME-copyright.
"Interactive short-cut to insert the NAME common ML form.
If a prefix argument is given insert a NEWLINE and indent first, or
just move to the proper indentation if the line is blank\; otherwise
completion from `sml-forms-alist'."
(interactive
(list (completing-read
- (format "Form to insert: (default %s) " sml-last-form)
- sml-forms-alist nil t nil)
+ (format "Form to insert (default %s): " sml-last-form)
+ sml-forms-alist nil t nil nil sml-forms-alist)
current-prefix-arg))
- ;; default is whatever the last insert was...
- (if (string= name "") (setq name sml-last-form) (setq sml-last-form name))
+ (setq sml-last-form name)
(unless (or (not newline)
(save-excursion (beginning-of-line) (looking-at "\\s-*$")))
(insert "\n"))
- (unless (/= ?w (char-syntax (preceding-char))) (insert " "))
+ (when (memq (char-syntax (preceding-char)) '(?_ ?w)) (insert " "))
(let ((f (cdr (assoc name sml-forms-alist))))
(cond
((commandp f) (command-execute f))
(f (funcall f))
- (t (error "Undefined form: %s" name)))))
+ (t (error "Undefined SML form: %s" name)))))
;; See also macros.el in emacs lisp dir.
-(defun sml-addto-forms-alist (name)
+(defun sml-addto-forms-alist (name) ;FIXME-copyright.
"Assign a name to the last keyboard macro defined.
Argument NAME is transmogrified to sml-form-NAME which is the symbol
actually defined.
`(("^\\(?:Error\\|\\(Warning\\)\\): \\(.+\\) \\([0-9]+\\)\\.\\([0-9]+\\)\\.$"
2 3 4
;; If subgroup 1 matched, then it's a warning, otherwise it's an error.
- ,@(if (fboundp 'compilation-fake-loc) '((1))))))
+ (1))))
+(defvar compilation-error-regexp-alist)
(eval-after-load "compile"
'(dolist (x sml-mlton-error-regexp-alist)
(add-to-list 'compilation-error-regexp-alist x)))
(defun sml-mlton-typecheck (mainfile)
"typecheck using MLton."
(interactive
- (list (if (and mainfile (not current-prefix-arg))
- mainfile
+ (list (if (and sml-mlton-mainfile (not current-prefix-arg))
+ sml-mlton-mainfile
(read-file-name "Main file: "))))
+ (setq sml-mlton-mainfile mainfile)
(save-some-buffers)
(require 'compile)
(dolist (x sml-mlton-error-regexp-alist)
(defun sml-defuse-symdata-at-point ()
(save-excursion
- (sml-forward-sym)
- (let ((symname (sml-backward-sym)))
+ (sml-smie-forward-token)
+ (let ((symname (sml-smie-backward-token)))
(if (equal symname "op")
- (save-excursion (setq symname (sml-forward-sym))))
+ (save-excursion (setq symname (sml-smie-forward-token))))
(when (string-match "op " symname)
(setq symname (substring symname (match-end 0)))
(forward-word)
- (sml-forward-spaces))
+ (forward-comment (point-max)))
(list symname
;; Def-use files seem to count chars, not columns.
;; We hope here that they don't actually count bytes.
(let ((line (string-to-number (match-string 3)))
(char (string-to-number (match-string 4))))
(pop-to-buffer (find-file-noselect (match-string 2)))
- (goto-line line)
+ (goto-char (point-min))
+ (forward-line (1- line))
(forward-char (1- char)))))))
;;;
(defvar sml-cm-mode-syntax-table sml-mode-syntax-table)
(defvar sml-cm-font-lock-keywords
- `(,(concat "\\<" (regexp-opt '("library" "group" "is" "structure"
+ `(,(concat "\\_<" (regexp-opt '("library" "group" "is" "structure"
"functor" "signature" "funsig") t)
- "\\>")))
+ "\\_>")))
;;;###autoload
(add-to-list 'completion-ignored-extensions ".cm/")
;; This was used with the old compilation manager.
(defvar sml-lex-font-lock-keywords
(append
- '(("^%\\sw+" . font-lock-builtin-face)
+ `((,(concat "^%" sml-id-re) . font-lock-builtin-face)
("^%%" . font-lock-module-def-face))
sml-font-lock-keywords))
(defconst sml-lex-font-lock-defaults
(defcustom sml-yacc-indent-action 16
"Indentation column of the opening paren of actions."
- :group 'sml
:type 'integer)
(defcustom sml-yacc-indent-pipe nil
"Indentation column of the pipe char in the BNF.
If nil, align it with `:' or with previous cases."
- :group 'sml
:type 'integer)
(defcustom sml-yacc-indent-term nil
"Indentation column of the (non)term part.
If nil, align it with previous cases."
- :group 'sml
:type 'integer)
(defvar sml-yacc-font-lock-keywords
- (cons '("^\\(\\sw+\\s-*:\\|\\s-*|\\)\\(\\s-*\\sw+\\)*\\s-*\\(\\(%\\sw+\\)\\s-+\\sw+\\|\\)"
- (0 (save-excursion
- (save-match-data
- (goto-char (match-beginning 0))
- (unless (or (re-search-forward "\\<of\\>" (match-end 0) 'move)
- (progn (sml-forward-spaces)
- (not (looking-at "("))))
- sml-yacc-bnf-face))))
- (4 font-lock-builtin-face t t))
- sml-lex-font-lock-keywords))
+ (cons `((concat "^\\(" sml-id-re "\\s-*:\\|\\s-*|\\)\\(\\s-*" sml-id-re
+ "\\)*\\s-*\\(\\(%" sml-id-re "\\)\\s-+" sml-id-re "\\|\\)")
+ (0 (save-excursion
+ (save-match-data
+ (goto-char (match-beginning 0))
+ (unless (or (re-search-forward "\\_<of\\_>"
+ (match-end 0) 'move)
+ (progn (forward-comment (point-max))
+ (not (looking-at "("))))
+ sml-yacc-bnf-face))))
+ (4 font-lock-builtin-face t t))
+ sml-lex-font-lock-keywords))
(defconst sml-yacc-font-lock-defaults
(cons 'sml-yacc-font-lock-keywords (cdr sml-font-lock-defaults)))
(defun sml-yacc-indentation ()
(save-excursion
(back-to-indentation)
- (or (and (looking-at "%\\|\\(\\sw\\|\\s_\\)+\\s-*:") 0)
+ (or (and (looking-at (eval-when-compile
+ (concat "%\\|" sml-id-re "\\s-*:")))
+ 0)
(when (save-excursion
(condition-case nil (progn (up-list -1) nil) (scan-error t)))
;; We're outside an action.
((looking-at "|")
(if (numberp sml-yacc-indent-pipe) sml-yacc-indent-pipe
(backward-sexp 1)
- (while (progn (sml-backward-spaces)
+ (while (progn (forward-comment (- (point)))
(/= 0 (skip-syntax-backward "w_"))))
- (sml-backward-spaces)
+ (forward-comment (- (point)))
(if (not (looking-at "\\s-$"))
(1- (current-column))
(skip-syntax-forward " ")
(- (current-column) 2))))))
;; default to SML rules
- (sml-calculate-indentation))))
+ (smie-indent-calculate))))
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.grm\\'" . sml-yacc-mode))
(set (make-local-variable 'indent-line-function) 'sml-yacc-indent-line)
(set (make-local-variable 'font-lock-defaults) sml-yacc-font-lock-defaults))
+\f
(provide 'sml-mode)
;;; sml-mode.el ends here