diff options
Diffstat (limited to 'Types.sml')
| -rw-r--r-- | Types.sml | 218 |
1 files changed, 110 insertions, 108 deletions
@@ -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 |