Mercurial > urweb
diff src/elab_env.sml @ 1303:c7b9a33c26c8
Hopeful fix for the Great Unification Bug
author | Adam Chlipala <adam@chlipala.net> |
---|---|
date | Sun, 10 Oct 2010 14:41:03 -0400 |
parents | b4480a56cab7 |
children | fdf48f6ba418 |
line wrap: on
line diff
--- a/src/elab_env.sml Sun Oct 10 13:07:38 2010 -0400 +++ b/src/elab_env.sml Sun Oct 10 14:41:03 2010 -0400 @@ -43,8 +43,6 @@ (* AST utility functions *) -exception SynUnif - val liftKindInKind = U.Kind.mapB {kind = fn bound => fn k => case k of @@ -78,13 +76,32 @@ c else CRel (xn + 1) - (*| CUnif _ => raise SynUnif*) + | CUnif (nl, loc, k, s, r) => CUnif (nl+1, loc, k, s, r) | _ => c, bind = fn (bound, U.Con.RelC _) => bound + 1 | (bound, _) => bound} val lift = liftConInCon 0 +fun mliftConInCon by c = + if by = 0 then + c + else + U.Con.mapB {kind = fn _ => fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + by) + | CUnif (nl, loc, k, s, r) => CUnif (nl+by, loc, k, s, r) + | _ => c, + bind = fn (bound, U.Con.RelC _) => bound + 1 + | (bound, _) => bound} 0 c + +val () = U.mliftConInCon := mliftConInCon + val liftKindInExp = U.Exp.mapB {kind = fn bound => fn k => case k of @@ -108,6 +125,7 @@ c else CRel (xn + 1) + | CUnif (nl, loc, k, s, r) => CUnif (nl+1, loc, k, s, r) | _ => c, exp = fn _ => fn e => e, bind = fn (bound, U.Exp.RelC _) => bound + 1 @@ -466,7 +484,7 @@ case c of CNamed n => SOME (ClNamed n) | CModProj x => SOME (ClProj x) - | CUnif (_, _, _, ref (SOME c)) => class_name_in c + | CUnif (_, _, _, _, ref (SOME c)) => class_name_in c | _ => NONE fun isClass (env : env) c = @@ -480,7 +498,7 @@ fun class_head_in c = case #1 c of CApp (f, _) => class_head_in f - | CUnif (_, _, _, ref (SOME c)) => class_head_in c + | CUnif (_, _, _, _, ref (SOME c)) => class_head_in c | _ => class_name_in c exception Unify @@ -502,8 +520,8 @@ fun eqCons (c1, c2) = case (#1 c1, #1 c2) of - (CUnif (_, _, _, ref (SOME c1)), _) => eqCons (c1, c2) - | (_, CUnif (_, _, _, ref (SOME c2))) => eqCons (c1, c2) + (CUnif (nl, _, _, _, ref (SOME c1)), _) => eqCons (mliftConInCon nl c1, c2) + | (_, CUnif (nl, _, _, _, ref (SOME c2))) => eqCons (c1, mliftConInCon nl c2) | (CRel n1, CRel n2) => if n1 = n2 then () else raise Unify @@ -545,8 +563,8 @@ let fun unify d (c1, c2) = case (#1 c1, #1 c2) of - (CUnif (_, _, _, ref (SOME c1)), _) => unify d (c1, c2) - | (_, CUnif (_, _, _, ref (SOME c2))) => unify d (c1, c2) + (CUnif (nl, _, _, _, ref (SOME c1)), _) => unify d (mliftConInCon nl c1, c2) + | (_, CUnif (nl, _, _, _, ref (SOME c2))) => unify d (c1, mliftConInCon nl c2) | (CUnif _, _) => () @@ -633,7 +651,7 @@ exception Bad of con * con val hasUnif = U.Con.exists {kind = fn _ => false, - con = fn CUnif (_, _, _, ref NONE) => true + con = fn CUnif (_, _, _, _, ref NONE) => true | _ => false} fun startsWithUnif c = @@ -670,7 +688,7 @@ val rk = ref NONE val k = (KUnif (loc, "k", rk), loc) val r = ref NONE - val rc = (CUnif (loc, k, "x", r), loc) + val rc = (CUnif (0, loc, k, "x", r), loc) in ((CApp (f, rc), loc), fn () => (if consEq (rc, x) then