[project @ 2003-06-20 11:14:18 by simonpj]

------------------------------
	Fix a small quantification bug
	------------------------------

We were quantifying over too few type variables, because fdPredsOfInsts was
being too eager to discard predicates. This only affects rather obscure
programs.  Here's the one Iavor found:

	class C a b where f :: a -> b
	g x = fst (f x)

We want to get the type
   	g :: forall a b c.  C a (b,c) => a -> b
but GHC 6.0 bogusly gets
   	g :: forall a b.  C a (b,()) => a -> b

A test is in should_compile/tc168

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index dc96759..19c484f 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -56,7 +56,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
                  isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
                  tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
                  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
-                 isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
+                 isClassPred, isTyVarClassPred, isLinearPred, 
                  getClassPredTys, getClassPredTys_maybe, mkPredName,
                  isInheritablePred, isIPPred, 
                  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
@@ -101,11 +101,14 @@ dictPred inst               = pprPanic "dictPred" (ppr inst)
 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 
 -- fdPredsOfInst is used to get predicates that contain functional 
--- dependencies; i.e. should participate in improvement
-fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred]
-                             | otherwise       = []
-fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta
-fdPredsOfInst other                   = []
+-- dependencies *or* might do so.  The "might do" part is because
+-- a constraint (C a b) might have a superclass with FDs
+-- Leaving these in is really important for the call to fdPredsOfInsts
+-- in TcSimplify.inferLoop, because the result is fed to 'grow',
+-- which is supposed to be conservative
+fdPredsOfInst (Dict _ pred _)         = [pred]
+fdPredsOfInst (Method _ _ _ theta _ _) = theta
+fdPredsOfInst other                   = []     -- LitInsts etc
 
 fdPredsOfInsts :: [Inst] -> [PredType]
 fdPredsOfInsts insts = concatMap fdPredsOfInst insts

diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 6dabc14..872a314 100644 (file)
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -49,7 +49,7 @@ import TcExpr                 ( tcInferRho )
 import TcRnMonad
 import TcMType         ( newTyVarTy, zonkTcType )
 import TcType          ( Type, liftedTypeKind, 
-                         tyVarsOfType, tcFunResultTy,
+                         tyVarsOfType, tcFunResultTy, tidyTopType,
                          mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
                        )
 import TcMatches       ( tcStmtsAndThen )
@@ -651,7 +651,7 @@ tc_rn_src_decls ds
 
        setEnvs tc_envs $
 
-       -- If there is no splice, we're nearlydone
+       -- If there is no splice, we're nearly done
        case group_tail of {
           Nothing -> do {      -- Last thing: check for `main'
                           (tcg_env, main_fvs) <- checkMain ;
@@ -1205,8 +1205,8 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
         , ppr_insts dfun_ids
         , vcat (map ppr rules)
         , ppr_gen_tycons (typeEnvTyCons type_env)
-        , ppr (moduleEnvElts (imp_dep_mods imports))
-        , ppr (imp_dep_pkgs imports)]
+        , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
+        , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
 
 pprModGuts :: ModGuts -> SDoc
 pprModGuts (ModGuts { mg_types = type_env,
@@ -1239,7 +1239,7 @@ ppr_sigs ids
        -- Convert to HsType so that we get source-language style printing
        -- And sort by RdrName
   = vcat $ map ppr_sig $ sortLt lt_sig $
-    [ (getRdrName id, toHsType (idType id))
+    [ (getRdrName id, toHsType (tidyTopType (idType id)))
     | id <- ids ]
   where
     lt_sig (n1,_) (n2,_) = n1 < n2

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index f5afb36..999d390 100644 (file)
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -569,6 +569,7 @@ inferLoop doc tau_tvs wanteds
          | isClassDict inst              = DontReduceUnlessConstant    -- Dicts
          | otherwise                     = ReduceMe                    -- Lits and Methods
     in
+    traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs])     `thenM_`
                -- Step 2
     reduceContext doc try_me [] wanteds'    `thenM` \ (no_improvement, frees, binds, irreds) ->
 

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 9635d41..f3e864c 100644 (file)
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -61,7 +61,7 @@ module TcType (
   ---------------------------------
   -- Predicate types  
   getClassPredTys_maybe, getClassPredTys, 
-  isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
+  isPredTy, isClassPred, isTyVarClassPred, 
   mkDictTy, tcSplitPredTy_maybe, 
   isDictTy, tcSplitDFunTy, predTyUnique, 
   mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, 
@@ -541,12 +541,6 @@ predTyUnique :: PredType -> Unique
 predTyUnique (IParam n _)      = getUnique (ipNameName n)
 predTyUnique (ClassP clas tys) = getUnique clas
 
-predHasFDs :: PredType -> Bool
--- True if the predicate has functional depenencies; 
--- I.e. should participate in improvement
-predHasFDs (IParam _ _)   = True
-predHasFDs (ClassP cls _) = classHasFDs cls
-
 mkPredName :: Unique -> SrcLoc -> SourceType -> Name
 mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
 mkPredName uniq loc (IParam ip ty)   = mkInternalName uniq (getOccName (ipNameName ip)) loc