├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── TODO.org ├── examples ├── poly.sml └── reflect.sml ├── lexer.cm ├── lib ├── pos.cm ├── pos.sml ├── reader.cm └── reader.sml ├── sources.cm ├── src ├── ast.sml ├── constraint.sml ├── desugar.sml ├── lexer.sml ├── maml.sml ├── monoast.sml ├── parser.sml ├── position.sml ├── show.sml ├── stringmap.sml ├── token.sml ├── top.sml ├── type.sml └── typecheck.sml └── tests ├── desugar.sml ├── legacy.sml ├── lexer.sml ├── main.sml ├── parser.sml └── typeinf.sml /.gitignore: -------------------------------------------------------------------------------- 1 | .cm 2 | *.x86-darwin 3 | *.x86-linux 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 Michiaki Yamada 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | default: 2 | ml-build sources.cm Main.main 3 | 4 | test: default 5 | sml @SMLload=sources.x86-linux 6 | 7 | clean: 8 | rm -f *.x86-linux 9 | rm -rf .cm/ src/.cm/ tests/.cm/ 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # MaML (isn't quite yet) An ML (compiler) 2 | 3 | This is a work-in-progress ML compiler, written in Standard ML. It consists of most of a front-end: a lexer, a parser, a type checker (along with Hindley-Milner type inference), and a naive pattern compiler. It's capable of parsing and type checking programs that are recognizably ML, e.g. 4 | 5 | ``` 6 | datatype 'a tree = Leaf of 'a 7 | | Branch of 'a tree * 'a tree 8 | val reflect = 9 | fn t => 10 | case t of 11 | Leaf x => t 12 | | Branch (t1, t2) => Branch (reflect t2, reflect t1) 13 | ``` 14 | 15 | ## syntax 16 | 17 | The parser accepts a concrete syntax that is mostly a subset of Standard ML, but diverges in a few places to cut corners: no top-level function declarations, just value bindings, constructors must be capitalized (if it's good enough for Haskell...), only pattern matching `case` expressions, no patterns in functions or lambdas, no syntactic sugar for lists, ... The type checker doesn't require `rec` after recursive value bindings (see `reflect` above) 18 | 19 | ## building and testing 20 | 21 | Requires [SML/NJ](http://smlnj.org/) and [QCheck/SML](http://contrapunctus.net/league/haques/qcheck/qcheck.html). To install QCheck, clone [this repo](https://github.com/league/qcheck) and add `QCHECK /path/to/qcheck/clone` to your `~/.smlnj-pathconfig`. 22 | 23 | Use `make test` to compile and run the tests; see the Makefile for more targets. 24 | 25 | It should build under MLton and other Standard ML compilers, as it doesn't use any language extensions, but this still needs to be tested and MLton `.mlb` files need to be written to make this easier. 26 | 27 | ## contributing 28 | 29 | Feel free to fork and work on anything in TODO.org 30 | 31 | ## disambiguation 32 | 33 | Not to be confused with [MAML](http://en.wikipedia.org/wiki/Microsoft_Assistance_Markup_Language). 34 | -------------------------------------------------------------------------------- /TODO.org: -------------------------------------------------------------------------------- 1 | 2 | * lexer 3 | 4 | - nested comments 5 | 6 | * parser 7 | 8 | ** infix 9 | 10 | - user-defined infix operators 11 | - user-defined infix precedence 12 | - Infix of 'a * string * 'a t * 'a t 13 | ^^^^^^ Infix should take a string for the op, not a binop 14 | 15 | ** general 16 | 17 | - refactor entire parser into more [[https://gist.github.com/spacemanaki/05492fd761121f037cd8][imperative-style]] 18 | - return value of type `(SyntaxError, AST) either` 19 | 20 | ** types 21 | 22 | - type annotations 23 | - open question: is it possible to remove Type.Paren ? 24 | 25 | * type checker 26 | 27 | - let expressions (+ let-polymorphism) 28 | - return value of type `(TypeError, AST) either` 29 | - annotations 30 | - typecheck patterns 31 | 32 | * desugaring 33 | 34 | - integrate the [[https://github.com/spacemanaki/maml/blob/master/src/desugar.sml][current pattern match compiler]] (from the [[http://research.microsoft.com/en-us/um/people/simonpj/papers/slpj-book-1987/][The Implementation of Functional Programming Languages]]) with the rest of the code 35 | 36 | * backend, runtime, etc. 37 | -------------------------------------------------------------------------------- /examples/poly.sml: -------------------------------------------------------------------------------- 1 | val id = fn x => x 2 | val a = id 1 3 | val b = id true 4 | -------------------------------------------------------------------------------- /examples/reflect.sml: -------------------------------------------------------------------------------- 1 | datatype 'a tree = Leaf of 'a 2 | | Branch of 'a tree * 'a tree 3 | val reflect = 4 | fn t => 5 | case t of 6 | Leaf x => t 7 | | Branch (t1, t2) => Branch (reflect t2, reflect t1) 8 | -------------------------------------------------------------------------------- /lexer.cm: -------------------------------------------------------------------------------- 1 | Library 2 | structure Main 3 | 4 | structure Token 5 | structure Lexer 6 | 7 | structure Reader 8 | structure Pos 9 | is 10 | src/top.sml 11 | 12 | src/show.sml 13 | src/reader.sml 14 | src/position.sml 15 | 16 | src/token.sml 17 | src/lexer.sml 18 | 19 | tests/legacy.sml 20 | tests/lexer.sml 21 | tests/main.sml 22 | 23 | $/basis.cm 24 | $/smlnj-lib.cm 25 | $QCHECK/qcheck.cm 26 | -------------------------------------------------------------------------------- /lib/pos.cm: -------------------------------------------------------------------------------- 1 | Library 2 | signature POS 3 | structure Pos 4 | is 5 | reader.cm 6 | 7 | pos.sml 8 | 9 | $/basis.cm 10 | -------------------------------------------------------------------------------- /lib/pos.sml: -------------------------------------------------------------------------------- 1 | (* Pos.sml: datatype for storing line and column position in a file. 2 | * 16 Aug 2014 v0.5 *) 3 | 4 | signature POS = 5 | sig 6 | (* Pos.t is an opaque type representing position in a stream *) 7 | (* ??? should include raw char count as well as line and col ??? *) 8 | eqtype t 9 | 10 | (* Pos.new constructs a new value at column and line *) 11 | val new: int * int -> t 12 | 13 | (* Pos.zero is the start of a file: line 1, column 0 *) 14 | val zero: t 15 | 16 | (* Select fields *) 17 | val col: t -> int 18 | val line: t -> int 19 | 20 | (* Increment fields *) 21 | val incrCol: t -> t 22 | val incrLine: t -> t 23 | 24 | (* Advance fields by a value *) 25 | val advCol: t * int -> t 26 | val advLine: t * int -> t 27 | 28 | (* Wrap a stream with the zero position *) 29 | val stream: 'a -> 'a * t 30 | (* Extract position from positional stream *) 31 | val getPos: 'a * t -> t 32 | 33 | (* TEMPORARY SHIM *) 34 | val reader: (char,'a) Reader.t -> (char * t,'a * t) Reader.t 35 | 36 | (* Given a char reader, return a positional char reader *) 37 | val reader2: (char, 'a) Reader.t -> (char, 'a * t) Reader.t 38 | 39 | val show: t -> string 40 | end 41 | 42 | structure Pos = 43 | struct 44 | type t = {col: int, line: int} 45 | 46 | fun new (col, line) = {col = col, line = line} 47 | 48 | val zero = {col = 0, line = 1} 49 | 50 | fun col {col, line} = col 51 | fun line {col, line} = line 52 | 53 | fun incrCol {col, line} = {col = col + 1, line = line} 54 | fun incrLine {col, line} = {col = 0, line = line + 1} 55 | 56 | fun advCol ({col, line}, n) = {col = col + n, line = line} 57 | fun advLine ({col, line}, n) = {col = 0, line = line + n} 58 | 59 | fun stream s = (s, zero) 60 | fun getPos (_, p) = p 61 | 62 | fun reader rdr = 63 | fn (s, p as {col, line}) => 64 | case rdr s of 65 | NONE => NONE 66 | | SOME (#"\n", t) => SOME ((#"\n", p), (t, incrLine p)) 67 | | SOME (x, t) => SOME ((x, p), (t, incrCol p)) 68 | 69 | fun reader2 rdr = 70 | fn (s, p) => 71 | case rdr s of 72 | NONE => NONE 73 | | SOME (#"\n", t) => SOME (#"\n", (t, incrLine p)) 74 | | SOME (x, t) => SOME (x, (t, incrCol p)) 75 | 76 | fun show {col, line} = Int.toString line ^ ":" ^ Int.toString col 77 | end 78 | 79 | (* structure Pos :> POS = Pos *) 80 | 81 | functor Test () = struct 82 | local 83 | open Pos 84 | in 85 | 86 | val 0 = col zero 87 | val 1 = line zero 88 | 89 | val 1 = col (incrCol zero) 90 | val 2 = line (incrLine zero) 91 | 92 | val 0 = col (incrLine zero) 93 | val 0 = col (incrLine (incrCol zero)) 94 | 95 | val rdr = reader2 Substring.getc 96 | 97 | (* A fresh positional stream starts at col=0 line=1. *) 98 | val s = stream (Substring.full "foo") 99 | val 0 = col (getPos s) 100 | val 1 = line (getPos s) 101 | 102 | (* After consuming one char, col incremented by one *) 103 | val SOME (#"f", (t, p)) = rdr s 104 | val 1 = col p 105 | val 1 = line p 106 | 107 | (* After consuming past a newline, col reset, line advanced *) 108 | val SOME (_, s) = rdr (stream (Substring.full "x\ny")) 109 | val SOME (#"\n", s as (_, p)) = rdr s 110 | val 0 = col p 111 | val 2 = line p 112 | 113 | val SOME (#"y", s as (_, p)) = rdr s 114 | val 1 = col p 115 | val 2 = line p 116 | 117 | val 3 = line (new (4, 3)) 118 | val 4 = col (new (4, 3)) 119 | 120 | val 5 = col (advCol (zero, 5)) 121 | val 4 = line (advLine (zero, 3)) 122 | 123 | end 124 | end 125 | -------------------------------------------------------------------------------- /lib/reader.cm: -------------------------------------------------------------------------------- 1 | Library 2 | structure Reader 3 | is 4 | reader.sml 5 | 6 | $/basis.cm 7 | -------------------------------------------------------------------------------- /lib/reader.sml: -------------------------------------------------------------------------------- 1 | (* Reader.sml: collection of readers and functions on readers and streams 2 | * See http://spacemanaki.com/blog/2013/08/31/Polymorphic-streams-in-ML/ 3 | * 16 Aug 2014 v0.2 *) 4 | 5 | structure Reader = 6 | struct 7 | 8 | type ('a,'b) t = ('a,'b) StringCvt.reader 9 | 10 | val list : ('a, 'a list) t = 11 | fn [] => NONE 12 | | (x::xs) => SOME (x, xs) 13 | 14 | local 15 | open String 16 | in 17 | val string : (char, string) t = 18 | fn "" => NONE 19 | | s => SOME (sub (s, 0), substring (s, 1, size s - 1)) 20 | end 21 | 22 | local 23 | open Substring 24 | in 25 | val substring : (char, substring) t = getc 26 | end 27 | 28 | val streamIO : (char, TextIO.StreamIO.instream) t = TextIO.StreamIO.input1 29 | 30 | (* 31 | * Given a reader and a stream, consume the entire stream and return a list of the resulting elements 32 | *) 33 | fun consume (rdr : ('a, 'b) t) s = 34 | let 35 | fun consume' acc s = 36 | case rdr s of 37 | NONE => rev acc 38 | | SOME (x, s') => consume' (x::acc) s' 39 | in 40 | consume' [] s 41 | end 42 | 43 | (* 44 | * Consume elements from s as long as p returns true. Returns elements as a list 45 | *) 46 | fun takeWhile rdr p s = 47 | let 48 | fun takeWhile' acc s = 49 | case rdr s of 50 | NONE => (rev acc, s) 51 | | SOME (x, s') => if p x then 52 | takeWhile' (x :: acc) s' 53 | else (rev acc, s) 54 | in 55 | takeWhile' [] s 56 | end 57 | 58 | (* 59 | * Consume elements from s up until p returns true, then return the rest of the stream 60 | *) 61 | fun dropWhile rdr p s = 62 | let 63 | fun dropWhile' s = 64 | case rdr s of 65 | NONE => s 66 | | SOME (x, s') => if p x then 67 | dropWhile' s' 68 | else s 69 | in 70 | dropWhile' s 71 | end 72 | 73 | fun take (rdr : ('a,'b) t) (n : int) (s : 'b) : ('a list * 'b) option = 74 | let 75 | fun take' 0 acc s = SOME (rev acc, s) 76 | | take' n acc s = 77 | case rdr s of 78 | SOME (x, s') => take' (n-1) (x::acc) s' 79 | | NONE => NONE 80 | in 81 | take' n [] s 82 | end 83 | 84 | fun drop (rdr : ('a,'b) t) (n : int) (s : 'b) : 'b = 85 | let 86 | fun drop' 0 s = s 87 | | drop' n s = 88 | case rdr s of 89 | SOME (_, s') => drop' (n-1) s' 90 | | NONE => s 91 | in 92 | drop' n s 93 | end 94 | 95 | exception Partial 96 | 97 | fun partial rdr s = 98 | case rdr s of 99 | SOME (x, _) => x 100 | | NONE => raise Partial 101 | 102 | end 103 | -------------------------------------------------------------------------------- /sources.cm: -------------------------------------------------------------------------------- 1 | Library 2 | structure Maml 3 | 4 | structure Type 5 | structure Typecheck 6 | 7 | structure Token 8 | structure Lexer 9 | structure Parser 10 | structure AST 11 | structure MonoAST 12 | structure Constraint 13 | 14 | structure Main 15 | 16 | structure Reader 17 | structure Pos 18 | is 19 | src/maml.sml 20 | src/top.sml 21 | 22 | src/show.sml 23 | 24 | lib/reader.cm 25 | lib/pos.sml 26 | 27 | src/type.sml 28 | src/typecheck.sml 29 | src/constraint.sml 30 | src/stringmap.sml 31 | 32 | src/token.sml 33 | src/lexer.sml 34 | src/parser.sml 35 | src/ast.sml 36 | src/monoast.sml 37 | 38 | 39 | tests/legacy.sml 40 | tests/lexer.sml 41 | tests/parser.sml 42 | tests/typeinf.sml 43 | tests/main.sml 44 | 45 | $/basis.cm 46 | $/smlnj-lib.cm 47 | $QCHECK/qcheck.cm 48 | -------------------------------------------------------------------------------- /src/ast.sml: -------------------------------------------------------------------------------- 1 | structure AST = 2 | struct 3 | type pos = {line : int, col : int} 4 | 5 | (* 6 | * AST for patterns (i.e. in match/case expressions) 7 | * Two kinds of patterns -- complex appear in source, simple appear in desugared case 8 | *) 9 | structure Pattern = 10 | struct 11 | structure Complex = (* allows nested patterns *) 12 | struct 13 | datatype t = Var of string 14 | | Tuple of t list 15 | | Ctor of string * t option 16 | fun show (Var v) = "Var " ^ v 17 | | show (Ctor (ctor, SOME p)) = "Ctor (" ^ ctor ^ "," ^ show p ^ ")" 18 | | show (Ctor (ctor, NONE)) = "Ctor " ^ ctor 19 | | show (Tuple ps) = "Tuple [" ^ Show.list show ps ^ "]" 20 | end 21 | structure Simple = (* simple patterns, no nesting *) 22 | struct 23 | datatype t = Var of string 24 | | Ctor of string * string list 25 | fun show (Var v) = "Var " ^ v 26 | | show (Ctor (ctor, vs)) = "Ctor (" ^ ctor ^ ",[" ^ String.concatWith "," vs ^ "])" 27 | end 28 | end 29 | 30 | (* 31 | * Abstract syntax tree for expressions 32 | *) 33 | structure Expr = 34 | struct 35 | 36 | (* actual AST type, with polymorphic info *) 37 | datatype 'a t = Num of 'a * int 38 | | Bool of 'a * bool 39 | | Id of 'a * string 40 | | App of 'a * 'a t * 'a t 41 | | If of 'a * 'a t * 'a t * 'a t 42 | 43 | (* Fn and Let: one info field for bound var, one for self *) 44 | | Fn of 'a * 'a * string * 'a t 45 | | Let of 'a * 'a * string * 'a t * 'a t 46 | 47 | | Case of 'a * 'a t * (Pattern.Complex.t * 'a t) list 48 | | Infix of 'a * string * 'a t * 'a t 49 | | Tuple of 'a * 'a t list 50 | 51 | fun getInfo (Num (info, _)) = info 52 | | getInfo (Bool (info, _)) = info 53 | | getInfo (Id (info, _)) = info 54 | | getInfo (If (info, _, _, _)) = info 55 | (* FIXME: two ids for Fn *) 56 | | getInfo (Fn (_, info, _, _)) = info 57 | | getInfo (Let (_, info, _, _, _)) = info 58 | 59 | | getInfo (App (info, _, _)) = info 60 | | getInfo (Case (info, _, _)) = info 61 | | getInfo (Infix (info, _, _, _)) = info 62 | | getInfo (Tuple (info, _)) = info 63 | 64 | fun show e = 65 | let 66 | fun showClause (pat, e) = "(" ^ Pattern.Complex.show pat ^ "=>" ^ show e ^ ")" 67 | fun showClause' (pat, e) = "(" ^ Pattern.Simple.show pat ^ "=>" ^ show e ^ ")" 68 | in 69 | case e of 70 | Num (_, n) => "Num " ^ Int.toString n 71 | | Bool (_, b) => "Bool " ^ Bool.toString b 72 | | Id (_, s) => "Id " ^ s 73 | | App (_, e1, e2) => "App (" ^ show e1 ^ "," ^ show e2 ^ ")" 74 | | If (_, e1, e2, e3) => "If (" ^ show e1 ^ "," ^ show e2 ^ "," ^ show e3 ^ ")" 75 | | Fn (_, _, x, e) => "Fn (" ^ x ^ "," ^ show e ^ ")" 76 | | Let (_, _, x, e1, e2) => "Let (" ^ x ^ "," ^ show e1 ^ "," ^ show e2 ^ ")" 77 | | Case (_, e, clauses) => "Case (" ^ show e ^ "," ^ String.concatWith "|" (map showClause clauses) ^ ")" 78 | | Infix (_, binop, e1, e2) => "Infix (" ^ binop ^ "," ^ show e1 ^ "," ^ show e1 ^ ")" 79 | | Tuple (_, es) => "Tuple [" ^ String.concatWith "," (map show es) ^ "]" 80 | end 81 | 82 | fun walk f e = 83 | case e of 84 | Num (a, n) => Num (f a, n) 85 | | Bool (a, b) => Bool (f a, b) 86 | | Id (a, x) => Id (f a, x) 87 | | App (a, e1, e2) => App (f a, walk f e1, walk f e2) 88 | | If (a, e1, e2, e3) => If (f a, walk f e1, walk f e2, walk f e3) 89 | | Fn (a1, a2, x, e) => Fn (f a1, f a2, x, walk f e) 90 | | Let (a1, a2, x, e1, e2) => Let (f a1, f a2, x, walk f e1, walk f e2) 91 | | Case (a, e1, clauses) => Case (f a, walk f e1, map (fn (p, e2) => (p, walk f e2)) clauses) 92 | | Infix (a, binop, e1, e2) => Infix (f a, binop, walk f e1, walk f e2) 93 | | Tuple (a, es) => Tuple (f a, map (walk f) es) 94 | 95 | end 96 | 97 | (* 98 | * AST for types, i.e. for type annotations in source code 99 | *) 100 | structure Type = 101 | struct 102 | datatype 'a t = Var of 'a * string 103 | | Con of 'a * string * 'a t list 104 | | Arrow of 'a * 'a t * 'a t 105 | | Tuple of 'a * 'a t list 106 | | Paren of 'a * 'a t 107 | fun show (Var (_, v)) = "Var (" ^ v ^ ")" 108 | | show (Con (_, c, ts)) = "Con (" ^ c ^ "," ^ Show.list show ts ^ ")" 109 | | show (Arrow (_, x, y)) = "Arrow (" ^ show x ^ "," ^ show y ^ ")" 110 | | show (Tuple (_, ts)) = "Tuple ([" ^ String.concatWith "," (map show ts) ^ "])" 111 | | show (Paren (_, t)) = "Paren " ^ show t 112 | 113 | fun walk f t = 114 | case t of 115 | Var (a, x) => Var (f a, x) 116 | | Con (a, c, ts) => Con (f a, c, map (walk f) ts) 117 | | Arrow (a, t1, t2) => Arrow (f a, walk f t1, walk f t2) 118 | | Tuple (a, ts) => Tuple (f a, map (walk f) ts) 119 | | Paren (a, t) => Paren (f a, walk f t) 120 | 121 | end 122 | 123 | (* 124 | * AST for top-level declarations: datatype declarations, value bindings 125 | *) 126 | structure Decl = 127 | struct 128 | datatype ('a, 'b) t = 129 | Data of 'b 130 | * string list (* zero or more bound type vars *) 131 | * string (* type name *) 132 | * (string * 'b Type.t option) list (* one or more ctors *) 133 | 134 | | Val of 'b * string * 'a Expr.t 135 | fun show d = 136 | let 137 | fun showCtor (c, NONE) = "(" ^ c ^ ", NONE)" 138 | | showCtor (c, SOME t) = "(" ^ c ^ "," ^ Type.show t ^ ")" 139 | in 140 | case d of 141 | Data (_, tyvars, name, cs) => "Data ([" ^ String.concatWith "," tyvars ^ "]," ^ name ^ ",[" ^ String.concatWith "," (map showCtor cs) ^ "])" 142 | | Val (_, x, e) => "Val (" ^ x ^ "," ^ Expr.show e ^ ")" 143 | end 144 | 145 | fun walk f g d = 146 | case d of 147 | Data (b, vars, name, ctors) => Data (g b, vars, name, map (fn (ctor, NONE) => (ctor, NONE) | (ctor, SOME t) => (ctor, SOME (Type.walk g t))) ctors) 148 | | Val (b, x, e) => Val (g b, x, Expr.walk f e) 149 | 150 | end 151 | 152 | structure Pgm = 153 | struct 154 | type ('a, 'b) t = ('a, 'b) Decl.t list 155 | fun show (p: ('a, 'b) t): string = Show.list Decl.show p 156 | end 157 | 158 | end 159 | -------------------------------------------------------------------------------- /src/constraint.sml: -------------------------------------------------------------------------------- 1 | structure Constraint = 2 | struct 3 | 4 | (* 5 | * A constraint relates types to types. For instance: 6 | * {lhs = Var "x3", rhs = Num } 7 | * {lhs = Arrow (Var "a1", Var "b2"), rhs = Arrow (Num, Bool) } 8 | *) 9 | type t = {lhs: Type.t, rhs: Type.t} 10 | 11 | fun show ({lhs, rhs} : t) = "{" ^ Type.show lhs ^ "," ^ Type.show rhs ^ "}" 12 | 13 | val compare : t * t -> order = 14 | fn ({lhs = l , rhs = r}, {lhs = l', rhs = r'}) => 15 | case Type.compare (l, l') of 16 | EQUAL => Type.compare (r, r') 17 | | ord => ord 18 | 19 | local 20 | structure Set = BinarySetFn( 21 | struct 22 | type ord_key = t 23 | val compare = compare 24 | end) 25 | structure Show = SetShowFn( 26 | structure Set = Set 27 | structure Show = struct 28 | type t = t 29 | val show = show 30 | end) 31 | in 32 | structure Set : sig 33 | include ORD_SET 34 | val show : set -> string 35 | end = 36 | struct 37 | open Set 38 | open Show 39 | end 40 | end 41 | 42 | end 43 | -------------------------------------------------------------------------------- /src/desugar.sml: -------------------------------------------------------------------------------- 1 | (* 2 | * A desugared intermediate form that is close to the object language 3 | * 4 | * - replaces pattern matching with simpler `case` expressions 5 | * - other desugarings? 6 | *) 7 | structure Desugar = 8 | struct 9 | 10 | structure E = AST.Expr 11 | type 'a eqxn = AST.Pattern.Complex.t list * 'a E.t 12 | exception Assert of string 13 | 14 | (* 15 | * check if eqxn starts with a var or ctor 16 | *) 17 | fun isVar (AST.Pattern.Complex.Var _ :: _, _) = true 18 | | isVar (AST.Pattern.Complex.Ctor _ :: _, _) = false 19 | | isVar _ = raise Assert "isVar: eqxn has empty pat list" 20 | 21 | fun isCtor (q : 'a eqxn) : bool = not (isVar q) 22 | 23 | (* 24 | * get the ctor (if this eqxn starts with one) 25 | *) 26 | fun getCtor (AST.Pattern.Complex.Ctor (c, ps') :: ps, e) = c 27 | | getCtor _ = raise Assert "getCtor: eqxn has empty pat list" 28 | 29 | (* 30 | * will be replaced with something from an earlier semantic analysis or typechecking phase 31 | *) 32 | exception UnknownCtor 33 | fun ctors "Cons" = ["Cons", "Nil"] 34 | | ctors "Nil" = ["Cons", "Nil"] 35 | | ctors "Branch" = ["Branch", "Leaf"] 36 | | ctors "Leaf" = ["Branch", "Leaf"] 37 | | ctors _ = raise UnknownCtor 38 | 39 | fun arity "Cons" = 2 40 | | arity "Nil" = 0 41 | | arity "Branch" = 2 42 | | arity "Leaf" = 1 43 | | arity _ = raise UnknownCtor 44 | 45 | local 46 | val g = ref 0 47 | in 48 | (* TODO: should have a symbol table by now, can generate truly unique gensyms *) 49 | fun gensym s = s ^ Int.toString (!g) before g := (!g) + 1 50 | end 51 | 52 | (* 53 | * substitute e2 for x in e1 54 | * this doesn't need to be so hairy if gensym can generate truly unique ids 55 | *) 56 | fun subst (e1 : 'a E.t, x : string, e2 : string) : 'a E.t = 57 | case e1 of 58 | n as E.Num _ => n 59 | | b as E.Bool _ => b 60 | | E.Infix (a, oper, e3, e4) => E.Infix (a, oper, subst (e3, x, e2), subst (e4, x, e2)) 61 | | E.App (a, e3, e4) => E.App (a, subst (e3, x, e2), subst (e4, x, e2)) 62 | | E.If (a, e3, e4, e5) => E.If (a, subst (e3, x, e2), subst (e4, x, e2), subst (e5, x, e2)) 63 | 64 | | id as E.Id (a, x') => if x = x' then E.Id (a, e2) else id 65 | 66 | (* have to be careful about bound vars *) 67 | | f as E.Fn (a', a, x', e) => 68 | if x = x' 69 | then f 70 | else E.Fn (a', a, x', subst (e, x, e2)) 71 | 72 | | l as E.Let (a, x', e3, e4) => 73 | if x = x' 74 | then l 75 | else E.Let (a, x', subst (e3, x, e2), subst (e3, x, e2)) 76 | 77 | (* match also binds new vars... *) 78 | | m as E.Case (a, e3, qs) => 79 | let 80 | fun occurs (AST.Pattern.Complex.Var v) = v = x 81 | | occurs (AST.Pattern.Complex.Ctor (_, ps)) = List.exists occurs ps 82 | fun subst' (p, e) = if occurs p then (p, e) else (p, subst (e, x, e2)) 83 | in 84 | E.Case (a, subst (e3, x, e2), map subst' qs) 85 | end 86 | 87 | fun tack (x, xss) = (x :: hd xss) :: tl xss 88 | 89 | fun partition f [] = [] 90 | | partition f [x] = [[x]] 91 | | partition f (x :: x' :: xs) = 92 | if f x = f x' 93 | then tack (x, (partition f (x' :: xs))) 94 | else [x] :: partition f (x' :: xs) 95 | 96 | (* 97 | * Given a list of eqxns with patterns all starting with the same ctor, 98 | * return the eqxns created by reducing the first pattern to its subpatterns, 99 | * then appending those subpatterns to the rest of the patterns in that equation 100 | *) 101 | fun subpats (ctor : string, eqxns : 'a eqxn list) : 'a eqxn list = 102 | let 103 | fun subpats' (AST.Pattern.Complex.Ctor (c, ps') :: ps, e) = 104 | if c <> ctor 105 | then raise Assert "subpats: non-matching ctors in eqxns" 106 | else (ps' @ ps, e) 107 | | subpats' _ = raise Assert "subpats: pat vars in eqxns" 108 | in 109 | map subpats' eqxns 110 | end 111 | 112 | (* 113 | * returns all eqxns that begin with ctor 114 | *) 115 | fun choose (ctor, qs) = 116 | List.filter (fn q => getCtor q = ctor) qs 117 | 118 | fun match ((u::us) : 'a E.t list, qs : 'a eqxn list, def : 'a E.t) : 'a E.t = 119 | foldr (fn (qs, acc) => matchVarCon (u::us, qs, acc)) def (partition isVar qs) 120 | | match ([], [(pats, e)], def) = 121 | if not (null pats) 122 | then raise Assert "match: patterns left but no exprs" 123 | else e 124 | | match ([], [], def) = def 125 | | match ([], q::q'::qs, _) = raise Assert "match: multiple eqxns but no exprs" 126 | 127 | and matchVarCon (us : 'a E.t list, (q::qs) : 'a eqxn list, def : 'a E.t) : 'a E.t = 128 | if isVar q 129 | then matchVar (us, q::qs, def) 130 | else matchCtor (us, q::qs, def) 131 | 132 | and matchVar ((u::us) : 'a E.t list, qs : 'a eqxn list, def : 'a E.t) : 'a E.t = 133 | let 134 | val u' = gensym "_u" 135 | fun matchVar' (AST.Pattern.Complex.Var v :: ps, e) = (ps, subst (e, v, u')) 136 | in 137 | (* FIXME getInfo u *) 138 | E.Let (E.getInfo u, u', u, match (us, map matchVar' qs, def)) 139 | end 140 | | matchVar ([], _, _) = raise Assert "matchVar: empty list of eqxns" 141 | 142 | (* 143 | * Return a case clause (pat * expr) for this ctor, exprs, eqxns, default 144 | * where the expr is the result of recursively compiling the rest of the pattern match 145 | *) 146 | and matchClause (ctor : string, (u::us) : 'a E.t list, qs : 'a eqxn list, def : 'a E.t) : (AST.Pattern.Simple.t * 'a E.t) = 147 | let 148 | val us' = List.tabulate (arity ctor, fn _ => gensym "_u") 149 | (* FIXME getInfo u *) 150 | val info = E.getInfo u 151 | in 152 | (AST.Pattern.Simple.Ctor (ctor, us'), match ((map (fn u' => E.Id (info, u')) us') @ us, subpats (ctor, qs), def)) 153 | end 154 | | matchClause (_, [], _, _) = raise Assert "matchClause: empty list of exprs" 155 | 156 | and matchCtor ((u::us) : 'a E.t list, (q::qs) : 'a eqxn list, def : 'a E.t) : 'a E.t = 157 | let 158 | val ctors = ctors (getCtor q) 159 | in 160 | (* FIXME getInfo u *) 161 | E.Case (E.getInfo u, u, map (fn ctor => matchClause (ctor, u::us, choose (ctor, q::qs), def)) ctors) 162 | end 163 | | matchCtor ([], _, _) = raise Assert "matchCtor: empty list of exprs" 164 | | matchCtor (_, [], _) = raise Assert "matchCtor: empty list of eqxns" 165 | 166 | fun mkEqxn (pat, e) = ([pat], e) 167 | 168 | fun desugar (E.Case (a, e, clauses), def) = match ([e], map mkEqxn clauses, def) 169 | | desugar _ = raise Assert "desugar: not implemented yet" 170 | 171 | end 172 | -------------------------------------------------------------------------------- /src/lexer.sml: -------------------------------------------------------------------------------- 1 | signature LEXER = 2 | sig 3 | val make : (char * Pos.t, 'a) Reader.t -> (Token.t * Pos.t, 'a) Reader.t 4 | exception LexicalError of string 5 | end 6 | 7 | structure Lexer : LEXER = 8 | struct 9 | 10 | open Top 11 | structure T = Token 12 | 13 | fun fst (a, _) = a 14 | fun snd (_, b) = b 15 | 16 | exception LexicalError of string 17 | 18 | (* 19 | * Extract an integer literal from a positional stream 20 | *) 21 | fun getInt rdr s = 22 | let 23 | val isDigit = Char.isDigit o fst 24 | val (chars, s') = Reader.takeWhile rdr isDigit s 25 | in 26 | if length chars < 1 then 27 | (NONE, s) 28 | else 29 | case Int.fromString (String.implode (map fst chars)) of 30 | NONE => (NONE, s) 31 | | SOME n => (SOME (n, snd (hd chars)), s') 32 | end 33 | 34 | (* 35 | * Drop leading whitespace from a positional stream 36 | *) 37 | fun skipWS (rdr : (char * Pos.t, 'a) Reader.t) : 'a -> 'a = 38 | Reader.dropWhile rdr (Char.isSpace o fst) 39 | 40 | (* Check is a stream starts with a comment *) 41 | fun isComment rdr s = 42 | case Reader.take rdr 2 s of 43 | SOME ([(#"(", _), (#"*", _)], s') => true 44 | | _ => false 45 | 46 | fun isSpace rdr s = 47 | case rdr s of 48 | SOME ((x, _), s) => Char.isSpace x 49 | | _ => false 50 | 51 | (* 52 | * Drop a comment from a positional stream 53 | *) 54 | fun skipComments (rdr : (char * Pos.t, 'a) Reader.t) (s : 'a) : 'a = 55 | let 56 | (* skip to end of comment block *) 57 | fun skip rdr s = 58 | case Reader.take rdr 2 s of 59 | SOME ([(#"*", _), (#")", _)], s') => s' 60 | | _ => case rdr s of 61 | SOME (_, s') => skip rdr s' 62 | | NONE => raise (LexicalError "unmatched comment block") 63 | in 64 | if isComment rdr s then 65 | skip rdr (Reader.drop rdr 2 s) 66 | else s 67 | end 68 | 69 | (* Drop comments and whitespace until *) 70 | fun trim (rdr : (char * Pos.t, 'a) Reader.t) (s : 'a) : 'a = 71 | if isComment rdr s then 72 | trim rdr (skipComments rdr s) 73 | else if isSpace rdr s then 74 | trim rdr (skipWS rdr s) 75 | else s 76 | 77 | (* 78 | * Extract a keyword or identifier as a string from a positional stream 79 | *) 80 | fun getWord rdr s = 81 | let 82 | fun notDelim #"(" = false 83 | | notDelim #")" = false 84 | | notDelim #"," = false 85 | | notDelim #"|" = false 86 | | notDelim ch = not (Char.isSpace ch) 87 | fun isSpecial x = notDelim x andalso Char.isPunct x 88 | fun isValid x = Char.isAlphaNum x orelse x = #"_" 89 | in 90 | case rdr s of 91 | NONE => (NONE, s) 92 | | SOME ((x, p), s') => 93 | let 94 | val (chars, s'') = 95 | if isSpecial x then 96 | Reader.takeWhile rdr (isSpecial o fst) s 97 | else Reader.takeWhile rdr (isValid o fst) s 98 | in 99 | if length chars < 1 then 100 | (NONE, s) 101 | else (SOME (String.implode (map fst chars), snd (hd chars)), s'') 102 | end 103 | end 104 | 105 | (* TODO: needs to be a Set build by previous infix declarations *) 106 | fun isInfix "+" = true 107 | | isInfix "-" = true 108 | | isInfix "*" = true 109 | | isInfix "/" = true 110 | | isInfix _ = false 111 | 112 | fun make (rdr : (char * Pos.t, 'a) Reader.t) : (T.t * Pos.t, 'a) Reader.t = 113 | fn t => 114 | let 115 | val s = trim rdr t 116 | in 117 | case rdr s of 118 | 119 | NONE => NONE 120 | 121 | (* misc. punctuation *) 122 | | SOME ((#"(", p), s') => SOME ((T.LParen, p), s') 123 | | SOME ((#")", p), s') => SOME ((T.RParen, p), s') 124 | | SOME ((#"|", p), s') => SOME ((T.Bar, p), s') 125 | | SOME ((#",", p), s') => SOME ((T.Comma, p), s') 126 | 127 | (* type variables *) 128 | | SOME ((#"'", p), s') => 129 | (case getWord rdr s' of 130 | (SOME ("", _), _) => raise CompilerBug "(Lexer.make) getWord returned empty string" 131 | | (NONE, _) => raise LexicalError "Expected type variable after apostrophe" 132 | | (SOME (v, _), s'') => SOME ((T.TypeVar v, p), s'')) 133 | 134 | (* integer literals *) 135 | | SOME ((x, _), s') => 136 | if Char.isDigit x then 137 | case getInt rdr s of 138 | (NONE, _) => raise CompilerBug "(Lexer.make) getInt returned NONE, but stream starts with a digit" 139 | | (SOME (n, p), s'') => SOME ((T.Num n, p), s'') 140 | else (* all other tokens *) 141 | case getWord rdr s of 142 | (SOME ("if", p), s'') => SOME ((T.If, p), s'') 143 | | (SOME ("then", p), s'') => SOME ((T.Then, p), s'') 144 | | (SOME ("else", p), s'') => SOME ((T.Else, p), s'') 145 | | (SOME ("true", p), s'') => SOME ((T.Bool true, p), s'') 146 | | (SOME ("false", p), s'') => SOME ((T.Bool false, p), s'') 147 | | (SOME ("fn", p), s'') => SOME ((T.Fn, p), s'') 148 | | (SOME ("let", p), s'') => SOME ((T.Let, p), s'') 149 | | (SOME ("in", p), s'') => SOME ((T.In, p), s'') 150 | | (SOME ("end", p), s'') => SOME ((T.End, p), s'') 151 | | (SOME ("case", p), s'') => SOME ((T.Case, p), s'') 152 | | (SOME ("datatype", p), s'') => SOME ((T.Datatype, p), s'') 153 | | (SOME ("of", p), s'') => SOME ((T.Of, p), s'') 154 | | (SOME ("val", p), s'') => SOME ((T.Val, p), s'') 155 | | (SOME ("=", p), s'') => SOME ((T.Eqls, p), s'') 156 | | (SOME ("=>", p), s'') => SOME ((T.DArrow, p), s'') 157 | | (SOME ("->", p), s'') => SOME ((T.TArrow, p), s'') 158 | 159 | | (SOME ("", _), _) => raise CompilerBug ("(Lexer.make) getWord returned empty string," ^ 160 | "but stream starts with #\"" ^ Char.toString x ^ "\"") 161 | | (NONE, _) => raise LexicalError "Error lexing" 162 | | (SOME (id, p), s'') => 163 | if Char.isUpper (String.sub (id, 0)) then 164 | SOME ((T.Ctor id, p), s'') 165 | else if isInfix id then 166 | SOME ((T.Infix id, p), s'') 167 | else SOME ((T.Id id, p), s'') 168 | end 169 | end 170 | -------------------------------------------------------------------------------- /src/maml.sml: -------------------------------------------------------------------------------- 1 | (* Main entry-point for the compiler. *) 2 | structure Maml = struct 3 | val fromFile : string -> TextIO.StreamIO.instream = 4 | TextIO.getInstream o TextIO.openIn 5 | 6 | val rdr = Pos.reader Reader.streamIO 7 | val lexer = Lexer.make rdr 8 | val parse = Parser.parse lexer 9 | 10 | fun main file = Typecheck.inferPgm (parse (Pos.stream (fromFile file))) 11 | end 12 | -------------------------------------------------------------------------------- /src/monoast.sml: -------------------------------------------------------------------------------- 1 | (* 2 | * monomorphic AST, used to make tests easier to write 3 | *) 4 | structure MonoAST = 5 | struct 6 | structure Expr = 7 | struct 8 | datatype t = Num of int 9 | | Bool of bool 10 | | Id of string 11 | | App of t * t 12 | | If of t * t * t 13 | | Fn of string * t 14 | | Let of string * t * t 15 | | Case of t * (AST.Pattern.Complex.t * t) list 16 | | Infix of string * t * t 17 | | Tuple of t list 18 | 19 | fun show e = 20 | let 21 | fun showClause (pat, e) = "(" ^ AST.Pattern.Complex.show pat ^ "=>" ^ show e ^ ")" 22 | fun showClause' (pat, e) = "(" ^ AST.Pattern.Simple.show pat ^ "=>" ^ show e ^ ")" 23 | in 24 | case e of 25 | Num n => "Num " ^ Int.toString n 26 | | Bool b => "Bool " ^ Bool.toString b 27 | | Id s => "Id " ^ s 28 | | App (e1, e2) => "App (" ^ show e1 ^ "," ^ show e2 ^ ")" 29 | | If (e1, e2, e3) => "If (" ^ show e1 ^ "," ^ show e2 ^ "," ^ show e3 ^ ")" 30 | | Fn (x, e) => "Fn (" ^ x ^ "," ^ show e ^ ")" 31 | | Let (x, e1, e2) => "Let (" ^ x ^ "," ^ show e1 ^ "," ^ show e2 ^ ")" 32 | | Case (e, clauses) => "Case (" ^ show e ^ "," ^ String.concatWith "|" (map showClause clauses) ^ ")" 33 | | Tuple es => "Tuple [" ^ String.concatWith "," (map show es) ^ "]" 34 | 35 | | Infix (binop, e1, e2) => "Infix (" ^ binop ^ "," ^ show e1 ^ "," ^ show e2 ^ ")" 36 | end 37 | 38 | local 39 | structure E = AST.Expr 40 | in 41 | fun make (e : 'a AST.Expr.t) : t = 42 | case e of 43 | E.Num (_, n) => Num n 44 | | E.Bool (_, b) => Bool b 45 | | E.Id (_, x) => Id x 46 | | E.App (_, f, a) => App (make f, make a) 47 | | E.If (_, e1, e2, e3) => If (make e1, make e2, make e3) 48 | | E.Fn (_, _, x, e) => Fn (x, make e) 49 | | E.Let (_, _, x, e1, e2) => Let (x, make e1, make e2) 50 | | E.Case (_, e, clauses) => Case (make e, map (fn (p, e) => (p, make e)) clauses) 51 | | E.Infix (_, b, e1, e2) => Infix (b, make e1, make e2) 52 | | E.Tuple (_, es) => Tuple (map make es) 53 | end 54 | end 55 | 56 | structure Type = 57 | struct 58 | datatype t = Var of string 59 | | Con of string * t list 60 | | Arrow of t * t 61 | | Tuple of t list 62 | | Paren of t 63 | fun show (Var v) = "Var " ^ v 64 | | show (Con (c, ts)) = "Con (" ^ c ^ "," ^ Show.list show ts ^ ")" 65 | | show (Arrow (x, y)) = "Arrow (" ^ show x ^ "," ^ show y ^ ")" 66 | | show (Tuple (ts)) = "Tuple ([" ^ String.concatWith "," (map show ts) ^ "])" 67 | | show (Paren t) = "Paren " ^ show t 68 | 69 | local 70 | structure T = AST.Type 71 | in 72 | fun make (e : 'a AST.Type.t) : t = 73 | case e of 74 | T.Var (_, x) => Var x 75 | | T.Con (_, name, ts) => Con (name, map make ts) 76 | | T.Arrow (_, t1, t2) => Arrow (make t1, make t2) 77 | | T.Tuple (_, ts) => Tuple (map make ts) 78 | | T.Paren (_, t) => Paren (make t) 79 | end 80 | end 81 | 82 | structure Decl = 83 | struct 84 | datatype t = 85 | Data of string list * string * (string * Type.t option) list 86 | | Val of string * Expr.t 87 | fun show d = 88 | let 89 | fun showCtor (c, NONE) = "(" ^ c ^ ", NONE)" 90 | | showCtor (c, SOME t) = "(" ^ c ^ "," ^ Type.show t ^ ")" 91 | in 92 | case d of 93 | Data (tyvars, name, cs) => "Data ([" ^ String.concatWith "," tyvars ^ "]," ^ name ^ ",[" ^ String.concatWith "," (map showCtor cs) ^ "])" 94 | | Val (x, e) => "Val (" ^ x ^ "," ^ Expr.show e ^ ")" 95 | end 96 | local 97 | structure D = AST.Decl 98 | in 99 | fun make (d : ('a, 'b) AST.Decl.t) : t = 100 | case d of 101 | D.Data (_, tyvars, name, ctors) => Data (tyvars, name, map (fn (c, NONE) => (c, NONE) | (c, SOME t) => (c, SOME (Type.make t))) ctors) 102 | | D.Val (_, x, e) => Val (x, Expr.make e) 103 | end 104 | end 105 | 106 | structure Pgm = 107 | struct 108 | type t = Decl.t list 109 | val show: t Show.t = Show.list Decl.show 110 | fun make p = map Decl.make p 111 | end 112 | 113 | end 114 | -------------------------------------------------------------------------------- /src/parser.sml: -------------------------------------------------------------------------------- 1 | (* Parser for a restricted subset of the ML grammar, adapted from the 2 | * Definition of Standard ML, appendix B fig 20 p63 *) 3 | structure Parser : sig 4 | val parse : (Token.t * Pos.t, 'a) Reader.t -> 'a -> (Pos.t, Pos.t) AST.Pgm.t 5 | val makeDecl : (Token.t * Pos.t, 'a) Reader.t -> ((Pos.t, Pos.t) AST.Decl.t, 'a) Reader.t 6 | val makeExpr : (Token.t * Pos.t, 'a) Reader.t -> (Pos.t AST.Expr.t, 'a) Reader.t 7 | val makeType : (Token.t * Pos.t, 'a) Reader.t -> (Pos.t AST.Type.t, 'a) Reader.t 8 | exception SyntaxError of string 9 | end = 10 | struct 11 | open Top 12 | 13 | exception SyntaxError of string 14 | 15 | (* Flag to control logging, mostly grammar productions *) 16 | val debug = false 17 | 18 | (* Conditionally on the flag above, log the current token with a tag *) 19 | fun log rdr s tag = 20 | let val t = case rdr s of 21 | SOME ((t, _), _) => Token.show t 22 | | NONE => ".." 23 | in 24 | if debug then 25 | print (tag ^ "(" ^ t ^ ")\n") 26 | else () 27 | end 28 | 29 | (* !! Raise an exception reporting _user_ errors, i.e. syntax errors *) 30 | fun expected rdr s msg = 31 | let 32 | val got = case rdr s of 33 | NONE => "unexpected EOF" 34 | | SOME ((t, _), _) => Token.show t 35 | in 36 | raise SyntaxError ("expected " ^ msg ^ ", got " ^ got) 37 | end 38 | 39 | (* 40 | * N.b. the procedures below actually operate on _references_ to streams 41 | *) 42 | 43 | (* Extracts the current position from a stream 44 | * Raises an error at EOF *) 45 | fun getPos rdr rest = 46 | case rdr (!rest) of 47 | SOME ((_, p), _) => p 48 | | NONE => raise CompilerBug "getPos called on an empty stream" 49 | 50 | (* Look ahead by one token and return it. 51 | * Safe, i.e. will never raise an error *) 52 | fun peek rdr rest = 53 | case rdr (!rest) of 54 | SOME ((t, _), _) => SOME t 55 | | NONE => NONE 56 | 57 | (* !! Advance the stream pointer by one token 58 | * Raise an error if the stream is at EOF *) 59 | fun adv rdr rest = 60 | case rdr (!rest) of 61 | SOME (_, s) => rest := s 62 | | NONE => raise CompilerBug "advancing past EOF in makeExpr" 63 | 64 | (* !! Advance the stream pointer by one token, and return that token 65 | * Raise an error if the stream is at EOF *) 66 | fun next rdr rest = 67 | case peek rdr rest of 68 | SOME t => (adv rdr rest; t) 69 | | NONE => raise CompilerBug "next called on empty stream" 70 | 71 | (* !! Look ahead by one token, compare to an expected token 72 | * If they're equal, advance the stream pointer 73 | * Raise an error if the tokens do not match or at EOF *) 74 | fun match rdr rest t = 75 | case peek rdr rest of 76 | SOME t' => if t = t' then 77 | adv rdr rest 78 | else expected rdr (!rest) (Token.show t) 79 | | NONE => expected rdr (!rest) (Token.show t) 80 | 81 | (* 82 | * Pratt parser for type expressions 83 | *) 84 | local 85 | 86 | datatype assoc = Left | Right 87 | 88 | exception NoPrecedence of string 89 | fun getPrec (Token.Infix "*") = (60, fn (pos, AST.Type.Tuple (_, xs), y) => AST.Type.Tuple (pos, xs @ [y]) | (pos, x, y) => AST.Type.Tuple (pos, [x, y]), Left) 90 | | getPrec Token.TArrow = (50, AST.Type.Arrow, Right) 91 | | getPrec t = raise NoPrecedence (Token.show t) 92 | 93 | fun isInfix (Token.Infix "*") = true 94 | | isInfix Token.TArrow = true 95 | | isInfix _ = false 96 | 97 | in 98 | 99 | (* 100 | * accepts a token reader and returns a reader for type expressions 101 | *) 102 | fun makeType (rdr : (Token.t * Pos.t, 'b) Reader.t) : (Pos.t AST.Type.t, 'b) Reader.t = 103 | fn s => 104 | let 105 | (* 106 | * parse a type sequence as argument to a type ctor, i.e. ('a, 'b) either 107 | *) 108 | fun tyseq s acc = 109 | (log rdr s "tyseq"; 110 | case rdr s of 111 | SOME ((Token.RParen, _), s') => (case rdr s' of 112 | SOME ((Token.Id c, p), s'') => SOME (AST.Type.Con (p, c, rev acc), s'') 113 | | _ => expected rdr s' "tycon following tyseq in type expression") 114 | | SOME ((Token.Comma, _), s') => (case infexp s' 0 of 115 | SOME (t, s'') => tyseq s'' (t :: acc) 116 | | NONE => expected rdr s' "type expression following comma in tyseq") 117 | | _ => expected rdr s "comma or right paren") 118 | 119 | (* 120 | * parse an atomic expression -- var or parenthesized infix 121 | *) 122 | and atom s = 123 | (log rdr s "atom"; 124 | case rdr s of 125 | SOME ((Token.TypeVar v, p), s') => SOME (AST.Type.Var (p, v), s') 126 | | SOME ((Token.LParen, p), s') => 127 | (case infexp s' 0 of 128 | SOME (ty, s'') => 129 | (case rdr s'' of 130 | SOME ((Token.RParen, _), s''') => SOME (AST.Type.Paren (p, ty), s''') 131 | | SOME ((Token.Comma, _), s''') => tyseq s'' [ty] 132 | | _ => expected rdr s'' "comma or right paren") 133 | | NONE => expected rdr s' "type expression after left paren") 134 | | SOME ((Token.Id c, p), s') => SOME (AST.Type.Con (p, c, []), s') 135 | | _ => expected rdr s "type variable, left paren, or type constructor (ident)") 136 | 137 | (* 138 | * parse an infix expression 139 | *) 140 | and infexp s prec = 141 | (log rdr s "infexp"; 142 | let 143 | fun infexp' s prec lhs = 144 | (log rdr s "infexp'"; 145 | case rdr s of 146 | SOME ((Token.Id c, p), s') => (infexp' s' prec (AST.Type.Con (p, c, [lhs]))) 147 | | SOME ((t, p), s') => 148 | if isInfix t then 149 | let val (prec', ctor, assoc) = getPrec t 150 | in 151 | if prec < prec' then 152 | let 153 | val prec'' = case assoc of Left => prec' | Right => prec' - 1 154 | in 155 | case infexp s' prec'' of 156 | SOME (ty, s'') => infexp' s'' prec (ctor (p, lhs, ty)) 157 | | _ => expected rdr s' "right hand side in type expression" 158 | end 159 | else SOME (lhs, s) 160 | end 161 | else SOME (lhs, s) 162 | | NONE => SOME (lhs, s)) 163 | in 164 | case atom s of 165 | NONE => NONE 166 | | SOME (ast, s') => infexp' s' prec ast 167 | end) 168 | in 169 | infexp s 0 170 | end 171 | end 172 | 173 | (* check if token is in FIRST(atexp) *) 174 | fun FIRSTatexp (Token.Id _) = true 175 | | FIRSTatexp (Token.Num _) = true 176 | | FIRSTatexp (Token.Bool _) = true 177 | | FIRSTatexp Token.Let = true 178 | | FIRSTatexp Token.LParen = true 179 | | FIRSTatexp _ = false 180 | 181 | fun isBinop (Token.Infix "+") = true 182 | | isBinop (Token.Infix "-") = true 183 | | isBinop (Token.Infix "*") = true 184 | | isBinop (Token.Infix "/") = true 185 | | isBinop _ = false 186 | 187 | fun getBinop (Token.Infix oper) = oper 188 | | getBinop _ = raise Match 189 | 190 | structure Expr = AST.Expr 191 | 192 | (* 193 | * accepts a token reader and returns a reader for expressions 194 | *) 195 | fun makeExpr (rdr : (Token.t * Pos.t, 'a) Reader.t) : (Pos.t AST.Expr.t, 'a) Reader.t = 196 | fn s => 197 | let 198 | val rest = ref s 199 | val getPos = fn _ => getPos rdr rest 200 | val adv = fn _ => adv rdr rest 201 | val peek = fn _ => peek rdr rest 202 | val match = match rdr rest 203 | 204 | fun getPrec () : int = 205 | case peek () of 206 | SOME (Token.Infix "+") => 1 207 | | SOME (Token.Infix "-") => 1 208 | | SOME (Token.Infix "*") => 2 209 | | SOME (Token.Infix "/") => 2 210 | | _ => 0 211 | 212 | fun parseIf () = 213 | let 214 | val p = getPos () 215 | val _ = match Token.If 216 | val e1 = expr () 217 | val _ = match Token.Then 218 | val e2 = expr () 219 | val _ = match Token.Else 220 | val e3 = expr () 221 | in 222 | Expr.If (p, e1, e2, e3) 223 | end 224 | 225 | (* attempt to parse an identifier. consume and return it if successful *) 226 | and parseId () = 227 | case peek () of 228 | SOME (Token.Id id) => (adv (); id) 229 | | _ => expected rdr (!rest) "identifer" 230 | 231 | and parseFn () = 232 | let 233 | val p = getPos () 234 | val _ = match Token.Fn 235 | val p' = getPos () 236 | val x = parseId () 237 | val _ = match Token.DArrow 238 | val b = expr () 239 | in 240 | Expr.Fn (p', p, x, b) 241 | end 242 | 243 | and parseCase () = 244 | let 245 | val p = getPos () 246 | val _ = match Token.Case 247 | val e = expr () 248 | val _ = match Token.Of 249 | val cs = clauses () 250 | in 251 | Expr.Case (p, e, cs) 252 | end 253 | 254 | and expr () : Pos.t Expr.t = 255 | (log rdr (!rest) "expr"; 256 | case peek () of 257 | SOME Token.If => parseIf () 258 | | SOME Token.Fn => parseFn () 259 | | SOME Token.Case => parseCase () 260 | | _ => infexp 0) 261 | 262 | and clauses () : (AST.Pattern.Complex.t * Pos.t Expr.t) list = 263 | (log rdr (!rest) "clauses"; 264 | let 265 | val pat = pattern () 266 | val _ = match Token.DArrow 267 | in 268 | (pat, expr ()) :: clauses' () 269 | end) 270 | 271 | and clauses' () : (AST.Pattern.Complex.t * Pos.t Expr.t) list = 272 | (log rdr (!rest) "clauses'" 273 | ; case peek () of 274 | SOME Token.Bar => (adv () ; clauses ()) 275 | | _ => []) 276 | 277 | and pattern () : AST.Pattern.Complex.t = 278 | (log rdr (!rest) "pattern" 279 | ; case peek () of 280 | SOME (Token.Id x) => (adv (); AST.Pattern.Complex.Var x) 281 | | SOME (Token.Ctor c) => (adv (); 282 | case peek () of 283 | SOME (Token.Id _) => AST.Pattern.Complex.Ctor (c, SOME (pattern ())) 284 | | SOME (Token.LParen) => AST.Pattern.Complex.Ctor (c, SOME (pattern ())) 285 | | SOME _ => AST.Pattern.Complex.Ctor (c, NONE) 286 | | NONE => AST.Pattern.Complex.Ctor (c, NONE)) 287 | | SOME Token.LParen => (adv () 288 | ; let val p = pattern () 289 | in 290 | case peek () of 291 | SOME Token.Comma => AST.Pattern.Complex.Tuple (p :: patterns ()) 292 | | SOME Token.RParen => (adv (); p) 293 | | _ => expected rdr (!rest) "comma or ) in pattern" 294 | end) 295 | | _ => expected rdr (!rest) "var, tuple, or ctor application in pattern") 296 | 297 | and patterns () : AST.Pattern.Complex.t list = 298 | (log rdr (!rest) "patterns" 299 | ; case peek () of 300 | SOME Token.Comma => (adv (); pattern () :: patterns ()) 301 | | SOME Token.RParen => (adv (); []) 302 | | _ => []) 303 | 304 | and infexp (prec : int) : Pos.t Expr.t = 305 | (log rdr (!rest) "infexp"; 306 | let 307 | val lhs = appexp () 308 | in 309 | case peek () of 310 | SOME t => if isBinop t then 311 | infexp' (prec, lhs) 312 | else lhs 313 | | NONE => lhs 314 | end) 315 | 316 | and infexp' (prec : int, lhs : Pos.t Expr.t) : Pos.t Expr.t = 317 | (log rdr (!rest) "infexp'"; 318 | let 319 | val prec' = getPrec () 320 | in 321 | if prec < prec' 322 | then let val t = next rdr rest 323 | (* TODO: check if t is a binop *) 324 | val lhs = Expr.Infix (Expr.getInfo lhs, getBinop t, lhs, 325 | infexp prec') 326 | in infexp' (prec, lhs) 327 | end 328 | else lhs 329 | end) 330 | 331 | and tuple () : Pos.t Expr.t list = 332 | (log rdr (!rest) "tuple"; 333 | case peek () of 334 | SOME Token.Comma => (adv (); let val e = expr () 335 | in e :: tuple () 336 | end) 337 | | SOME Token.RParen => (adv (); []) 338 | | _ => expected rdr (!rest) "comma or )") 339 | 340 | and parseLet () = 341 | let 342 | val p = getPos () 343 | val _ = match Token.Let 344 | val _ = match Token.Val 345 | val p' = getPos () 346 | val x = parseId () 347 | val _ = match Token.Eqls 348 | val e = expr () 349 | val _ = match Token.In 350 | val b = expr () 351 | val _ = match Token.End 352 | in 353 | Expr.Let (p', p, x, e, b) 354 | end 355 | 356 | and atexp () : Pos.t Expr.t = 357 | (log rdr (!rest) "atexp"; 358 | case rdr (!rest) of 359 | SOME ((Token.Let, _), _) => parseLet () 360 | | SOME ((Token.Num n, p), _) => (adv (); Expr.Num (p, n)) 361 | | SOME ((Token.Bool b, p), _) => (adv (); Expr.Bool (p, b)) 362 | | SOME ((Token.Id x, p), _) => (adv (); Expr.Id (p, x)) 363 | 364 | (* in the context of an atexp, parse a Ctor as an Ident. *) 365 | | SOME ((Token.Ctor c, p), _) => (adv (); Expr.Id (p, c)) 366 | 367 | | SOME ((Token.LParen, p), _) => 368 | (adv (); 369 | let 370 | val e = expr () 371 | in 372 | case peek () of 373 | SOME Token.RParen => (adv (); e) 374 | | SOME Token.Comma => Expr.Tuple (p, e :: tuple ()) 375 | | _ => expected rdr (!rest) "comma or )" 376 | end) 377 | | _ => expected rdr (!rest) "let, id or constant") 378 | 379 | (* 380 | * lhs is the left hand side of the (potential) application 381 | *) 382 | and appexp' (lhs : Pos.t Expr.t) : Pos.t Expr.t = 383 | (log rdr (!rest) "appexp'"; 384 | case peek () of 385 | SOME t => if FIRSTatexp t then 386 | appexp' (Expr.App (Expr.getInfo lhs, lhs, atexp ())) 387 | else lhs 388 | | NONE => lhs) 389 | 390 | and appexp () : Pos.t Expr.t = 391 | (log rdr (!rest) "appexp"; 392 | appexp' (atexp ())) 393 | 394 | in 395 | SOME (expr (), !rest) 396 | end 397 | 398 | (* 399 | * accepts a token reader and returns a reader for declarations 400 | *) 401 | fun makeDecl (rdr : (Token.t * Pos.t, 'a) Reader.t) : ((Pos.t, Pos.t) AST.Decl.t, 'a) Reader.t = 402 | fn s => 403 | let 404 | val rest = ref s 405 | val getPos = fn _ => getPos rdr rest 406 | val adv = fn _ => adv rdr rest 407 | val peek = fn _ => peek rdr rest 408 | val match = match rdr rest 409 | 410 | (* parse a single constructor, returning its name and (optionally) its argument type *) 411 | fun ctor () : string * Pos.t AST.Type.t option = 412 | (log rdr (!rest) "ctor"; 413 | let 414 | val c = case peek () of 415 | SOME (Token.Ctor c) => (adv (); c) 416 | | _ => expected rdr (!rest) "constructor" 417 | val t = case peek () of 418 | SOME Token.Of => 419 | ( adv () 420 | ; case makeType rdr (!rest) of 421 | SOME (t, rest') => (rest := rest' ; SOME t) 422 | | NONE => expected rdr (!rest) "type after `Of` in datatype constructor") 423 | | _ => NONE 424 | in 425 | (c, t) 426 | end) 427 | 428 | (* parse one or more constructors, separated by bars *) 429 | and ctors () : (string * Pos.t AST.Type.t option) list = 430 | let 431 | fun ctors' () : (string * Pos.t AST.Type.t option) list = 432 | case peek () of 433 | SOME Token.Bar => (adv (); ctor () :: ctors' ()) 434 | | _ => [] 435 | in 436 | (log rdr (!rest) "ctors"; ctor () :: ctors' ()) 437 | end 438 | 439 | (* parse a comma-delimited list of type variables between parentheses *) 440 | and typeVars () = 441 | case peek () of 442 | SOME (Token.TypeVar t) => (adv (); [t]) 443 | | SOME Token.LParen => 444 | let 445 | fun typeVars' () = 446 | case peek () of 447 | SOME (Token.TypeVar t) => (adv (); t :: typeVars' ()) 448 | | SOME Token.Comma => (adv (); typeVars' ()) 449 | | _ => [] 450 | 451 | val _ = match Token.LParen 452 | val ts = typeVars' () 453 | val _ = match Token.RParen 454 | in 455 | ts (* TODO this allows `datatype () foo = ...` *) 456 | end 457 | | _ => [] 458 | 459 | 460 | (* parse a datatype declaration *) 461 | and data () = 462 | (log rdr (!rest) "data"; 463 | let 464 | val p = getPos () 465 | val _ = match Token.Datatype 466 | val ts = typeVars () 467 | val x = id () 468 | val _ = match Token.Eqls 469 | val cs = ctors () 470 | in 471 | AST.Decl.Data (p, ts, x, cs) 472 | end) 473 | 474 | (* attempt to parse an identifier. consume and return it if successful *) 475 | and id () = 476 | case peek () of 477 | SOME (Token.Id id) => (adv (); id) 478 | | _ => expected rdr (!rest) "identifier" 479 | 480 | and value () = 481 | let 482 | val p = getPos () 483 | val _ = match Token.Val 484 | val x = id () 485 | val _ = match Token.Eqls 486 | in 487 | case makeExpr rdr (!rest) of 488 | SOME (e, rest') => (rest := rest'; AST.Decl.Val (p, x, e)) 489 | | NONE => expected rdr (!rest) "expression in value declaration" 490 | end 491 | 492 | and decl () : ((Pos.t, Pos.t) AST.Decl.t * 'a) option = 493 | (log rdr (!rest) "decl"; 494 | case peek () of 495 | SOME Token.Datatype => SOME (data (), !rest) 496 | | SOME Token.Val => SOME (value (), !rest) 497 | | SOME _ => expected rdr (!rest) "datatype or value declaration" 498 | | NONE => NONE) 499 | in 500 | decl () 501 | end 502 | 503 | fun parse (rdr : (Token.t * Pos.t, 'a) Reader.t) (s : 'a) : (Pos.t, Pos.t) AST.Pgm.t = 504 | let 505 | val decl = makeDecl rdr 506 | 507 | fun parse' s = 508 | case decl s of 509 | NONE => [] 510 | | SOME (ast, s') => ast :: parse' s' 511 | in 512 | parse' s 513 | end 514 | 515 | end 516 | -------------------------------------------------------------------------------- /src/position.sml: -------------------------------------------------------------------------------- 1 | signature POSITION = 2 | sig 3 | eqtype t 4 | val new : t 5 | val line : t -> int 6 | val col : t -> int 7 | val incrCol : t -> t 8 | val incrLine : t -> t 9 | val start : 'a -> 'a * t 10 | val reader : (char,'a) StringCvt.reader -> (char * t,'a * t) StringCvt.reader 11 | end 12 | 13 | structure Pos : POSITION = 14 | struct 15 | type t = {line: int, col: int} 16 | val new = {col = 1, line = 1} 17 | fun line {line, col} = line 18 | fun col {line, col} = col 19 | fun incrCol {col, line} = {col = col + 1, line = line} 20 | fun incrLine {col, line} = {col = 1, line = line + 1} 21 | fun start s = (s, new) 22 | fun reader rdr = 23 | fn (s, pos as {col, line}) => 24 | case rdr s of 25 | NONE => NONE 26 | | SOME (#"\n", s') => SOME ((#"\n", pos), (s', {col=1, line=line+1})) 27 | | SOME (x, s') => SOME ((x, pos), (s', {col=col+1, line=line})) 28 | 29 | end 30 | -------------------------------------------------------------------------------- /src/show.sml: -------------------------------------------------------------------------------- 1 | structure Show = 2 | struct 3 | type 'a t = 'a -> string 4 | val unit: unit t = fn _ => "()" 5 | val int: int t = Int.toString 6 | val word: word t = Word.toString 7 | val char: char t = Char.toString 8 | val real: real t = Real.toString 9 | val string: string t = fn s => "\"" ^ s ^ "\"" 10 | val bool: bool t = Bool.toString 11 | local 12 | fun interleave l i = 13 | let 14 | fun recur [] acc = rev acc 15 | | recur (x :: []) acc = recur [] (x :: acc) 16 | | recur (x :: xs) acc = recur xs (i :: x :: acc) 17 | in 18 | recur l [] 19 | end 20 | in 21 | val list: 'a t -> 'a list t = 22 | fn show => fn xs => "[" ^ concat (interleave (map show xs) ",") ^ "]" 23 | end 24 | val option: 'a t -> 'a option t = 25 | fn show => fn NONE => "NONE" | (SOME x) => "SOME " ^ show x 26 | 27 | val pair: 'a t * 'b t -> ('a * 'b) t = 28 | fn (showa,showb) => fn (a,b) => "(" ^ showa a ^ "," ^ showb b ^ ")" 29 | 30 | val triple: 'a t * 'b t * 'c t -> ('a * 'b * 'c) t = 31 | fn (showa,showb,showc) => fn (a,b,c) => "(" ^ showa a ^ "," 32 | ^ showb b ^ "," 33 | ^ showc c ^ ")" 34 | 35 | val sq: 'a t -> ('a * 'a) t = 36 | fn (show) => fn (a,a') => "(" ^ show a ^ "," ^ show a' ^ ")" 37 | end 38 | 39 | signature SHOW = 40 | sig 41 | type t 42 | val show : t -> string 43 | end 44 | 45 | functor SetShowFn(structure Set: ORD_SET 46 | structure Show: SHOW 47 | sharing type Set.Key.ord_key = Show.t): SHOW = 48 | struct 49 | type t = Set.set 50 | 51 | fun show s = 52 | let 53 | val items = Set.listItems s 54 | val strs = map Show.show items 55 | fun interleave l i = 56 | let 57 | fun recur [] acc = rev acc 58 | | recur (x :: []) acc = recur [] (x :: acc) 59 | | recur (x :: xs) acc = recur xs (i :: x :: acc) 60 | in 61 | recur l [] 62 | end 63 | in 64 | "{" ^ String.concat (interleave strs ",") ^ "}" 65 | end 66 | end 67 | -------------------------------------------------------------------------------- /src/stringmap.sml: -------------------------------------------------------------------------------- 1 | structure StringMap = BinaryMapFn( 2 | struct 3 | type ord_key = String.string 4 | val compare = String.compare 5 | end) 6 | -------------------------------------------------------------------------------- /src/token.sml: -------------------------------------------------------------------------------- 1 | structure Token = 2 | struct 3 | 4 | datatype t = Num of int 5 | | Id of string 6 | | Infix of string 7 | | Ctor of string 8 | | Bool of bool 9 | | LParen 10 | | RParen 11 | | If 12 | | Then 13 | | Else 14 | | Fn 15 | | DArrow 16 | | Let 17 | | End 18 | | Eqls 19 | | In 20 | | Case 21 | | Bar 22 | 23 | | Datatype 24 | | Of 25 | | Val 26 | | TypeVar of string 27 | | TArrow 28 | | Comma 29 | 30 | fun show (Num n) = "Num " ^ Int.toString n 31 | | show (Bool b) = "Bool " ^ Bool.toString b 32 | | show (Id s) = "Id " ^ s 33 | | show (Infix s) = "Infix " ^ s 34 | | show (Ctor s) = "Ctor " ^ s 35 | | show LParen = "LParen" 36 | | show RParen = "RParen" 37 | | show If = "If" 38 | | show Else = "Else" 39 | | show Then = "Then" 40 | | show Fn = "Fn" 41 | | show DArrow = "DArrow" 42 | | show Let = "Let" 43 | | show End = "End" 44 | | show Eqls = "Eqls" 45 | | show In = "In" 46 | | show Case = "Case" 47 | | show Bar = "Bar" 48 | 49 | | show Datatype = "Datatype" 50 | | show Of = "Of" 51 | | show Val = "Val" 52 | | show (TypeVar tv) = "TypeVar " ^ tv 53 | | show TArrow = "TArrow" 54 | | show Comma = "Comma" 55 | 56 | fun eq (Num a, Num b) = a = b 57 | | eq (Bool a, Bool b) = a = b 58 | | eq (Id a, Id b) = a = b 59 | | eq (Infix a, Infix b) = a = b 60 | | eq (Ctor a, Ctor b) = a = b 61 | | eq (TypeVar a, TypeVar b) = a = b 62 | 63 | | eq (LParen, LParen) = true 64 | | eq (RParen, RParen) = true 65 | | eq (If, If) = true 66 | | eq (Else, Else) = true 67 | | eq (Then, Then) = true 68 | | eq (Fn, Fn) = true 69 | | eq (DArrow, DArrow) = true 70 | | eq (Let, Let) = true 71 | | eq (End, End) = true 72 | | eq (Eqls, Eqls_) = true 73 | | eq (In, In) = true 74 | | eq (Case, Case) = true 75 | | eq (Bar, Bar) = true 76 | | eq (Datatype, Datatype) = true 77 | | eq (Of, Of) = true 78 | | eq (Val, Val) = true 79 | | eq (TArrow, TArrow) = true 80 | | eq (Comma, Comma) = true 81 | 82 | | eq (_, _) = false 83 | 84 | end 85 | -------------------------------------------------------------------------------- /src/top.sml: -------------------------------------------------------------------------------- 1 | (* Top-level module with a few things used everywhere, should be safe to `open` *) 2 | structure Top = struct 3 | exception CompilerBug of string 4 | end 5 | -------------------------------------------------------------------------------- /src/type.sml: -------------------------------------------------------------------------------- 1 | structure Type : sig 2 | 3 | datatype t = Num 4 | | Bool 5 | | Con of string * t list 6 | | Arrow of t * t 7 | | Tuple of t list 8 | | Var of string 9 | | List of t 10 | 11 | val compare : t * t -> order 12 | val show : t -> string 13 | val normalize : t -> t 14 | val fromAST : 'a AST.Type.t -> t 15 | 16 | end = struct 17 | 18 | datatype t = Num 19 | | Bool 20 | | Con of string * t list 21 | | Arrow of t * t 22 | | Tuple of t list 23 | | Var of string 24 | | List of t 25 | 26 | fun fromAST (AST.Type.Var (_, x)) = Var x 27 | | fromAST (AST.Type.Con (_, c, t)) = Con (c, map fromAST t) 28 | | fromAST (AST.Type.Arrow (_, t1, t2)) = Arrow (fromAST t1, fromAST t2) 29 | | fromAST (AST.Type.Tuple (_, ts)) = Tuple (map fromAST ts) 30 | | fromAST (AST.Type.Paren (_, t)) = fromAST t 31 | 32 | local 33 | 34 | fun list c = 35 | let 36 | fun compare ([], []) = EQUAL 37 | | compare (x::xs, []) = GREATER 38 | | compare ([], y::ys) = LESS 39 | | compare (x::xs, y::ys) = 40 | case c (x, y) of 41 | EQUAL => compare (xs, ys) 42 | | ord => ord 43 | in 44 | compare 45 | end 46 | 47 | in 48 | 49 | (* boilerplate comparison stuff *) 50 | fun compare (Num , Num) = EQUAL 51 | | compare (Num , _) = GREATER 52 | 53 | | compare (Bool , Bool) = EQUAL 54 | | compare (Bool , Num) = LESS 55 | | compare (Bool , _) = GREATER 56 | 57 | | compare (Con (c, ts), Con (c', ts')) = 58 | (case String.compare (c, c') of 59 | EQUAL => list compare (ts, ts') 60 | | ord => ord) 61 | | compare (Con _, Num) = LESS 62 | | compare (Con _, Bool) = LESS 63 | | compare (Con _, _) = GREATER 64 | 65 | | compare (Arrow (t1 , t2), Arrow (t1', t2')) = 66 | (case compare (t1, t1') of 67 | EQUAL => compare (t2', t2') 68 | | ord => ord) 69 | | compare (Arrow _, Num) = LESS 70 | | compare (Arrow _, Bool) = LESS 71 | | compare (Arrow _, _) = GREATER 72 | 73 | | compare (Tuple ts, Tuple ts') = 74 | (case Int.compare (length ts, length ts') of 75 | EQUAL => list compare (ts, ts') 76 | | ord => ord) 77 | | compare (Tuple _, Num) = LESS 78 | | compare (Tuple _, Bool) = LESS 79 | | compare (Tuple _, Arrow _) = LESS 80 | | compare (Tuple _, _) = GREATER 81 | 82 | | compare (Var s , Var s') = String.compare (s, s') 83 | | compare (Var _ , List _) = GREATER 84 | | compare (Var _ , _) = LESS 85 | 86 | | compare (List t, List t') = compare (t, t') 87 | | compare (List _, _) = LESS 88 | 89 | end 90 | 91 | fun showArrowTyp (t1, t2) = 92 | let 93 | val s1 = case t1 of 94 | Arrow _ => "(" ^ show t1 ^ ")" 95 | | _ => show t1 96 | (* don't need to wrap result type, -> is left assoc *) 97 | val s2 = show t2 98 | in 99 | s1 ^ " -> " ^ s2 100 | end 101 | and show Num = "num" 102 | | show Bool = "bool" 103 | | show (Var s) = "'" ^ s 104 | | show (Con (c, t)) = Show.list show t ^ " " ^ c 105 | | show (Arrow (t1, t2)) = showArrowTyp (t1, t2) 106 | | show (List t) = "[" ^ show t ^ "]" 107 | | show (Tuple ts) = "(" ^ String.concatWith "," (map show ts) ^ ")" 108 | 109 | fun normalize t = 110 | let 111 | val idx = ref 0 112 | val letters = "abcdefghijklmnopqrstuvwxyz" 113 | fun freshVar () = 114 | let 115 | val i = !idx 116 | val var = 117 | if i >= 26 118 | then Char.toString 119 | (String.sub (letters, i mod 26)) ^ Int.toString i 120 | else Char.toString (String.sub (letters, i)) 121 | in 122 | var before (idx := i + 1) 123 | end 124 | val vars = ref StringMap.empty 125 | fun getVar tv = 126 | case StringMap.find (!vars, tv) of 127 | SOME tv' => tv' 128 | | NONE => 129 | let 130 | val var = freshVar () 131 | in 132 | vars := StringMap.insert (!vars, tv, var) 133 | ; var 134 | end 135 | 136 | fun normalize' Bool = Bool 137 | | normalize' Num = Num 138 | | normalize' (Con (c, t)) = Con (c, map normalize' t) 139 | | normalize' (Var tv) = Var (getVar tv) 140 | | normalize' (Arrow (t1, t2)) = Arrow (normalize' t1, normalize' t2) 141 | | normalize' (List t) = List (normalize' t) 142 | | normalize' (Tuple ts) = Tuple (map normalize' ts) 143 | in 144 | normalize' t 145 | end 146 | 147 | end 148 | -------------------------------------------------------------------------------- /src/typecheck.sml: -------------------------------------------------------------------------------- 1 | structure Typecheck = 2 | struct 3 | 4 | open Top 5 | 6 | structure T = Type 7 | structure E = AST.Expr 8 | 9 | local 10 | val tVarId = ref 0 11 | val letters = "abcdefghijklmnopqrstuvwxyz" 12 | in 13 | (* generate fresh type variables *) 14 | fun gensym () = 15 | (Char.toString (String.sub (letters, !tVarId mod 26)) ^ Int.toString (!tVarId)) 16 | before (tVarId := !tVarId + 1) 17 | fun reset () = tVarId := 0 18 | end 19 | 20 | type typed = {pos : AST.pos, typ: T.t} 21 | 22 | structure Env = StringMap (* environment mapping vars in obj lang to types *) 23 | exception Unbound (* thrown if there is an unbound ident *) 24 | 25 | fun makeTyped (p : AST.pos) : typed = {pos = p, typ = T.Var (gensym ())} 26 | 27 | fun getBoundVarsInPat (AST.Pattern.Complex.Var x) = [x] 28 | | getBoundVarsInPat (AST.Pattern.Complex.Tuple ps) = List.concat (map getBoundVarsInPat ps) 29 | | getBoundVarsInPat (AST.Pattern.Complex.Ctor (_, NONE)) = [] 30 | | getBoundVarsInPat (AST.Pattern.Complex.Ctor (_, SOME p)) = getBoundVarsInPat p 31 | 32 | (* 33 | * Given an expression, assign each sub expression type vars unless it's an ident bound in the existing gamma 34 | *) 35 | fun assignTypeVars (env : T.t Env.map, e : AST.pos E.t) : typed E.t = 36 | case e of 37 | E.Num (p, n) => E.Num (makeTyped p, n) 38 | | E.Bool (p, b) => E.Bool (makeTyped p, b) 39 | | E.Infix (p, bin, e1, e2) => E.Infix (makeTyped p, bin, assignTypeVars (env, e1), assignTypeVars (env, e2)) 40 | | E.App (p, e1, e2) => E.App (makeTyped p, assignTypeVars (env, e1), assignTypeVars (env, e2)) 41 | | E.If (p, e1, e2, e3) => E.If (makeTyped p, assignTypeVars (env, e1), assignTypeVars (env, e2), assignTypeVars (env, e3)) 42 | 43 | | E.Fn (boundp, selfp, x, body) => 44 | let 45 | val boundVar = gensym () 46 | in 47 | E.Fn ({pos = boundp, typ = T.Var boundVar}, makeTyped selfp, x, assignTypeVars (Env.insert (env, x, T.Var boundVar), body)) 48 | end 49 | 50 | | E.Id (p, x) => 51 | (case Env.find (env, x) of 52 | SOME typ => E.Id ({pos = p, typ = typ}, x) 53 | | NONE => raise Unbound) 54 | 55 | | E.Tuple (p, es) => E.Tuple (makeTyped p, map (fn e => assignTypeVars (env, e)) es) 56 | 57 | | E.Case (p, e, cs) => 58 | E.Case (makeTyped p, assignTypeVars (env, e), 59 | map (fn (p, e) => 60 | let val vars = getBoundVarsInPat p 61 | in (p, assignTypeVars (foldl (fn (v, acc) => Env.insert (acc, v, T.Var (gensym ()))) env vars, e)) 62 | end) 63 | cs) 64 | 65 | | E.Let (boundp, selfp, x, e, body) => 66 | let 67 | val boundVar = gensym () 68 | val env' = Env.insert (env, x, T.Var boundVar) 69 | in 70 | E.Let ({pos = boundp, typ = T.Var boundVar}, makeTyped selfp, x, assignTypeVars (env', e), assignTypeVars (env', body)) 71 | end 72 | 73 | fun gettyp (e : typed E.t) = #typ (E.getInfo e) 74 | 75 | exception TypeError 76 | 77 | val rec genCon : (T.t Env.map * typed E.t * Constraint.Set.set) -> Constraint.Set.set = 78 | fn (env, e, constrs) => 79 | case e of 80 | 81 | E.Bool ({typ, ...}, _) => Constraint.Set.add (constrs, {lhs = typ, rhs = T.Bool}) 82 | 83 | | E.Num ({typ, ...}, _) => Constraint.Set.add (constrs, {lhs = typ, rhs = T.Num}) 84 | 85 | | E.If ({typ, ...}, e1, e2, e3) => 86 | let 87 | fun f (x, cs) = genCon (env, x, cs) 88 | val constrs' = foldl f constrs [e1, e2, e3] 89 | val tv1 = gettyp e1 90 | val tv2 = gettyp e2 91 | val tv3 = gettyp e3 92 | val constrs'' = [ 93 | {lhs = tv1, rhs = T.Bool}, 94 | {lhs = tv2, rhs = typ}, 95 | {lhs = tv3, rhs = typ} 96 | ] 97 | in 98 | Constraint.Set.addList (constrs', constrs'') 99 | end 100 | 101 | | E.Fn ({typ=bound, ...}, {typ=self, ...}, x, body) => 102 | let 103 | val tvbody = gettyp body 104 | val constrs' = genCon (env, body, constrs) 105 | in 106 | Constraint.Set.add (constrs', {lhs = self, rhs = T.Arrow (bound, tvbody)}) 107 | end 108 | 109 | | E.Id _ => constrs 110 | 111 | | E.App ({typ,...}, f, a) => 112 | let 113 | val tvf = gettyp f 114 | val tva = gettyp a 115 | val constrs' = genCon (env, f, constrs) 116 | val constrs'' = genCon (env, a, constrs') 117 | in 118 | Constraint.Set.add (constrs'', 119 | {lhs = tvf, rhs = T.Arrow (tva, typ)}) 120 | end 121 | 122 | | E.Tuple ({typ, ...}, es) => 123 | let 124 | val constrs' = foldl (fn (e, acc) => genCon (env, e, acc)) constrs es 125 | in 126 | Constraint.Set.add (constrs', {lhs = typ, rhs = T.Tuple (map gettyp es)}) 127 | end 128 | 129 | | E.Case ({typ, ...}, e1, clauses) => 130 | let 131 | (* TODO: type check patterns *) 132 | fun gen ((pat, exp), cs) = 133 | let val pattyp = 134 | case pat of 135 | AST.Pattern.Complex.Ctor (ctor, subpat) => (case Env.find (env, ctor) of 136 | NONE => raise TypeError 137 | | SOME (T.Arrow (_, typ)) => typ 138 | | SOME typ => typ) 139 | | AST.Pattern.Complex.Var _ => raise CompilerBug "(Typecheck.genCon/gen) not implemented yet: variable patterns" 140 | | AST.Pattern.Complex.Tuple _ => raise CompilerBug "(Typecheck.genCon/gen) not implemented yet: tuple patterns" 141 | in 142 | Constraint.Set.addList (genCon (env, exp, cs), [{lhs = gettyp exp, rhs = typ}, 143 | {lhs = gettyp e1, rhs = pattyp}]) 144 | end 145 | 146 | in 147 | foldl gen constrs clauses 148 | end 149 | 150 | (* infix expr, treat as an application the operator to a pair *) 151 | | E.Infix ({typ, ...}, oper, e1, e2) => 152 | let 153 | val tvarg = T.Tuple [gettyp e1, gettyp e2] 154 | val constrs' = genCon (env, e1, constrs) 155 | val constrs'' = genCon (env, e2, constrs') 156 | in 157 | case Env.find (env, oper) of 158 | NONE => raise TypeError 159 | | SOME tvop => 160 | Constraint.Set.add (constrs'', {lhs = tvop, rhs = T.Arrow (tvarg, typ)}) 161 | end 162 | 163 | | E.Let _ => raise CompilerBug "(Typecheck.genCon) not implemented yet: let" 164 | 165 | fun prettyPrintConstraint ({lhs, rhs} : Constraint.t, env, ast) : string = 166 | let 167 | fun showTyp T.Num = "num" 168 | | showTyp T.Bool = "bool" 169 | | showTyp (T.Arrow (t1, t2)) = "(" ^ showTyp t1 ^ ") -> (" ^ showTyp t2 ^ ")" 170 | | showTyp (T.List t) = "[" ^ showTyp t ^ "]" 171 | | showTyp (T.Var tv) = tv 172 | | showTyp (T.Tuple ts) = "(" ^ String.concatWith "," (map showTyp ts) ^ ")" 173 | | showTyp (T.Con (name, ts)) = name ^ "{" ^ String.concatWith "," (map showTyp ts) ^ "}" 174 | in 175 | showTyp lhs ^ " === " ^ showTyp rhs 176 | end 177 | 178 | fun printConstraint (c, env, ast) = print (prettyPrintConstraint (c, env, ast) ^ "\n") 179 | 180 | fun printConstraints (cs, env, ast) = 181 | List.app (fn c => printConstraint (c, env, ast)) cs 182 | 183 | fun printSub s = 184 | List.app (fn (k, v) => print (k ^ ":=" ^ T.show v ^ "\n")) (StringMap.listItemsi s) 185 | 186 | exception NotImplemented of string 187 | 188 | exception Conflict 189 | exception Assert of string 190 | 191 | (* replace tv with typ in a single type *) 192 | fun replace (_, _, T.Bool) = T.Bool 193 | | replace (_, _, T.Num) = T.Num 194 | | replace (tv, typ, t as T.Var tv') = if tv = tv' then typ else t 195 | | replace (tv, typ, T.Arrow (d, r)) = T.Arrow (replace (tv, typ, d), replace (tv, typ, r)) 196 | | replace (tv, typ, T.List t) = T.List (replace (tv, typ, t)) 197 | | replace (tv, typ, T.Tuple ts) = T.Tuple (map (fn t => replace (tv, typ, t)) ts) 198 | | replace (tv, typ, T.Con (c, ts)) = T.Con (c, map (fn t => replace (tv, typ, t)) ts) 199 | 200 | (* apply a substitution to a single type *) 201 | fun substitute s T.Bool = T.Bool 202 | | substitute s T.Num = T.Num 203 | | substitute s (t as T.Var tv) = (case StringMap.find (s, tv) of 204 | SOME t' => t' 205 | | NONE => t) 206 | | substitute s (T.Arrow (d, r)) = T.Arrow (substitute s d, substitute s r) 207 | | substitute s (T.List t) = T.List (substitute s t) 208 | | substitute s (T.Tuple ts) = T.Tuple (map (substitute s) ts) 209 | | substitute s (T.Con (c, ts)) = T.Con (c, map (substitute s) ts) 210 | 211 | (* replace tv with typ in a substitution *) 212 | fun extend (tv : string, typ : T.t, s : T.t StringMap.map) : T.t StringMap.map = 213 | let 214 | fun f (k, v) = 215 | if k = tv 216 | then raise (Assert ("apply2S: bound type var in substitution, " ^ 217 | k ^ " bound to " ^ T.show v)) 218 | else replace (tv, typ, v) 219 | in 220 | StringMap.insert (StringMap.mapi f s, tv, typ) 221 | end 222 | 223 | fun substituteInC s ({lhs, rhs} : Constraint.t) : Constraint.t = 224 | {lhs = substitute s lhs, rhs = substitute s rhs} 225 | 226 | exception VarBoundInSub 227 | val applyAndExtend : (T.t StringMap.map * Constraint.t list * string * T.t) -> Constraint.t list * T.t StringMap.map = 228 | fn (sub, stack, tv, typ) => 229 | case StringMap.find (sub, tv) of 230 | (* unbound... *) 231 | NONE => let val sub' = extend (tv, typ, sub) 232 | in (map (substituteInC sub') stack, sub') 233 | end 234 | (* I think this should never happen... *) 235 | | SOME _ => raise VarBoundInSub 236 | 237 | exception Occurs 238 | fun occurs ({lhs, rhs} : Constraint.t) : bool = 239 | let 240 | fun occurs' (tv, T.Num) = false 241 | | occurs' (tv, T.Bool) = false 242 | | occurs' (tv, T.Var tv') = tv = tv' 243 | | occurs' (tv, T.List ty) = occurs' (tv, ty) 244 | | occurs' (tv, T.Arrow (t1, t2)) = occurs' (tv, t1) orelse occurs' (tv, t2) 245 | | occurs' (tv, T.Tuple ts) = List.exists (fn t => occurs' (tv, t)) ts 246 | | occurs' (tv, T.Con (_, ts)) = List.exists (fn t => occurs' (tv, t)) ts 247 | in 248 | case (lhs, rhs) of 249 | (* constraint that just relates any two vars is ok *) 250 | (T.Var _, T.Var _) => false 251 | | (T.Var tv, ty) => occurs' (tv, ty) 252 | | (ty, T.Var tv) => occurs' (tv, ty) 253 | | _ => false 254 | end 255 | 256 | 257 | fun unify (constrs : Constraint.Set.set) = 258 | let 259 | fun unify' ([], acc) = acc 260 | | unify' ((c as {lhs, rhs}) :: stack, acc) = 261 | ( 262 | if occurs c 263 | then raise Occurs 264 | else 265 | case (lhs, rhs) of 266 | (T.Var tv1, t2 as T.Var tv2) => 267 | if tv1 = tv2 268 | then unify' (stack, acc) 269 | else unify' (applyAndExtend (acc, stack, tv1, t2)) 270 | 271 | | (T.Var tv, typ) => unify' (applyAndExtend (acc, stack, tv, typ)) 272 | 273 | | (typ, T.Var tv) => unify' (applyAndExtend (acc, stack, tv, typ)) 274 | 275 | | (T.Arrow (dom, rng), T.Arrow (dom', rng')) => 276 | unify' ({lhs = dom, rhs = dom'} :: 277 | {lhs = rng, rhs = rng'} :: stack, acc) 278 | 279 | | (T.Bool, T.Bool) => unify' (stack, acc) 280 | 281 | | (T.Num, T.Num) => unify' (stack, acc) 282 | 283 | | (T.List t, T.List t') => unify' ({lhs = t, rhs = t'} :: stack, acc) 284 | 285 | | (T.Tuple ts, T.Tuple ts') => unify' ((map (fn (t, t') => {lhs = t, rhs = t'}) (ListPair.zip (ts, ts'))) @ stack, acc) 286 | 287 | | (T.Con (c, ts), T.Con (c', ts')) => if c = c' 288 | then unify' ((map (fn (t, t') => {lhs = t, rhs = t'}) (ListPair.zip (ts, ts'))) @ stack, acc) 289 | else raise TypeError 290 | | _ => raise TypeError) 291 | in 292 | unify' (Constraint.Set.listItems constrs, StringMap.empty) 293 | end 294 | 295 | fun applySubToAST (e : typed E.t, sub : T.t StringMap.map) = 296 | let 297 | fun getType (tv, sub) = 298 | case StringMap.find (sub, tv) of 299 | SOME ty => ty 300 | | NONE => T.Var tv 301 | in 302 | case e of 303 | E.Num ({typ = T.Var tv, pos}, n) => E.Num ({typ = getType (tv, sub), pos = pos}, n) 304 | | E.Num _ => e 305 | 306 | | E.Bool ({typ = T.Var tv, pos}, b) => E.Bool ({typ = getType (tv, sub), pos=pos}, b) 307 | | E.Bool _ => e 308 | 309 | | E.Id ({typ = T.Var tv, pos}, x) => E.Id ({typ = getType (tv, sub), pos = pos}, x) 310 | | E.Id _ => e 311 | 312 | | E.App ({typ = T.Var tv, pos}, f, a) => E.App ({typ = getType (tv, sub), pos = pos}, applySubToAST (f, sub), applySubToAST (a, sub)) 313 | | E.App _ => e 314 | 315 | | E.If ({typ = T.Var tv, pos}, e1, e2, e3) => E.If ({typ=getType (tv, sub), pos=pos}, applySubToAST (e1, sub), applySubToAST (e2, sub), applySubToAST (e3, sub)) 316 | | E.If _ => e 317 | 318 | | E.Fn ({typ = T.Var tv1, pos = p1}, {typ = T.Var tv2, pos = p2}, x, e) => E.Fn ({typ = getType (tv1, sub), pos = p1}, 319 | {typ = getType (tv2, sub), pos=p2}, x, applySubToAST (e, sub)) 320 | | E.Fn _ => e 321 | 322 | | E.Tuple ({typ = T.Var tv, pos}, es) => E.Tuple ({typ = getType (tv, sub), pos = pos}, map (fn e => applySubToAST (e, sub)) es) 323 | | E.Tuple (typed, es) => E.Tuple (typed, map (fn e => applySubToAST (e, sub)) es) 324 | 325 | | E.Case ({typ = T.Var tv, pos}, e1, es) => 326 | E.Case ({typ = getType (tv, sub), pos = pos}, applySubToAST (e1, sub), map (fn (p, e) => (p, applySubToAST (e, sub))) es) 327 | | E.Case (typed, e1, es) => E.Case (typed, applySubToAST (e1, sub), map (fn (p, e) => (p, applySubToAST (e, sub))) es) 328 | 329 | | E.Infix ({typ = T.Var tv, pos}, oper, e1, e2) => 330 | E.Infix ({typ = getType (tv, sub), pos = pos}, oper, applySubToAST (e1, sub), applySubToAST (e2, sub)) 331 | | E.Infix (typed, oper, e1, e2) => E.Infix (typed, oper, applySubToAST (e1, sub), applySubToAST (e2, sub)) 332 | 333 | | E.Let _ => raise CompilerBug "(Typecheck.applySubToAst) not implemented yet: let" 334 | end 335 | 336 | local 337 | val numOp = T.Arrow (T.Tuple [T.Num, T.Num], T.Num) 338 | in 339 | val initEnv = foldl Env.insert' Env.empty [("+", numOp), ("-", numOp), ("*", numOp), ("/", numOp)] 340 | end 341 | fun inferExpr (env : T.t Env.map, e : AST.pos E.t) : typed E.t = 342 | (reset (); 343 | let 344 | val ast = assignTypeVars (env, e) 345 | val constraints = genCon (env, ast, Constraint.Set.empty) 346 | val substitution = unify constraints 347 | in 348 | applySubToAST (ast, substitution) 349 | end) 350 | 351 | fun inferDecl (env : T.t Env.map, d : (AST.pos, AST.pos) AST.Decl.t) : ((typed, AST.pos) AST.Decl.t * T.t Env.map) = 352 | case d of 353 | AST.Decl.Val (p, x, e) => 354 | let 355 | val tyvar = T.Var (gensym ()) 356 | val ast = assignTypeVars (Env.insert (env, x, tyvar), e) 357 | val constraints = genCon (env, ast, Constraint.Set.empty) 358 | val substitution = unify (Constraint.Set.add (constraints, {lhs = tyvar, rhs = gettyp ast})) 359 | 360 | val typedExpr = applySubToAST (ast, substitution) 361 | val typ = gettyp typedExpr 362 | in 363 | (AST.Decl.Val (p, x, typedExpr), Env.insert (env, x, typ)) 364 | end 365 | | d as AST.Decl.Data (p, vars, name, ctors) => 366 | let 367 | (* TODO: check vars *) 368 | val typ = Type.Con (name, (map Type.Var vars)) 369 | (* TODO: check ctors *) 370 | fun ctor (name, NONE) = (name, typ) 371 | | ctor (name, SOME t) = (name, Type.Arrow (Type.fromAST t, typ)) 372 | in 373 | (AST.Decl.Data (p, vars, name, ctors), 374 | foldl (fn ((k, v), acc) => Env.insert (acc, k, v)) env (map ctor ctors)) 375 | end 376 | 377 | fun inferPgm (p : (AST.pos, AST.pos) AST.Pgm.t) : (typed, AST.pos) AST.Pgm.t = 378 | let 379 | fun infer (d, (ds, env)) = 380 | let 381 | val (d', env') = inferDecl (env, d) 382 | in 383 | (d' :: ds, env') 384 | end 385 | val (ds, env) = foldl infer ([], initEnv) p 386 | in 387 | List.rev ds 388 | end 389 | end 390 | -------------------------------------------------------------------------------- /tests/desugar.sml: -------------------------------------------------------------------------------- 1 | structure DesugarTests = 2 | struct 3 | 4 | open QCheck 5 | open Desugar 6 | structure E = AST.Expr 7 | structure M = AST.Expr.Mono 8 | structure Pat = AST.Pattern.Complex 9 | 10 | local 11 | val eqxn = Show.pair (Show.list Pat.show, E.show) 12 | in 13 | fun test _ = ( 14 | check (List.getItem, SOME (Show.pair (Show.pair (Show.string, Show.list eqxn), 15 | Show.list eqxn))) 16 | ("desugar/subpats", pred (fn (inp, out) => out = Desugar.subpats inp)) 17 | [ 18 | (("Cons", [([Pat.Ctor ("Cons", [Pat.Var "x", Pat.Var "xs"])], E.Num ((), 0)), 19 | ([Pat.Ctor ("Cons", [Pat.Var "x", Pat.Ctor ("Cons", [Pat.Var "y", Pat.Var "z"])])], E.Num ((), 1))]), 20 | [([Pat.Var "x", Pat.Var "xs"], E.Num ((), 0)), 21 | ([Pat.Var "x", Pat.Ctor ("Cons", [Pat.Var "y", Pat.Var "z"])], E.Num ((), 1))]) 22 | 23 | , (("Branch", [([Pat.Ctor ("Branch", [Pat.Var "t1", Pat.Var "t2"])], E.Num ((), 0)), 24 | ([Pat.Ctor ("Branch", [Pat.Ctor ("Leaf", [Pat.Var "x"]), Pat.Ctor ("Leaf", [Pat.Var "y"])])], E.Num ((), 1))]), 25 | [([Pat.Var "t1", Pat.Var "t2"], E.Num ((), 0)), 26 | ([Pat.Ctor ("Leaf", [Pat.Var "x"]), Pat.Ctor ("Leaf", [Pat.Var "y"])], E.Num ((), 1))]) 27 | ]) 28 | 29 | end 30 | 31 | end 32 | -------------------------------------------------------------------------------- /tests/legacy.sml: -------------------------------------------------------------------------------- 1 | (* Our parser requires the lexer to fully tokenize the input and give 2 | * it a list of tokens. Eventually this will be changed to take a 3 | * reader (lexer) * and a stream *) 4 | structure Legacy = 5 | struct 6 | fun lexStr s = Reader.consume (Lexer.make (Pos.reader Reader.string)) (Pos.stream s) 7 | end 8 | -------------------------------------------------------------------------------- /tests/lexer.sml: -------------------------------------------------------------------------------- 1 | structure LexerTests = 2 | struct 3 | 4 | open QCheck 5 | structure T = Token 6 | 7 | (* 8 | * Compare Pos.t with {line: int, col: int} 9 | *) 10 | fun posEq (pos, {line, col}) = 11 | Pos.line pos = line andalso Pos.col pos = col 12 | 13 | val tokEq: (T.t * Pos.t) * (T.t * {line: int, col: int}) -> bool = 14 | fn ((t1, p1), (t2, p2)) => T.eq (t1, t2) andalso posEq (p1, p2) 15 | 16 | val verbose = false 17 | fun showPos {line: int, col: int} = 18 | if verbose then 19 | "{" ^ Int.toString line ^ "," ^ Int.toString col ^ "}" 20 | else "_" 21 | 22 | val show = (Show.pair (Show.string, Show.list (Show.pair (T.show, showPos)))) 23 | 24 | fun test _ = 25 | check (List.getItem, SOME show) 26 | ("lexer", pred (fn (s, toks) => ListPair.allEq tokEq (Legacy.lexStr s, toks))) 27 | [ 28 | ("0", [(T.Num 0, {line=1,col=0})]) 29 | 30 | ,("fn x=>x", 31 | [ 32 | (T.Fn, {line=1,col=0}), 33 | (T.Id "x", {line=1,col=3}), 34 | (T.DArrow, {line=1,col=4}), 35 | (T.Id "x", {line=1,col=6}) 36 | ]) 37 | 38 | ,("fn (* comment *) x=>x", 39 | [ 40 | (T.Fn, {line=1,col=0}), 41 | (T.Id "x", {line=1,col=17}), 42 | (T.DArrow, {line=1,col=18}), 43 | (T.Id "x", {line=1,col=20}) 44 | ]) 45 | 46 | ,("fn (* one comment *) (* another comment *) x=>x", 47 | [ 48 | (T.Fn, {line=1,col=0}), 49 | (T.Id "x", {line=1,col=43}), 50 | (T.DArrow, {line=1,col=44}), 51 | (T.Id "x", {line=1,col=46}) 52 | ]) 53 | 54 | ,("fn (* multi-line \n comment *) x=>x", 55 | [ 56 | (T.Fn, {line=1,col=0}), 57 | (T.Id "x", {line=2,col=12}), 58 | (T.DArrow, {line=2,col=13}), 59 | (T.Id "x", {line=2,col=15}) 60 | ]) 61 | 62 | ,("fn x => x", 63 | [ 64 | (T.Fn, {line=1,col=0}), 65 | (T.Id "x", {line=1,col=3}), 66 | (T.DArrow, {line=1,col=5}), 67 | (T.Id "x", {line=1,col=8}) 68 | ]) 69 | 70 | ,("if 1 then 2 else 3", 71 | [ 72 | (T.If, {line=1,col=0}), 73 | (T.Num 1, {line=1,col=3}), 74 | (T.Then, {line=1,col=5}), 75 | (T.Num 2, {line=1,col=10}), 76 | (T.Else, {line=1,col=12}), 77 | (T.Num 3, {line=1,col=17}) 78 | ]) 79 | 80 | ,("if foo then bar else baz", 81 | [ 82 | (T.If, {line=1,col=0}), 83 | (T.Id "foo", {line=1,col=3}), 84 | (T.Then, {line=1,col=7}), 85 | (T.Id "bar", {line=1,col=12}), 86 | (T.Else, {line=1,col=16}), 87 | (T.Id "baz", {line=1,col=21}) 88 | ]) 89 | 90 | ,("let x = 0 in x + x", 91 | [ 92 | (T.Let, {line=1,col=0}), 93 | (T.Id "x", {line=1,col=4}), 94 | (T.Eqls, {line=1,col=6}), 95 | (T.Num 0, {line=1,col=8}), 96 | (T.In, {line=1,col=10}), 97 | (T.Id "x", {line=1,col=13}), 98 | (T.Infix "+", {line=1,col=15}), 99 | (T.Id "x", {line=1,col=17}) 100 | ]) 101 | 102 | ,("let x=0 in x + x", 103 | [ 104 | (T.Let, {line=1,col=0}), 105 | (T.Id "x", {line=1,col=4}), 106 | (T.Eqls, {line=1,col=5}), 107 | (T.Num 0, {line=1,col=6}), 108 | (T.In, {line=1,col=8}), 109 | (T.Id "x", {line=1,col=11}), 110 | (T.Infix "+", {line=1,col=13}), 111 | (T.Id "x", {line=1,col=15}) 112 | ]) 113 | 114 | ,("case x of (Nil) => 0 | (Cons y ys) => 1", 115 | [ 116 | (T.Case, {line=1,col=0}), 117 | (T.Id "x", {line=1,col=5}), 118 | (T.Of, {line=1,col=7}), 119 | (T.LParen, {line=1,col=10}), 120 | (T.Ctor "Nil", {line=1,col=11}), 121 | (T.RParen, {line=1,col=14}), 122 | (T.DArrow, {line=1,col=16}), 123 | (T.Num 0, {line=1,col=19}), 124 | (T.Bar, {line=1,col=21}), 125 | (T.LParen, {line=1,col=23}), 126 | (T.Ctor "Cons", {line=1,col=24}), 127 | (T.Id "y", {line=1,col=29}), 128 | (T.Id "ys", {line=1,col=31}), 129 | (T.RParen, {line=1,col=33}), 130 | (T.DArrow, {line=1,col=35}), 131 | (T.Num 1, {line=1,col=38}) 132 | ]) 133 | 134 | ,("case x of 1 => 1 | 2 => 2", 135 | [ 136 | (T.Case, {line=1,col=0}), 137 | (T.Id "x", {line=1,col=5}), 138 | (T.Of, {line=1,col=7}), 139 | (T.Num 1, {line=1,col=10}), 140 | (T.DArrow, {line=1,col=12}), 141 | (T.Num 1, {line=1,col=15}), 142 | (T.Bar, {line=1,col=17}), 143 | (T.Num 2, {line=1,col=19}), 144 | (T.DArrow, {line=1,col=21}), 145 | (T.Num 2, {line=1,col=24}) 146 | ]) 147 | 148 | ,("datatype 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree", 149 | [ 150 | (T.Datatype, {line=1,col=0}), 151 | (T.TypeVar "a", {line=1,col=9}), 152 | (T.Id "tree", {line=1,col=12}), 153 | (T.Eqls, {line=1,col=17}), 154 | (T.Ctor "Leaf", {line=1,col=19}), 155 | (T.Of, {line=1,col=24}), 156 | (T.TypeVar "a", {line=1,col=27}), 157 | (T.Bar, {line=1,col=30}), 158 | (T.Ctor "Branch", {line=1,col=32}), 159 | (T.Of, {line=1,col=39}), 160 | (T.TypeVar "a", {line=1,col=42}), 161 | (T.Id "tree", {line=1,col=45}), 162 | (T.Infix "*", {line=1,col=50}), 163 | (T.TypeVar "a", {line=1,col=52}), 164 | (T.Id "tree", {line=1,col=55}) 165 | ]) 166 | ] 167 | 168 | end 169 | -------------------------------------------------------------------------------- /tests/main.sml: -------------------------------------------------------------------------------- 1 | structure Main = 2 | struct 3 | fun main _ = ( 4 | LexerTests.test () 5 | ; ParserTests.test () 6 | ; TypeInfTests.test () 7 | ; OS.Process.success 8 | ) 9 | end 10 | -------------------------------------------------------------------------------- /tests/parser.sml: -------------------------------------------------------------------------------- 1 | structure ParserTests = 2 | struct 3 | open QCheck 4 | structure E = MonoAST.Expr 5 | structure T = MonoAST.Type 6 | structure D = MonoAST.Decl 7 | structure P = AST.Pattern.Complex 8 | structure Pgm = MonoAST.Pgm 9 | 10 | (* Partial parsers that blow up on failures instead of returning an option type *) 11 | val lexer = Lexer.make (Pos.reader Reader.string) 12 | fun makePartial makeParser s = Reader.partial (makeParser lexer) (Pos.stream s) 13 | fun parseDecl s = makePartial Parser.makeDecl s 14 | fun parseExpr s = makePartial Parser.makeExpr s 15 | fun parseType s = makePartial Parser.makeType s 16 | 17 | fun test _ = 18 | let 19 | fun pgm name = check (List.getItem, SOME (Show.pair (fn x => x, Pgm.show))) 20 | (name, pred (fn (s, ast) => (Pgm.make (Parser.parse lexer (Pos.stream s))) = ast)) 21 | 22 | fun decl name = check (List.getItem, SOME (Show.pair (fn x => x, D.show))) 23 | (name, pred (fn (s, ast) => (MonoAST.Decl.make (parseDecl s)) = ast)) 24 | 25 | fun expr name = check (List.getItem, SOME (Show.pair (fn x => x, E.show))) 26 | (name, pred (fn (s, ast) => (MonoAST.Expr.make (parseExpr s)) = ast)) 27 | 28 | fun type' name = check (List.getItem, SOME (Show.pair (fn x => x, T.show))) 29 | (name, pred (fn (s, ast) => (MonoAST.Type.make (parseType s)) = ast)) 30 | in 31 | ( 32 | expr "parser/exprs" 33 | [ 34 | ("0", E.Num 0) 35 | ,("foo", E.Id "foo") 36 | ,("1 + 2", E.Infix ("+", E.Num 1, E.Num 2)) 37 | ,("1 * 2 + 3", E.Infix ("+", E.Infix ("*", E.Num 1, E.Num 2), E.Num 3)) 38 | ,("1 - 2 / 3", E.Infix ("-", E.Num 1, E.Infix ("/", E.Num 2, E.Num 3))) 39 | ,("(1 - 2) * 3", E.Infix ("*", E.Infix ("-", E.Num 1, E.Num 2), E.Num 3)) 40 | ,("(1 - 2) * (3)", E.Infix ("*", E.Infix ("-", E.Num 1, E.Num 2), E.Num 3)) 41 | ,("(bar - 2) / foo", E.Infix ("/", E.Infix ("-", E.Id "bar", E.Num 2), E.Id "foo")) 42 | ,("1 - 2 + 3 - 4", E.Infix ("-", E.Infix ("+", E.Infix ("-", E.Num 1, E.Num 2), E.Num 3), E.Num 4)) 43 | ] 44 | ; expr "parser/fns" 45 | [ 46 | ("fn x=>x", E.Fn ("x", E.Id "x")) 47 | ,("fn x => fn y => y", E.Fn ("x", E.Fn ("y", E.Id "y"))) 48 | ,("fn x => x + x", E.Fn ("x", E.Infix ("+", E.Id "x", E.Id "x"))) 49 | ,("fn x=>x+x", E.Fn ("x", E.Infix ("+", E.Id "x", E.Id "x"))) 50 | ] 51 | ; expr "parser/parens" 52 | [ 53 | ("(1)", E.Num 1) 54 | ,("(x)", E.Id "x") 55 | ,("(true)", E.Bool true) 56 | ,("if (true) then (x) else ((y))",E.If (E.Bool true, E.Id "x", E.Id "y")) 57 | ] 58 | ; expr "parser/tuples" 59 | [ 60 | ("(1, 2)", E.Tuple [E.Num 1, E.Num 2]) 61 | ,("(1, 2, 3)", E.Tuple [E.Num 1, E.Num 2, E.Num 3]) 62 | ,("(true, 2, fn x => x)", E.Tuple [E.Bool true, E.Num 2, E.Fn ("x", E.Id "x")]) 63 | ] 64 | ; expr "parser/app" 65 | [ 66 | ("x y", E.App (E.Id "x", E.Id "y")) 67 | ,("(x y)", E.App (E.Id "x", E.Id "y")) 68 | ,("(fn x => x) 1", E.App (E.Fn ("x", E.Id "x"), E.Num 1)) 69 | ,("(fn f => f 1)", E.Fn ("f", E.App (E.Id "f", E.Num 1))) 70 | ,("if not true then false else true", E.If (E.App (E.Id "not", E.Bool true), E.Bool false, E.Bool true)) 71 | ,("if true then not false else true", E.If (E.Bool true, E.App (E.Id "not", E.Bool false), E.Bool true)) 72 | ,("if true then false else not true", E.If (E.Bool true, E.Bool false, E.App (E.Id "not", E.Bool true))) 73 | ,("let val f = fn x => x in f 1 end", E.Let ("f", E.Fn ("x", E.Id "x"), E.App (E.Id "f", E.Num 1))) 74 | 75 | (* function application has higher prec than infix arith operators *) 76 | ,("f x + g y", E.Infix ("+", E.App (E.Id "f", E.Id "x"), E.App (E.Id "g", E.Id "y"))) 77 | ,("f x + g y * h z", E.Infix ("+", E.App (E.Id "f", E.Id "x"), E.Infix ("*", E.App (E.Id "g", E.Id "y"), E.App (E.Id "h", E.Id "z")))) 78 | ] 79 | ; expr "parser/case" 80 | [ 81 | ("case f x of y => 0 | z => 1", E.Case (E.App (E.Id "f", E.Id "x"), [(P.Var "y", E.Num 0), (P.Var "z", E.Num 1)])) 82 | ,("case x of y => if y then 1 else 2", E.Case (E.Id "x", [(P.Var "y", E.If (E.Id "y", E.Num 1, E.Num 2))])) 83 | ,("case (x) of y => (if y then 1 else 2)", E.Case (E.Id "x", [(P.Var "y", E.If (E.Id "y", E.Num 1, E.Num 2))])) 84 | 85 | ,("case x of Nil => 0 | Cons (y, ys) => 1", 86 | E.Case (E.Id "x", [(P.Ctor ("Nil", NONE), E.Num 0), (P.Ctor ("Cons", SOME (P.Tuple [P.Var "y", P.Var "ys"])), E.Num 1)])) 87 | 88 | ,("case x of (Nil) => 0 | Cons (y, ys) => 1", 89 | E.Case (E.Id "x", [(P.Ctor ("Nil", NONE), E.Num 0), (P.Ctor ("Cons", SOME (P.Tuple [P.Var "y", P.Var "ys"])), E.Num 1)])) 90 | 91 | ,("case f x of y => g y | z => h z", 92 | E.Case (E.App (E.Id "f", E.Id "x"), [(P.Var "y", E.App (E.Id "g", E.Id "y")), (P.Var "z", E.App (E.Id "h", E.Id "z"))])) 93 | 94 | ,("case x of\n Nil => 0\n | Cons (y, Nil) => 1\n | Cons (y, ys) => 2\n", 95 | E.Case (E.Id "x", [ 96 | (P.Ctor ("Nil", NONE), E.Num 0) 97 | ,(P.Ctor ("Cons", SOME (P.Tuple [P.Var "y", P.Ctor ("Nil", NONE)])), E.Num 1) 98 | ,(P.Ctor ("Cons", SOME (P.Tuple [P.Var "y", P.Var "ys"])), E.Num 2)])) 99 | ] 100 | 101 | ; type' "parser/type" 102 | [ 103 | ("'a", T.Var "a") 104 | ,("'a list tree", T.Con ("tree", [T.Con ("list", [T.Var "a"])])) 105 | ,("'a list", T.Con ("list", [T.Var "a"])) 106 | (* ,("('a, 'b) either", ... ) *) 107 | 108 | ,("'a * 'b", T.Tuple [T.Var "a", T.Var "b"]) 109 | ,("'a * 'b * 'c", T.Tuple [T.Var "a", T.Var "b", T.Var "c"]) 110 | ,("('a)", T.Paren (T.Var "a")) 111 | ,("('a * 'b) * 'c", T.Tuple [T.Paren (T.Tuple [T.Var "a", T.Var "b"]), T.Var "c"]) 112 | ,("'a * ('b * 'c)", T.Tuple [T.Var "a", T.Paren (T.Tuple [T.Var "b", T.Var "c"])]) 113 | 114 | (* ctor app has higher prec than * (tuple op) *) 115 | ,("'a list * 'b", T.Tuple [T.Con ("list", [T.Var "a"]), T.Var "b"]) 116 | ,("'a * 'b list", T.Tuple [T.Var "a", T.Con ("list", [T.Var "b"])]) 117 | ,("('a * 'b) list", T.Con ("list", [T.Paren (T.Tuple [T.Var "a", T.Var "b"])])) 118 | 119 | (* ... and higher prec than -> (arrow) *) 120 | ,("'a list -> 'a", T.Arrow (T.Con ("list", [T.Var "a"]), T.Var "a")) 121 | ,("'a -> 'a list", T.Arrow (T.Var "a", T.Con ("list", [T.Var "a"]))) 122 | ,("('a -> 'a) list", T.Con ("list", [T.Paren (T.Arrow (T.Var "a", T.Var "a"))])) 123 | 124 | (* arrow associates to the right *) 125 | ,("'a -> 'a", T.Arrow (T.Var "a", T.Var "a")) 126 | ,("'a -> 'a -> 'a", T.Arrow (T.Var "a", T.Arrow (T.Var "a", T.Var "a"))) 127 | ,("('a -> 'a) -> 'a", T.Arrow (T.Paren (T.Arrow (T.Var "a", T.Var "a")), T.Var "a")) 128 | ,("('a -> 'a) -> 'a -> 'a", T.Arrow (T.Paren (T.Arrow (T.Var "a", T.Var "a")), T.Arrow (T.Var "a", T.Var "a"))) 129 | 130 | ,("'a * 'b -> 'c", T.Arrow (T.Tuple [T.Var "a", T.Var "b"], T.Var "c")) 131 | ,("('a * 'b) -> 'c", T.Arrow (T.Paren (T.Tuple [T.Var "a", T.Var "b"]), T.Var "c")) 132 | ,("'a * ('b -> 'c)", T.Tuple [T.Var "a", T.Paren (T.Arrow (T.Var "b", T.Var "c"))]) 133 | 134 | (* tyseqs *) 135 | ,("('a) list", T.Con ("list", [T.Paren (T.Var "a")])) 136 | ,("('a, 'b) either", T.Con ("either", [T.Var "a", T.Var "b"])) 137 | ,("('a, 'b, 'c) foo", T.Con ("foo", [T.Var "a", T.Var "b", T.Var "c"])) 138 | ,("('a, 'b, 'c, 'd, 'e, 'f) bar", T.Con ("bar", [T.Var "a", T.Var "b", T.Var "c", T.Var "d", T.Var "e", T.Var "f"])) 139 | 140 | (* nullary tycons *) 141 | ,("int", T.Con ("int", [])) 142 | ,("int list", T.Con ("list", [T.Con ("int", [])])) 143 | ] 144 | 145 | ; decl "parser/val" 146 | [ 147 | ("val x = 1", D.Val ("x", E.Num 1)) 148 | ,("val xx = 1 + 2 + 3", D.Val ("xx", E.Infix ("+", E.Infix ("+", E.Num 1, E.Num 2), E.Num 3))) 149 | ,("val y = 1 + 2 * 3", D.Val ("y", E.Infix ("+", E.Num 1, E.Infix ("*", E.Num 2, E.Num 3)))) 150 | ,("val yy = 1 * 2 + 3", D.Val ("yy", E.Infix ("+", E.Infix ("*", E.Num 1, E.Num 2), E.Num 3))) 151 | ,("val z = (1 + 2) * 3", D.Val ("z", E.Infix ("*", E.Infix ("+", E.Num 1, E.Num 2), E.Num 3))) 152 | ,("val zz = 1 * (2 + 3)", D.Val ("zz", E.Infix ("*", E.Num 1, E.Infix ("+", E.Num 2, E.Num 3)))) 153 | 154 | ,("val f = fn x => x", D.Val ("f", E.Fn ("x", E.Id "x"))) 155 | ,("val ff = fn x => (x)", D.Val ("ff", E.Fn ("x", E.Id "x"))) 156 | ,("val fff = (fn x => x)", D.Val ("fff", E.Fn ("x", E.Id "x"))) 157 | ,("val g = fn z => fn y => fn x => x", D.Val ("g", E.Fn ("z", E.Fn ("y", E.Fn ("x", E.Id "x"))))) 158 | ,("val gg = (fn z => (fn y => (fn x => (x))))", D.Val ("gg", E.Fn ("z", E.Fn ("y", E.Fn ("x", E.Id "x"))))) 159 | 160 | ,("val m = let val x = 1 in x end ", D.Val ("m", E.Let ("x", E.Num 1, E.Id "x"))) 161 | ,("val mm = let val id = fn x => x in id end ", D.Val ("mm", E.Let ("id", E.Fn ("x", E.Id "x"), E.Id "id"))) 162 | 163 | ,("val a = if true then false else true", D.Val ("a", E.If (E.Bool true, E.Bool false, E.Bool true))) 164 | ,("val aa = if (true) then (false) else (true)", D.Val ("aa", E.If (E.Bool true, E.Bool false, E.Bool true))) 165 | ,("val b = if true then if false then true else false else true", D.Val ("b", E.If (E.Bool true, E.If (E.Bool false, E.Bool true, E.Bool false), E.Bool true))) 166 | 167 | ,("val bb = if (true) then (if (false) then (true) else (false)) else (true)", 168 | D.Val ("bb", E.If (E.Bool true, E.If (E.Bool false, E.Bool true, E.Bool false), E.Bool true))) 169 | 170 | 171 | ,("val q = case x of\n Nil => 0\n | Cons (y, Nil) => 1\n | Cons (y, ys) => 2\n", 172 | D.Val ("q", E.Case (E.Id "x", [(P.Ctor ("Nil", NONE), E.Num 0) 173 | ,(P.Ctor ("Cons", SOME (P.Tuple [P.Var "y", P.Ctor ("Nil", NONE)])), E.Num 1) 174 | ,(P.Ctor ("Cons", SOME (P.Tuple [P.Var "y", P.Var "ys"])), E.Num 2)]))) 175 | ,("val qq = case x of y => if y then 1 else 2", D.Val ("qq", E.Case (E.Id "x", [(P.Var "y", E.If (E.Id "y", E.Num 1, E.Num 2))]))) 176 | 177 | ,("val u = x y", D.Val ("u", E.App (E.Id "x", E.Id "y"))) 178 | ,("val uu = (x y)", D.Val ("uu", E.App (E.Id "x", E.Id "y"))) 179 | ,("val v = let val f = fn x => x in f end 1", D.Val ("v", E.App (E.Let ("f", E.Fn ("x", E.Id "x"), E.Id "f"), E.Num 1))) 180 | ,("val vv = let val f = fn x => x in f end let val x = 2 in x end", D.Val ("vv", E.App (E.Let ("f", E.Fn ("x", E.Id "x"), E.Id "f"), 181 | E.Let ("x", E.Num 2, E.Id "x")))) 182 | ] 183 | 184 | ; decl "parser/data" 185 | [ 186 | ("datatype color = Red | Blue | Green", 187 | D.Data ([], "color", [("Red", NONE), ("Blue", NONE), ("Green", NONE)])) 188 | 189 | ,("datatype foo = Bar", 190 | D.Data ([], "foo", [("Bar", NONE)])) 191 | 192 | ,("datatype 'a list1 = Cons of 'a * 'a list1 | Nil", 193 | D.Data (["a"], "list1", [("Cons", SOME (T.Tuple [T.Var "a", T.Con ("list1", [T.Var "a"])])), ("Nil", NONE)])) 194 | 195 | ,("datatype 'a list2 = Nil | Cons of 'a * 'a list2", 196 | D.Data (["a"], "list2", [("Nil", NONE), ("Cons", SOME (T.Tuple [T.Var "a", T.Con ("list2", [T.Var "a"])]))])) 197 | 198 | ,("datatype 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree", 199 | D.Data (["a"], "tree", [("Leaf", SOME (T.Var "a")), ("Branch", SOME (T.Tuple [T.Con ("tree", [T.Var "a"]), T.Con ("tree", [T.Var "a"])]))])) 200 | 201 | ,("datatype 'a option = None | Some of 'a", 202 | D.Data (["a"], "option", [("None", NONE), ("Some", SOME (T.Var "a"))])) 203 | 204 | ,("datatype ('a, 'b) either = Left of 'a | Right of 'b", 205 | D.Data (["a", "b"], "either", [("Left", SOME (T.Var "a")), ("Right", SOME (T.Var "b"))])) 206 | ] 207 | 208 | ; pgm "parser/pgm" 209 | [ 210 | ("val id = fn x => x", [D.Val ("id", E.Fn ("x", E.Id "x"))]) 211 | ,("datatype foo = Bar", [D.Data ([], "foo", [("Bar", NONE)])]) 212 | ,("val id = fn x => x\ndatatype foo = Bar", [D.Val ("id", E.Fn ("x", E.Id "x")),D.Data ([], "foo", [("Bar", NONE)])]) 213 | ] 214 | ) 215 | end 216 | 217 | end 218 | -------------------------------------------------------------------------------- /tests/typeinf.sml: -------------------------------------------------------------------------------- 1 | structure TypeInfTests = 2 | struct 3 | 4 | open QCheck infix ==> 5 | 6 | structure T = Type 7 | 8 | (* Partial parser that blows up on failure instead of returning an option type *) 9 | val lexer = Lexer.make (Pos.reader Reader.string) 10 | fun parseExpr s = Reader.partial (Parser.makeExpr lexer) s 11 | 12 | (* Parse an expression, and return the fully annotated AST *) 13 | fun infer s = Typecheck.inferExpr (Typecheck.initEnv, parseExpr (Pos.stream s)) 14 | 15 | (* Parse an expression, and return the type of that expression *) 16 | fun typeOf s = 17 | Type.normalize (Typecheck.gettyp (infer s)) 18 | 19 | fun test _ = ( 20 | check (List.getItem, SOME (Show.pair (T.show, fn x => x))) 21 | ("typeOf", pred (fn (ty, s) => ty = typeOf s)) 22 | [ 23 | (* literals, arith infix *) 24 | (T.Num, "0") 25 | ,(T.Num, "123") 26 | ,(T.Bool, "true") 27 | ,(T.Bool, "false") 28 | ,(T.Num, "0 + 1") 29 | ,(T.Num, "0 - 1") 30 | 31 | (* tuples *) 32 | ,(T.Tuple [T.Num, T.Num], "(1, 2)") 33 | ,(T.Tuple [T.Bool, T.Num, T.Bool], "(true, 2, false)") 34 | 35 | (* if *) 36 | ,(T.Num, "if true then 0 else 1") 37 | ,(T.Bool, "if true then true else false") 38 | 39 | (* functions *) 40 | ,(T.Arrow (T.Bool, T.Num), "fn x => if x then 0 else 1") 41 | ,(T.Arrow (T.Num, T.Num), "fn x => x + x") 42 | ,(T.Arrow (T.Var "a", T.Var "a"), "fn x => x") 43 | 44 | (* nested functions *) 45 | ,(T.Arrow (T.Var "a", T.Arrow (T.Var "b", T.Var "b")), "fn x => fn y => y") 46 | ,(T.Arrow (T.Var "a", T.Arrow (T.Var "b", T.Var "a")), "fn x => fn y => x") 47 | 48 | (* application *) 49 | ,(T.Num, "(fn x => x) 0") 50 | 51 | (* ,(T.List T.Num, S.Cons (S.Num 0, S.Nil)) *) 52 | (* ,(T.List T.Num, S.Tl (S.Cons (S.Num 0, S.Nil))) *) 53 | (* ,(T.Num, S.Hd (S.Cons (S.Num 0, S.Nil))) *) 54 | (* ,(T.Bool, S.IsNil (S.Cons (S.Num 0, S.Nil))) *) 55 | (* ,(T.Arrow (T.Var "a", T.List (T.Var "a")), S.Fun ("x", S.Cons (S.Id "x", S.Nil))) *) 56 | 57 | (* (* map : (a -> b) -> [a] -> [b] *) *) 58 | (* ,(T.Arrow (T.Arrow (T.Var "a", T.Var "b"), T.Arrow (T.List (T.Var "a"), T.List (T.Var "b"))), *) 59 | (* S.Rec ("map", *) 60 | (* S.Fun ("f", *) 61 | (* S.Fun ("l", *) 62 | (* S.If (S.IsNil (S.Id "l"), *) 63 | (* S.Nil, *) 64 | (* (S.Cons (S.App (S.Id "f", (S.Hd (S.Id "l"))), *) 65 | (* S.apply (S.Id "map", [S.Id "f", S.Tl (S.Id "l")])))))))) *) 66 | 67 | (* (* reduce : (a -> b -> b) -> b -> [a] -> b *) *) 68 | (* ,(T.Arrow (T.Arrow (T.Var "a", T.Arrow (T.Var "b", T.Var "b")), T.Arrow (T.Var "b", T.Arrow (T.List (T.Var "a"), T.Var "b"))), *) 69 | (* S.Rec ("reduce", *) 70 | (* S.Fun ("f", *) 71 | (* S.Fun ("acc", *) 72 | (* S.Fun ("l", *) 73 | (* S.If (S.IsNil (S.Id "l"), *) 74 | (* S.Id "acc", *) 75 | (* S.apply (S.Id "reduce", [S.Id "f", S.apply (S.Id "f", [S.Hd (S.Id "l"), S.Id "acc"]), S.Tl (S.Id "l")]))))))) *) 76 | (* (* filter : (a -> bool) -> [a] -> [a] *) *) 77 | (* ,(T.Arrow (T.Arrow (T.Var "a", T.Bool), (T.Arrow (T.List (T.Var "a"), T.List (T.Var "a")))), *) 78 | (* S.Rec ("filter", *) 79 | (* S.Fun ("f", *) 80 | (* S.Fun ("l", *) 81 | (* S.If (S.App (S.Id "f", S.Hd (S.Id "l")), *) 82 | (* S.apply (S.Id "filter", [S.Id "f", S.Tl (S.Id "l")]), *) 83 | (* S.Cons (S.Hd (S.Id "l"), S.apply (S.Id "filter", [S.Id "f", S.Tl (S.Id "l")]))))))) *) 84 | ]) 85 | 86 | end 87 | --------------------------------------------------------------------------------