Moved canonicalisation inside solveInteract

[ghc-hetmet.git] / compiler / typecheck / TcInstDcls.lhs

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 76ba66f..801992c 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -33,7 +33,6 @@ import TyCon
 import DataCon
 import Class
 import Var
-import VarSet    ( emptyVarSet )
 import CoreUtils  ( mkPiTypes )
 import CoreUnfold ( mkDFunUnfolding )
 import CoreSyn   ( Expr(Var) )
@@ -617,7 +616,9 @@ tc_inst_decl2 dfun_id inst_binds
        -- to use in each method binding
        -- Why?  See Note [Subtle interaction of recursion and overlap]
        ; let self_ev_bind = EvBind self_dict $ 
-                            EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars
+                            EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars []
+                                      -- Empty dependencies [], since it only
+                                      -- depends on "given" things
 
        -- Deal with 'SPECIALISE instance' pragmas
        -- See Note [SPECIALISE instance pragmas]
@@ -638,7 +639,7 @@ tc_inst_decl2 dfun_id inst_binds
                                     mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts)
 
                                    -- NOT FINISHED!
-       ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol emptyVarSet 
+       ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol
                                            inst_tyvars' dfun_ev_vars $
                                       emitWanteds ScOrigin sc_eqs
 
@@ -696,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
@@ -704,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 emptyVarSet 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)
@@ -724,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}
@@ -970,7 +964,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 -- by the constraint solver, since the <context> may be
 -- user-specified.
 
-  = do { rep_d_stuff <- checkConstraints InstSkol emptyVarSet tyvars dfun_ev_vars $
+  = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
                         emitWanted ScOrigin rep_pred
                          
        ; mapAndUnzipM (tc_item rep_d_stuff) op_items }