X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonoType.lhs;h=2e6a570decf6ec101c9226268eae50359414e769;hb=91ef36b9f74a61c0fb0047f3261ce49ed3026e93;hp=cb6c3be3e6a393fe14ca6987b9aa29db56154a33;hpb=495ef8bd9ef30bffe50ea399b91e3ba09646b59a;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index cb6c3be..2e6a570 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -28,19 +28,21 @@ import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType, newKindVar, tcInstSigVar, zonkTcKindToKind, zonkTcTypeToType, zonkTcTyVars, zonkTcType, zonkTcTyVar ) -import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr ) +import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr, + instFunDeps, instFunDepsOfTheta ) +import FunDeps ( tyVarFunDep, oclose ) import TcUnify ( unifyKind, unifyKinds, unifyTypeKind ) import Type ( Type, PredType(..), ThetaType, UsageAnn(..), mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy, mkUsForAllTy, zipFunTys, hoistForAllTys, mkSigmaTy, mkDictTy, mkPredTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy, mkRhoTy, - boxedTypeKind, unboxedTypeKind, tyVarsOfType, + boxedTypeKind, unboxedTypeKind, mkArrowKinds, getTyVar_maybe, getTyVar, tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, - tyVarsOfType, tyVarsOfTypes, mkForAllTys + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, mkForAllTys ) -import PprType ( pprConstraint, pprType ) +import PprType ( pprConstraint, pprType, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) import Id ( mkVanillaId, idName, idType, idFreeTyVars ) import Var ( TyVar, mkTyVar, mkNamedUVar, varName ) @@ -200,10 +202,9 @@ tc_type_kind (HsUsgForAllTy uv_name ty) returnTc (kind, mkUsForAllTy uv tc_ty) tc_type_kind (HsForAllTy (Just tv_names) context ty) - = tcExtendTyVarScope tv_names $ \ tyvars -> + = tcExtendTyVarScope tv_names $ \ forall_tyvars -> tcContext context `thenTc` \ theta -> tc_type_kind ty `thenTc` \ (kind, tau) -> - tcGetInScopeTyVars `thenTc` \ in_scope_vars -> let body_kind | null theta = kind | otherwise = boxedTypeKind @@ -212,17 +213,60 @@ tc_type_kind (HsForAllTy (Just tv_names) context ty) -- give overloaded functions like -- f :: forall a. Num a => (# a->a, a->a #) -- And we want these to get through the type checker - check ct@(Class c tys) | ambiguous = failWithTc (ambigErr (c,tys) tau) - where ct_vars = tyVarsOfTypes tys - forall_tyvars = map varName in_scope_vars - tau_vars = tyVarsOfType tau - ambig ct_var = (varName ct_var `elem` forall_tyvars) && - not (ct_var `elemUFM` tau_vars) - ambiguous = foldUFM ((||) . ambig) False ct_vars - check _ = returnTc () + + -- Check for ambiguity + -- forall V. P => tau + -- is ambiguous if P contains generic variables + -- (i.e. one of the Vs) that are not mentioned in tau + -- + -- However, we need to take account of functional dependencies + -- when we speak of 'mentioned in tau'. Example: + -- class C a b | a -> b where ... + -- Then the type + -- forall x y. (C x y) => x + -- is not ambiguous because x is mentioned and x determines y + -- + -- NOTE: In addition, GHC insists that at least one type variable + -- in each constraint is in V. So we disallow a type like + -- forall a. Eq b => b -> b + -- even in a scope where b is in scope. + -- This is the is_free test below. + + tau_vars = tyVarsOfType tau + fds = instFunDepsOfTheta theta + tvFundep = tyVarFunDep fds + extended_tau_vars = oclose tvFundep tau_vars + is_ambig ct_var = (ct_var `elem` forall_tyvars) && + not (ct_var `elemUFM` extended_tau_vars) + is_free ct_var = not (ct_var `elem` forall_tyvars) + + check_pred pred = checkTc (not any_ambig) (ambigErr pred ty) `thenTc_` + checkTc (not all_free) (freeErr pred ty) + where + ct_vars = varSetElems (tyVarsOfPred pred) + any_ambig = is_source_polytype && any is_ambig ct_vars + all_free = all is_free ct_vars + + -- Check ambiguity only for source-program types, not + -- for types coming from inteface files. The latter can + -- legitimately have ambiguous types. Example + -- class S a where s :: a -> (Int,Int) + -- instance S Char where s _ = (1,1) + -- f:: S a => [a] -> Int -> (Int,Int) + -- f (_::[a]) x = (a*x,b) + -- where (a,b) = s (undefined::a) + -- Here the worker for f gets the type + -- fw :: forall a. S a => Int -> (# Int, Int #) + -- + -- If the list of tv_names is empty, we have a monotype, + -- and then we don't need to check for ambiguity either, + -- because the test can't fail (see is_ambig). + is_source_polytype = case tv_names of + (UserTyVar _ : _) -> True + other -> False in - mapTc check theta `thenTc_` - returnTc (body_kind, mkSigmaTy tyvars theta tau) + mapTc check_pred theta `thenTc_` + returnTc (body_kind, mkSigmaTy forall_tyvars theta tau) \end{code} Help functions for type applications @@ -383,7 +427,7 @@ data TcSigInfo -- Does *not* have name = N -- Has type tau - Inst -- Empty if theta is null, or + [Inst] -- Empty if theta is null, or -- (method mono_id) otherwise SrcLoc -- Of the signature @@ -405,7 +449,8 @@ maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name tcTySig :: RenamedSig -> TcM s TcSigInfo tcTySig (Sig v ty src_loc) - = tcAddSrcLoc src_loc $ + = tcAddSrcLoc src_loc $ + tcAddErrCtxt (tcsigCtxt v) $ tcHsSigType ty `thenTc` \ sigma_tc_ty -> mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> returnTc sig @@ -438,8 +483,9 @@ mkTcSig poly_id src_loc tyvar_tys' theta' tau' `thenNF_Tc` \ inst -> -- We make a Method even if it's not overloaded; no harm + instFunDeps SignatureOrigin theta' `thenNF_Tc` \ fds -> - returnNF_Tc (TySigInfo name poly_id tyvars' theta' tau' (instToIdBndr inst) inst src_loc) + returnNF_Tc (TySigInfo name poly_id tyvars' theta' tau' (instToIdBndr inst) (inst : fds) src_loc) where name = idName poly_id \end{code} @@ -693,6 +739,8 @@ sigPatCtxt bound_tvs bound_ids tidy_env %************************************************************************ \begin{code} +tcsigCtxt v = ptext SLIT("In a type signature for") <+> quotes (ppr v) + typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty) typeKindCtxt :: RenamedHsType -> Message @@ -712,8 +760,14 @@ tyConAsClassErr name tyVarAsClassErr name = ptext SLIT("Type variable used as a class:") <+> ppr name -ambigErr (c, ts) ty - = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprConstraint c ts), +ambigErr pred ty + = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred), nest 4 (ptext SLIT("for the type:") <+> ppr ty), nest 4 (ptext SLIT("Each forall'd type variable mentioned by the constraint must appear after the =>"))] + +freeErr pred ty + = sep [ptext SLIT("The constraint") <+> quotes (pprPred pred) <+> + ptext SLIT("does not mention any of the universally quantified type variables"), + nest 4 (ptext SLIT("in the type") <+> quotes (ppr ty)) + ] \end{code}