Mercurial > urweb
diff src/elaborate.sml @ 750:059074c8d2fc
LEFT JOIN
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Tue, 28 Apr 2009 11:05:28 -0400 |
parents | 9864b64b1700 |
children | d484df4e841a |
line wrap: on
line diff
--- a/src/elaborate.sml Tue Apr 28 10:11:56 2009 -0400 +++ b/src/elaborate.sml Tue Apr 28 11:05:28 2009 -0400 @@ -1131,26 +1131,35 @@ | (L'.TFun (dom, ran), _) => let fun default () = (e, t, []) + + fun isInstance () = + if infer <> L.TypesOnly then + let + val r = ref NONE + val (e, t, gs) = unravel (ran, (L'.EApp (e, (L'.EUnif r, loc)), loc)) + in + (e, t, TypeClass (env, dom, r, loc) :: gs) + end + else + default () + + fun hasInstance c = + case #1 (hnormCon env c) of + L'.CApp (cl, x) => + let + val cl = hnormCon env cl + in + isClassOrFolder env cl + end + | L'.TRecord c => U.Con.exists {kind = fn _ => false, + con = fn c => + E.isClass env (hnormCon env (c, loc))} c + | _ => false in - case #1 (hnormCon env dom) of - L'.CApp (cl, x) => - let - val cl = hnormCon env cl - in - if infer <> L.TypesOnly then - if isClassOrFolder env cl then - let - val r = ref NONE - val (e, t, gs) = unravel (ran, (L'.EApp (e, (L'.EUnif r, loc)), loc)) - in - (e, t, TypeClass (env, dom, r, loc) :: gs) - end - else - default () - else - default () - end - | _ => default () + if hasInstance dom then + isInstance () + else + default () end | (L'.TDisjoint (r1, r2, t'), loc) => if infer <> L.TypesOnly then @@ -3638,7 +3647,7 @@ let val c = normClassKey env c in - case E.resolveClass env c of + case E.resolveClass (hnormCon env) env c of SOME e => r := SOME e | NONE => expError env (Unresolvable (loc, c)) end) gs @@ -3688,11 +3697,6 @@ if ErrorMsg.anyErrors () then () else - app (fn f => f ()) (!checks); - - if ErrorMsg.anyErrors () then - () - else app (fn Disjoint (loc, env, denv, c1, c2) => (case D.prove env denv (c1, c2, loc) of [] => () @@ -3708,7 +3712,7 @@ val c = normClassKey env c in - case E.resolveClass env c of + case E.resolveClass (hnormCon env) env c of SOME e => r := SOME e | NONE => case #1 (hnormCon env c) of @@ -3747,6 +3751,11 @@ | _ => default () end) gs; + if ErrorMsg.anyErrors () then + () + else + app (fn f => f ()) (!checks); + (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) :: ds @ (L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan)