From c48a992a6ed6ebd79c344b37364a680ddd948dea Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Sat, 31 Aug 2024 13:08:56 -0700 Subject: Combine structs and expressions --- Elab.sml | 150 ++++++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 85 insertions(+), 65 deletions(-) (limited to 'Elab.sml') diff --git a/Elab.sml b/Elab.sml index cd7a5d4..ba436f5 100644 --- a/Elab.sml +++ b/Elab.sml @@ -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 -- cgit v1.3.1