Commit 1f861358 authored by simonpj's avatar simonpj

[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
parent 4418c8e9
......@@ -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
......
......@@ -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
......
......@@ -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) ->
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment