summaryrefslogtreecommitdiffstats
path: root/Elab.sml
diff options
context:
space:
mode:
Diffstat (limited to 'Elab.sml')
-rw-r--r--Elab.sml150
1 files changed, 85 insertions, 65 deletions
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
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 04:28:29 +0000