[commit: ghc] master: Use TcMType.growThetaTyVars (which works) rather than TcSimplify.growPreds (which doesn't) (de07bf2)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/de07bf2657fc5709331ad933b5563fac97b1a05b

>---------------------------------------------------------------

commit de07bf2657fc5709331ad933b5563fac97b1a05b
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Aug 15 18:10:54 2012 +0100

    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

>---------------------------------------------------------------

 compiler/typecheck/TcSimplify.lhs |   40 +++++++++++++------------------------
 1 files changed, 14 insertions(+), 26 deletions(-)

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 04f0528..a848e7f 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -388,8 +388,8 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
                                   , wc_insol = emptyBag }
 
               -- Step 6) Final candidates for quantification                
-       ; let final_quant_candidates :: Bag PredType
-             final_quant_candidates = mapBag ctPred $ 
+       ; let final_quant_candidates :: [PredType]
+             final_quant_candidates = map ctPred $ bagToList $
                                       keepWanted (wc_flat quant_candidates_transformed)
              -- NB: Already the fixpoint of any unifications that may have happened
                   
@@ -401,25 +401,27 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
               , ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs
               , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs ]
          
-       ; let init_tvs 	     = zonked_tau_tvs `minusVarSet` gbl_tvs
-             poly_qtvs       = growPreds gbl_tvs id final_quant_candidates init_tvs
-             
-             pbound          = filterBag (quantifyMe poly_qtvs id) final_quant_candidates
+       ; let init_tvs  = zonked_tau_tvs `minusVarSet` gbl_tvs
+             poly_qtvs = growThetaTyVars final_quant_candidates init_tvs 
+                         `minusVarSet` gbl_tvs
+             pbound    = filter (quantifyMe poly_qtvs id) final_quant_candidates
              
        ; 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
        ; let mr_qtvs  	     = init_tvs `minusVarSet` constrained_tvs
-             constrained_tvs = tyVarsOfBag tyVarsOfType final_quant_candidates
-	     mr_bites        = apply_mr && not (isEmptyBag pbound)
+             constrained_tvs = tyVarsOfTypes final_quant_candidates
+	     mr_bites        = apply_mr && not (null pbound)
 
              (qtvs, bound)
-                | mr_bites  = (mr_qtvs,   emptyBag)
+                | mr_bites  = (mr_qtvs,   [])
                 | otherwise = (poly_qtvs, pbound)
              
 
-       ; if isEmptyVarSet qtvs && isEmptyBag bound
+       ; if isEmptyVarSet qtvs && null bound
          then do { traceTc "} simplifyInfer/no quantification" empty                   
                  ; emitConstraints wanted_transformed
                     -- Includes insolubles (if -fdefer-type-errors)
@@ -431,7 +433,7 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
          ptext (sLit "bound are =") <+> ppr bound 
          
             -- 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)
                                    | (name, ty) <- name_taus ]
                         -- Don't add the quantified variables here, because
@@ -514,10 +516,7 @@ from superclass selection from Ord alpha. This minimization is what
 mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint
 to check the original wanted.
 
-
 \begin{code}
-
-
 approximateWC :: WantedConstraints -> Cts
 -- Postcondition: Wanted or Derived Cts 
 approximateWC wc = float_wc emptyVarSet wc
@@ -541,17 +540,6 @@ approximateWC wc = float_wc emptyVarSet wc
     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
 	   -> (a -> PredType)
 	   -> a -> Bool	    -- True <=> quantify over this wanted