X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=6a43e2396cbc026172eda1e81a40af240b5a809c;hb=67ee8a93fc96a38c3f73468cb86d8421a11d2911;hp=968ccfb960b1fe48531e1a560b2c43c8acf8c6d9;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 968ccfb..6a43e23 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -24,7 +24,7 @@ module TcHsType ( #include "HsVersions.h" import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, - LHsContext, HsPred(..), LHsPred, HsExplicitForAll(..) ) + LHsContext, HsPred(..), LHsPred ) import RnHsSyn ( extractHsTyVars ) import TcRnMonad import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnvTvs, @@ -45,7 +45,7 @@ import TcType ( Type, PredType(..), ThetaType, BoxySigmaType, substTyWith, mkTyVarTys, tcEqType, tcIsTyVarTy, mkFunTy, mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys, typeKind ) -import Kind ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind, +import {- Kind parts of -} Type ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind, openTypeKind, argTypeKind, splitKindFunTys ) import Var ( TyVar, mkTyVar, tyVarName ) import TyCon ( TyCon, tyConKind ) @@ -191,8 +191,7 @@ kcHsSigType ty = kcTypeType ty kcHsLiftedSigType ty = kcLiftedType ty tcHsKindedType :: LHsType Name -> TcM Type - -- Don't do kind checking, nor validity checking, - -- but do hoist for-alls to the top + -- Don't do kind checking, nor validity checking. -- This is used in type and class decls, where kinding is -- done in advance, and validity checking is done later -- [Validity checking done later because of knot-tying issues.] @@ -242,15 +241,27 @@ kcCheckHsType (L span ty) exp_kind -- because checkExpectedKind already mentions -- 'ty' by name in any error message - ; checkExpectedKind ty act_kind exp_kind + ; checkExpectedKind (strip ty) act_kind exp_kind ; return (L span ty') } where - -- Wrap a context around only if we want to - -- show that contexts. Omit invisble ones - -- and ones user's won't grok (HsPred p). - add_ctxt (HsPredTy p) thing = thing - add_ctxt (HsForAllTy Implicit tvs (L _ []) ty) thing = thing - add_ctxt other_ty thing = addErrCtxt (typeCtxt ty) thing + -- Wrap a context around only if we want to show that contexts. + add_ctxt (HsPredTy p) thing = thing + -- Omit invisble ones and ones user's won't grok (HsPred p). + add_ctxt (HsForAllTy _ _ (L _ []) _) thing = thing + -- Omit wrapping if the theta-part is empty + -- Reason: the recursive call to kcLiftedType, in the ForAllTy + -- case of kc_hs_type, will do the wrapping instead + -- and we don't want to duplicate + add_ctxt other_ty thing = addErrCtxt (typeCtxt other_ty) thing + + -- We infer the kind of the type, and then complain if it's + -- not right. But we don't want to complain about + -- (ty) or !(ty) or forall a. ty + -- when the real difficulty is with the 'ty' part. + strip (HsParTy (L _ ty)) = strip ty + strip (HsBangTy _ (L _ ty)) = strip ty + strip (HsForAllTy _ _ _ (L _ ty)) = strip ty + strip ty = ty \end{code} Here comes the main function @@ -326,17 +337,18 @@ kc_hs_type (HsPredTy pred) kc_hs_type (HsForAllTy exp tv_names context ty) = kcHsTyVars tv_names $ \ tv_names' -> - kcHsContext context `thenM` \ ctxt' -> - kcLiftedType ty `thenM` \ ty' -> - -- The body of a forall is usually a type, but in principle - -- there's no reason to prohibit *unlifted* types. - -- In fact, GHC can itself construct a function with an - -- unboxed tuple inside a for-all (via CPR analyis; see - -- typecheck/should_compile/tc170) - -- - -- Still, that's only for internal interfaces, which aren't - -- kind-checked, so we only allow liftedTypeKind here - returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) + do { ctxt' <- kcHsContext context + ; ty' <- kcLiftedType ty + -- The body of a forall is usually a type, but in principle + -- there's no reason to prohibit *unlifted* types. + -- In fact, GHC can itself construct a function with an + -- unboxed tuple inside a for-all (via CPR analyis; see + -- typecheck/should_compile/tc170) + -- + -- Still, that's only for internal interfaces, which aren't + -- kind-checked, so we only allow liftedTypeKind here + + ; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) } kc_hs_type (HsBangTy b ty) = do { (ty', kind) <- kcHsType ty @@ -494,6 +506,8 @@ ds_type full_ty@(HsForAllTy exp tv_names ctxt ty) dsHsType ty `thenM` \ tau -> returnM (mkSigmaTy tyvars theta tau) +ds_type (HsSpliceTy {}) = panic "ds_type: HsSpliceTy" + dsHsTypes arg_tys = mappM dsHsType arg_tys \end{code} @@ -543,23 +557,26 @@ GADT constructor signatures \begin{code} tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType]) -tcLHsConResTy ty@(L span _) - = setSrcSpan span $ - addErrCtxt (gadtResCtxt ty) $ - tc_con_res ty [] - -tc_con_res (L _ (HsAppTy fun res_ty)) res_tys - = do { res_ty' <- dsHsType res_ty - ; tc_con_res fun (res_ty' : res_tys) } - -tc_con_res ty@(L _ (HsTyVar name)) res_tys - = do { thing <- tcLookup name - ; case thing of - AGlobal (ATyCon tc) -> return (tc, res_tys) - other -> failWithTc (badGadtDecl ty) - } - -tc_con_res ty _ = failWithTc (badGadtDecl ty) +tcLHsConResTy res_ty + = addErrCtxt (gadtResCtxt res_ty) $ + case get_largs res_ty [] of + (HsTyVar tc_name, args) + -> do { args' <- mapM dsHsType args + ; thing <- tcLookup tc_name + ; case thing of + AGlobal (ATyCon tc) -> return (tc, args') + other -> failWithTc (badGadtDecl res_ty) } + other -> failWithTc (badGadtDecl res_ty) + where + -- We can't call dsHsType on res_ty, and then do tcSplitTyConApp_maybe + -- because that causes a black hole, and for good reason. Building + -- the type means expanding type synonyms, and we can't do that + -- inside the "knot". So we have to work by steam. + get_largs (L _ ty) args = get_args ty args + get_args (HsAppTy fun arg) args = get_largs fun (arg:args) + get_args (HsParTy ty) args = get_largs ty args + get_args (HsOpTy ty1 (L span tc) ty2) args = (HsTyVar tc, ty1:ty2:args) + get_args ty args = (ty, args) gadtResCtxt ty = hang (ptext SLIT("In the result type of a data constructor:")) @@ -610,7 +627,7 @@ tcTyVarBndrs bndrs thing_inside ----------------------------------- tcDataKindSig :: Maybe Kind -> TcM [TyVar] --- GADT decls can have a (perhpas partial) kind signature +-- GADT decls can have a (perhaps partial) kind signature -- e.g. data T :: * -> * -> * where ... -- This function makes up suitable (kinded) type variables for -- the argument kinds, and checks that the result kind is indeed *