diff options
| -rw-r--r-- | Elab.sml | 150 | ||||
| -rw-r--r-- | Parser.sml | 115 | ||||
| -rw-r--r-- | ShowSyntax.sml | 58 | ||||
| -rw-r--r-- | Syntax.sml | 51 | ||||
| -rw-r--r-- | Types.sml | 218 | ||||
| -rw-r--r-- | generate-show-syntax.sml | 2 | ||||
| -rw-r--r-- | main.sml | 10 | ||||
| -rw-r--r-- | tests/24-functor.sml | 17 |
8 files changed, 351 insertions, 270 deletions
@@ -1,7 +1,9 @@ structure Elab = struct - structure StringMap = Map(type k = string val cmp = String.compare) structure IntMap = Map(type k = int val cmp = Int.compare) + structure IdentMap = Map(type k = Syntax.identType * string val cmp = Syntax.compareIdentifiers) + + fun printIdent (ty : Syntax.identType, name : string) : string = "(" ^ ShowSyntax.identTypeToString ty ^ ", \"" ^ name ^ "\")" fun primop (s : string) : Syntax.primop = case s of @@ -35,24 +37,39 @@ struct NONE => [] | SOME (heads, tails) => heads :: transpose tails - datatype env = Env of int StringMap.map + type env = int IdentMap.map - val emptyEnv = Env StringMap.empty + val emptyEnv = IdentMap.empty - fun bindVar (name : string) (sym : int) (Env env) : env = Env (StringMap.insert name sym env) + fun bindVar (name : Syntax.identType * string) (sym : int) (env : env) : env = + IdentMap.insert name sym env - fun lookupVar (name : string) (Env env) : int = - case StringMap.lookup name env of + fun lookupVar (name: Syntax.identType * string) (env : env) : int = + case IdentMap.lookup name env of SOME x => x - | NONE => raise Fail ("unbound identifier " ^ name) + | NONE => raise Fail ("unbound identifier " ^ printIdent name) + + fun bindDataCons (cons : (string * Syntax.ty option) list) (env : env) : env = + foldl + (fn ((name, _), acc) => + IdentMap.insert (Syntax.ITVar, name) (GenSym.new ()) acc) + env + cons + + 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.TPCon (_, arg), _) = patternBindings (Syntax.LSelect (1, expr)) arg + | patternBindings _ _ = [] + + fun declBoundVars (Syntax.TDVal (p, _)) : (Syntax.identType * string) list = map (fn (x, _) => (Syntax.ITVar, x)) (patternBindings (Syntax.LInt 0) p) + | declBoundVars (Syntax.TDValRec (p, _)) = map (fn (x, _) => (Syntax.ITVar, x)) (patternBindings (Syntax.LInt 0) p) + | declBoundVars (Syntax.TDFun (name, _)) = [(Syntax.ITVar, name)] + | declBoundVars (Syntax.TDDatatype (_, cons)) = map (fn (x, _) => (Syntax.ITVar, x)) cons + | declBoundVars (Syntax.TDStruct (name, _)) = [(Syntax.ITStruct, name)] + | declBoundVars (Syntax.TDFunctor (name, _, _, _)) = [(Syntax.ITFunctor, name)] - 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 structBoundVars (decls : Syntax.typedDec list) : (Syntax.identType * string) list = List.concatMap declBoundVars decls 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 @@ -80,12 +97,6 @@ struct | _ => List.concat (map (fn (i, col) => occurrenceVector (Syntax.LSelect (i, expr)) col) (enumerate cols)) end - 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.TPCon (_, arg), _) = patternBindings (Syntax.LSelect (1, expr)) arg - | patternBindings _ _ = [] - fun swap1 0 (l : 'a list) : 'a list = l | swap1 n (first :: rest) = (case swap1 (n - 1) rest of @@ -205,14 +216,6 @@ struct end end - 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 structBoundVars (decls : Syntax.typedDec list) : string list = List.concatMap declBoundVars decls - fun actionVector (env : env) (expr : Syntax.lexp) (arms : ((Syntax.typedPat * Syntax.ty) * (Syntax.typedExpr * Syntax.ty)) list) : Syntax.lexp list = map (fn (p, body) => @@ -221,13 +224,13 @@ struct val env = foldl (fn ((name, _), env) => - bindVar name (GenSym.new ()) env) + bindVar (Syntax.ITVar, name) (GenSym.new ()) env) env bindings in foldl (fn ((name, binding), acc) => - Syntax.LApp (Syntax.LFn (lookupVar name env, acc), binding)) + Syntax.LApp (Syntax.LFn (lookupVar (Syntax.ITVar, name) env, acc), binding)) (elab env body) bindings end) @@ -256,13 +259,13 @@ struct and elab (env : env) (p : Syntax.typedExpr, ty : Syntax.ty) : Syntax.lexp = case p of Syntax.TEIdent i => Syntax.LVar (lookupVar i env) - | Syntax.TEDot (structExpr as (_, Syntax.TStruct (_, fields)), field) => + | Syntax.TEDot (structExpr as (_, Syntax.TStruct fields), field) => let val i = case List.find (fn (_, (x, _)) => x = field) (enumerate fields) of - NONE => raise Fail ("Unknown field " ^ field) + NONE => raise Fail ("Unknown field " ^ printIdent field) | SOME (i, _) => i - in Syntax.LSelect (i, elabStructExpr env structExpr) end + in Syntax.LSelect (i, elab env structExpr) end | Syntax.TEBuiltin builtin => Syntax.LPrim (primop builtin) | Syntax.TEInt i => Syntax.LInt i | Syntax.TEStr s => Syntax.LString s @@ -277,7 +280,7 @@ struct | Syntax.TEAndAlso (_, _) => raise Fail "unimplemented" | Syntax.TEOrElse (_, _) => raise Fail "unimplemented" | Syntax.TELet ([], body) => elab env body - | Syntax.TELet (Syntax.TDDatatype (name, cons) :: decls, body) => + | Syntax.TELet (Syntax.TDDatatype (_, cons) :: decls, body) => let val env = bindDataCons cons env val funs = @@ -285,12 +288,12 @@ struct (fn (_, (_, NONE)) => NONE | (i, (name, _)) => let val v = GenSym.new () - in SOME (lookupVar name env, v, Syntax.LRecord [Syntax.LInt i, Syntax.LVar v]) + in SOME (lookupVar (Syntax.ITVar, name) env, v, Syntax.LRecord [Syntax.LInt i, Syntax.LVar v]) end) (enumerate cons) val vals = List.mapPartial - (fn (i, (name, NONE)) => SOME (lookupVar name env, Syntax.LRecord [Syntax.LInt i]) + (fn (i, (name, NONE)) => SOME (lookupVar (Syntax.ITVar, name) env, Syntax.LRecord [Syntax.LInt i]) | _ => NONE) (enumerate cons) in @@ -305,7 +308,7 @@ struct | Syntax.TELet (Syntax.TDValRec ((Syntax.TPVar name, _), f as (Syntax.TELambda _, _)) :: decls, body) => let val n = GenSym.new () - val env = bindVar name n env + val env = bindVar (Syntax.ITVar, name) n env val (arg, fnBody) = case elab env f of Syntax.LFn x => x @@ -323,7 +326,7 @@ struct else let val n = GenSym.new () val temps = List.tabulate (nPats, fn _ => GenSym.new ()) - val env = bindVar name n env + val env = bindVar (Syntax.ITVar, name) n env val t = GenSym.new () val innerCase = elabCase env (Syntax.LVar t) @@ -344,41 +347,58 @@ struct , elab env (Syntax.TELet (decls, body), ty) ) end end - | Syntax.TELet (Syntax.TDStruct (name, (Syntax.TSStruct structDecls, _)) :: decls, body) => - let - val names = structBoundVars structDecls - 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) => + | Syntax.TELet (Syntax.TDStruct (name, expr) :: decls, body) => let - val v = GenSym.new () - val env = bindVar name v env - 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) => + val s = GenSym.new () + val structExpr = elab env expr + val env = bindVar (Syntax.ITStruct, name) s env + in Syntax.LApp (Syntax.LFn (s, elab env (Syntax.TELet (decls, body), ty)), structExpr) + end + | Syntax.TELet (Syntax.TDFunctor (name, arg, _, functorBody) :: decls, body) => let - val v = GenSym.new () - val env = bindVar name v env - 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 + val (n, v) = (GenSym.new (), GenSym.new()) + val functorBody = elab (bindVar (Syntax.ITStruct, arg) v env) functorBody + val env = bindVar (Syntax.ITFunctor, name) n env + in + Syntax.LFix + ( [ ( n + , v + , functorBody + ) + ] + , elab env (Syntax.TELet (decls, body), ty) + ) + end | Syntax.TELambda body => let val v = GenSym.new () in Syntax.LFn (v, elabCase env (Syntax.LVar v) [body]) end | 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 - - 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 + | Syntax.TEStruct structDecls => + let val names = structBoundVars structDecls + in + elab env + (Syntax.TELet + (structDecls, + (Syntax.TETuple (map (fn n => (Syntax.TEIdent n, Syntax.TTuple [])) names), + Syntax.TTuple [] (* TODO *))), + Syntax.TTuple [] (* TODO *)) + end + | Syntax.TEFunctorApp (func as (_, funcType as Syntax.TFunctor (Syntax.TStruct funcArgs, _)), arg as (_, argType as Syntax.TStruct args)) => + let + val _ = print (ShowSyntax.tyToString funcType) + val _ = print (ShowSyntax.tyToString argType) + val func = elab env func + val arg = elab env arg + val (_, argIdxs) = + foldl + (fn ((name, _), (i, argIdxs)) => (i + 1, IdentMap.insert name i argIdxs)) + (0, IdentMap.empty) + args + val tuple = Syntax.LRecord (map (fn (name, _) => Syntax.LSelect (valOf (IdentMap.lookup name argIdxs), arg)) funcArgs) + in Syntax.LApp (func, tuple) end + | _ => raise Fail ("invalid expression " ^ ShowSyntax.typedExprToString p) fun elaborate (p : Syntax.typedExpr * Syntax.ty) : Syntax.lexp = elab emptyEnv p end @@ -123,6 +123,8 @@ struct | (Empty, Result.Left err) => (consumed1, Result.Left (withHints hints err))) | (consumed, Result.Left err) => (consumed, Result.Left err) + fun thunk (f : unit -> 'a parser) : 'a parser = fn st => f () st + fun (p1 : 'a parser) >> (p2 : 'b parser) : 'b parser = bind p1 (fn _ => p2) fun (p : 'a parser) <?> (msg : string) : 'a parser = @@ -451,25 +453,22 @@ struct typedPat (List.tabulate (10, fn i => 9 - i)) st - fun makeConvolutedEDotSyntax ([i] : string list) : Syntax.expr = Syntax.EIdent i - | makeConvolutedEDotSyntax (i :: is) = + fun makeConvolutedEDotSyntax (ty : Syntax.identType) ([i] : string list) : Syntax.expr = + Syntax.EIdent (ty, i) + | makeConvolutedEDotSyntax (ty : Syntax.identType) (i :: is : string list) : Syntax.expr = 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" + fun go acc [i] = Syntax.EDot (acc, (ty, i)) + | go acc (i :: is) = go (Syntax.EDot (acc, (Syntax.ITStruct, i))) is + | go _ _ = raise Fail "unreachable" + in go (Syntax.EIdent (Syntax.ITStruct, i)) is end + | makeConvolutedEDotSyntax _ _ = raise Fail "bad identifier" val rec atom : Syntax.expr parser = fn st => (Syntax.EInt <$> integer <|> Syntax.EStr <$> stringConstant - <|> makeConvolutedEDotSyntax <$> longIdentifier - <|> (reserved "op" >> makeConvolutedEDotSyntax <$> longInfixIdentifier) + <|> makeConvolutedEDotSyntax Syntax.ITVar <$> longIdentifier + <|> (reserved "op" >> makeConvolutedEDotSyntax Syntax.ITVar <$> longInfixIdentifier) <|> builtin <|> (reserved "let" >> bind (many dec) (fn decs => @@ -496,14 +495,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 (Syntax.ITVar, 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 (Syntax.ITVar, opEx), Syntax.ETuple [expr1, rest]))))) in bind exprLower (fn expr1 => exprLeft expr1 <|> exprRight expr1 <|> const expr1) @@ -605,6 +604,7 @@ struct bind (many1 atpat) (fn args => const (name, args)) | _ => unexpected "pattern"))) (fn (name, args) => + ((reserved ":" >> () <$ parseType) <|> const ()) >> reserved "=" >> bind expr (fn body => const (name, args, body)))) @@ -627,27 +627,19 @@ struct reserved "=" >> bind structExpr (fn str => const (SOME (Syntax.DStruct (strID, s, str))))))) - <|> (reserved "signature" >> - bind identifier (fn sigID => - reserved "=" >> - reserved "sig" >> - bind - (many - (reserved "val" >> - bind identifier (fn id => - reserved ":" >> - bind parseType (fn ty => - const (id, ty))))) - (fn bindings => - reserved "end" >> - const (SOME (Syntax.DSig (sigID, bindings)))))) <|> dec) st - and structExpr : Syntax.structExpr parser = fn st => + and structExpr : Syntax.expr parser = fn st => ((reserved "struct" >> bind (many strdec) (fn bindings => reserved "end" >> - const (Syntax.SStruct (List.mapPartial (fn x => x) bindings)))) - <|> (fn is => foldl (fn (x, acc) => Syntax.SDot (acc, x)) (Syntax.SIdent (hd is)) (tl is)) <$> longIdentifier) st + const (Syntax.EStruct (List.mapPartial (fn x => x) bindings)))) + <|> bind longIdentifier (fn is => + (symbol "(" >> + thunk (fn () => if length is <> 1 then raise Fail "bad functor has a dot" else + bind structExpr (fn arg => + symbol ")" >> + const (Syntax.EFunctorApp (Syntax.EIdent (Syntax.ITFunctor, hd is), arg))))) + <|> const (makeConvolutedEDotSyntax Syntax.ITStruct is))) st (* There's ambiguity between pattern variables and constructors that can only * be resolved by checking for constructors in scope *) @@ -674,19 +666,9 @@ struct Syntax.DFun (f, map (fn (args, body) => (map (fixPatConstructors constructors) args, fixConstructors constructors body)) arms) | fixDecConstructors _ (decl as Syntax.DDatatype _) = decl | fixDecConstructors _ (decl as Syntax.DType _) = decl - | fixDecConstructors constructors (Syntax.DStruct (name, s, str)) = Syntax.DStruct (name, s, fixStructExprConstructors constructors str) + | fixDecConstructors constructors (Syntax.DStruct (name, s, str)) = Syntax.DStruct (name, s, fixConstructors constructors str) | fixDecConstructors constructors (s as Syntax.DSig _) = s - - and fixStructExprConstructors (constructors : unit StringMap.map) (Syntax.SStruct decls) : Syntax.structExpr = - let val constructors = ref constructors in - Syntax.SStruct - (map - (fn dec => - (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ; - fixDecConstructors (!constructors) dec)) - decls) - end - | fixStructExprConstructors _ expr = expr + | fixDecConstructors constructors (Syntax.DFunctor (name, arg, ty, body)) = Syntax.DFunctor (name, arg, ty, fixConstructors constructors body) and fixConstructors (constructors : unit StringMap.map) (Syntax.ETuple exprs) : Syntax.expr = Syntax.ETuple (map (fixConstructors constructors) exprs) @@ -715,11 +697,54 @@ struct Syntax.ELambda (fixPatConstructors constructors pat, fixConstructors constructors body) | fixConstructors constructors (Syntax.ECase (expr, arms)) = Syntax.ECase (fixConstructors constructors expr, map (fn (pat, expr) => (fixPatConstructors constructors pat, fixConstructors constructors expr)) arms) + | fixConstructors constructors (Syntax.EStruct decls) = + let val constructors = ref constructors in + Syntax.EStruct + (map + (fn dec => + (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ; + fixDecConstructors (!constructors) dec)) + decls) + end | fixConstructors _ expr = expr + val spec : (string * Syntax.etype) parser = + reserved "val" >> + bind identifier (fn id => + reserved ":" >> + bind parseType (fn ty => + const (id, ty))) + + val sigexp : (string * Syntax.etype) list parser = + between (reserved "sig") (reserved "end") (many spec) + + val sigdec : Syntax.dec parser = + reserved "signature" >> + bind identifier (fn sigID => + reserved "=" >> + bind sigexp (fn vals => + const (Syntax.DSig (sigID, vals)))) + + val fundec : Syntax.dec parser = + reserved "functor" >> + bind identifier (fn funID => + symbol "(" >> + bind identifier (fn arg => + reserved ":" >> + bind identifier (fn sigID => + symbol ")" >> + reserved "=" >> + reserved "struct" >> + bind (many strdec) (fn bindings => + reserved "end" >> + const (Syntax.DFunctor (funID, arg, sigID, Syntax.EStruct (List.mapPartial (fn x => x) bindings))))))) + + val topdec : Syntax.dec option parser = + strdec <|> SOME <$> sigdec <|> SOME <$> fundec + val program : Syntax.expr parser = whiteSpace >> - bind (many strdec) (fn decs => + bind (many topdec) (fn decs => const (fixConstructors StringMap.empty (Syntax.ELet (List.mapPartial (fn x => x) decs, Syntax.EInt 0)))) fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f end diff --git a/ShowSyntax.sml b/ShowSyntax.sml index 53cc2af..519fb2b 100644 --- a/ShowSyntax.sml +++ b/ShowSyntax.sml @@ -46,10 +46,20 @@ and patToStringI (indent : string) (Syntax.PWild : Syntax.pat) : string = "PCon " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ listToString (stringToStringI) indent' x0 ^ ",\n" ^ indent' ^ patToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x and patToString (x : Syntax.pat) : string = patToStringI "" x +and identTypeToStringI (indent : string) (Syntax.ITVar : Syntax.identType) : string = + "ITVar" + | identTypeToStringI (indent : string) (Syntax.ITStruct : Syntax.identType) : string = + "ITStruct" + | identTypeToStringI (indent : string) (Syntax.ITFunctor : Syntax.identType) : string = + "ITFunctor" + | identTypeToStringI (indent : string) (Syntax.ITSignature : Syntax.identType) : string = + "ITSignature" +and identTypeToString (x : Syntax.identType) : string = identTypeToStringI "" x + and exprToStringI (indent : string) (Syntax.EIdent x : Syntax.expr) : string = - "EIdent " ^ stringToStringI indent x + "EIdent " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ identTypeToStringI indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) 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 + "EDot " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ exprToStringI indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ identTypeToStringI indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) 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 = @@ -74,6 +84,10 @@ and exprToStringI (indent : string) (Syntax.EIdent x : Syntax.expr) : string = "ELambda " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ patToStringI indent' x0 ^ ",\n" ^ indent' ^ exprToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x | exprToStringI (indent : string) (Syntax.ECase x : Syntax.expr) : string = "ECase " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ exprToStringI indent' x0 ^ ",\n" ^ indent' ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ patToStringI indent' x0 ^ ",\n" ^ indent' ^ exprToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | exprToStringI (indent : string) (Syntax.EStruct x : Syntax.expr) : string = + "EStruct " ^ listToString (decToStringI) indent x + | exprToStringI (indent : string) (Syntax.EFunctorApp x : Syntax.expr) : string = + "EFunctorApp " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ exprToStringI indent' x0 ^ ",\n" ^ indent' ^ exprToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x and exprToString (x : Syntax.expr) : string = exprToStringI "" x and decToStringI (indent : string) (Syntax.DVal x : Syntax.dec) : string = @@ -87,19 +101,13 @@ and decToStringI (indent : string) (Syntax.DVal x : Syntax.dec) : string = | 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 = - "DStruct " ^ (fn indent => fn (x0, x1, x2) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ optionToString (stringToStringI) indent' x1 ^ ",\n" ^ indent' ^ structExprToStringI indent' x2 ^ "\n" ^ indent ^ ")" end) indent x + "DStruct " ^ (fn indent => fn (x0, x1, x2) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ optionToString (stringToStringI) indent' x1 ^ ",\n" ^ indent' ^ exprToStringI indent' x2 ^ "\n" ^ indent ^ ")" end) indent x | decToStringI (indent : string) (Syntax.DSig x : Syntax.dec) : string = "DSig " ^ (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' ^ etypeToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | decToStringI (indent : string) (Syntax.DFunctor x : Syntax.dec) : string = + "DFunctor " ^ (fn indent => fn (x0, x1, x2, x3) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ ",\n" ^ indent' ^ stringToStringI indent' x2 ^ ",\n" ^ indent' ^ exprToStringI indent' x3 ^ "\n" ^ indent ^ ")" end) indent x and decToString (x : Syntax.dec) : string = decToStringI "" x -and structExprToStringI (indent : string) (Syntax.SIdent x : Syntax.structExpr) : string = - "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 = @@ -116,12 +124,12 @@ and tyToStringI (indent : string) (Syntax.TInt : Syntax.ty) : string = "TList " ^ tyToStringI indent x | tyToStringI (indent : string) (Syntax.TDatatype x : Syntax.ty) : string = "TDatatype " ^ listToString (stringToStringI) indent x + | tyToStringI (indent : string) (Syntax.TStruct x : Syntax.ty) : string = + "TStruct " ^ 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' ^ identTypeToStringI indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent x + | tyToStringI (indent : string) (Syntax.TFunctor x : Syntax.ty) : string = + "TFunctor " ^ (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 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 = @@ -135,9 +143,9 @@ and typedPatToStringI (indent : string) (Syntax.TPWild : Syntax.typedPat) : stri and typedPatToString (x : Syntax.typedPat) : string = typedPatToStringI "" x and typedExprToStringI (indent : string) (Syntax.TEIdent x : Syntax.typedExpr) : string = - "TEIdent " ^ stringToStringI indent x + "TEIdent " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ identTypeToStringI indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) 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 + "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' ^ 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' ^ identTypeToStringI indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) 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 = @@ -160,6 +168,10 @@ and typedExprToStringI (indent : string) (Syntax.TEIdent x : Syntax.typedExpr) : "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 + | typedExprToStringI (indent : string) (Syntax.TEStruct x : Syntax.typedExpr) : string = + "TEStruct " ^ listToString (typedDecToStringI) indent x + | typedExprToStringI (indent : string) (Syntax.TEFunctorApp x : Syntax.typedExpr) : string = + "TEFunctorApp " ^ (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 and typedExprToString (x : Syntax.typedExpr) : string = typedExprToStringI "" x and typedDecToStringI (indent : string) (Syntax.TDVal x : Syntax.typedDec) : string = @@ -171,17 +183,11 @@ and typedDecToStringI (indent : string) (Syntax.TDVal x : Syntax.typedDec) : str | 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 + "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' ^ typedExprToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x + | typedDecToStringI (indent : string) (Syntax.TDFunctor x : Syntax.typedDec) : string = + "TDFunctor " ^ (fn indent => fn (x0, x1, x2, x3) => let val indent' = indent ^ " " in "(\n" ^ indent' ^ stringToStringI indent' x0 ^ ",\n" ^ indent' ^ stringToStringI indent' x1 ^ ",\n" ^ indent' ^ tyToStringI indent' x2 ^ ",\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' x3 ^ "\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 = @@ -14,9 +14,25 @@ struct | PTuple of pat list | PCon of string list * pat + datatype identType = + ITVar + | ITStruct + | ITFunctor + | ITSignature + + fun identTypeOrder ITVar = 0 + | identTypeOrder ITStruct = 1 + | identTypeOrder ITFunctor = 2 + | identTypeOrder ITSignature = 3 + + fun compareIdentifiers ((t1, n1) : identType * string, (t2, n2) : identType * string) : order = + case Int.compare (identTypeOrder t1, identTypeOrder t2) of + EQUAL => String.compare (n1, n2) + | ord => ord + datatype expr = - EIdent of string - | EDot of structExpr * string + EIdent of identType * string + | EDot of expr * (identType * string) | EBuiltin of string | EInt of int | EStr of string @@ -29,6 +45,8 @@ struct | ELet of dec list * expr | ELambda of pat * expr | ECase of expr * (pat * expr) list + | EStruct of dec list + | EFunctorApp of expr * expr and dec = DVal of pat * expr @@ -36,13 +54,10 @@ struct | DFun of string * (pat list * expr) list | DDatatype of string list * string * (string * etype option) list | DType of string * etype - | DStruct of string * string option * structExpr + | DStruct of string * string option * expr | DSig of string * (string * etype) list - - and structExpr = - SIdent of string - | SDot of structExpr * string - | SStruct of dec list + (* Functor? I hardly know 'er! *) + | DFunctor of string * string * string * expr datatype ty = TInt @@ -53,10 +68,8 @@ struct | 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 *) + | TStruct of ((identType * string) * ty) list + | TFunctor of ty * ty datatype typedPat = TPWild @@ -66,8 +79,8 @@ struct | TPCon of string list * (typedPat * ty) datatype typedExpr = - TEIdent of string - | TEDot of (typedStructExpr * structType) * string + TEIdent of identType * string + | TEDot of (typedExpr * ty) * (identType * string) | TEBuiltin of string | TEInt of int | TEStr of string @@ -79,18 +92,16 @@ struct | TELet of typedDec list * (typedExpr * ty) | TELambda of (typedPat * ty) * (typedExpr * ty) | TECase of (typedExpr * ty) * ((typedPat * ty) * (typedExpr * ty)) list + | TEStruct of typedDec list + | TEFunctorApp of (typedExpr * ty) * (typedExpr * ty) 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 + | TDStruct of string * (typedExpr * ty) + | TDFunctor of string * string * ty * (typedExpr * ty) (* Lambda language *) type var = int @@ -1,30 +1,34 @@ structure Types = struct structure StringMap = Map(type k = string val cmp = String.compare) structure IntMap = Map(type k = int val cmp = Int.compare) + structure IdentMap = Map(type k = Syntax.identType * string val cmp = Syntax.compareIdentifiers) type tyvar = int - datatype tycon = Bool | Int | Str | Fun | Tuple | List | Datatype of int - and ty = + datatype tycon = Bool | Int | Str | Fun | Tuple | List | Datatype of int | Functor + datatype ty = TyVar of tyvar | TyCon of tycon * ty list - | TyStruct of structTy - and structTy = Struct of { - structs : structTy StringMap.map, - vals : ty StringMap.map - } + | TyStruct of ty IdentMap.map structure TyVarMap = IntMap fun listToString (show : 'a -> string) (l : 'a list) : string = "[" ^ String.concatWith ", " (map show l) ^ "]" + fun printIdent (ty : Syntax.identType, name : string) : string = "(" ^ ShowSyntax.identTypeToString ty ^ ", \"" ^ name ^ "\")" + fun printTyCon Int : string = "Int" + | printTyCon Bool = "Bool" + | printTyCon Str = "Str" | printTyCon Fun = "Fun" | printTyCon Tuple = "Tuple" + | printTyCon List = "List" | printTyCon (Datatype tag) = "Datatype " ^ Int.toString tag + | printTyCon Functor = "Functor" and printTy (TyVar a) : string = "TyVar " ^ Int.toString a | printTy (TyCon (n, tys)) = "TyCon (" ^ printTyCon n ^ ", " ^ listToString printTy tys ^ ")" + | printTy (TyStruct decls) = "TyStruct " ^ listToString (fn (id, ty) => "(" ^ printIdent id ^ ", " ^ printTy ty ^ ")") (IdentMap.toList decls) (* map of type variables to types *) val substitution : ty TyVarMap.map ref = ref TyVarMap.empty @@ -55,19 +59,17 @@ structure Types = struct 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 - } + type env = + { bindings : binding IdentMap.map + , boundVars : unit TyVarMap.map + , typesByName : tycon 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 - } + fun bind (makeBinding : tyvar -> binding) (s : Syntax.identType * string) (v : tyvar) (env : env) : env = + { bindings = IdentMap.insert s (makeBinding v) (#bindings env) + , boundVars = TyVarMap.insert v () (#boundVars env) + , typesByName = (#typesByName env) + } fun genericVars (env : env) (TyVar a) : unit TyVarMap.map = if isSome (TyVarMap.lookup a (#boundVars env)) @@ -115,15 +117,14 @@ structure Types = struct | go (Syntax.Tyfun (arg, result)) = TyCon (Fun, [go arg, go result]) in instantiate env (go t) end - fun bindType ((vars, name, constructors) : string list * string * (string * Syntax.etype option) list) (env as {bindings, boundVars, typesByName, structs} : env) : env = + fun bindType ((vars, name, constructors) : string list * string * (string * Syntax.etype option) list) (env : env) : env = let val tag = GenSym.new () - val env = { - bindings = bindings, - boundVars = boundVars, - typesByName = StringMap.insert name (Datatype tag) typesByName, - structs = structs - } + val env = + { bindings = #bindings env + , boundVars = #boundVars env + , typesByName = StringMap.insert name (Datatype tag) (#typesByName env) + } in datatypes := IntMap.insert tag (map (fn (x, _) => x) constructors) (!datatypes) ; foldl @@ -137,31 +138,24 @@ structure Types = struct | SOME t => TyCon (Fun, [etypeToTy env t, resType]) in unify (TyVar g) conType; - bind Let x g env + bind Let (Syntax.ITVar, 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 + bind makeBinding (Syntax.ITVar, 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 lookupBinding (name : string) (env : env) : ty = - case StringMap.lookup name (#bindings env) of + fun lookupBinding (name: Syntax.identType * string) (env : env) : ty = + case IdentMap.lookup name (#bindings env) of SOME (Let t) => instantiate env (find (TyVar t)) | SOME (Arg t) => TyVar t - | NONE => raise Fail ("unbound var " ^ name) + | NONE => raise Fail ("unbound var " ^ printIdent name) fun patBindings (Syntax.PVar v) : string list = [v] | patBindings (Syntax.PTuple pats) = List.concat (map patBindings pats) @@ -179,17 +173,12 @@ structure Types = struct (case (IntMap.lookup tag (!datatypes)) of SOME cases => Syntax.TDatatype cases | NONE => raise Fail ("unknown datatype tag " ^ Int.toString tag)) + | tyToSyntaxTy (TyCon (Functor, [f, x])) = Syntax.TFunctor (tyToSyntaxTy f, tyToSyntaxTy x) + | tyToSyntaxTy (TyStruct decls) = Syntax.TStruct (map (fn (id, ty) => (id, tyToSyntaxTy ty)) (IdentMap.toList decls)) | 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 env (Syntax.PVar v) = (Syntax.TPVar v, TyVar (case (IdentMap.lookup (Syntax.ITVar, 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 @@ -201,21 +190,23 @@ structure Types = struct let val conBinding = case con of - [ident] => lookupBinding ident env + [ident] => lookupBinding (Syntax.ITVar, ident) env + | [] => raise Fail "invalid constructor" | str :: fields => - case StringMap.lookup str (#structs env) of - SOME (Struct structTy) => + case lookupBinding (Syntax.ITStruct, str) env of + TyStruct structTy => let fun go structTy [field] = - (case StringMap.lookup field (#vals structTy) of + (case IdentMap.lookup (Syntax.ITVar, field) 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) + (case IdentMap.lookup (Syntax.ITStruct, str) structTy of + SOME (TyStruct structTy) => go structTy fields + | _ => raise Fail ("unbound field " ^ str)) + | go _ _ = raise (Fail "a constructor should have at least one field") in go structTy fields end - | NONE => raise Fail ("unbound struct " ^ str) + | _ => raise Fail ("that's a weird struct " ^ str) in case conBinding of TyCon (Fun, [argType, resType]) => @@ -230,13 +221,15 @@ structure Types = struct | _ => 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 = + fun F (env : env) (Syntax.EIdent i) : 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 + (case F env expr of + (str, TyStruct structType) => + let + val fieldType = instantiate env (find (valOf (IdentMap.lookup field structType))) + in (Syntax.TEDot ((str, tyToSyntaxTy (TyStruct structType)), field), fieldType) end + | (_, ty) => raise Fail ("wrong struct type " ^ printTy ty)) | 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, [])])) @@ -312,6 +305,26 @@ structure Types = struct end) arms in (Syntax.TECase ((arg, tyToSyntaxTy argType), arms), resultType) end + | F env (Syntax.EStruct decls) = + let val (env, decls) = tagDecs env decls + in + ( Syntax.TEStruct decls + , TyStruct + (IdentMap.fromList + (map + (fn (name, Let v) => (name, TyVar v) + | (name, Arg v) => (name, TyVar v)) + (IdentMap.toList (#bindings env)))) + ) + end + | F env (Syntax.EFunctorApp (func, arg)) = + case F env func of + (func, funcType as TyCon (Functor, [_, result])) => + let + val (arg, argType) = F env arg + in (Syntax.TEFunctorApp ((func, tyToSyntaxTy funcType), (arg, tyToSyntaxTy argType)), result) end + | _ => raise Fail "invalid functor" + (* | F _ expr = raise Fail ("invalid expression " ^ ShowSyntax.exprToString expr) *) and tagDec (env : env) (Syntax.DVal (pat, expr)) : env * Syntax.typedDec option = let @@ -337,7 +350,7 @@ structure Types = struct val args1Env = foldl (fn (arg, env) => bindPat Arg arg env) - (bind Arg name fnType env) + (bind Arg (Syntax.ITVar, name) fnType env) args val args = map (tagPat args1Env) args val argTypes = map (fn (_, ty) => ty) args @@ -350,7 +363,7 @@ structure Types = struct val env = foldl (fn (arg, env) => bindPat Arg arg env) - (bind Arg name fnType env) + (bind Arg (Syntax.ITVar, name) fnType env) args val args = map (tagPat env) args val (body, bt) = F env body @@ -362,16 +375,40 @@ structure Types = struct (map (fn (arg, ty) => (arg, tyToSyntaxTy ty)) args, (body, tyToSyntaxTy bt)) end) cases - in (bind Let name fnType env, SOME (Syntax.TDFun (name, cases))) + in (bind Let (Syntax.ITVar, 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 env (Syntax.DSig (s, decls)) = (env, NONE) + let + val v = GenSym.new () + val (str, strType) = F env str + val _ = unify (TyVar v) strType + in (bind Let (Syntax.ITStruct, name) v env, SOME (Syntax.TDStruct (name, (str, tyToSyntaxTy strType)))) end + | tagDec env (Syntax.DSig (s, decls)) = + let + val signType = TyStruct + (IdentMap.fromList + (map + (fn (name, ty) => ((Syntax.ITVar, name), etypeToTy env ty)) + decls)) + val v = GenSym.new () + val _ = unify (TyVar v) signType + val env = bind Let (Syntax.ITSignature, s) v env + in (env, NONE) end + | tagDec env (Syntax.DFunctor (functorName, arg, sign, body)) = + let + val (_, signType) = F env (Syntax.EIdent (Syntax.ITSignature, sign)) + val a = GenSym.new () + val _ = unify (TyVar a) signType + val bodyEnv = bind Let (Syntax.ITStruct, arg) a env + val (body, bodyType) = F bodyEnv body + val f = GenSym.new () + val _ = unify (TyVar f) (TyCon (Functor, [signType, bodyType])) + val env = bind Let (Syntax.ITFunctor, functorName) f env + in (env, SOME (Syntax.TDFunctor (functorName, arg, tyToSyntaxTy signType, (body, tyToSyntaxTy bodyType)))) end | tagDec _ _ = raise Fail "invalid expr" and tagDecs env [] = (env, []) @@ -386,32 +423,6 @@ structure Types = struct 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 @@ -428,7 +439,7 @@ structure Types = struct let val expr = case expr of - Syntax.TEDot (str, field) => Syntax.TEDot (reexpandStructExpr str, field) + Syntax.TEDot (str, field) => Syntax.TEDot (reexpand 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) @@ -444,25 +455,16 @@ structure Types = struct | 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 + | reexpandDecl (Syntax.TDStruct (name, str)) = Syntax.TDStruct (name, reexpand str) + | reexpandDecl (Syntax.TDFunctor (name, arg, argType, body)) = Syntax.TDFunctor (name, arg, reexpandType argType, reexpand body) 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 env = + { bindings = IdentMap.empty + , boundVars = TyVarMap.empty + , typesByName = 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 708d1b7..d524fcc 100644 --- a/generate-show-syntax.sml +++ b/generate-show-syntax.sml @@ -45,7 +45,7 @@ val ast = | Result.Right x => x val (structName, decls) = case ast of - Syntax.ELet (Syntax.DStruct (structName, _, Syntax.SStruct decls) :: _, _) => (structName, decls) + Syntax.ELet (Syntax.DStruct (structName, _, Syntax.EStruct decls) :: _, _) => (structName, decls) | _ => raise Fail "ast has unexpected format (I can't print it sorry)" val out = TextIO.openOut (!(#o opts)) val _ = TextIO.output (out, "(*\n This file was generated by generate-show-syntax.sml. Do not edit manually.\n To regenerate, use\n\n sml generate-show-syntax.sml -o " ^ !(#o opts) ^ " " ^ filename ^ "\n*)\n\n") @@ -1,17 +1,17 @@ use "Sort.sml"; use "Result.sml"; use "Buffer.sml"; -use "GenSym.sml"; use "Map.sml"; -use "Syntax.sml"; use "Opts.sml"; +use "GenSym.sml"; +use "Syntax.sml"; use "Parser.sml"; use "ShowSyntax.sml"; -use "Types.sml"; -use "Elab.sml"; -use "CPS.sml"; use "CodeGen.sml"; use "Linker.sml"; +use "CPS.sml"; +use "Elab.sml"; +use "Types.sml"; use "Compiler.sml"; val _ = Compiler.main (CommandLine.arguments ()) diff --git a/tests/24-functor.sml b/tests/24-functor.sml new file mode 100644 index 0000000..d18337e --- /dev/null +++ b/tests/24-functor.sml @@ -0,0 +1,17 @@ +signature MagicNumber = sig + val n : int +end + +functor Exiter(N : MagicNumber) = struct + fun exit _ = __builtin "exit" N.n +end + +structure FourtyTwo = struct + val a = 16 + val n = 42 + val z = 38 +end + +structure FourtyTwoExiter = Exiter(FourtyTwo) + +val _ = FourtyTwoExiter.exit () |