Mercurial > urweb
diff src/elab_env.sml @ 13:6049e2193bf2
Lifting cons in ElabEnv
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Sun, 08 Jun 2008 11:32:48 -0400 |
parents | e97c6d335869 |
children | f1c36df29ed7 |
line wrap: on
line diff
--- a/src/elab_env.sml Fri Mar 28 17:34:57 2008 -0400 +++ b/src/elab_env.sml Sun Jun 08 11:32:48 2008 -0400 @@ -29,6 +29,9 @@ open Elab +structure L' = Elab +structure U = ElabUtil + structure IM = IntBinaryMap structure SM = BinaryMapFn(struct type ord_key = string @@ -38,6 +41,30 @@ 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 @@ 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 @@ | 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