Skip to content
Snippets Groups Projects
Commit ab4c7d3b authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by pcapriotti
Browse files

Use TcMType.growThetaTyVars (which works) rather than TcSimplify.growPreds (which doesn't)

I think this got left behind when we simplified and improved TcSimplify.  The effect
was that we had a function like
   class P a b | a -> b
   class Q b c | b -> c

   f :: (P a b, Q b c) => a -> a

and were were failing to quanitfy over 'c', even though it is (indirectly) determined
by 'a'.

This make Programatica fail to compile: Trac #7147

MERGED from commit de07bf26
parent 038bec8a
No related branches found
No related tags found
No related merge requests found
...@@ -388,8 +388,8 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) ...@@ -388,8 +388,8 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
, wc_insol = emptyBag } , wc_insol = emptyBag }
-- Step 6) Final candidates for quantification -- Step 6) Final candidates for quantification
; let final_quant_candidates :: Bag PredType ; let final_quant_candidates :: [PredType]
final_quant_candidates = mapBag ctPred $ final_quant_candidates = map ctPred $ bagToList $
keepWanted (wc_flat quant_candidates_transformed) keepWanted (wc_flat quant_candidates_transformed)
-- NB: Already the fixpoint of any unifications that may have happened -- NB: Already the fixpoint of any unifications that may have happened
...@@ -401,25 +401,27 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) ...@@ -401,25 +401,27 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
, ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs , ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs
, ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs ] , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs ]
; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs
poly_qtvs = growPreds gbl_tvs id final_quant_candidates init_tvs poly_qtvs = growThetaTyVars final_quant_candidates init_tvs
`minusVarSet` gbl_tvs
pbound = filterBag (quantifyMe poly_qtvs id) final_quant_candidates pbound = filter (quantifyMe poly_qtvs id) final_quant_candidates
; traceTc "simplifyWithApprox" $ ; traceTc "simplifyWithApprox" $
vcat [ ptext (sLit "pbound =") <+> ppr pbound ] vcat [ ptext (sLit "pbound =") <+> ppr pbound
, ptext (sLit "init_qtvs =") <+> ppr init_tvs
, ptext (sLit "poly_qtvs =") <+> ppr poly_qtvs ]
-- Monomorphism restriction -- Monomorphism restriction
; let mr_qtvs = init_tvs `minusVarSet` constrained_tvs ; let mr_qtvs = init_tvs `minusVarSet` constrained_tvs
constrained_tvs = tyVarsOfBag tyVarsOfType final_quant_candidates constrained_tvs = tyVarsOfTypes final_quant_candidates
mr_bites = apply_mr && not (isEmptyBag pbound) mr_bites = apply_mr && not (null pbound)
(qtvs, bound) (qtvs, bound)
| mr_bites = (mr_qtvs, emptyBag) | mr_bites = (mr_qtvs, [])
| otherwise = (poly_qtvs, pbound) | otherwise = (poly_qtvs, pbound)
; if isEmptyVarSet qtvs && isEmptyBag bound ; if isEmptyVarSet qtvs && null bound
then do { traceTc "} simplifyInfer/no quantification" empty then do { traceTc "} simplifyInfer/no quantification" empty
; emitConstraints wanted_transformed ; emitConstraints wanted_transformed
-- Includes insolubles (if -fdefer-type-errors) -- Includes insolubles (if -fdefer-type-errors)
...@@ -431,7 +433,7 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) ...@@ -431,7 +433,7 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
ptext (sLit "bound are =") <+> ppr bound ptext (sLit "bound are =") <+> ppr bound
-- Step 4, zonk quantified variables -- Step 4, zonk quantified variables
; let minimal_flat_preds = mkMinimalBySCs $ bagToList bound ; let minimal_flat_preds = mkMinimalBySCs bound
skol_info = InferSkol [ (name, mkSigmaTy [] minimal_flat_preds ty) skol_info = InferSkol [ (name, mkSigmaTy [] minimal_flat_preds ty)
| (name, ty) <- name_taus ] | (name, ty) <- name_taus ]
-- Don't add the quantified variables here, because -- Don't add the quantified variables here, because
...@@ -514,10 +516,7 @@ from superclass selection from Ord alpha. This minimization is what ...@@ -514,10 +516,7 @@ from superclass selection from Ord alpha. This minimization is what
mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint
to check the original wanted. to check the original wanted.
\begin{code} \begin{code}
approximateWC :: WantedConstraints -> Cts approximateWC :: WantedConstraints -> Cts
-- Postcondition: Wanted or Derived Cts -- Postcondition: Wanted or Derived Cts
approximateWC wc = float_wc emptyVarSet wc approximateWC wc = float_wc emptyVarSet wc
...@@ -541,17 +540,6 @@ approximateWC wc = float_wc emptyVarSet wc ...@@ -541,17 +540,6 @@ approximateWC wc = float_wc emptyVarSet wc
do_bag f = foldrBag (unionBags.f) emptyBag do_bag f = foldrBag (unionBags.f) emptyBag
\end{code}
\begin{code}
growPreds :: TyVarSet -> (a -> PredType) -> Bag a -> TyVarSet -> TyVarSet
growPreds gbl_tvs get_pred items tvs
= foldrBag extend tvs items
where
extend item tvs = tvs `unionVarSet`
(growPredTyVars (get_pred item) tvs `minusVarSet` gbl_tvs)
--------------------
quantifyMe :: TyVarSet -- Quantifying over these quantifyMe :: TyVarSet -- Quantifying over these
-> (a -> PredType) -> (a -> PredType)
-> a -> Bool -- True <=> quantify over this wanted -> a -> Bool -- True <=> quantify over this wanted
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment