From 1f861358a07a4bf2586964a65aebb4433f16ac70 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 20 Jun 2003 11:14:22 +0000
Subject: [PATCH] [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
---
 ghc/compiler/typecheck/Inst.lhs       |   15 +++++++++------
 ghc/compiler/typecheck/TcRnDriver.lhs |   10 +++++-----
 ghc/compiler/typecheck/TcSimplify.lhs |    1 +
 ghc/compiler/typecheck/TcType.lhs     |    8 +-------
 4 files changed, 16 insertions(+), 18 deletions(-)

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index dc96759..19c484f 100644
--- 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 6dabc142..872a314 100644
--- 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
--- 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
--- 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
-- 
1.7.10.4