- ; let (binds, irreds1, needed_givens) = extractResults avails wanted_dicts
- ; traceTc $ text "reduceContext extractresults" <+> vcat
- [ppr avails,ppr wanted_dicts,ppr binds,ppr needed_givens]
-
- -- *** ToDo: what to do with the "extra_eqs"? For the
- -- moment I'm simply discarding them, which is probably wrong
-
- -- 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. Substitute the wanted *equations* in the wanted *dictionaries*
- ; (irreds,normalise_binds2) <- substEqInDictInsts eq_irreds irreds1
-
- -- 9. eliminate the artificial skolem constants introduced in 1.
- ; eliminate_skolems
-
- -- Figure out whether we should go round again
- -- My current plan is to see if any of the mutable tyvars in
- -- givens or irreds has been filled in by improvement.
- -- If so, there is merit in going around again, because
- -- we may make further progress
- --
- -- ToDo: is it only mutable stuff? 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 = irreds ++ eq_irreds
- ; improved <- anyM isFilledMetaTyVar $ varSetElems $
- tyVarsOfInsts (givens ++ all_irreds)
-
- -- The old plan (fragile)
- -- improveed = availsImproved avails
- -- || (not $ isEmptyBag normalise_binds1)
- -- || (not $ isEmptyBag normalise_binds2)
- -- || (any isEqInst irreds)
+ -- The getLIE is reqd because reduceList does improvement
+ -- (via extendAvails) which may in turn do unification
+ ; (dict_binds,
+ bound_dicts,
+ dict_irreds) <- extractResults avails wanted_dicts
+ ; traceTc $ text "reduceContext: extractResults" <+> vcat
+ [ppr avails, ppr wanted_dicts, ppr dict_binds]
+
+ -- 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
+ -- NB: Equality irreds need to be converted, as the recursive
+ -- invocation of the solver will still treat them as wanteds
+ -- otherwise.
+ ; let implic_env = env { red_givens
+ = givens ++ bound_dicts ++
+ map wantedToLocalEqInst dict_irreds }
+ ; (implic_binds_s, implic_irreds_s)
+ <- mapAndUnzipM (reduceImplication implic_env) wanted_implics
+ ; let implic_binds = unionManyBags implic_binds_s
+ implic_irreds = concat implic_irreds_s
+
+ -- Collect all irreducible instances, and determine whether we should
+ -- go round again. We do so in either of two cases:
+ -- (1) If dictionary reduction or equality solving led to
+ -- improvement (i.e., instantiated type variables).
+ -- (2) If we reduced dictionaries (i.e., got dictionary bindings),
+ -- they may have exposed further opportunities to normalise
+ -- family applications. See Note [Dictionary Improvement]
+ --
+ -- NB: We do *not* go around for new extra_eqs. Morally, we should,
+ -- but we can't without risking non-termination (see #2688). By
+ -- not going around, we miss some legal programs mixing FDs and
+ -- TFs, but we never claimed to support such programs in the
+ -- current implementation anyway.
+
+ ; let all_irreds = dict_irreds ++ implic_irreds ++ extra_eqs
+ avails_improved = availsImproved avails
+ improvedFlexible = avails_improved || eq_improved
+ reduced_dicts = not (isEmptyBag dict_binds)
+ improved = improvedFlexible || reduced_dicts
+ --
+ improvedHint = (if avails_improved then " [AVAILS]" else "") ++
+ (if eq_improved then " [EQ]" else "")