X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonoType.lhs;h=ff2b84f795ebfb50e085cc8b99148bf8acb8b759;hb=90fa6b84fdc99ba99c0b7df9691ca69d50b62530;hp=cc2f96a4104c81d58d505648186a7498d33ee6c2;hpb=1c3601593186639f1086bc402582ff56fd3fe9f8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index cc2f96a..ff2b84f 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -5,7 +5,7 @@ \begin{code} module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, - tcContext, tcClassContext, + tcContext, tcClassContext, checkAmbiguity, -- Kind checking kcHsTyVar, kcHsTyVars, mkTyClTyVars, @@ -18,16 +18,17 @@ module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, #include "HsVersions.h" -import HsSyn ( HsType(..), HsTyVarBndr(..), HsUsageAnn(..), +import HsSyn ( HsType(..), HsTyVarBndr(..), Sig(..), HsPred(..), pprParendHsType, HsTupCon(..), hsTyVarNames ) import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig ) import TcHsSyn ( TcId ) import TcMonad -import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, tcLookupTy, - tcGetEnv, tcEnvTyVars, tcEnvTcIds, +import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, + tcLookupGlobal, tcLookup, + tcEnvTcIds, tcEnvTyVars, tcGetGlobalTyVars, - TyThing(..) + TyThing(..), TcTyThing(..) ) import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType, newKindVar, tcInstSigVar, @@ -37,34 +38,34 @@ import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr, instFunDeps, instFunDepsOfTheta ) import FunDeps ( tyVarFunDep, oclose ) import TcUnify ( unifyKind, unifyOpenTypeKind ) -import Type ( Type, Kind, PredType(..), ThetaType, UsageAnn(..), - mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy, - mkUsForAllTy, zipFunTys, hoistForAllTys, +import Type ( Type, Kind, PredType(..), ThetaType, + mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, + zipFunTys, hoistForAllTys, mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy, mkRhoTy, boxedTypeKind, unboxedTypeKind, mkArrowKind, mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe, tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, tyVarsOfType, tyVarsOfPred, mkForAllTys, - classesOfPreds, isUnboxedTupleType + classesOfPreds, ) import PprType ( pprType, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) -import Id ( mkVanillaId, idName, idType, idFreeTyVars ) -import Var ( TyVar, mkTyVar, tyVarKind ) +import Id ( Id, mkVanillaId, idName, idType, idFreeTyVars ) +import Var ( Var, TyVar, mkTyVar, tyVarKind ) import VarEnv import VarSet import ErrUtils ( Message ) -import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind, tyConName ) +import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind ) import Class ( ClassContext, classArity, classTyCon ) -import Name ( Name, isLocallyDefined ) +import Name ( Name ) import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon ) import UniqFM ( elemUFM ) import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc ) import Util ( mapAccumL, isSingleton ) import Outputable - +import HscTypes ( TyThing(..) ) \end{code} @@ -240,18 +241,6 @@ kcHsType (HsForAllTy (Just tv_names) context ty) returnTc boxedTypeKind --------------------------- -kcTyVar name -- Could be a tyvar or a tycon - = tcLookup name `thenTc` \ thing -> - case thing of { - ATyVar tv -> returnTc (tyVarKind tv) ; - AThing k -> returnTc k ; - AGlobal (ATyCon tc) -> returnTc (tyConKind tc) ; - other -> - - failWithTc (wrongThingErr "type" thing name) - }} - ---------------------------- kcFunResType :: RenamedHsType -> TcM TcKind -- The only place an unboxed tuple type is allowed -- is at the right hand end of an arrow @@ -283,13 +272,25 @@ kcHsPred pred@(HsPIParam name ty) kcHsPred pred@(HsPClass cls tys) = tcAddErrCtxt (appKindCtxt (ppr pred)) $ - tcLookupTy cls `thenNF_Tc` \ thing -> - (case thing of - AClass cls -> returnTc (tyConKind (classTyCon cls)) - AThing kind -> returnTc kind - other -> failWithTc (wrongThingErr "class" (pp_thing thing) cls)) `thenTc` \ kind -> - mapTc kcHsType tys `thenTc` \ arg_kinds -> + kcClass cls `thenTc` \ kind -> + mapTc kcHsType tys `thenTc` \ arg_kinds -> unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) + +--------------------------- +kcTyVar name -- Could be a tyvar or a tycon + = tcLookup name `thenTc` \ thing -> + case thing of + AThing kind -> returnTc kind + ATyVar tv -> returnTc (tyVarKind tv) + AGlobal (ATyCon tc) -> returnTc (tyConKind tc) + other -> failWithTc (wrongThingErr "type" thing name) + +kcClass cls -- Must be a class + = tcLookup cls `thenNF_Tc` \ thing -> + case thing of + AThing kind -> returnTc kind + AGlobal (AClass cls) -> returnTc (tyConKind (classTyCon cls)) + other -> failWithTc (wrongThingErr "class" thing cls) \end{code} %************************************************************************ @@ -370,9 +371,13 @@ tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty) tcHsTyVars tv_names kind_check $ \ tyvars -> tcContext ctxt `thenTc` \ theta -> tcHsType ty `thenTc` \ tau -> - checkAmbiguity full_ty tyvars theta tau `thenTc_` - returnTc (mkSigmaTy tyvars theta tau) + checkAmbiguity is_source tyvars theta tau + where + is_source = case tv_names of + (UserTyVar _ : _) -> True + other -> False +checkAmbiguity :: Bool -> [TyVar] -> ThetaType -> Type -> TcM Type -- Check for ambiguity -- forall V. P => tau -- is ambiguous if P contains generic variables @@ -391,25 +396,6 @@ tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty) -- even in a scope where b is in scope. -- This is the is_free test below. -checkAmbiguity full_ty forall_tyvars theta tau - = mapTc check_pred theta - where - 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 full_ty) `thenTc_` - checkTc (not all_free) (freeErr pred full_ty) - where - ct_vars = varSetElems (tyVarsOfPred pred) - all_free = all is_free ct_vars - any_ambig = is_source_polytype && any is_ambig ct_vars - -- Notes on the 'is_source_polytype' test above -- Check ambiguity only for source-program types, not -- for types coming from inteface files. The latter can @@ -425,10 +411,27 @@ checkAmbiguity full_ty forall_tyvars theta tau -- 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 full_ty of - HsForAllTy (Just (UserTyVar _ : _)) _ _ -> True - other -> False + +checkAmbiguity is_source_polytype forall_tyvars theta tau + = mapTc_ check_pred theta `thenTc_` + returnTc sigma_ty + where + sigma_ty = mkSigmaTy forall_tyvars theta tau + 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 sigma_ty) `thenTc_` + checkTc (not all_free) (freeErr pred sigma_ty) + where + ct_vars = varSetElems (tyVarsOfPred pred) + all_free = all is_free ct_vars + any_ambig = is_source_polytype && any is_ambig ct_vars \end{code} Help functions for type applications @@ -454,16 +457,17 @@ tc_app ty tys -- hence the rather strange functionality. tc_fun_type name arg_tys - = tcLookupGlobal name `thenTc` \ thing -> + = tcLookup name `thenTc` \ thing -> case thing of ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys) - ATyCon tc | isSynTyCon tc -> checkTc arity_ok err_msg `thenTc_` - returnTc (mkAppTys (mkSynTy tc (take arity arg_tys)) + AGlobal (ATyCon tc) + | isSynTyCon tc -> checkTc arity_ok err_msg `thenTc_` + returnTc (mkAppTys (mkSynTy tc (take arity arg_tys)) (drop arity arg_tys)) - | otherwise -> returnTc (mkTyConApp tc arg_tys) - where + | otherwise -> returnTc (mkTyConApp tc arg_tys) + where arity_ok = arity <= n_args arity = tyConArity tc @@ -474,7 +478,7 @@ tc_fun_type name arg_tys err_msg = arityErr "Type synonym" name arity n_args n_args = length arg_tys - other -> failWithTc (wrongThingErr "type constructor" (pp_thing thing) name) + other -> failWithTc (wrongThingErr "type constructor" thing name) \end{code} @@ -493,7 +497,7 @@ tcContext context = mapTc (tcClassAssertion False) context tcClassAssertion ccall_ok assn@(HsPClass class_name tys) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ mapTc tcHsType tys `thenTc` \ arg_tys -> - tcLookupTy class_name `thenTc` \ thing -> + tcLookupGlobal class_name `thenTc` \ thing -> case thing of AClass clas -> checkTc (arity == n_tys) err `thenTc_` returnTc (Class clas arg_tys) @@ -502,7 +506,7 @@ tcClassAssertion ccall_ok assn@(HsPClass class_name tys) n_tys = length tys err = arityErr "Class" class_name arity n_tys - other -> failWithTc (wrongThingErr "class" (ppr_thing thing) class_name) + other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name) tcClassAssertion ccall_ok assn@(HsPIParam name ty) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ @@ -745,44 +749,54 @@ checkSigTyVars sig_tyvars free_tyvars main_msg = ptext SLIT("Inferred type is less polymorphic than expected") - check (env, acc, msgs) (sig_tyvar,ty) + check (tidy_env, acc, msgs) (sig_tyvar,ty) -- sig_tyvar is from the signature; -- ty is what you get if you zonk sig_tyvar and then tidy it -- -- acc maps a zonked type variable back to a signature type variable = case getTyVar_maybe ty of { Nothing -> -- Error (a)! - returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ; + returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ; Just tv -> case lookupVarEnv acc tv of { Just sig_tyvar' -> -- Error (b) or (d)! - returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ; + returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ; Nothing -> if tv `elemVarSet` globals -- Error (c)! Type variable escapes -- The least comprehensible, so put it last - then tcGetEnv `thenNF_Tc` \ env -> - find_globals tv env [] (tcEnvTcIds) `thenNF_Tc` \ (env1, globs) -> - find_frees tv env1 [] (varSetElems free_tyvars) `thenNF_Tc` \ (env2, frees) -> - returnNF_Tc (env2, acc, escape_msg sig_tyvar tv globs frees : msgs) + -- Game plan: + -- a) get the local TcIds from the environment, + -- and pass them to find_globals (they might have tv free) + -- b) similarly, find any free_tyvars that mention tv + then tcGetEnv `thenNF_Tc` \ tc_env -> + find_globals tv tidy_env [] (tcEnvTcIds tc_env) `thenNF_Tc` \ (tidy_env1, globs) -> + find_frees tv tidy_env1 [] (varSetElems free_tyvars) `thenNF_Tc` \ (tidy_env2, frees) -> + returnNF_Tc (tidy_env2, acc, escape_msg sig_tyvar tv globs frees : msgs) else -- All OK - returnNF_Tc (env, extendVarEnv acc tv sig_tyvar, msgs) + returnNF_Tc (tidy_env, extendVarEnv acc tv sig_tyvar, msgs) }} -- find_globals looks at the value environment and finds values -- whose types mention the offending type variable. It has to be -- careful to zonk the Id's type first, so it has to be in the monad. -- We must be careful to pass it a zonked type variable, too. + +find_globals :: Var + -> TidyEnv + -> [(Name,Type)] + -> [Id] + -> NF_TcM (TidyEnv,[(Name,Type)]) + find_globals tv tidy_env acc [] = returnNF_Tc (tidy_env, acc) find_globals tv tidy_env acc (id:ids) - | not (isLocallyDefined id) || - isEmptyVarSet (idFreeTyVars id) + | isEmptyVarSet (idFreeTyVars id) = find_globals tv tidy_env acc ids | otherwise @@ -888,15 +902,14 @@ appKindCtxt :: SDoc -> Message appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp wrongThingErr expected thing name - = thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected - -pp_ty_thing (ATyCon _) = ptext SLIT("Type constructor") -pp_ty_thing (AClass _) = ptext SLIT("Class") -pp_ty_thing (AnId _) = ptext SLIT("Identifier") - -pp_tc_ty_thing (ATyVar _) = ptext SLIT("Type variable") -pp_tc_ty_thing (ATcId _) = ptext SLIT("Local identifier") -pp_tc_ty_thing (AThing _) = ptext SLIT("Utterly bogus") + = pp_thing thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected + where + pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor") + pp_thing (AGlobal (AClass _)) = ptext SLIT("Class") + pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier") + pp_thing (ATyVar _) = ptext SLIT("Type variable") + pp_thing (ATcId _) = ptext SLIT("Local identifier") + pp_thing (AThing _) = ptext SLIT("Utterly bogus") ambigErr pred ty = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred),