X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonoType.lhs;h=0d2712760b2f3be01107c5876aa4123f999c39bb;hb=20d387c481324aed48e8469d3fbf0695b3b2e365;hp=123b4b7d987fdedf10842cf770d457d15dbbc626;hpb=db95d6e8d319b0c5cee1ccc23751e8190152ade3;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 123b4b7..0d27127 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -5,12 +5,12 @@ \begin{code} module TcMonoType ( tcHsType, tcHsRecType, - tcHsSigType, tcHsBoxedSigType, + tcHsSigType, tcHsLiftedSigType, tcRecClassContext, checkAmbiguity, -- Kind checking kcHsTyVar, kcHsTyVars, mkTyClTyVars, - kcHsType, kcHsSigType, kcHsBoxedSigType, kcHsContext, + kcHsType, kcHsSigType, kcHsLiftedSigType, kcHsContext, tcTyVars, tcHsTyVars, mkImmutTyVars, TcSigInfo(..), tcTySig, mkTcSig, maybeSig, @@ -35,14 +35,14 @@ import TcType ( TcKind, TcTyVar, TcThetaType, TcTauType, ) import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr, instFunDeps, instFunDepsOfTheta ) -import FunDeps ( tyVarFunDep, oclose ) +import FunDeps ( oclose ) import TcUnify ( unifyKind, unifyOpenTypeKind ) -import Type ( Type, Kind, PredType(..), ThetaType, +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, @@ -50,7 +50,8 @@ import Type ( Type, Kind, PredType(..), ThetaType, ) import PprType ( pprType, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) -import Id ( mkVanillaId, idName, idType, idFreeTyVars ) +import CoreFVs ( idFreeTyVars ) +import Id ( mkVanillaId, idName, idType ) import Var ( Id, Var, TyVar, mkTyVar, tyVarKind ) import VarEnv import VarSet @@ -160,45 +161,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 -> @@ -210,7 +211,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 -> @@ -223,7 +224,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 @@ -243,13 +244,13 @@ kcHsContext ctxt = mapTc_ kcHsPred ctxt kcHsPred :: RenamedHsPred -> TcM () kcHsPred pred@(HsPIParam name ty) = tcAddErrCtxt (appKindCtxt (ppr pred)) $ - kcBoxedType ty + kcLiftedType ty kcHsPred pred@(HsPClass 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 @@ -274,10 +275,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 @@ -288,10 +289,10 @@ 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 +tcHsLiftedSigType ty = kcLiftedType ty `thenTc_` tcHsType ty tcHsType :: RenamedHsType -> TcM Type tcHsRecType :: RecFlag -> RenamedHsType -> TcM Type @@ -344,9 +345,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 @@ -546,6 +548,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,8 +559,7 @@ checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau 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 = oclose fds tau_vars is_ambig ct_var = (ct_var `elem` forall_tyvars) && not (ct_var `elemUFM` extended_tau_vars)