X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonoType.lhs;h=93083908da7b118bcbc36b155112ca205a0fc874;hb=b473b6c241cf54b5edc1e21553250739476c0cf9;hp=2176456519680a5f3be85d3fb14d5ac8b1abb262;hpb=4161ba13916463f8e67259498eacf22744160e1f;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 2176456..9308390 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -4,13 +4,13 @@ \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} -module TcMonoType ( tcHsType, tcHsRecType, - tcHsSigType, tcHsBoxedSigType, - tcRecClassContext, checkAmbiguity, +module TcMonoType ( tcHsType, tcHsRecType, tcIfaceType, + tcHsSigType, tcHsLiftedSigType, + tcRecTheta, checkAmbiguity, -- Kind checking kcHsTyVar, kcHsTyVars, mkTyClTyVars, - kcHsType, kcHsSigType, kcHsBoxedSigType, kcHsContext, + kcHsType, kcHsSigType, kcHsLiftedSigType, kcHsContext, tcTyVars, tcHsTyVars, mkImmutTyVars, TcSigInfo(..), tcTySig, mkTcSig, maybeSig, @@ -33,34 +33,33 @@ import TcType ( TcKind, TcTyVar, TcThetaType, TcTauType, newKindVar, tcInstSigVar, zonkKindEnv, zonkTcType, zonkTcTyVars, zonkTcTyVar ) -import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr, - instFunDeps, instFunDepsOfTheta ) -import FunDeps ( tyVarFunDep, oclose ) +import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId ) +import FunDeps ( grow ) import TcUnify ( unifyKind, unifyOpenTypeKind ) -import Type ( Type, Kind, PredType(..), ThetaType, +import Unify ( allDistinctTyVars ) +import Type ( Type, Kind, PredType(..), ThetaType, SigmaType, TauType, mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, zipFunTys, hoistForAllTys, mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy, mkRhoTy, - boxedTypeKind, unboxedTypeKind, mkArrowKind, + liftedTypeKind, unliftedTypeKind, mkArrowKind, mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe, tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, tyVarsOfType, tyVarsOfPred, mkForAllTys, - classesOfPreds, isUnboxedTupleType, isForAllTy + isUnboxedTupleType, isForAllTy, isIPPred ) -import PprType ( pprType, pprPred ) +import PprType ( pprType, pprTheta, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) import CoreFVs ( idFreeTyVars ) -import Id ( mkVanillaId, idName, idType ) +import Id ( mkLocalId, idName, idType ) import Var ( Id, Var, TyVar, mkTyVar, tyVarKind ) import VarEnv import VarSet import ErrUtils ( Message ) import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind ) -import Class ( ClassContext, classArity, classTyCon ) +import Class ( classArity, classTyCon ) import Name ( Name ) import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon ) -import UniqFM ( elemUFM ) import BasicTypes ( Boxity(..), RecFlag(..), isRec ) import SrcLoc ( SrcLoc ) import Util ( mapAccumL, isSingleton ) @@ -161,45 +160,45 @@ newNamedKindVar name = newKindVar `thenNF_Tc` \ kind -> returnNF_Tc (name, kind) --------------------------- -kcBoxedType :: RenamedHsType -> TcM () - -- The type ty must be a *boxed* *type* -kcBoxedType ty +kcLiftedType :: RenamedHsType -> TcM () + -- The type ty must be a *lifted* *type* +kcLiftedType ty = kcHsType ty `thenTc` \ kind -> tcAddErrCtxt (typeKindCtxt ty) $ - unifyKind boxedTypeKind kind + unifyKind liftedTypeKind kind --------------------------- kcTypeType :: RenamedHsType -> TcM () - -- The type ty must be a *type*, but it can be boxed or unboxed. + -- The type ty must be a *type*, but it can be lifted or unlifted. kcTypeType ty = kcHsType ty `thenTc` \ kind -> tcAddErrCtxt (typeKindCtxt ty) $ unifyOpenTypeKind kind --------------------------- -kcHsSigType, kcHsBoxedSigType :: RenamedHsType -> TcM () +kcHsSigType, kcHsLiftedSigType :: RenamedHsType -> TcM () -- Used for type signatures kcHsSigType = kcTypeType -kcHsBoxedSigType = kcBoxedType +kcHsLiftedSigType = kcLiftedType --------------------------- kcHsType :: RenamedHsType -> TcM TcKind kcHsType (HsTyVar name) = kcTyVar name kcHsType (HsListTy ty) - = kcBoxedType ty `thenTc` \ tau_ty -> - returnTc boxedTypeKind + = kcLiftedType ty `thenTc` \ tau_ty -> + returnTc liftedTypeKind -kcHsType (HsTupleTy (HsTupCon _ boxity) tys) +kcHsType (HsTupleTy (HsTupCon _ boxity _) tys) = mapTc kcTypeType tys `thenTc_` returnTc (case boxity of - Boxed -> boxedTypeKind - Unboxed -> unboxedTypeKind) + Boxed -> liftedTypeKind + Unboxed -> unliftedTypeKind) kcHsType (HsFunTy ty1 ty2) = kcTypeType ty1 `thenTc_` kcTypeType ty2 `thenTc_` - returnTc boxedTypeKind + returnTc liftedTypeKind kcHsType ty@(HsOpTy ty1 op ty2) = kcTyVar op `thenTc` \ op_kind -> @@ -211,7 +210,7 @@ kcHsType ty@(HsOpTy ty1 op ty2) kcHsType (HsPredTy pred) = kcHsPred pred `thenTc_` - returnTc boxedTypeKind + returnTc liftedTypeKind kcHsType ty@(HsAppTy ty1 ty2) = kcHsType ty1 `thenTc` \ tc_kind -> @@ -224,7 +223,7 @@ kcHsType (HsForAllTy (Just tv_names) context ty) tcExtendKindEnv kind_env $ kcHsContext context `thenTc_` kcHsType ty `thenTc_` - returnTc boxedTypeKind + returnTc liftedTypeKind --------------------------- kcAppKind fun_kind arg_kind @@ -242,15 +241,15 @@ kcAppKind fun_kind arg_kind kcHsContext ctxt = mapTc_ kcHsPred ctxt kcHsPred :: RenamedHsPred -> TcM () -kcHsPred pred@(HsPIParam name ty) +kcHsPred pred@(HsIParam name ty) = tcAddErrCtxt (appKindCtxt (ppr pred)) $ - kcBoxedType ty + kcLiftedType ty -kcHsPred pred@(HsPClass cls tys) +kcHsPred pred@(HsClassP cls tys) = tcAddErrCtxt (appKindCtxt (ppr pred)) $ kcClass cls `thenTc` \ kind -> mapTc kcHsType tys `thenTc` \ arg_kinds -> - unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) + unifyKind kind (mkArrowKinds arg_kinds liftedTypeKind) --------------------------- kcTyVar name -- Could be a tyvar or a tycon @@ -275,10 +274,10 @@ kcClass cls -- Must be a class %* * %************************************************************************ -tcHsSigType and tcHsBoxedSigType +tcHsSigType and tcHsLiftedSigType ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcHsSigType and tcHsBoxedSigType are used for type signatures written by the programmer +tcHsSigType and tcHsLiftedSigType are used for type signatures written by the programmer * We hoist any inner for-alls to the top @@ -289,16 +288,27 @@ tcHsSigType and tcHsBoxedSigType are used for type signatures written by the pro so the kind returned is indeed a Kind not a TcKind \begin{code} -tcHsSigType, tcHsBoxedSigType :: RenamedHsType -> TcM Type +tcHsSigType, tcHsLiftedSigType :: RenamedHsType -> TcM Type -- Do kind checking, and hoist for-alls to the top -tcHsSigType ty = kcTypeType ty `thenTc_` tcHsType ty -tcHsBoxedSigType ty = kcBoxedType ty `thenTc_` tcHsType ty +tcHsSigType ty = kcTypeType ty `thenTc_` tcHsType ty +tcHsLiftedSigType ty = kcLiftedType ty `thenTc_` tcHsType ty tcHsType :: RenamedHsType -> TcM Type tcHsRecType :: RecFlag -> RenamedHsType -> TcM Type -- Don't do kind checking, but do hoist for-alls to the top + -- These are used in type and class decls, where kinding is + -- done in advance tcHsType ty = tc_type NonRecursive ty `thenTc` \ ty' -> returnTc (hoistForAllTys ty') tcHsRecType wimp_out ty = tc_type wimp_out ty `thenTc` \ ty' -> returnTc (hoistForAllTys ty') + +-- In interface files the type is already kinded, +-- and we definitely don't want to hoist for-alls. +-- Otherwise we'll change +-- dmfail :: forall m:(*->*) Monad m => forall a:* => String -> m a +-- into +-- dmfail :: forall m:(*->*) a:* Monad m => String -> m a +-- which definitely isn't right! +tcIfaceType ty = tc_type NonRecursive ty \end{code} @@ -345,9 +355,10 @@ tc_type wimp_out (HsListTy ty) = tc_arg_type wimp_out ty `thenTc` \ tau_ty -> returnTc (mkListTy tau_ty) -tc_type wimp_out (HsTupleTy (HsTupCon _ boxity) tys) - = mapTc tc_tup_arg tys `thenTc` \ tau_tys -> - returnTc (mkTupleTy boxity (length tys) tau_tys) +tc_type wimp_out (HsTupleTy (HsTupCon _ boxity arity) tys) + = ASSERT( arity == length tys ) + mapTc tc_tup_arg tys `thenTc` \ tau_tys -> + returnTc (mkTupleTy boxity arity tau_tys) where tc_tup_arg = case boxity of Boxed -> tc_arg_type wimp_out @@ -386,7 +397,7 @@ tc_type wimp_out full_ty@(HsForAllTy (Just tv_names) ctxt ty) kind_check = kcHsContext ctxt `thenTc_` kcHsType ty in tcHsTyVars tv_names kind_check $ \ tyvars -> - tc_context wimp_out ctxt `thenTc` \ theta -> + tcRecTheta wimp_out ctxt `thenTc` \ theta -> -- Context behaves like a function type -- This matters. Return-unboxed-tuple analysis can @@ -481,22 +492,17 @@ tc_fun_type name arg_tys Contexts ~~~~~~~~ \begin{code} -tcRecClassContext :: RecFlag -> RenamedContext -> TcM ClassContext +tcRecTheta :: RecFlag -> RenamedContext -> TcM ThetaType -- Used when we are expecting a ClassContext (i.e. no implicit params) -tcRecClassContext wimp_out context - = tc_context wimp_out context `thenTc` \ theta -> - returnTc (classesOfPreds theta) - -tc_context :: RecFlag -> RenamedContext -> TcM ThetaType -tc_context wimp_out context = mapTc (tc_pred wimp_out) context +tcRecTheta wimp_out context = mapTc (tc_pred wimp_out) context -tc_pred wimp_out assn@(HsPClass class_name tys) +tc_pred wimp_out assn@(HsClassP class_name tys) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ tc_arg_types wimp_out tys `thenTc` \ arg_tys -> tcLookupGlobal class_name `thenTc` \ thing -> case thing of AClass clas -> checkTc (arity == n_tys) err `thenTc_` - returnTc (Class clas arg_tys) + returnTc (ClassP clas arg_tys) where arity = classArity clas n_tys = length tys @@ -504,7 +510,7 @@ tc_pred wimp_out assn@(HsPClass class_name tys) other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name) -tc_pred wimp_out assn@(HsPIParam name ty) +tc_pred wimp_out assn@(HsIParam name ty) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ tc_arg_type wimp_out ty `thenTc` \ arg_ty -> returnTc (IParam name arg_ty) @@ -547,6 +553,9 @@ and then we don't need to check for ambiguity either, because the test can't fail (see is_ambig). \begin{code} +checkAmbiguity :: RecFlag -> Bool + -> [TyVar] -> ThetaType -> TauType + -> TcM SigmaType checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau | isRec wimp_out = returnTc sigma_ty | otherwise = mapTc_ check_pred theta `thenTc_` @@ -554,22 +563,29 @@ checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau 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 + extended_tau_vars = grow theta tau_vars + + -- Hack alert. If there are no tyvars, (ppr sigma_ty) will print + -- something strange like {Eq k} -> k -> k, because there is no + -- ForAll at the top of the type. Since this is going to the user + -- we want it to look like a proper Haskell type even then; hence the hack + -- + -- This shows up in the complaint about + -- case C a where + -- op :: Eq a => a -> a + ppr_sigma | null forall_tyvars = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau + | otherwise = ppr sigma_ty is_ambig ct_var = (ct_var `elem` forall_tyvars) && - not (ct_var `elemUFM` extended_tau_vars) + not (ct_var `elemVarSet` 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 (is_ip pred || not all_free) (freeErr pred sigma_ty) + check_pred pred = checkTc (not any_ambig) (ambigErr pred ppr_sigma) `thenTc_` + checkTc (isIPPred pred || not all_free) (freeErr pred ppr_sigma) where ct_vars = varSetElems (tyVarsOfPred pred) all_free = all is_free ct_vars any_ambig = is_source_polytype && any is_ambig ct_vars - is_ip (IParam _ _) = True - is_ip _ = False \end{code} %************************************************************************ @@ -648,7 +664,7 @@ tcTySig (Sig v ty 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 -> + mkTcSig (mkLocalId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> returnTc sig mkTcSig :: TcId -> SrcLoc -> NF_TcM TcSigInfo @@ -679,9 +695,8 @@ 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 : fds) src_loc) + returnNF_Tc (TySigInfo name poly_id tyvars' theta' tau' (instToId inst) [inst] src_loc) where name = idName poly_id \end{code} @@ -753,29 +768,22 @@ give a helpful message in checkSigTyVars. \begin{code} checkSigTyVars :: [TcTyVar] -- Universally-quantified type variables in the signature -> TcTyVarSet -- Tyvars that are free in the type signature - -- These should *already* be in the global-var set, and are - -- used here only to improve the error message - -> TcM [TcTyVar] -- Zonked signature type variables + -- Not necessarily zonked + -- These should *already* be in the free-in-env set, + -- and are used here only to improve the error message + -> TcM [TcTyVar] -- Zonked signature type variables checkSigTyVars [] free = returnTc [] - checkSigTyVars sig_tyvars free_tyvars = zonkTcTyVars sig_tyvars `thenNF_Tc` \ sig_tys -> tcGetGlobalTyVars `thenNF_Tc` \ globals -> - checkTcM (all_ok sig_tys globals) + checkTcM (allDistinctTyVars sig_tys globals) (complain sig_tys globals) `thenTc_` returnTc (map (getTyVar "checkSigTyVars") sig_tys) where - all_ok [] acc = True - all_ok (ty:tys) acc = case getTyVar_maybe ty of - Nothing -> False -- Point (a) - Just tv | tv `elemVarSet` acc -> False -- Point (b) or (c) - | otherwise -> all_ok tys (acc `extendVarSet` tv) - - complain sig_tys globals = -- For the in-scope ones, zonk them and construct a map -- from the zonked tyvar to the in-scope one @@ -813,15 +821,17 @@ checkSigTyVars sig_tyvars free_tyvars -- acc maps a zonked type variable back to a signature type variable = case getTyVar_maybe ty of { Nothing -> -- Error (a)! - returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ; + returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (quotes (ppr ty)) : msgs) ; Just tv -> case lookupVarEnv acc tv of { Just sig_tyvar' -> -- Error (b) or (d)! - returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ; + returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar thing : msgs) + where + thing = ptext SLIT("another quantified type variable") <+> quotes (ppr sig_tyvar') - Nothing -> + ; Nothing -> if tv `elemVarSet` globals -- Error (c)! Type variable escapes -- The least comprehensible, so put it last @@ -905,7 +915,7 @@ escape_msg sig_tv tv globs frees vcat_first 0 (x:xs) = text "...others omitted..." vcat_first n (x:xs) = x $$ vcat_first (n-1) xs -unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> quotes thing +unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> thing mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv) \end{code} @@ -968,15 +978,17 @@ wrongThingErr expected thing name pp_thing (ATcId _) = ptext SLIT("Local identifier") pp_thing (AThing _) = ptext SLIT("Utterly bogus") -ambigErr pred ty +ambigErr pred ppr_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)) + nest 4 (ptext SLIT("for the type:") <+> ppr_ty), + nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$ + ptext SLIT("must be reachable from the type after the =>"))] + +freeErr pred ppr_ty + = sep [ptext SLIT("All of the type variables in the constraint") <+> quotes (pprPred pred) <+> + ptext SLIT("are already in scope"), + nest 4 (ptext SLIT("At least one must be universally quantified here")), + ptext SLIT("In the type") <+> quotes ppr_ty ] polyArgTyErr ty = ptext SLIT("Illegal polymorphic type as argument:") <+> ppr ty