+ ; let givens = red_givens env
+ (given_eqs0, given_dicts0) = partition isEqInst givens
+ (wanted_eqs0, wanted_non_eqs) = partition isEqInst wanteds
+ (wanted_implics0, wanted_dicts0) = partition isImplicInst wanted_non_eqs
+
+ -- We want to add as wanted equalities those that (transitively)
+ -- occur in superclass contexts of wanted class constraints.
+ -- See Note [Ancestor Equalities]
+ ; ancestor_eqs <- ancestorEqualities wanted_dicts0
+ ; let wanted_eqs = wanted_eqs0 ++ ancestor_eqs
+ ; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs
+
+ -- 1. Normalise the *given* *equality* constraints
+ ; (given_eqs, eliminate_skolems) <- normaliseGivenEqs given_eqs0
+
+ -- 2. Normalise the *given* *dictionary* constraints
+ -- wrt. the toplevel and given equations
+ ; (given_dicts, given_binds) <- normaliseGivenDicts given_eqs
+ given_dicts0
+
+ -- 5. Build the Avail mapping from "given_dicts"
+ ; (init_state, extra_givens) <- getLIE $ do
+ { init_state <- foldlM addGiven emptyAvails given_dicts
+ ; return init_state
+ }
+
+ -- *** ToDo: what to do with the "extra_givens"? For the
+ -- moment I'm simply discarding them, which is probably wrong
+
+ -- 7. Normalise the *wanted* *dictionary* constraints
+ -- wrt. the toplevel and given equations
+ -- NB: normalisation includes zonking as part of what it does
+ -- so it's important to do it after any unifications
+ -- that happened as a result of the addGivens
+ ; (wanted_dicts, normalise_binds1)
+ <- normaliseWantedDicts given_eqs wanted_dicts0
+
+ -- 6. Solve the *wanted* *dictionary* constraints (not implications)
+ -- This may expose some further equational constraints...
+ ; (avails, extra_eqs) <- getLIE (reduceList env wanted_dicts init_state)
+ ; (dict_binds, bound_dicts, dict_irreds)
+ <- extractResults avails wanted_dicts
+ ; traceTc $ text "reduceContext extractresults" <+> vcat
+ [ppr avails,ppr wanted_dicts,ppr dict_binds]
+
+ -- *** ToDo: what to do with the "extra_eqs"? For the
+ -- moment I'm simply discarding them, which is probably wrong
+
+ -- Solve the wanted *implications*. In doing so, we can provide
+ -- as "given" all the dicts that were originally given,
+ -- *or* for which we now have bindings,
+ -- *or* which are now irreds
+ ; let implic_env = env { red_givens = givens ++ bound_dicts
+ ++ dict_irreds }
+ ; (implic_binds_s, implic_irreds_s)
+ <- mapAndUnzipM (reduceImplication implic_env) wanted_implics0
+ ; let implic_binds = unionManyBags implic_binds_s
+ implic_irreds = concat implic_irreds_s
+
+ -- 3. Solve the *wanted* *equation* constraints
+ ; eq_irreds0 <- solveWantedEqs given_eqs wanted_eqs
+
+ -- 4. Normalise the *wanted* equality constraints with respect to
+ -- each other
+ ; eq_irreds <- normaliseWantedEqs eq_irreds0
+
+ -- 8. Normalise the wanted *dictionaries* wrt the wanted *equations*
+ -- and top-level equalities
+ -- TODO: reduceList may have introduced dictionaries with type
+ -- terms as parameters that haven't be normalised wrt to the
+ -- given equalities yet...
+ ; let irreds = dict_irreds ++ implic_irreds
+ ; (norm_irreds, normalise_binds2)
+ <- normaliseWantedDicts eq_irreds irreds
+
+ -- Figure out whether we should go round again. We do so in either
+ -- two cases:
+ -- (1) If any of the mutable tyvars in givens or irreds has been
+ -- filled in by improvement, there is merit in going around
+ -- again, because we may make further progress.
+ -- (2) If we managed to normalise any dicts, there is merit in going
+ -- around gain, because reduceList may be able to get further.
+ --
+ -- ToDo: We may have exposed new
+ -- equality constraints and should probably go round again
+ -- then as well. But currently we are dropping them on the
+ -- floor anyway.
+
+ ; let all_irreds = norm_irreds ++ eq_irreds
+ ; improvedMetaTy <- anyM isFilledMetaTyVar $ varSetElems $
+ tyVarsOfInsts (givens ++ all_irreds)
+ ; let improvedDicts = not $ isEmptyBag normalise_binds2
+ improved = improvedMetaTy || improvedDicts
+
+ -- The old plan (fragile)
+ -- improveed = availsImproved avails
+ -- || (not $ isEmptyBag normalise_binds1)
+ -- || (not $ isEmptyBag normalise_binds2)
+ -- || (any isEqInst irreds)