From b5a8dd88e3939cf547be50ab62bae84f5bf0398d Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Thu, 13 Mar 2008 06:52:20 +0000 Subject: [PATCH] Some cleanup in TcSimplify.reduceContext - Makes this horrid function a bit better - and shorter! - Also gets rid of another API function of TcTyFuns --- compiler/typecheck/TcSimplify.lhs | 40 +++++++++-------------------------- compiler/typecheck/TcTyFuns.lhs | 42 +++++++------------------------------ 2 files changed, 18 insertions(+), 64 deletions(-) diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 7de56a2..d0bdb69 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1754,12 +1754,12 @@ reduceContext env wanteds ; 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 + (wanted_implics0, wanted_dicts) = 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 + ; ancestor_eqs <- ancestorEqualities wanted_dicts ; let wanted_eqs = wanted_eqs0 ++ ancestor_eqs ; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs @@ -1780,24 +1780,13 @@ reduceContext env wanteds -- *** 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 + [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, @@ -1810,21 +1799,13 @@ reduceContext env wanteds ; 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 + -- Normalise the wanted equality constraints + ; eq_irreds <- normaliseWantedEqs given_eqs (wanted_eqs ++ extra_eqs) - -- 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... + -- Normalise the wanted dictionaries ; let irreds = dict_irreds ++ implic_irreds - ; (norm_irreds, normalise_binds2) - <- normaliseWantedDicts eq_irreds irreds + eqs = eq_irreds ++ given_eqs + ; (norm_irreds, normalise_binds) <- normaliseWantedDicts eqs irreds -- Figure out whether we should go round again. We do so in either -- two cases: @@ -1842,7 +1823,7 @@ reduceContext env wanteds ; let all_irreds = norm_irreds ++ eq_irreds ; improvedMetaTy <- anyM isFilledMetaTyVar $ varSetElems $ tyVarsOfInsts (givens ++ all_irreds) - ; let improvedDicts = not $ isEmptyBag normalise_binds2 + ; let improvedDicts = not $ isEmptyBag normalise_binds improved = improvedMetaTy || improvedDicts -- The old plan (fragile) @@ -1868,8 +1849,7 @@ reduceContext env wanteds ])) ; return (improved, - given_binds `unionBags` normalise_binds1 - `unionBags` normalise_binds2 + given_binds `unionBags` normalise_binds `unionBags` dict_binds `unionBags` implic_binds, all_irreds, diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs index e3e28ab..3bd5fb6 100644 --- a/compiler/typecheck/TcTyFuns.lhs +++ b/compiler/typecheck/TcTyFuns.lhs @@ -7,7 +7,6 @@ module TcTyFuns ( normaliseGivenEqs, normaliseGivenDicts, normaliseWantedEqs, normaliseWantedDicts, - solveWantedEqs, -- errors misMatchMsg, failWithMisMatch @@ -310,38 +309,12 @@ normaliseGivenEqs givens \end{code} \begin{code} -normaliseWantedEqs :: [Inst] -> TcM [Inst] -normaliseWantedEqs insts - = do { traceTc (text "normaliseWantedEqs <-" <+> ppr insts) - ; result <- liftM fst $ rewriteToFixedPoint Nothing - [ ("(ZONK)", dontRerun $ zonkInsts) - , ("(TRIVIAL)", dontRerun $ trivialRule) - , ("(DECOMP)", decompRule) - , ("(TOP)", topRule) - , ("(UNIFY)", unifyMetaRule) -- incl. occurs check - , ("(SUBST)", substRule) -- incl. occurs check - ] insts - ; traceTc (text "normaliseWantedEqs ->" <+> ppr result) - ; return result - } -\end{code} - - -%************************************************************************ -%* * -\section{Solving of wanted constraints with respect to a given set} -%* * -%************************************************************************ - -The set of given equalities must have been normalised already. - -\begin{code} -solveWantedEqs :: [Inst] -- givens - -> [Inst] -- wanteds - -> TcM [Inst] -- irreducible wanteds -solveWantedEqs givens wanteds - = do { traceTc $ text "solveWantedEqs <-" <+> ppr wanteds <+> text "with" <+> - ppr givens +normaliseWantedEqs :: [Inst] -- givens + -> [Inst] -- wanteds + -> TcM [Inst] -- irreducible wanteds +normaliseWantedEqs givens wanteds + = do { traceTc $ text "normaliseWantedEqs <-" <+> ppr wanteds + <+> text "with" <+> ppr givens ; result <- liftM fst $ rewriteToFixedPoint Nothing [ ("(ZONK)", dontRerun $ zonkInsts) , ("(TRIVIAL)", dontRerun $ trivialRule) @@ -349,8 +322,9 @@ solveWantedEqs givens wanteds , ("(TOP)", topRule) , ("(GIVEN)", substGivens givens) -- incl. occurs check , ("(UNIFY)", unifyMetaRule) -- incl. occurs check + , ("(SUBST)", substRule) -- incl. occurs check ] wanteds - ; traceTc (text "solveWantedEqs ->" <+> ppr result) + ; traceTc (text "normaliseWantedEqs ->" <+> ppr result) ; return result } where -- 1.7.10.4