From 62f76a3cbced691b60f511fb83547a5d62653252 Mon Sep 17 00:00:00 2001
From: "dimitris@microsoft.com" <unknown>
Date: Fri, 10 Dec 2010 13:22:21 +0000
Subject: [PATCH] Doing the smart canonicalization only if we are not
 simplifying a Rule LHS. Also, same thing now applies for
 adding superclasses.

---
 compiler/typecheck/TcCanonical.lhs |    7 +++++--
 compiler/typecheck/TcInteract.lhs  |   16 +++++++++++++---
 compiler/typecheck/TcSMonad.lhs    |    1 +
 3 files changed, 19 insertions(+), 5 deletions(-)

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index b9edd5f..7fdb63e 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
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index aeb78d8..bc0aae0 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -402,15 +402,25 @@ React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canoni
 solveInteract :: InertSet -> Bag (CtFlavor,EvVar) -> TcS InertSet
 solveInteract inert ws 
   = do { dyn_flags <- getDynFlags
-       ; can_ws    <- foldlBagM (tryPreSolveAndCanon inert) emptyCCan ws
+       ; sctx <- getTcSContext 
+
+       ; traceTcS "solveInteract, before clever canonicalization:" $ 
+         ppr (mapBag (\(ct,ev) -> (ct,evVarPred ev)) ws)
+
+       ; can_ws    <- foldlBagM (tryPreSolveAndCanon sctx inert) emptyCCan ws
+
+       ; traceTcS "solveInteract, after clever canonicalization:" $ 
+         ppr can_ws
+
        ; solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) inert can_ws }
 
-tryPreSolveAndCanon :: InertSet -> CanonicalCts -> (CtFlavor, EvVar) -> TcS CanonicalCts
+tryPreSolveAndCanon :: SimplContext -> InertSet -> CanonicalCts -> (CtFlavor, EvVar) -> TcS CanonicalCts
 -- Checks if this constraint can be immediately solved from a constraint in the 
 -- inert set or in the previously encountered CanonicalCts and only then  
 -- canonicalise it. See Note [Avoiding the superclass explosion]
-tryPreSolveAndCanon is cts_acc (fl,ev_var)
+tryPreSolveAndCanon sctx is cts_acc (fl,ev_var)
   | ClassP clas tys <- evVarPred ev_var 
+  , not $ simplEqsOnly sctx -- And we *can* discharge constraints from other constraints
   = do { let (relevant_inert_dicts,_) = getRelevantCts clas (inert_dicts is) 
        ; b <- dischargeFromCans (cts_acc `unionBags` relevant_inert_dicts)
                                 (fl,ev_var,clas,tys)
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 0920a8b..edeb5cb 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -460,6 +460,7 @@ data SimplContext
   | SimplRuleLhs	-- Inferring type of a RULE lhs
   | SimplInteractive	-- Inferring type at GHCi prompt
   | SimplCheck		-- Checking a type signature or RULE rhs
+  deriving Eq
 
 instance Outputable SimplContext where
   ppr SimplInfer       = ptext (sLit "SimplInfer")
-- 
1.7.10.4