diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Compiler.sml | 4 | ||||
| -rw-r--r-- | Elab.sml | 306 | ||||
| -rw-r--r-- | Parser.sml | 34 | ||||
| -rw-r--r-- | ShowSyntax.sml | 92 | ||||
| -rw-r--r-- | Syntax.sml | 56 | ||||
| -rw-r--r-- | Types.sml | 464 | ||||
| -rw-r--r-- | generate-show-syntax.sml | 41 | ||||
| -rw-r--r-- | main.sml | 5 | ||||
| -rw-r--r-- | program.cm | 4 | ||||
| -rw-r--r-- | run-tests.fish | 12 |
11 files changed, 793 insertions, 226 deletions
@@ -1 +1,2 @@ a.out +.cm diff --git a/Compiler.sml b/Compiler.sml index 0ca0ee5..539d334 100644 --- a/Compiler.sml +++ b/Compiler.sml @@ -3,7 +3,9 @@ struct fun compile (prog : Syntax.expr) : Word8Vector.vector = let val _ = print ("ast:\n" ^ ShowSyntax.exprToString prog ^ "\n") - val elab = Elab.elaborate prog + val typed as (typedAST, _) = Types.tag prog + val _ = print ("typed AST:\n" ^ ShowSyntax.typedExprToString typedAST ^ "\n") + val elab = Elab.elaborate typed val _ = print ("lambda lang:\n" ^ ShowSyntax.lexpToString elab ^ "\n") val cps = CPS.toCPS elab @@ -35,80 +35,42 @@ struct NONE => [] | SOME (heads, tails) => heads :: transpose tails - datatype env = Env of { vars: int StringMap.map, types: (int * int) StringMap.map, structTypes: env StringMap.map } + datatype env = Env of int StringMap.map - val emptyEnv = Env { vars = StringMap.empty, types = StringMap.empty, structTypes = StringMap.empty } + val emptyEnv = Env StringMap.empty - fun bindVar (name : string) (sym : int) (Env env) : env = Env { vars = StringMap.insert name sym (#vars env), types = #types env, structTypes = #structTypes env } + fun bindVar (name : string) (sym : int) (Env env) : env = Env (StringMap.insert name sym env) fun lookupVar (name : string) (Env env) : int = - case StringMap.lookup name (#vars env) of + case StringMap.lookup name env of SOME x => x | NONE => raise Fail ("unbound identifier " ^ name) - fun bindDataCons (cons : (string * Syntax.etype option) list) (Env env) : env = - let - val nCons = length cons - val (_, vars, types) = - foldl - (fn ((name, _), (i, vars, types)) => - (i + 1, StringMap.insert name (GenSym.new ()) vars, StringMap.insert name (i, nCons) types)) - (0, #vars env, #types env) - cons - in Env { vars = vars, types = types, structTypes = #structTypes env } - end - - fun lookupStructType (name : string) (Env env) : env = - case StringMap.lookup name (#structTypes env) of - SOME x => x - | NONE => raise Fail ("unbound structure " ^ name) - - fun lookupCon ([name] : string list) (Env env) : int option = - Option.map (fn (i, _) => i) (StringMap.lookup name (#types env)) - | lookupCon (structName :: names) env = - lookupCon names (lookupStructType structName env) - | lookupCon [] _ = raise Fail "lookupCon empty" - - fun nConstructors ([name] : string list) (Env env) : int = - let val (_, n) = valOf (StringMap.lookup name (#types env)) - in n - end - | nConstructors (structName :: names) env = - nConstructors names (lookupStructType structName env) - | nConstructors [] _ = raise Fail "nConstructors empty" + fun bindDataCons (cons : (string * Syntax.ty option) list) (Env env) : env = + Env + (foldl + (fn ((name, _), acc) => + StringMap.insert name (GenSym.new ()) acc) + env + cons) - fun patternMatrix (arms : Syntax.pat list) : Syntax.pat list list = - let val ts = - foldl - (fn (Syntax.PWild, tupleSize) => tupleSize - | (Syntax.PVar _, tupleSize) => tupleSize - | (Syntax.PCon _, _) => ~2 - | (Syntax.PInt _, _) => ~2 - | (Syntax.PTuple t, ~1) => length t - | (Syntax.PTuple t, tupleSize) => - if tupleSize = length t - then tupleSize - else raise Fail "a type checker would have caught this") - ~1 - arms - in if ts < 0 - then [arms] - else let - val expandedArms = - map - (fn Syntax.PTuple t => t - | _ => List.tabulate (ts, fn _ => Syntax.PWild)) - arms - val cols = transpose expandedArms - in List.concat (map patternMatrix cols) - end - end + fun patternMatrix (arms : (Syntax.typedPat * Syntax.ty) list) : (Syntax.typedPat * Syntax.ty) list list = + if not (isSome (List.find (fn (Syntax.TPTuple t, _) => true | _ => false) arms)) then [arms] else + let + val expandedArms = + map + (fn (Syntax.TPTuple t, _) => t + | (_, Syntax.TTuple tys) => map (fn ty => (Syntax.TPWild, ty)) tys + | _ => raise Fail "unreachable") + arms + val cols = transpose expandedArms + in List.concat (map patternMatrix cols) end - fun occurrenceVector (expr : Syntax.lexp) (arms : Syntax.pat list) : Syntax.lexp list = + fun occurrenceVector (expr : Syntax.lexp) (arms : (Syntax.typedPat * Syntax.ty) list) : Syntax.lexp list = let val expandedArms = List.mapPartial - (fn Syntax.PTuple t => SOME t + (fn (Syntax.TPTuple t, _) => SOME t | _ => NONE) arms val cols = transpose expandedArms @@ -118,10 +80,10 @@ struct | _ => List.concat (map (fn (i, col) => occurrenceVector (Syntax.LSelect (i, expr)) col) (enumerate cols)) end - fun patternBindings (expr : Syntax.lexp) (Syntax.PVar v) : (string * Syntax.lexp) list = [(v, expr)] - | patternBindings expr (Syntax.PTuple t) = + fun patternBindings (expr : Syntax.lexp) (Syntax.TPVar v, _ : Syntax.ty) : (string * Syntax.lexp) list = [(v, expr)] + | patternBindings expr (Syntax.TPTuple t, _) = List.concat (map (fn (i, p) => patternBindings (Syntax.LSelect (i, expr)) p) (enumerate t)) - | patternBindings expr (Syntax.PCon (_, arg)) = patternBindings (Syntax.LSelect (1, expr)) arg + | patternBindings expr (Syntax.TPCon (_, arg), _) = patternBindings (Syntax.LSelect (1, expr)) arg | patternBindings _ _ = [] fun swap1 0 (l : 'a list) : 'a list = l @@ -131,19 +93,24 @@ struct | _ => raise Fail "swap1: index out of bounds") | swap1 _ _ = raise Fail "swap1: index out of bounds" - fun swap (n : int) (patterns : Syntax.pat list list) (occurrences : Syntax.lexp list) : Syntax.pat list list * Syntax.lexp list = + fun swap (n : int) (patterns : (Syntax.typedPat * Syntax.ty) list list) (occurrences : Syntax.lexp list) : (Syntax.typedPat * Syntax.ty) list list * Syntax.lexp list = (map (swap1 n) patterns, swap1 n occurrences) - fun specialize (env : env) (n : int) (patterns : Syntax.pat list list, occurrences : Syntax.lexp list, actions : Syntax.lexp list) : Syntax.pat list list * Syntax.lexp list * Syntax.lexp list = + fun lookupCon (name : string) (ty : string list) : int = + case List.find (fn (_, x) => x = name) (enumerate ty) of + SOME (i, _) => i + | NONE => raise Fail ("Unknown field " ^ name) + + fun specialize (n : int) (patterns : (Syntax.typedPat * Syntax.ty) list list, occurrences : Syntax.lexp list, actions : Syntax.lexp list) : (Syntax.typedPat * Syntax.ty) list list * Syntax.lexp list * Syntax.lexp list = let val con1 = List.find - (fn Syntax.PCon (name, _) => valOf (lookupCon name env) = n + (fn (Syntax.TPCon (name, _), Syntax.TDatatype cons) => lookupCon (List.last name) cons = n | _ => false) (map hd patterns) val newTupleSize = case con1 of - SOME (Syntax.PCon (_, Syntax.PTuple t)) => length t + SOME (Syntax.TPCon (_, (Syntax.TPTuple t, _)), _) => length t | _ => 0 val occHead = hd occurrences val occRest = tl occurrences @@ -152,19 +119,19 @@ struct then Syntax.LSelect (1, occHead) :: occRest else List.tabulate (newTupleSize, fn i => Syntax.LSelect (i, Syntax.LSelect (1, occHead))) @ occRest - fun specializeRow (Syntax.PInt i :: rest) = - if i = n then SOME (Syntax.PWild :: rest) else NONE - | specializeRow (Syntax.PWild :: rest) = SOME (Syntax.PWild :: rest) - | specializeRow (Syntax.PVar _ :: rest) = SOME (Syntax.PWild :: rest) - | specializeRow (Syntax.PCon (con, Syntax.PTuple []) :: rest) = - specializeRow (Syntax.PCon (con, Syntax.PTuple [Syntax.PWild]) :: rest) - | specializeRow (Syntax.PCon (con, Syntax.PTuple args) :: rest) = - if valOf (lookupCon con env) = n + fun specializeRow ((Syntax.TPInt i, ty):: rest) = + if i = n then SOME ((Syntax.TPWild, ty) :: rest) else NONE + | specializeRow ((Syntax.TPWild, ty) :: rest) = SOME ((Syntax.TPWild, ty) :: rest) + | specializeRow ((Syntax.TPVar _, ty) :: rest) = SOME ((Syntax.TPWild, ty) :: rest) + | specializeRow ((Syntax.TPCon (con, (Syntax.TPTuple [], tupleTy)), conTy) :: rest) = + specializeRow ((Syntax.TPCon (con, (Syntax.TPTuple [(Syntax.TPWild, Syntax.TTuple [])], tupleTy)), conTy) :: rest) + | specializeRow ((Syntax.TPCon (con, (Syntax.TPTuple args, _)), Syntax.TDatatype cons) :: rest) = + if lookupCon (List.last con) cons = n then SOME (args @ rest) else NONE - | specializeRow (Syntax.PCon (con, obj) :: rest) = - specializeRow (Syntax.PCon (con, Syntax.PTuple [obj]) :: rest) - | specializeRow _ = raise Fail "unexpected pattern in the matrix" + | specializeRow ((Syntax.TPCon (con, (obj, objTy)), ty) :: rest) = + specializeRow ((Syntax.TPCon (con, (Syntax.TPTuple [(obj, objTy)], Syntax.TTuple [objTy])), ty) :: rest) + | specializeRow _ = raise Fail "you think that's air you're breathing now?" val (patterns, actions) = ListPair.unzip (List.mapPartial @@ -174,26 +141,26 @@ struct in (patterns, occurrences, actions) end - fun default (patterns : Syntax.pat list list, occurrences : Syntax.lexp list, actions : Syntax.lexp list) : Syntax.pat list list * Syntax.lexp list * Syntax.lexp list = + fun default (patterns : (Syntax.typedPat * Syntax.ty) list list, occurrences : Syntax.lexp list, actions : Syntax.lexp list) : (Syntax.typedPat * Syntax.ty) list list * Syntax.lexp list * Syntax.lexp list = let val (patterns, actions) = ListPair.unzip (List.filter - (fn (Syntax.PWild :: _, _) => true - | (Syntax.PVar _ :: _, _) => true + (fn ((Syntax.TPWild, _) :: _, _) => true + | ((Syntax.TPVar _, _) :: _, _) => true | _ => false) (ListPair.zipEq (patterns, actions))) in (patterns, occurrences, actions) end (* https://compiler.club/compiling-pattern-matching/ *) - fun compilePatternMatching (env : env) ([] : Syntax.pat list list, _ : Syntax.lexp list, _ : Syntax.lexp list) : Syntax.lexp = + fun compilePatternMatching ([] : (Syntax.typedPat * Syntax.ty) list list, _ : Syntax.lexp list, _ : Syntax.lexp list) : Syntax.lexp = raise Fail "nonexhaustive match" - | compilePatternMatching env (patterns as firstRow :: rows, occurrences, actions) = + | compilePatternMatching (patterns as firstRow :: rows, occurrences, actions) = let val refutablePattern = List.find - (fn (_, Syntax.PInt _) => true - | (_, Syntax.PCon _) => true + (fn (_, (Syntax.TPInt _, _)) => true + | (_, (Syntax.TPCon _, _)) => true | _ => false) (enumerate firstRow) in @@ -210,19 +177,19 @@ struct map (fn (x, _) => x) (IntMap.toList (foldl - (fn (Syntax.PInt i, acc) => IntMap.insert i true acc - | (Syntax.PCon (c, _), acc) => IntMap.insert (valOf (lookupCon c env)) true acc + (fn ((Syntax.TPInt i, _), acc) => IntMap.insert i true acc + | ((Syntax.TPCon (c, _), Syntax.TDatatype cons), acc) => IntMap.insert (lookupCon (List.last c) cons) true acc | (_, acc) => acc) IntMap.empty firstCol)) val nCons = - case List.find (fn (Syntax.PCon _) => true | _ => false) firstCol of - SOME (Syntax.PCon (name, _)) => nConstructors name env + case List.find (fn (Syntax.TPCon _, _) => true | _ => false) firstCol of + SOME (Syntax.TPCon _, Syntax.TDatatype cons) => length cons | _ => ~1 val defaultCase = if length signatures = nCons then NONE - else SOME (compilePatternMatching env (default (patterns, occurrences, actions))) + else SOME (compilePatternMatching (default (patterns, occurrences, actions))) val switchOperand = if nCons < 0 then hd occurrences @@ -231,49 +198,22 @@ struct Syntax.LSwitch ( switchOperand , map - (fn i => (i, compilePatternMatching env (specialize env i (patterns, occurrences, actions)))) + (fn i => (i, compilePatternMatching (specialize i (patterns, occurrences, actions)))) signatures , defaultCase ) end end - fun declBoundVars (Syntax.DVal (p, _)) : string list = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p) - | declBoundVars (Syntax.DValRec (p, _)) = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p) - | declBoundVars (Syntax.DFun (name, _)) = [name] - | declBoundVars (Syntax.DDatatype (_, cons)) = map (fn (x, _) => x) cons - | declBoundVars (Syntax.DStruct (name, _)) = [name] - - fun structBoundVars (decls : Syntax.dec list) : string list = List.concatMap declBoundVars decls + fun declBoundVars (Syntax.TDVal (p, _)) : string list = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p) + | declBoundVars (Syntax.TDValRec (p, _)) = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p) + | declBoundVars (Syntax.TDFun (name, _)) = [name] + | declBoundVars (Syntax.TDDatatype (_, cons)) = map (fn (x, _) => x) cons + | declBoundVars (Syntax.TDStruct (name, _)) = [name] - fun bindStruct (name : string) (structEnv : env) (Env { vars, types, structTypes }) : env = - Env { vars = vars, types = types, structTypes = StringMap.insert name structEnv structTypes } - - fun bindStructType (name : string) (decls : Syntax.dec list) (env : env) : env = - let - val structEnv = - foldl - (fn (Syntax.DDatatype (_, cons), env) => bindDataCons cons env - | (Syntax.DStruct (name, Syntax.SStruct decls), env) => bindStructType name decls env - | (Syntax.DStruct (name, Syntax.SIdent ident), env) => - let - fun lookup [name] env = lookupStructType name env - | lookup (name :: names) env = lookup names (lookupStructType name env) - | lookup _ _ = raise Fail "invalid struct identifier" - in lookup ident env end - | (_, env) => env) - emptyEnv - decls - val structEnv = - foldl - (fn ((i, n), env) => bindVar n i env) - structEnv - (enumerate (structBoundVars decls)) - in - bindStruct name structEnv env - end + fun structBoundVars (decls : Syntax.typedDec list) : string list = List.concatMap declBoundVars decls - fun actionVector (env : env) (expr : Syntax.lexp) (arms : (Syntax.pat * Syntax.expr) list) : Syntax.lexp list = + fun actionVector (env : env) (expr : Syntax.lexp) (arms : ((Syntax.typedPat * Syntax.ty) * (Syntax.typedExpr * Syntax.ty)) list) : Syntax.lexp list = map (fn (p, body) => let @@ -293,7 +233,7 @@ struct end) arms - and elabCase (env : env) (expr : Syntax.lexp) (arms : (Syntax.pat * Syntax.expr) list) = + and elabCase (env : env) (expr : Syntax.lexp) (arms : ((Syntax.typedPat * Syntax.ty) * (Syntax.typedExpr * Syntax.ty)) list) = let val patterns = transpose (patternMatrix (map (fn (x, _) => x) arms)) val occurrences = occurrenceVector expr (map (fn (x, _) => x) arms) @@ -309,41 +249,35 @@ struct in Syntax.LFix ( actionFns - , compilePatternMatching env (patterns, occurrences, smallActions) + , compilePatternMatching (patterns, occurrences, smallActions) ) end - and elab (env : env) (p : Syntax.expr) : Syntax.lexp = + and elab (env : env) (p : Syntax.typedExpr, ty : Syntax.ty) : Syntax.lexp = case p of - Syntax.EIdent [i] => Syntax.LVar (lookupVar i env) - | Syntax.EIdent (structName :: accessors) => + Syntax.TEIdent i => Syntax.LVar (lookupVar i env) + | Syntax.TEDot (structExpr as (_, Syntax.TStruct (_, fields)), field) => let - val s = Syntax.LVar (lookupVar structName env) - val env = lookupStructType structName env - fun go env [i] acc = Syntax.LSelect (lookupVar i env, acc) - | go env (accessor :: accessors) acc = - let val env = lookupStructType accessor env - in go env accessors (Syntax.LSelect (lookupVar accessor env, acc)) end - | go _ [] _ = raise Fail "go empty" - in go env accessors s - end - | Syntax.EIdent [] => raise Fail "invalid syntax" - | Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin) - | Syntax.EInt i => Syntax.LInt i - | Syntax.EStr s => Syntax.LString s - | Syntax.ETuple exprs => Syntax.LRecord (map (elab env) exprs) - | Syntax.EList exprs => + val i = + case List.find (fn (_, (x, _)) => x = field) (enumerate fields) of + NONE => raise Fail ("Unknown field " ^ field) + | SOME (i, _) => i + in Syntax.LSelect (i, elabStructExpr env structExpr) end + | Syntax.TEBuiltin builtin => Syntax.LPrim (primop builtin) + | Syntax.TEInt i => Syntax.LInt i + | Syntax.TEStr s => Syntax.LString s + | Syntax.TETuple exprs => Syntax.LRecord (map (elab env) exprs) + | Syntax.TEList exprs => foldr (fn (x, acc) => Syntax.LRecord [elab env x, acc]) (Syntax.LInt 0) exprs - | Syntax.EApp (f, x) => Syntax.LApp (elab env f, elab env x) - | Syntax.ETyped (e, _) => elab env e - | Syntax.EAndAlso (_, _) => raise Fail "unimplemented" - | Syntax.EOrElse (_, _) => raise Fail "unimplemented" - | Syntax.ELet ([], body) => elab env body - | Syntax.ELet (Syntax.DDatatype (name, cons) :: decls, body) => + | Syntax.TEApp (f, x) => Syntax.LApp (elab env f, elab env x) + | Syntax.TEAndAlso (_, _) => raise Fail "unimplemented" + | Syntax.TEOrElse (_, _) => raise Fail "unimplemented" + | Syntax.TELet ([], body) => elab env body + | Syntax.TELet (Syntax.TDDatatype (name, cons) :: decls, body) => let val env = bindDataCons cons env val funs = @@ -363,12 +297,12 @@ struct foldl (fn ((v, x), acc) => Syntax.LApp (Syntax.LFn (v, acc), x)) - (Syntax.LFix (funs, elab env (Syntax.ELet (decls, body)))) + (Syntax.LFix (funs, elab env (Syntax.TELet (decls, body), ty))) vals end - | Syntax.ELet (Syntax.DVal (pat, v) :: decls, body) => - elab env (Syntax.ECase (v, [(pat, Syntax.ELet (decls, body))])) - | Syntax.ELet (Syntax.DValRec (Syntax.PVar name, f as Syntax.ELambda _) :: decls, body) => + | Syntax.TELet (Syntax.TDVal (pat, v) :: decls, body) => + elab env (Syntax.TECase (v, [(pat, (Syntax.TELet (decls, body), ty))]), ty) + | Syntax.TELet (Syntax.TDValRec ((Syntax.TPVar name, _), f as (Syntax.TELambda _, _)) :: decls, body) => let val n = GenSym.new () val env = bindVar name n env @@ -377,10 +311,10 @@ struct Syntax.LFn x => x | _ => raise Fail "Syntax.ELambda should expand to Syntax.LFn" in - Syntax.LFix ([(n, arg, fnBody)], elab env (Syntax.ELet (decls, body))) + Syntax.LFix ([(n, arg, fnBody)], elab env (Syntax.TELet (decls, body), ty)) end - | Syntax.ELet (Syntax.DValRec _ :: _, _) => raise Fail "invalid val rec" - | Syntax.ELet (Syntax.DFun (name, cases) :: decls, body) => + | Syntax.TELet (Syntax.TDValRec _ :: _, _) => raise Fail "invalid val rec" + | Syntax.TELet (Syntax.TDFun (name, cases) :: decls, body) => let val (ps1, _) = hd cases val nPats = length ps1 @@ -391,7 +325,12 @@ struct val temps = List.tabulate (nPats, fn _ => GenSym.new ()) val env = bindVar name n env val t = GenSym.new () - val innerCase = elabCase env (Syntax.LVar t) (map (fn (ps, b) => (Syntax.PTuple ps, b)) cases) + val innerCase = + elabCase env (Syntax.LVar t) + (map + (fn (ps, b) => + ((Syntax.TPTuple ps, Syntax.TTuple (map (fn (_, t) => t) ps)), b)) + cases) in Syntax.LFix ( [ ( n @@ -402,37 +341,44 @@ struct (tl temps) ) ] - , elab env (Syntax.ELet (decls, body)) + , elab env (Syntax.TELet (decls, body), ty) ) end end - | Syntax.ELet (Syntax.DStruct (name, Syntax.SStruct structDecls) :: decls, body) => + | Syntax.TELet (Syntax.TDStruct (name, (Syntax.TSStruct structDecls, _)) :: decls, body) => let val names = structBoundVars structDecls - val tuple = elab env (Syntax.ELet (structDecls, Syntax.ETuple (map (fn n => Syntax.EIdent [n]) names))) + val tuple = elab env (Syntax.TELet (structDecls, (Syntax.TETuple (map (fn n => (Syntax.TEIdent n, Syntax.TTuple [])) names), Syntax.TTuple [] (* TODO *))), Syntax.TTuple [] (* TODO *)) + val v = GenSym.new () + val env = bindVar name v env + in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.TELet (decls, body), ty)), tuple) end + | Syntax.TELet (Syntax.TDStruct (name, (Syntax.TSIdent structName, _)) :: decls, body) => + let val v = GenSym.new () - val env = bindStructType name structDecls env val env = bindVar name v env - in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.ELet (decls, body))), tuple) end - | Syntax.ELet (Syntax.DStruct (name, Syntax.SIdent (structName :: accessors)) :: decls, body) => + in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.TELet (decls, body), ty)), Syntax.LVar (lookupVar structName env)) end + | Syntax.TELet (Syntax.TDStruct (name, (Syntax.TSDot (parent as (_, Syntax.TStruct (fields, _)), field), _)) :: decls, body) => let - val s = Syntax.LVar (lookupVar structName env) - fun go env [] acc = (env, acc) - | go env (accessor :: accessors) acc = - go - (lookupStructType accessor env) - accessors - (Syntax.LSelect (lookupVar accessor env, acc)) - val (structEnv, structExpr) = go (lookupStructType structName env) accessors s val v = GenSym.new () - val env = bindStruct name structEnv env val env = bindVar name v env - in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.ELet (decls, body))), structExpr) end - | Syntax.ELambda body => + val i = + case List.find (fn (_, (x, _)) => x = field) (enumerate fields) of + NONE => raise Fail ("Unknown field " ^ field) + | SOME (i, _) => i + in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.TELet (decls, body), ty)), Syntax.LSelect (i, elabStructExpr env parent)) end + | Syntax.TELambda body => let val v = GenSym.new () in Syntax.LFn (v, elabCase env (Syntax.LVar v) [body]) end - | Syntax.ECase (expr, arms) => + | Syntax.TECase (expr, arms) => let val v = GenSym.new () in Syntax.LApp (Syntax.LFn (v, elabCase env (Syntax.LVar v) arms), elab env expr) end - fun elaborate (p : Syntax.expr) : Syntax.lexp = elab emptyEnv p + and elabStructExpr (env : env) (Syntax.TSIdent structName, _ : Syntax.structType) : Syntax.lexp = Syntax.LVar (lookupVar structName env) + | elabStructExpr env (Syntax.TSDot (expr as (_, Syntax.TStruct (_, fields)), field), _) = + let val i = + case List.find (fn (_, (x, _)) => x = field) (enumerate fields) of + SOME (i, _) => i + | NONE => raise Fail "unbound field" + in Syntax.LSelect (i, elabStructExpr env expr) end + + fun elaborate (p : Syntax.typedExpr * Syntax.ty) : Syntax.lexp = elab emptyEnv p end @@ -451,12 +451,25 @@ struct typedPat (List.tabulate (10, fn i => 9 - i)) st + fun makeConvolutedEDotSyntax ([i] : string list) : Syntax.expr = Syntax.EIdent i + | makeConvolutedEDotSyntax (i :: is) = + let + val structSelectors = List.take (is, length is - 1) + val exprSelector = List.last is + in + Syntax.EDot + ( foldl (fn (x, acc) => Syntax.SDot (acc, x)) (Syntax.SIdent i) structSelectors + , exprSelector + ) + end + | makeConvolutedEDotSyntax _ = raise Fail "bad identifier" + val rec atom : Syntax.expr parser = fn st => (Syntax.EInt <$> integer <|> Syntax.EStr <$> stringConstant - <|> Syntax.EIdent <$> longIdentifier - <|> (reserved "op" >> Syntax.EIdent <$> longInfixIdentifier) + <|> makeConvolutedEDotSyntax <$> longIdentifier + <|> (reserved "op" >> makeConvolutedEDotSyntax <$> longInfixIdentifier) <|> builtin <|> (reserved "let" >> bind (many dec) (fn decs => @@ -483,14 +496,14 @@ struct fun exprLeft expr1 = bind (leftOp i) (fn opEx => bind exprLower (fn expr2 => - let val app = Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, expr2]) + let val app = Syntax.EApp (Syntax.EIdent opEx, Syntax.ETuple [expr1, expr2]) in exprLeft app <|> const app end)) fun exprRight expr1 = bind (rightOp i) (fn opEx => bind exprLower (fn expr2 => bind (exprRight expr2 <|> const expr2) (fn rest => - const (Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, rest]))))) + const (Syntax.EApp (Syntax.EIdent opEx, Syntax.ETuple [expr1, rest]))))) in bind exprLower (fn expr1 => exprLeft expr1 <|> exprRight expr1 <|> const expr1) @@ -550,9 +563,10 @@ struct end) >> const NONE))) <|> ((reserved "datatype" <|> reserved "and") >> - (between (symbol "(") (symbol ")") (sepBy1 tyvar (symbol ",")) - <|> (fn x => [x]) <$> tyvar - <|> const []) >> + bind + (between (symbol "(") (symbol ")") (sepBy1 tyvar (symbol ",")) + <|> (fn x => [x]) <$> tyvar + <|> const []) (fn vars => bind identifier (fn name => reserved "=" >> bind @@ -563,7 +577,7 @@ struct const (con, SOME ty))) <|> const (con, NONE))) (reserved "|")) (fn cons => - const (SOME (Syntax.DDatatype (name, cons)))))) + const (SOME (Syntax.DDatatype (vars, name, cons))))))) <|> (reserved "type" >> bind identifier (fn name => reserved "=" >> @@ -614,7 +628,7 @@ struct bind (many strdec) (fn bindings => reserved "end" >> const (Syntax.SStruct (List.mapPartial (fn x => x) bindings)))) - <|> Syntax.SIdent <$> longIdentifier) st + <|> (fn is => foldl (fn (x, acc) => Syntax.SDot (acc, x)) (Syntax.SIdent (hd is)) (tl is)) <$> longIdentifier) st (* There's ambiguity between pattern variables and constructors that can only * be resolved by checking for constructors in scope *) @@ -626,7 +640,7 @@ struct | fixPatConstructors constructors (Syntax.PCon (con, arg)) = Syntax.PCon (con, fixPatConstructors constructors arg) | fixPatConstructors _ pat = pat - fun findConstructors (Syntax.DDatatype (_, cases)) : string list = + fun findConstructors (Syntax.DDatatype (_, _, cases)) : string list = List.mapPartial (fn (constructor, NONE) => SOME constructor | _ => NONE) diff --git a/ShowSyntax.sml b/ShowSyntax.sml index 651ddda..f28895d 100644 --- a/ShowSyntax.sml +++ b/ShowSyntax.sml @@ -47,7 +47,9 @@ and patToStringI (indent : string) (Syntax.PWild : Syntax.pat) : string = and patToString (x : Syntax.pat) : string = patToStringI "" x and exprToStringI (indent : string) (Syntax.EIdent x : Syntax.expr) : string = - "EIdent " ^ listToString (stringToStringI) indent x + "EIdent " ^ stringToStringI indent x + | exprToStringI (indent : string) (Syntax.EDot x : Syntax.expr) : string = + "EDot " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ structExprToStringI indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x | exprToStringI (indent : string) (Syntax.EBuiltin x : Syntax.expr) : string = "EBuiltin " ^ stringToStringI indent x | exprToStringI (indent : string) (Syntax.EInt x : Syntax.expr) : string = @@ -81,7 +83,7 @@ and decToStringI (indent : string) (Syntax.DVal x : Syntax.dec) : string = | decToStringI (indent : string) (Syntax.DFun x : Syntax.dec) : string = "DFun " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ listToString (patToStringI) indent' x0 ^ ",\n" ^ indent' ^ exprToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x | decToStringI (indent : string) (Syntax.DDatatype x : Syntax.dec) : string = - "DDatatype " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ optionToString (etypeToStringI) indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + "DDatatype " ^ (fn indent => fn (x0, x1, x2) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ listToString (stringToStringI) indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ ",\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ optionToString (etypeToStringI) indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x2 ^ "\n" ^ indent ^ ")" end) indent x | decToStringI (indent : string) (Syntax.DType x : Syntax.dec) : string = "DType " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ etypeToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x | decToStringI (indent : string) (Syntax.DStruct x : Syntax.dec) : string = @@ -89,11 +91,95 @@ and decToStringI (indent : string) (Syntax.DVal x : Syntax.dec) : string = and decToString (x : Syntax.dec) : string = decToStringI "" x and structExprToStringI (indent : string) (Syntax.SIdent x : Syntax.structExpr) : string = - "SIdent " ^ listToString (stringToStringI) indent x + "SIdent " ^ stringToStringI indent x + | structExprToStringI (indent : string) (Syntax.SDot x : Syntax.structExpr) : string = + "SDot " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ structExprToStringI indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x | structExprToStringI (indent : string) (Syntax.SStruct x : Syntax.structExpr) : string = "SStruct " ^ listToString (decToStringI) indent x and structExprToString (x : Syntax.structExpr) : string = structExprToStringI "" x +and tyToStringI (indent : string) (Syntax.TInt : Syntax.ty) : string = + "TInt" + | tyToStringI (indent : string) (Syntax.TBool : Syntax.ty) : string = + "TBool" + | tyToStringI (indent : string) (Syntax.TString : Syntax.ty) : string = + "TString" + | tyToStringI (indent : string) (Syntax.TVar x : Syntax.ty) : string = + "TVar " ^ intToStringI indent x + | tyToStringI (indent : string) (Syntax.TTuple x : Syntax.ty) : string = + "TTuple " ^ listToString (tyToStringI) indent x + | tyToStringI (indent : string) (Syntax.TFun x : Syntax.ty) : string = + "TFun " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ tyToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | tyToStringI (indent : string) (Syntax.TList x : Syntax.ty) : string = + "TList " ^ tyToStringI indent x + | tyToStringI (indent : string) (Syntax.TDatatype x : Syntax.ty) : string = + "TDatatype " ^ listToString (stringToStringI) indent x +and tyToString (x : Syntax.ty) : string = tyToStringI "" x + +and structTypeToStringI (indent : string) (Syntax.TStruct x : Syntax.structType) : string = + "TStruct " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ structTypeToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x0 ^ ",\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x +and structTypeToString (x : Syntax.structType) : string = structTypeToStringI "" x + +and typedPatToStringI (indent : string) (Syntax.TPWild : Syntax.typedPat) : string = + "TPWild" + | typedPatToStringI (indent : string) (Syntax.TPVar x : Syntax.typedPat) : string = + "TPVar " ^ stringToStringI indent x + | typedPatToStringI (indent : string) (Syntax.TPInt x : Syntax.typedPat) : string = + "TPInt " ^ intToStringI indent x + | typedPatToStringI (indent : string) (Syntax.TPTuple x : Syntax.typedPat) : string = + "TPTuple " ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent x + | typedPatToStringI (indent : string) (Syntax.TPCon x : Syntax.typedPat) : string = + "TPCon " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ listToString (stringToStringI) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x +and typedPatToString (x : Syntax.typedPat) : string = typedPatToStringI "" x + +and typedExprToStringI (indent : string) (Syntax.TEIdent x : Syntax.typedExpr) : string = + "TEIdent " ^ stringToStringI indent x + | typedExprToStringI (indent : string) (Syntax.TEDot x : Syntax.typedExpr) : string = + "TEDot " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedStructExprToStringI indent' x0 ^ ",\n" ^ indent' ^ structTypeToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedExprToStringI (indent : string) (Syntax.TEBuiltin x : Syntax.typedExpr) : string = + "TEBuiltin " ^ stringToStringI indent x + | typedExprToStringI (indent : string) (Syntax.TEInt x : Syntax.typedExpr) : string = + "TEInt " ^ intToStringI indent x + | typedExprToStringI (indent : string) (Syntax.TEStr x : Syntax.typedExpr) : string = + "TEStr " ^ stringToStringI indent x + | typedExprToStringI (indent : string) (Syntax.TETuple x : Syntax.typedExpr) : string = + "TETuple " ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent x + | typedExprToStringI (indent : string) (Syntax.TEList x : Syntax.typedExpr) : string = + "TEList " ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent x + | typedExprToStringI (indent : string) (Syntax.TEApp x : Syntax.typedExpr) : string = + "TEApp " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedExprToStringI (indent : string) (Syntax.TEAndAlso x : Syntax.typedExpr) : string = + "TEAndAlso " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedExprToStringI (indent : string) (Syntax.TEOrElse x : Syntax.typedExpr) : string = + "TEOrElse " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedExprToStringI (indent : string) (Syntax.TELet x : Syntax.typedExpr) : string = + "TELet " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ listToString (typedDecToStringI) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedExprToStringI (indent : string) (Syntax.TELambda x : Syntax.typedExpr) : string = + "TELambda " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedExprToStringI (indent : string) (Syntax.TECase x : Syntax.typedExpr) : string = + "TECase " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x +and typedExprToString (x : Syntax.typedExpr) : string = typedExprToStringI "" x + +and typedDecToStringI (indent : string) (Syntax.TDVal x : Syntax.typedDec) : string = + "TDVal " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedDecToStringI (indent : string) (Syntax.TDValRec x : Syntax.typedDec) : string = + "TDValRec " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedDecToStringI (indent : string) (Syntax.TDFun x : Syntax.typedDec) : string = + "TDFun " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedDecToStringI (indent : string) (Syntax.TDDatatype x : Syntax.typedDec) : string = + "TDDatatype " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ optionToString (tyToStringI) indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedDecToStringI (indent : string) (Syntax.TDStruct x : Syntax.typedDec) : string = + "TDStruct " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedStructExprToStringI indent' x0 ^ ",\n" ^ indent' ^ structTypeToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x +and typedDecToString (x : Syntax.typedDec) : string = typedDecToStringI "" x + +and typedStructExprToStringI (indent : string) (Syntax.TSIdent x : Syntax.typedStructExpr) : string = + "TSIdent " ^ stringToStringI indent x + | typedStructExprToStringI (indent : string) (Syntax.TSDot x : Syntax.typedStructExpr) : string = + "TSDot " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ typedStructExprToStringI indent' x0 ^ ",\n" ^ indent' ^ structTypeToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedStructExprToStringI (indent : string) (Syntax.TSStruct x : Syntax.typedStructExpr) : string = + "TSStruct " ^ listToString (typedDecToStringI) indent x +and typedStructExprToString (x : Syntax.typedStructExpr) : string = typedStructExprToStringI "" x + and primopToStringI (indent : string) (Syntax.PExit : Syntax.primop) : string = "PExit" | primopToStringI (indent : string) (Syntax.PAdd : Syntax.primop) : string = @@ -15,7 +15,8 @@ struct | PCon of string list * pat datatype expr = - EIdent of string list + EIdent of string + | EDot of structExpr * string | EBuiltin of string | EInt of int | EStr of string @@ -33,14 +34,63 @@ struct DVal of pat * expr | DValRec of pat * expr | DFun of string * (pat list * expr) list - | DDatatype of string * (string * etype option) list + | DDatatype of string list * string * (string * etype option) list | DType of string * etype | DStruct of string * structExpr and structExpr = - SIdent of string list + SIdent of string + | SDot of structExpr * string | SStruct of dec list + datatype ty = + TInt + | TBool + | TString + | TVar of int + | TTuple of ty list + | TFun of ty * ty + | TList of ty + | TDatatype of string list + + datatype structType = + TStruct of (string * structType) list * (string * ty) list +(*| TFunctor of structType * structType *) + + datatype typedPat = + TPWild + | TPVar of string + | TPInt of int + | TPTuple of (typedPat * ty) list + | TPCon of string list * (typedPat * ty) + + datatype typedExpr = + TEIdent of string + | TEDot of (typedStructExpr * structType) * string + | TEBuiltin of string + | TEInt of int + | TEStr of string + | TETuple of (typedExpr * ty) list + | TEList of (typedExpr * ty) list + | TEApp of (typedExpr * ty) * (typedExpr * ty) + | TEAndAlso of (typedExpr * ty) * (typedExpr * ty) + | TEOrElse of (typedExpr * ty) * (typedExpr * ty) + | TELet of typedDec list * (typedExpr * ty) + | TELambda of (typedPat * ty) * (typedExpr * ty) + | TECase of (typedExpr * ty) * ((typedPat * ty) * (typedExpr * ty)) list + + and typedDec = + TDVal of (typedPat * ty) * (typedExpr * ty) + | TDValRec of (typedPat * ty) * (typedExpr * ty) + | TDFun of string * ((typedPat * ty) list * (typedExpr * ty)) list + | TDDatatype of string * (string * ty option) list + | TDStruct of string * (typedStructExpr * structType) + + and typedStructExpr = + TSIdent of string + | TSDot of (typedStructExpr * structType) * string + | TSStruct of typedDec list + (* Lambda language *) type var = int diff --git a/Types.sml b/Types.sml new file mode 100644 index 0000000..2722063 --- /dev/null +++ b/Types.sml @@ -0,0 +1,464 @@ +structure Types = struct + structure StringMap = Map(type k = string val cmp = String.compare) + structure IntMap = Map(type k = int val cmp = Int.compare) + + type tyvar = int + datatype tycon = Bool | Int | Str | Fun | Tuple | List | Datatype of int + and ty = + TyVar of tyvar + | TyCon of tycon * ty list + | TyStruct of structTy + and structTy = Struct of { + structs : structTy StringMap.map, + vals : ty StringMap.map + } + + structure TyVarMap = IntMap + + fun listToString (show : 'a -> string) (l : 'a list) : string = + "[" ^ String.concatWith ", " (map show l) ^ "]" + + fun printTyCon Int : string = "Int" + | printTyCon Fun = "Fun" + | printTyCon Tuple = "Tuple" + | printTyCon (Datatype tag) = "Datatype " ^ Int.toString tag + + and printTy (TyVar a) : string = "TyVar " ^ Int.toString a + | printTy (TyCon (n, tys)) = "TyCon (" ^ printTyCon n ^ ", " ^ listToString printTy tys ^ ")" + + (* map of type variables to types *) + val substitution : ty TyVarMap.map ref = ref TyVarMap.empty + + (* map of datatype tags to type description *) + val datatypes : string list IntMap.map ref = ref IntMap.empty + + fun find (TyVar a) : ty = + let val representative = + case getOpt (TyVarMap.lookup a (!substitution), TyVar a) of + TyVar b => if a = b then TyVar a else find (TyVar b) + | t => find t + in + substitution := TyVarMap.insert a representative (!substitution) ; + representative + end + | find (TyCon (n, ts)) = TyCon (n, map find ts) + | find (TyStruct structType) = TyStruct structType + + fun unify (t1 : ty) (t2 : ty) : unit = + case (find t1, find t2) of + (TyVar a, t2) => substitution := TyVarMap.insert a t2 (!substitution) + | (t1, TyVar a) => substitution := TyVarMap.insert a t1 (!substitution) + | (TyCon (n1, tys1), TyCon (n2, tys2)) => + if n1 <> n2 orelse length tys1 <> length tys2 then raise Fail ("attempt to unify distinct types " ^ printTy (TyCon (n1, tys1)) ^ " and " ^ printTy (TyCon (n2, tys2))) else + ListPair.appEq (fn (t1, t2) => unify t1 t2) (tys1, tys2) + | _ => raise Fail "unify invalid types" + + datatype binding = Let of tyvar | Arg of tyvar + + type env = { + bindings : binding StringMap.map, + boundVars : unit TyVarMap.map, + typesByName : tycon StringMap.map, + structs : structTy StringMap.map + } + + fun bind (makeBinding : tyvar -> binding) (s : string) (v : tyvar) ({bindings, boundVars, typesByName, structs} : env) : env = { + bindings = StringMap.insert s (makeBinding v) bindings, + boundVars = TyVarMap.insert v () boundVars, + typesByName = typesByName, + structs = structs + } + + val userTypeVariables : tyvar StringMap.map ref = ref StringMap.empty + + fun etypeToTy (_ : env) (Syntax.Tyvar "int") = TyCon (Int, []) + | etypeToTy _ (Syntax.Tyvar "bool") = TyCon (Bool, []) + | etypeToTy _ (Syntax.Tyvar "string") = TyCon (Str, []) + | etypeToTy env (Syntax.Tyvar v) = + if String.isPrefix "'" v then + case StringMap.lookup v (!userTypeVariables) of + SOME v => TyVar v + | NONE => + let val t = GenSym.new () in + userTypeVariables := StringMap.insert v t (!userTypeVariables); + TyVar t + end + else + (case StringMap.lookup v (#typesByName env) of + SOME t => TyCon (t, []) + | NONE => raise Fail "unknown type") + | etypeToTy env (Syntax.Tycon (tys, ty)) = + (case StringMap.lookup ty (#typesByName env) of + SOME t => TyCon (t, map (etypeToTy env) tys) + | NONE => raise Fail ("unknown type " ^ ty)) + | etypeToTy env (Syntax.TyTuple tys) = TyCon (Tuple, map (etypeToTy env) tys) + | etypeToTy env (Syntax.Tyfun (arg, result)) = TyCon (Fun, [etypeToTy env arg, etypeToTy env result]) + + fun bindType ((vars, name, constructors) : string list * string * (string * Syntax.etype option) list) (env as {bindings, boundVars, typesByName, structs} : env) : env = + let + val tag = GenSym.new () + val env = { + bindings = bindings, + boundVars = boundVars, + typesByName = StringMap.insert name (Datatype tag) typesByName, + structs = structs + } + in + datatypes := IntMap.insert tag (map (fn (x, _) => x) constructors) (!datatypes) ; + foldl + (fn ((x, t), env) => + let + val g = GenSym.new () + val resType = TyCon (Datatype tag, map (etypeToTy env o Syntax.Tyvar) vars) + val conType = + case t of + NONE => resType + | SOME t => TyCon (Fun, [etypeToTy env t, resType]) + in + unify (TyVar g) conType; + bind Let x g env + end) + env + constructors + end + + fun bindStruct (name : string) (str : structTy) ({bindings, boundVars, typesByName, structs} : env) : env = { + bindings = bindings, + boundVars = boundVars, + typesByName = typesByName, + structs = StringMap.insert name str structs + } + + fun bindPat (makeBinding : tyvar -> binding) (Syntax.PVar v) (env : env) : env = + bind makeBinding v (GenSym.new ()) env + | bindPat makeBinding (Syntax.PTuple pats) env = + foldl (fn (pat, env) => bindPat makeBinding pat env) env pats + | bindPat makeBinding (Syntax.PCon (_, pat)) env = bindPat makeBinding pat env + | bindPat _ _ env = env + + fun genericVars (env : env) (TyVar a) : unit TyVarMap.map = + if isSome (TyVarMap.lookup a (#boundVars env)) + then TyVarMap.empty + else TyVarMap.fromList [(a, ())] + | genericVars env (TyCon (_, tys)) = + foldl (fn (x, acc) => TyVarMap.union acc (genericVars env x)) TyVarMap.empty tys + | genericVars _ (TyStruct _) = TyVarMap.empty + + fun instantiate (env : env) (t : ty) : ty = + let + val genericVars = genericVars env t + val newVars = TyVarMap.fromList (map (fn (a, _) => (a, GenSym.new ())) (TyVarMap.toList genericVars)) + fun replace (TyVar a) = + TyVar (getOpt (TyVarMap.lookup a newVars, a)) + | replace (TyCon (n, tys)) = TyCon (n, map replace tys) + | replace (TyStruct structType) = TyStruct structType + in replace t end + + fun lookupBinding (name : string) (env : env) : ty = + case StringMap.lookup name (#bindings env) of + SOME (Let t) => instantiate env (find (TyVar t)) + | SOME (Arg t) => TyVar t + | NONE => raise Fail ("unbound var " ^ name) + + fun patBindings (Syntax.PVar v) : string list = [v] + | patBindings (Syntax.PTuple pats) = List.concat (map patBindings pats) + | patBindings (Syntax.PCon (_, pat)) = patBindings pat + | patBindings _ = [] + + fun tyToSyntaxTy (TyVar v) = Syntax.TVar v + | tyToSyntaxTy (TyCon (Bool, [])) = Syntax.TBool + | tyToSyntaxTy (TyCon (Int, [])) = Syntax.TInt + | tyToSyntaxTy (TyCon (Str, [])) = Syntax.TString + | tyToSyntaxTy (TyCon (Fun, [f, x])) = Syntax.TFun (tyToSyntaxTy f, tyToSyntaxTy x) + | tyToSyntaxTy (TyCon (Tuple, ts)) = Syntax.TTuple (map tyToSyntaxTy ts) + | tyToSyntaxTy (TyCon (List, [t])) = Syntax.TList (tyToSyntaxTy t) + | tyToSyntaxTy (TyCon (Datatype tag, _)) = + (case (IntMap.lookup tag (!datatypes)) of + SOME cases => Syntax.TDatatype cases + | NONE => raise Fail ("unknown datatype tag " ^ Int.toString tag)) + | tyToSyntaxTy t = raise Fail ("invalid ty " ^ printTy t) + + fun structTypeToSyntaxStructType (Struct s) = + Syntax.TStruct + ( map (fn (name, ty) => (name, structTypeToSyntaxStructType ty)) (StringMap.toList (#structs s)) + , map (fn (name, ty) => (name, tyToSyntaxTy ty)) (StringMap.toList (#vals s)) + ) + (* | structTypeToSyntaxStructType _ = raise Fail "we really need to combine structs and expressions" *) + + fun tagPat (_ : env) Syntax.PWild : Syntax.typedPat * ty = (Syntax.TPWild, TyVar (GenSym.new ())) + | tagPat env (Syntax.PVar v) = (Syntax.TPVar v, TyVar (case (StringMap.lookup v (#bindings env)) of SOME (Let t) => t | SOME (Arg t) => t | NONE => raise Fail "unknown pattern variable")) + | tagPat _ (Syntax.PInt i) = (Syntax.TPInt i, TyCon (Int, [])) + | tagPat env (Syntax.PTuple pats) = + let + val taggedPats = map (tagPat env) pats + val types = map (fn (_, ty) => ty) taggedPats + val taggedPats = map (fn (p, ty) => (p, tyToSyntaxTy ty)) taggedPats + in (Syntax.TPTuple taggedPats, TyCon (Tuple, types)) end + | tagPat env (Syntax.PCon (con, pat)) = + let + val conBinding = + case con of + [ident] => lookupBinding ident env + | str :: fields => + case StringMap.lookup str (#structs env) of + SOME (Struct structTy) => + let + fun go structTy [field] = + (case StringMap.lookup field (#vals structTy) of + SOME t => instantiate env (find t) + | NONE => raise Fail "unbound something or other") + | go structTy (str :: fields) = + case StringMap.lookup str (#structs structTy) of + SOME (Struct structTy) => go structTy fields + | NONE => raise Fail ("unbound field " ^ str) + in go structTy fields end + | NONE => raise Fail ("unbound struct " ^ str) + in + case conBinding of + TyCon (Fun, [argType, resType]) => + let val (pat, patType) = tagPat env pat + in + unify patType argType ; + (Syntax.TPCon (con, (pat, tyToSyntaxTy patType)), resType) + end + | conType => + case pat of + Syntax.PTuple [] => (Syntax.TPCon (con, (Syntax.TPTuple [], Syntax.TTuple [])), conType) + | _ => raise Fail ("non-function " ^ (String.concatWith "." con) ^ " applied to argument in pattern") + end + + fun F (env : env) (Syntax.EIdent i : Syntax.expr) : Syntax.typedExpr * ty = + (Syntax.TEIdent i, lookupBinding i env) + | F env (Syntax.EDot (expr, field)) = + let + val (str, Struct structType) = tagStructExpr env expr + val fieldType = instantiate env (find (valOf (StringMap.lookup field (#vals structType)))) + in (Syntax.TEDot ((str, structTypeToSyntaxStructType (Struct structType)), field), fieldType) end + | F _ (Syntax.EBuiltin "exit") = (Syntax.TEBuiltin "exit", TyCon (Fun, [TyCon (Int, []), TyVar (GenSym.new ())])) + | F _ (Syntax.EBuiltin "add") = (Syntax.TEBuiltin "add", TyCon (Fun, [TyCon (Tuple, [TyCon (Int, []), TyCon (Int, [])]), TyCon (Int, [])])) + | F _ (Syntax.EBuiltin "sub") = (Syntax.TEBuiltin "sub", TyCon (Fun, [TyCon (Tuple, [TyCon (Int, []), TyCon (Int, [])]), TyCon (Int, [])])) + | F _ (Syntax.EBuiltin "mul") = (Syntax.TEBuiltin "mul", TyCon (Fun, [TyCon (Tuple, [TyCon (Int, []), TyCon (Int, [])]), TyCon (Int, [])])) + | F _ (Syntax.EBuiltin "div") = (Syntax.TEBuiltin "div", TyCon (Fun, [TyCon (Tuple, [TyCon (Int, []), TyCon (Int, [])]), TyCon (Int, [])])) + | F _ (Syntax.EBuiltin b) = raise Fail ("unknown builtin " ^ b) + | F _ (Syntax.EInt i) = (Syntax.TEInt i, TyCon (Int, [])) + | F _ (Syntax.EStr s) = (Syntax.TEStr s, TyCon (Str, [])) + | F env (Syntax.ETuple exprs) = + let + val taggedExprs = map (F env) exprs + val types = map (fn (_, x) => x) taggedExprs + in (Syntax.TETuple (map (fn (e, t) => (e, tyToSyntaxTy t)) taggedExprs), TyCon (Tuple, types)) end + | F env (Syntax.EList exprs) = + let + val taggedExprs = map (fn expr => F env expr) exprs + val alpha = TyVar (GenSym.new ()) + val _ = app (fn (_, t) => unify alpha t) taggedExprs + in (Syntax.TEList (map (fn (e, t) => (e, tyToSyntaxTy t)) taggedExprs), TyCon (List, [alpha])) end + | F env (Syntax.EApp (func, arg)) = + let + val (func, funcType) = F env func + val (arg, argType) = F env arg + val beta = TyVar (GenSym.new ()) + val _ = unify funcType (TyCon (Fun, [argType, beta])) + in (Syntax.TEApp ((func, tyToSyntaxTy funcType), (arg, tyToSyntaxTy argType)), beta) end + | F env (Syntax.ETyped (expr, _)) = F env expr + | F env (Syntax.EAndAlso (e1, e2)) = + let + val (e1, e1Type) = F env e1 + val (e2, e2Type) = F env e2 + in + unify e1Type (TyCon (Bool, [])) ; + unify e2Type (TyCon (Bool, [])) ; + (Syntax.TEAndAlso ((e1, tyToSyntaxTy e1Type), (e2, tyToSyntaxTy e2Type)), TyCon (Bool, [])) + end + | F env (Syntax.EOrElse (e1, e2)) = + let + val (e1, e1Type) = F env e1 + val (e2, e2Type) = F env e2 + in + unify e1Type (TyCon (Bool, [])) ; + unify e2Type (TyCon (Bool, [])) ; + (Syntax.TEOrElse ((e1, tyToSyntaxTy e1Type), (e2, tyToSyntaxTy e2Type)), TyCon (Bool, [])) + end + | F env (Syntax.ELet (decs, body)) = + let + val (env, decs) = tagDecs env decs + val (body, bodyType) = F env body + in (Syntax.TELet (decs, (body, tyToSyntaxTy bodyType)), bodyType) + end + | F env (Syntax.ELambda (pat, body)) = + let + val env = bindPat Arg pat env + val (pat, patType) = tagPat env pat + val (body, bodyType) = F env body + in (Syntax.TELambda ((pat, tyToSyntaxTy patType), (body, tyToSyntaxTy bodyType)), TyCon (Fun, [patType, bodyType])) end + | F env (Syntax.ECase (arg, arms)) = + let + val (arg, argType) = F env arg + val resultType = TyVar (GenSym.new ()) + val arms = + map + (fn (pat, body) => + let + val env = bindPat Arg pat env + val (pat, patType) = tagPat env pat + val (body, bodyType) = F env body + in + unify patType argType; + unify bodyType resultType; + ((pat, tyToSyntaxTy patType), (body, tyToSyntaxTy bodyType)) + end) + arms + in (Syntax.TECase ((arg, tyToSyntaxTy argType), arms), resultType) end + + and tagDec (env : env) (Syntax.DVal (pat, expr)) : env * Syntax.typedDec option = + let + val (expr, exprType) = F env expr + val env = bindPat Let pat env + val (pat, patType) = tagPat env pat + in + unify patType exprType ; + (env, SOME (Syntax.TDVal ((pat, tyToSyntaxTy patType), (expr, tyToSyntaxTy exprType)))) + end + | tagDec env (Syntax.DValRec (pat, expr)) = + let + val recEnv = bindPat Arg pat env + val (expr, exprType) = F recEnv expr + val (taggedPat, patType) = tagPat recEnv pat + in + unify patType exprType ; + (bindPat Let pat env, SOME (Syntax.TDValRec ((taggedPat, tyToSyntaxTy patType), (expr, tyToSyntaxTy exprType)))) + end + | tagDec env (Syntax.DFun (name, (args, body) :: cases)) = + let + val fnType = GenSym.new () + val args1Env = + foldl + (fn (arg, env) => bindPat Arg arg env) + (bind Arg name fnType env) + args + val args = map (tagPat args1Env) args + val argTypes = map (fn (_, ty) => ty) args + val (body, bodyType) = F args1Env body + val cases = + (map (fn (arg, ty) => (arg, tyToSyntaxTy ty)) args, (body, tyToSyntaxTy bodyType)) + :: map + (fn (args, body) => + let + val env = + foldl + (fn (arg, env) => bindPat Arg arg env) + (bind Arg name fnType env) + args + val args = map (tagPat env) args + val (body, bt) = F env body + in + ListPair.appEq + (fn ((_, myArgType), argType) => unify myArgType argType) + (args, argTypes) ; + unify bodyType bt ; + (map (fn (arg, ty) => (arg, tyToSyntaxTy ty)) args, (body, tyToSyntaxTy bt)) + end) + cases + in (bind Let name fnType env, SOME (Syntax.TDFun (name, cases))) + end + | tagDec env (Syntax.DDatatype (vars, name, data)) = + let val env = bindType (vars, name, data) env + in (env, SOME (Syntax.TDDatatype (name, map (fn (name, ty) => (name, Option.map (tyToSyntaxTy o (etypeToTy env)) ty)) data))) end + | tagDec _ (Syntax.DType _) = raise Fail "TODO" + | tagDec env (Syntax.DStruct (name, str)) = + let val (str, strType) = tagStructExpr env str + in (bindStruct name strType env, SOME (Syntax.TDStruct (name, (str, structTypeToSyntaxStructType strType)))) end + | tagDec _ _ = raise Fail "invalid expr" + + and tagDecs env [] = (env, []) + | tagDecs env (dec :: decs) = + let + val (env, dec) = tagDec env dec + val (env, decs) = tagDecs env decs + val decs = + case dec of + NONE => decs + | SOME dec => dec :: decs + in (env, decs) + end + + and tagStructExpr (env : env) (Syntax.SIdent s) : Syntax.typedStructExpr * structTy = + (case StringMap.lookup s (#structs env) of + SOME t => (Syntax.TSIdent s, t) + | NONE => raise Fail ("unknown struct type " ^ s)) + | tagStructExpr env (Syntax.SDot (sExpr, field)) = + let + val (parent, Struct parentType) = tagStructExpr env sExpr + val fieldType = + case StringMap.lookup field (#structs parentType) of + SOME x => x + | NONE => raise Fail ("unknown struct field " ^ field) + in (Syntax.TSDot ((parent, structTypeToSyntaxStructType (Struct parentType)), field), fieldType) end + | tagStructExpr env (Syntax.SStruct decls) = + let val (env, decls) = tagDecs env decls + in + (Syntax.TSStruct decls, Struct { + structs = #structs env, + vals = + StringMap.fromList + (map + (fn (name, Let v) => (name, TyVar v) + | (name, Arg v) => (name, TyVar v)) + (StringMap.toList (#bindings env))) + }) + end + + fun reexpandType (Syntax.TVar i) : Syntax.ty = tyToSyntaxTy (find (TyVar i)) + | reexpandType ty = ty + + fun reexpandPat (pat : Syntax.typedPat, ty : Syntax.ty) : Syntax.typedPat * Syntax.ty = + let + val pat = + case pat of + Syntax.TPTuple pats => Syntax.TPTuple (map reexpandPat pats) + | Syntax.TPCon (con, arg) => Syntax.TPCon (con, reexpandPat arg) + | _ => pat + in (pat, reexpandType ty) end + + fun reexpand (expr : Syntax.typedExpr, ty : Syntax.ty) : Syntax.typedExpr * Syntax.ty = + let + val expr = + case expr of + Syntax.TEDot (str, field) => Syntax.TEDot (reexpandStructExpr str, field) + | Syntax.TETuple exprs => Syntax.TETuple (map reexpand exprs) + | Syntax.TEList exprs => Syntax.TEList (map reexpand exprs) + | Syntax.TEApp (f, arg) => Syntax.TEApp (reexpand f, reexpand arg) + | Syntax.TEAndAlso (expr1, expr2) => Syntax.TEAndAlso (reexpand expr1, reexpand expr2) + | Syntax.TEOrElse (expr1, expr2) => Syntax.TEOrElse (reexpand expr1, reexpand expr2) + | Syntax.TELet (decls, body) => Syntax.TELet (map reexpandDecl decls, reexpand body) + | Syntax.TELambda (arg, body) => Syntax.TELambda (reexpandPat arg, reexpand body) + | Syntax.TECase (arg, arms) => Syntax.TECase (reexpand arg, map (fn (pat, body) => (reexpandPat pat, reexpand body)) arms) + | _ => expr + in (expr, reexpandType ty) end + + and reexpandDecl (Syntax.TDVal (pat, expr)) : Syntax.typedDec = Syntax.TDVal (reexpandPat pat, reexpand expr) + | reexpandDecl (Syntax.TDValRec (pat, expr)) = Syntax.TDValRec (reexpandPat pat, reexpand expr) + | reexpandDecl (Syntax.TDFun (name, arms)) = Syntax.TDFun (name, map (fn (pats, body) => (map reexpandPat pats, reexpand body)) arms) + | reexpandDecl (decl as Syntax.TDDatatype _) = decl + | reexpandDecl (Syntax.TDStruct (name, str)) = Syntax.TDStruct (name, reexpandStructExpr str) + + and reexpandStructExpr (str : Syntax.typedStructExpr, structType : Syntax.structType) : Syntax.typedStructExpr * Syntax.structType = + let + val str = + case str of + Syntax.TSIdent _ => str + | Syntax.TSDot (str, field) => Syntax.TSDot (reexpandStructExpr str, field) + | Syntax.TSStruct decls => Syntax.TSStruct (map reexpandDecl decls) + in (str, structType) end + + fun tag (expr : Syntax.expr) : Syntax.typedExpr * Syntax.ty = + let + val env = { + bindings = StringMap.empty, + boundVars = TyVarMap.empty, + typesByName = StringMap.empty, + structs = StringMap.empty + } + val (expr, ty) = F env expr + in reexpand (expr, tyToSyntaxTy ty) end +end diff --git a/generate-show-syntax.sml b/generate-show-syntax.sml index d58d73d..c1e104f 100644 --- a/generate-show-syntax.sml +++ b/generate-show-syntax.sml @@ -4,30 +4,31 @@ use "Syntax.sml"; use "Parser.sml"; use "Opts.sml"; -val header = - "fun intToStringI (_ : string) (i : int) : string = Int.toString i\n" - ^ "\n" - ^ "fun varToStringI (_ : string) (v : Syntax.var) : string = \"Var \" ^ Int.toString v\n" - ^ "\n" - ^ "fun stringToStringI (_ : string) (s : string) : string = \"\\\"\" ^ String.toString s ^ \"\\\"\"\n" - ^ "\n" - ^ "fun optionToString (_ : string -> 'a -> string) (_ : string) NONE : string = \"NONE\"\n" - ^ " | optionToString show indent (SOME x) = \"SOME (\" ^ show indent x ^ \")\"\n" - ^ "\n" - ^ "fun listToString (_ : string -> 'a -> string) (_ : string) ([] : 'a list) : string = \"[]\"\n" - ^ " | listToString show indent [x] = \"[\" ^ show indent x ^ \"]\"\n" - ^ " | listToString show indent xs =\n" - ^ " let val indent' = indent ^ \" \" in\n" - ^ " \"[\\n\"\n" - ^ " ^ indent' ^ String.concatWith (\",\\n\" ^ indent') (map (show indent') xs) ^ \"\\n\"\n" - ^ " ^ indent ^ \"]\"\n" - ^ " end\n" +val header = "\ + \fun intToStringI (_ : string) (i : int) : string = Int.toString i\n\ + \\n\ + \fun varToStringI (_ : string) (v : Syntax.var) : string = \"Var \" ^ Int.toString v\n\ + \\n\ + \fun stringToStringI (_ : string) (s : string) : string = \"\\\"\" ^ String.toString s ^ \"\\\"\"\n\ + \\n\ + \fun optionToString (_ : string -> 'a -> string) (_ : string) NONE : string = \"NONE\"\n\ + \ | optionToString show indent (SOME x) = \"SOME (\" ^ show indent x ^ \")\"\n\ + \\n\ + \fun listToString (_ : string -> 'a -> string) (_ : string) ([] : 'a list) : string = \"[]\"\n\ + \ | listToString show indent [x] = \"[\" ^ show indent x ^ \"]\"\n\ + \ | listToString show indent xs =\n\ + \ let val indent' = indent ^ \" \" in\n\ + \ \"[\\n\"\n\ + \ ^ indent' ^ String.concatWith (\",\\n\" ^ indent') (map (show indent') xs) ^ \"\\n\"\n\ + \ ^ indent ^ \"]\"\n\ + \ end\n\ +\" fun showTy (Syntax.Tyvar var) : string = var ^ "ToStringI" | showTy (Syntax.Tycon ([ty], con)) = con ^ "ToString (" ^ showTy ty ^ ")" | showTy (Syntax.TyTuple tys) = let val vars = List.tabulate (length tys, fn i => "x" ^ Int.toString i) in - "(fn indent => fn (" ^ String.concatWith ", " vars ^ ") => let val indent' = indent ^ \" \" in \"(\\n\" ^ indent' ^ " ^ String.concatWith " ^ \",\\n\" ^ indent' ^ " (map (fn (var, ty) => showTy ty ^ " indent' " ^ var) (ListPair.zip (vars, tys))) ^ " ^ \"\\n\" ^ indent ^ \")\" end)" + "(fn indent => fn (" ^ String.concatWith ", " vars ^ ") => let val indent' = indent ^ \" \" in \"(\\n\" ^ indent' ^ " ^ String.concatWith " ^ \",\\n\" ^ indent' ^ " (map (fn (var, ty) => showTy ty ^ " indent' " ^ var) (ListPair.zipEq (vars, tys))) ^ " ^ \"\\n\" ^ indent ^ \")\" end)" end | showTy _ = "(fn _ => fn _ => \"UNHANDLED\")" @@ -51,7 +52,7 @@ val _ = TextIO.output (out, "(*\n This file was generated by generate-show-synt val _ = TextIO.output (out, "structure Show" ^ structName ^ " = struct\n") val _ = TextIO.output (out, header) val _ = map - (fn (i, Syntax.DDatatype (typeName, cases)) => + (fn (i, Syntax.DDatatype (_, typeName, cases)) => (TextIO.output (out, "\n" ^ (if i = 0 then "fun" else "and") ^ " " ^ String.concatWith "\n | " (map @@ -7,9 +7,10 @@ use "Syntax.sml"; use "Opts.sml"; use "Parser.sml"; use "ShowSyntax.sml"; -use "CodeGen.sml"; -use "CPS.sml"; +use "Types.sml"; use "Elab.sml"; +use "CPS.sml"; +use "CodeGen.sml"; use "Linker.sml"; use "Compiler.sml"; @@ -2,7 +2,7 @@ Group is Buffer.sml CPS.sml -Codegen.sml +CodeGen.sml Compiler.sml Elab.sml GenSym.sml @@ -12,6 +12,8 @@ Opts.sml Parser.sml Result.sml ShowSyntax.sml +Sort.sml Syntax.sml +Types.sml $/basis.cm diff --git a/run-tests.fish b/run-tests.fish index 22c86d5..92200d2 100644 --- a/run-tests.fish +++ b/run-tests.fish @@ -13,12 +13,12 @@ else set files $d/tests/* end -for f in $files - $d/bytecode/target/debug/bytecode (sml $d/main.sml -o /dev/stderr $f >/dev/null 2>| psub) - set -l got $status +printf %s\n $files | parallel --keep-order --quote fish -c ' + bytecode/target/debug/bytecode (sml main.sml -o /dev/stderr $argv[1] >/dev/null 2>| psub) + set got $status if test $got -eq 42 - echo (basename -s.sml $f): PASS + echo (basename -s.sml $argv[1]): PASS else - echo (basename -s.sml $f): FAIL "(status $got)" + echo (basename -s.sml $argv[1]): FAIL "(status $got)" end -end +' |