X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcCanonical.lhs;h=60d1836ee1a82bcc3ee9d6b011b464b44432ca26;hb=820ddd55446773b33c797267bcad9e09a621ab2b;hp=9c7bba91b164ecac36c19d402bef5556ff717a4c;hpb=5688fe994cff4cc70b717918bdbccaaf5236f3af;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 9c7bba9..60d1836 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -247,8 +247,11 @@ canClass fl v cn tys
                             else setDictBind v' (EvCast v (mkSymCoercion dict_co))
                           ; return v' }
 
-       -- Add the superclasses of this one here, See Note [Adding superclasses]
-       ; sc_cts <- newSCWorkFromFlavored v_new fl cn xis
+       -- Add the superclasses of this one here, See Note [Adding superclasses]. 
+       -- But only if we are not simplifying the LHS of a rule. 
+       ; sctx <- getTcSContext
+       ; sc_cts <- if simplEqsOnly sctx then return emptyCCan 
+                   else newSCWorkFromFlavored v_new fl cn xis
 
        ; return (sc_cts `andCCan` ccs `extendCCans` CDictCan { cc_id     = v_new
                                                              , cc_flavor = fl
@@ -317,11 +320,10 @@ happen.
 newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS CanonicalCts
 -- Returns superclasses, see Note [Adding superclasses]
 newSCWorkFromFlavored ev orig_flavor cls xis 
-  | Given loc <- orig_flavor   -- Very important!
-  , NoScSkol  <- ctLocOrigin loc
+  | isEmptyVarSet (tyVarsOfTypes xis)
   = return emptyCCan
   | otherwise
-  = do { let (tyvars, sc_theta, _, _) = classBigSig cls 
+  = do { let (tyvars, sc_theta, _, _) = classBigSig cls
              sc_theta1 = substTheta (zipTopTvSubst tyvars xis) sc_theta
        ; sc_vars <- zipWithM inst_one sc_theta1 [0..]
        ; mkCanonicals flavor sc_vars }