X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/254d5faaae330b43f04ad7f39fb4340457d78776..8061fadf3b4e8cb08c97fe61cb38476f66efa352:/src/env.sml

diff --git a/src/env.sml b/src/env.sml
index 4b5be9d..be8438a 100644
--- a/src/env.sml
+++ b/src/env.sml
@@ -212,42 +212,43 @@ fun container_one name args (f, g) = registerContainer (name, one name args f, g
 fun containerV_none name (f, g) = registerContainer (name, noneV name f, g)
 fun containerV_one name args (f, g) = registerContainer (name, oneV name args f, g)
 
-type env = SS.set * (typ * exp option) SM.map * SS.set * (typ * exp) SM.map
-val empty : env = (SS.empty, SM.empty, SS.empty, SM.empty)
+datatype env = Env of SS.set * (typ * exp option * env) SM.map * SS.set * (typ * exp * env) SM.map
+val empty : env = Env (SS.empty, SM.empty, SS.empty, SM.empty)
 
 
-fun initialDynEnvTypes (_, _, _, ds) =
-    SM.map (fn (t, e) => t) ds
+fun initialDynEnvTypes (Env (_, _, _, ds)) =
+    SM.map (fn (t, _, _) => t) ds
 
 (* hack ahead: These are not reduced when declared and must be before
    starting evaluation. Pass in reduceExp, and force an awkward
    calling convention so no one thinks this is the Right Way (tm) *)
-fun initialDynEnvVals f (env as (_, _, _, ds)) =
-    SM.map (fn (t, v) => f env v) ds
+fun initialDynEnvVals f (Env (_, _, _, ds)) =
+    SM.map (fn (t, v, env) => f env v) ds
 
-fun lookupType (ts, _, _, _) name = SS.member (ts, name)
-fun lookupVal (_, vs, _, _) name =
+fun lookupType (Env (ts, _, _, _)) name = SS.member (ts, name)
+fun lookupVal (Env (_, vs, _, _)) name =
     case SM.find (vs, name) of
 	NONE => NONE
-      | SOME (t, _) => SOME t
-fun lookupEquation (_, vs, _, _) name =
+      | SOME (t, _, _) => SOME t
+fun lookupEquation (Env (_, vs, _, _)) name =
     case SM.find (vs, name) of
 	NONE => NONE
-      | SOME (_, eqo) => eqo
-fun lookupContext (_, _, cs, _) name = SS.member (cs, name)
-fun lookupInitialDynEnvVal (_, _, _, ds) name =
+      | SOME (_, NONE, _) => NONE
+      | SOME (_, SOME eq, env) => SOME (eq, env)
+fun lookupContext (Env (_, _, cs, _)) name = SS.member (cs, name)
+fun lookupInitialDynEnvVal (Env (_, _, _, ds)) name =
     case SM.find (ds, name) of
 	NONE => NONE
-      | SOME (t, _) => SOME t
+      | SOME (t, _, _) => SOME t
 
-fun bindType (ts, vs, cs, ds) name = (SS.add (ts, name), vs, cs, ds)
-fun bindVal (ts, vs, cs, ds) (name, t, eqo) = (ts, SM.insert (vs, name, (t, eqo)), cs, ds)
-fun bindContext (ts, vs, cs, ds) name = (ts, vs, SS.add (cs, name), ds)
-fun bindInitialDynEnvVal (ts, vs, cs, ds) (name, t, eqn) = (ts, vs, cs, SM.insert (ds, name, (t, eqn)))
+fun bindType (Env (ts, vs, cs, ds)) name = Env (SS.add (ts, name), vs, cs, ds)
+fun bindVal (env as (Env (ts, vs, cs, ds))) (name, t, eqo) = Env (ts, SM.insert (vs, name, (t, eqo, env)), cs, ds)
+fun bindContext (Env (ts, vs, cs, ds)) name = Env (ts, vs, SS.add (cs, name), ds)
+fun bindInitialDynEnvVal (env as (Env (ts, vs, cs, ds))) (name, t, eqn) = Env (ts, vs, cs, SM.insert (ds, name, (t, eqn, env)))
 
-fun types (ts, _, _, _) = ts
-fun vals (_, vs, _, _) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs
-fun contexts (_, _, cs, _) = cs
-fun dynamics (_, _, _, ds) = SM.foldli (fn (name, _, ds) => SS.add (ds, name)) SS.empty ds
+fun types (Env (ts, _, _, _)) = ts
+fun vals (Env (_, vs, _, _)) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs
+fun contexts (Env (_, _, cs, _)) = cs
+fun dynamics (Env (_, _, _, ds)) = SM.foldli (fn (name, _, ds) => SS.add (ds, name)) SS.empty ds
 
 end