+ ; sctx <- getTcSContext
+
+ ; traceTcS "solveInteract, before clever canonicalization:" $
+ vcat [ text "ws = " <+> ppr (mapBag (\(EvVarX ev ct)
+ -> (ct,evVarPred ev)) ws)
+ , text "inert = " <+> ppr inert ]
+
+ ; can_ws <- mkCanonicalFEVs ws
+
+ ; (flag, inert_ret)
+ <- foldrWorkListM (tryPreSolveAndInteract sctx dyn_flags) (True,inert) can_ws
+
+ ; traceTcS "solveInteract, after clever canonicalization (and interaction):" $
+ vcat [ text "No interaction happened = " <+> ppr flag
+ , text "inert_ret = " <+> ppr inert_ret ]
+
+ ; return (flag, inert_ret) }
+
+tryPreSolveAndInteract :: SimplContext
+ -> DynFlags
+ -> CanonicalCt
+ -> (Bool, InertSet)
+ -> TcS (Bool, InertSet)
+-- Returns: True if it was able to discharge this constraint AND all previous ones
+tryPreSolveAndInteract sctx dyn_flags ct (all_previous_discharged, inert)
+ = do { let inert_cts = get_inert_cts (evVarPred ev_var)
+
+ ; this_one_discharged <-
+ if isCFrozenErr ct then
+ return False
+ else
+ dischargeFromCCans inert_cts ev_var fl
+
+ ; if this_one_discharged
+ then return (all_previous_discharged, inert)
+
+ else do
+ { inert_ret <- solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) ct inert
+ ; return (False, inert_ret) } }
+
+ where
+ ev_var = cc_id ct
+ fl = cc_flavor ct
+
+ get_inert_cts (ClassP clas _)
+ | simplEqsOnly sctx = emptyCCan
+ | otherwise = fst (getRelevantCts clas (inert_dicts inert))
+ get_inert_cts (IParam {})
+ = emptyCCan -- We must not do the same thing for IParams, because (contrary
+ -- to dictionaries), work items /must/ override inert items.
+ -- See Note [Overriding implicit parameters] in TcInteract.
+ get_inert_cts (EqPred {})
+ = inert_eqs inert `unionBags` cCanMapToBag (inert_funeqs inert)
+
+dischargeFromCCans :: CanonicalCts -> EvVar -> CtFlavor -> TcS Bool
+-- See if this (pre-canonicalised) work-item is identical to a
+-- one already in the inert set. Reasons:
+-- a) Avoid creating superclass constraints for millions of incoming (Num a) constraints
+-- b) Termination for improve_eqs in TcSimplify.simpl_loop
+dischargeFromCCans cans ev fl
+ = Bag.foldrBag discharge_ct (return False) cans
+ where
+ the_pred = evVarPred ev
+
+ discharge_ct :: CanonicalCt -> TcS Bool -> TcS Bool
+ discharge_ct ct _rest
+ | evVarPred (cc_id ct) `tcEqPred` the_pred
+ , cc_flavor ct `canSolve` fl
+ = do { when (isWanted fl) $ set_ev_bind ev (cc_id ct)
+ -- Deriveds need no evidence
+ -- For Givens, we already have evidence, and we don't need it twice
+ ; return True }
+ where
+ set_ev_bind x y
+ | EqPred {} <- evVarPred y = setEvBind x (EvCoercion (mkCoVarCoercion y))
+ | otherwise = setEvBind x (EvId y)
+
+ discharge_ct _ct rest = rest
+\end{code}
+
+Note [Avoiding the superclass explosion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This note now is not as significant as it used to be because we no
+longer add the superclasses of Wanted as Derived, except only if they
+have equality superclasses or superclasses with functional
+dependencies. The fear was that hundreds of identical wanteds would
+give rise each to the same superclass or equality Derived's which
+would lead to a blo-up in the number of interactions.
+
+Instead, what we do with tryPreSolveAndCanon, is when we encounter a
+new constraint, we very quickly see if it can be immediately
+discharged by a class constraint in our inert set or the previous
+canonicals. If so, we add nothing to the returned canonical
+constraints.
+
+\begin{code}
+solveOne :: WorkItem -> InertSet -> TcS InertSet
+solveOne workItem inerts