Lifting cons in ElabEnv

7 files changed, 46 insertions, 31 deletions

diff --git a/src/elab_env.sig b/src/elab_env.sig
index 075fe0dd..f7f798e5 100644
--- a/src/elab_env.sig
+++ b/src/elab_env.sig
@@ -27,6 +27,9 @@
 
 signature ELAB_ENV = sig
 
+    exception SynUnif
+    val liftConInCon : int -> Elab.con -> Elab.con
+
     type env
 
     val empty : env
@@ -57,4 +60,6 @@ signature ELAB_ENV = sig
                                                  
     val lookupE : env -> string -> Elab.con var
 
+    val declBinds : env -> Elab.decl -> env
+
 end
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 27ea1750..417eab74 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -29,6 +29,9 @@ structure ElabEnv :> ELAB_ENV = struct
 
 open Elab
 
+structure L' = Elab
+structure U = ElabUtil
+
 structure IM = IntBinaryMap
 structure SM = BinaryMapFn(struct
                            type ord_key = string
@@ -38,6 +41,30 @@ structure SM = BinaryMapFn(struct
 exception UnboundRel of int
 exception UnboundNamed of int
 
+
+(* AST utility functions *)
+
+exception SynUnif
+
+val liftConInCon =
+    U.Con.mapB {kind = fn k => k,
+                con = fn bound => fn c =>
+                                     case c of
+                                         L'.CRel xn =>
+                                         if xn < bound then
+                                             c
+                                         else
+                                             L'.CRel (xn + 1)
+                                       | L'.CUnif _ => raise SynUnif
+                                       | _ => c,
+                bind = fn (bound, U.Con.Rel _) => bound + 1
+                        | (bound, _) => bound}
+
+val lift = liftConInCon 0
+
+
+(* Back to environments *)
+
 datatype 'a var' =
          Rel' of int * 'a
        | Named' of int * 'a
@@ -76,11 +103,11 @@ fun pushCRel (env : env) x k =
     in
         {renameC = SM.insert (renameC, x, Rel' (0, k)),
          relC = (x, k) :: #relC env,
-         namedC = #namedC env,
+         namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env),
 
          renameE = #renameE env,
-         relE = #relE env,
-         namedE = #namedE env}
+         relE = map (fn (x, c) => (x, lift c)) (#relE env),
+         namedE = IM.map (fn (x, c) => (x, lift c)) (#namedE env)}
     end
 
 fun lookupCRel (env : env) n =
@@ -161,4 +188,9 @@ fun lookupE (env : env) x =
       | SOME (Rel' x) => Rel x
       | SOME (Named' x) => Named x
 
+fun declBinds env (d, _) =
+    case d of
+        DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c)
+      | DVal (x, n, t, _) => pushENamedAs env x n t
+
 end
diff --git a/src/elab_print.sml b/src/elab_print.sml
index c11b0da1..2b9d7920 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -270,7 +270,7 @@ fun p_decl env ((d, _) : decl) =
 fun p_file env file =
     let
         val (_, pds) = ListUtil.mapfoldl (fn (d, env) =>
-                                             (ElabUtil.declBinds env d,
+                                             (E.declBinds env d,
                                               p_decl env d))
                              env file
     in
diff --git a/src/elab_util.sig b/src/elab_util.sig
index 4782d69d..80d04465 100644
--- a/src/elab_util.sig
+++ b/src/elab_util.sig
@@ -75,6 +75,4 @@ structure Exp : sig
                   exp : Elab.exp' -> bool} -> Elab.exp -> bool
 end
 
-val declBinds : ElabEnv.env -> Elab.decl -> ElabEnv.env
-
 end
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 56be1328..7a40a889 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -286,11 +286,4 @@ fun exists {kind, con, exp} k =
 
 end
 
-structure E = ElabEnv
-
-fun declBinds env (d, _) =
-    case d of
-        DCon (x, n, k, c) => E.pushCNamedAs env x n k (SOME c)
-      | DVal (x, n, t, _) => E.pushENamedAs env x n t
-
 end
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 9d672869..53a45358 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -344,21 +344,8 @@ fun cunifyError env err =
       | CRecordFailure =>
         eprefaces "Can't unify record constructors" []
 
-exception SynUnif
-
-val liftConInCon =
-    U.Con.mapB {kind = fn k => k,
-                con = fn bound => fn c =>
-                                     case c of
-                                         L'.CRel xn =>
-                                         if xn < bound then
-                                             c
-                                         else
-                                             L'.CRel (xn + 1)
-                                       | L'.CUnif _ => raise SynUnif
-                                       | _ => c,
-                bind = fn (bound, U.Con.Rel _) => bound + 1
-                        | (bound, _) => bound}
+exception SynUnif = E.SynUnif
+val liftConInCon = E.liftConInCon
 
 val subConInCon =
     U.Con.mapB {kind = fn k => k,
diff --git a/src/sources b/src/sources
index aab5a522..1c3ae6ff 100644
--- a/src/sources
+++ b/src/sources
@@ -20,12 +20,12 @@ source_print.sml
 
 elab.sml
 
-elab_env.sig
-elab_env.sml
-
 elab_util.sig
 elab_util.sml
 
+elab_env.sig
+elab_env.sml
+
 elab_print.sig
 elab_print.sml