diff options
| author | simonpj@microsoft.com <unknown> | 2010-12-03 18:07:58 +0000 |
|---|---|---|
| committer | simonpj@microsoft.com <unknown> | 2010-12-03 18:07:58 +0000 |
| commit | 081632b8f49b5afae43afa8b4fac9c2334e7a3ec (patch) | |
| tree | 9679ab141ba62cd19a7360d6538b45ee7cb4ef93 | |
| parent | c9bb9c464e9f1ab778db936cd389e5ab3550da43 (diff) | |
| download | haskell-081632b8f49b5afae43afa8b4fac9c2334e7a3ec.tar.gz | |
Fix up TcInstDcls
I really don't know how this module got left out of my last
patch, namely
Thu Dec 2 12:35:47 GMT 2010 simonpj@microsoft.com
* Re-jig simplifySuperClass (again)
I suggest you don't pull either the patch above, or this
one, unless you really have to. I'm not fully confident
that it works properly yet. Ran out of time. Sigh.
| -rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 19 |
1 files changed, 6 insertions, 13 deletions
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index dd7424a52a..801992c7ad 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -697,7 +697,7 @@ tcSpecInstPrags dfun_id (VanillaInst binds uprags _) ------------------------------ tcSuperClass :: [TyVar] -> [EvVar] -> EvBind - -> (Id, PredType) -> TcM (Id, LHsBind Id) + -> (Id, PredType) -> TcM (Id, LHsBind Id) -- Build a top level decl like -- sc_op = /\a \d. let this = ... in -- let sc = ... in @@ -705,16 +705,10 @@ tcSuperClass :: [TyVar] -> [EvVar] -- The "this" part is just-in-case (discarded if not used) -- See Note [Recursive superclasses] tcSuperClass tyvars dicts - self_ev_bind@(EvBind self_dict _) - (sc_sel, sc_pred) - = do { (ev_binds, wanted, sc_dict) - <- newImplication InstSkol tyvars dicts $ - emitWanted ScOrigin sc_pred - - ; simplifySuperClass self_dict wanted - -- We include self_dict in the 'givens'; the simplifier - -- is clever enough to stop sc_pred geting bound by just - -- selecting from self_dict!! + self_ev_bind + (sc_sel, sc_pred) + = do { sc_dict <- newWantedEvVar sc_pred + ; ev_binds <- simplifySuperClass tyvars dicts sc_dict self_ev_bind ; uniq <- newUnique ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes dicts (varType sc_dict) @@ -725,8 +719,7 @@ tcSuperClass tyvars dicts , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict } sc_wrapper = mkWpTyLams tyvars <.> mkWpLams dicts - <.> mkWpLet (EvBinds (unitBag self_ev_bind)) - <.> mkWpLet ev_binds + <.> mkWpLet ev_binds ; return (sc_op_id, noLoc sc_op_bind) } \end{code} |