Mercurial > urweb
diff src/elaborate.sml @ 216:38b299373676
Looking up in a type class from a module
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Sat, 16 Aug 2008 15:58:25 -0400 |
parents | 0343557355fc |
children | 56db662ebcfd |
line wrap: on
line diff
--- a/src/elaborate.sml Sat Aug 16 15:09:53 2008 -0400 +++ b/src/elaborate.sml Sat Aug 16 15:58:25 2008 -0400 @@ -1373,6 +1373,21 @@ isTotal (combinedCoverage ps, t) end +fun normClassConstraint envs c = + let + val ((c, loc), gs1) = hnormCon envs c + in + case c of + L'.CApp (f, x) => + let + val (f, gs2) = hnormCon envs f + val (x, gs3) = hnormCon envs x + in + ((L'.CApp (f, x), loc), gs1 @ gs2 @ gs3) + end + | _ => ((c, loc), gs1) + end + fun elabExp (env, denv) (eAll as (e, loc)) = let @@ -1430,10 +1445,14 @@ in case t1 of (L'.TFun (dom, ran), _) => - (case E.resolveClass env dom of - NONE => (expError env (Unresolvable (loc, dom)); - (eerror, cerror, [])) - | SOME pf => ((L'.EApp (e1', pf), loc), ran, gs1 @ gs2 @ gs3)) + let + val (dom, gs4) = normClassConstraint (env, denv) dom + in + case E.resolveClass env dom of + NONE => (expError env (Unresolvable (loc, dom)); + (eerror, cerror, [])) + | SOME pf => ((L'.EApp (e1', pf), loc), ran, gs1 @ gs2 @ gs3 @ gs4) + end | _ => (expError env (OutOfContext loc); (eerror, cerror, [])) end