Mercurial > urweb
diff src/elaborate.sml @ 82:b4f2a258e52c
Initial disjointness prover
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Tue, 01 Jul 2008 10:55:38 -0400 |
parents | 60d97de1bbe8 |
children | 0a1baddd8ab2 |
line wrap: on
line diff
--- a/src/elaborate.sml Tue Jul 01 09:29:49 2008 -0400 +++ b/src/elaborate.sml Tue Jul 01 10:55:38 2008 -0400 @@ -32,6 +32,7 @@ structure L' = Elab structure E = ElabEnv structure U = ElabUtil +structure D = Disjoint open Print open ElabPrint @@ -73,6 +74,8 @@ in case (k1, k2) of (L'.KType, L'.KType) => () + | (L'.KUnit, L'.KUnit) => () + | (L'.KArrow (d1, r1), L'.KArrow (d2, r2)) => (unifyKinds' d1 d2; unifyKinds' r1 r2) @@ -199,6 +202,7 @@ | L.KArrow (k1, k2) => (L'.KArrow (elabKind k1, elabKind k2), loc) | L.KName => (L'.KName, loc) | L.KRecord k => (L'.KRecord (elabKind k), loc) + | L.KUnit => (L'.KUnit, loc) | L.KWild => kunif loc fun foldKind (dom, ran, loc)= @@ -330,6 +334,10 @@ val ku = kunif loc val k = (L'.KRecord ku, loc) in + case D.prove env D.empty (c1', c2', loc) of + [] => () + | _ => raise Fail "Can't prove disjointness"; + checkKind env c1' k1 k; checkKind env c2' k2 k; ((L'.CConcat (c1', c2'), loc), k) @@ -343,6 +351,8 @@ foldKind (dom, ran, loc)) end + | L.CUnit => ((L'.CUnit, loc), (L'.KUnit, loc)) + | L.CWild k => let val k' = elabKind k @@ -478,6 +488,8 @@ | L'.CConcat (c, _) => kindof env c | L'.CFold (dom, ran) => foldKind (dom, ran, loc) + | L'.CUnit => (L'.KUnit, loc) + | L'.CError => kerror | L'.CUnif (_, k, _, _) => k