X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsType.lhs;h=a234bfbd23d395493df0e00b693308675d2060cb;hb=edf6bdfb5dee21f9bc5077083e5350ee64efffbc;hp=81558201607b39a9bb5baffab2508d5b990cd97f;hpb=75649bccc12b26d31a055acb510badfd03621a98;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 8155820..a234bfb 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -14,7 +14,8 @@ module TcHsType ( -- Typechecking kinded types tcHsKindedContext, tcHsKindedType, tcHsBangType, - tcTyVarBndrs, dsHsType, tcLHsConSig, tcDataKindSig, + tcTyVarBndrs, dsHsType, tcLHsConResTy, + tcDataKindSig, tcHsPatSigType, tcAddLetBoundTyVars, @@ -23,12 +24,12 @@ module TcHsType ( #include "HsVersions.h" -import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, HsBang, - LHsContext, HsPred(..), LHsPred, LHsBinds, - getBangStrictness, collectSigTysFromHsBinds ) +import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, + LHsContext, HsPred(..), LHsPred, LHsBinds, HsExplicitForAll(..), + collectSigTysFromHsBinds ) import RnHsSyn ( extractHsTyVars ) import TcRnMonad -import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, +import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnvTvs, tcLookup, tcLookupClass, tcLookupTyCon, TyThing(..), getInLocalScope, wrongThingErr ) @@ -36,12 +37,12 @@ import TcMType ( newKindVar, newMetaTyVar, zonkTcKindToKind, checkValidType, UserTypeCtxt(..), pprHsSigCtxt ) import TcUnify ( unifyFunKind, checkExpectedKind ) +import TcIface ( checkWiredInTyCon ) import TcType ( Type, PredType(..), ThetaType, MetaDetails(Flexi), hoistForAllTys, TcType, TcTyVar, TcKind, TcThetaType, TcTauType, - mkFunTy, - mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, - typeKind ) + mkFunTy, mkSigmaTy, mkPredTy, mkGenTyConApp, + mkTyConApp, mkAppTys, typeKind ) import Kind ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind, openTypeKind, argTypeKind, splitKindFunTys ) import Id ( idName ) @@ -51,10 +52,10 @@ import Class ( Class, classTyCon ) import Name ( Name, mkInternalName ) import OccName ( mkOccName, tvName ) import NameSet +import NameEnv import PrelNames ( genUnitTyConName ) -import TysWiredIn ( mkListTy, mkPArrTy, mkTupleTy ) -import Bag ( bagToList ) -import BasicTypes ( Boxity(..) ) +import TysWiredIn ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon ) +import BasicTypes ( Boxity(..), RecFlag ) import SrcLoc ( Located(..), unLoc, noLoc, srcSpanStart ) import UniqSupply ( uniqsFromSupply ) import Outputable @@ -238,9 +239,20 @@ kcCheckHsType :: LHsType Name -> TcKind -> TcM (LHsType Name) -- with OpenTypeKind, because it gives better error messages kcCheckHsType (L span ty) exp_kind = setSrcSpan span $ - kc_hs_type ty `thenM` \ (ty', act_kind) -> - checkExpectedKind ty act_kind exp_kind `thenM_` - returnM (L span ty') + do { (ty', act_kind) <- add_ctxt ty (kc_hs_type ty) + -- Add the context round the inner check only + -- because checkExpectedKind already mentions + -- 'ty' by name in any error message + + ; checkExpectedKind 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 \end{code} Here comes the main function @@ -440,16 +452,21 @@ ds_type (HsKindSig ty k) = dsHsType ty -- Kind checking done already ds_type (HsListTy ty) - = dsHsType ty `thenM` \ tau_ty -> + = dsHsType ty `thenM` \ tau_ty -> + checkWiredInTyCon listTyCon `thenM_` returnM (mkListTy tau_ty) ds_type (HsPArrTy ty) - = dsHsType ty `thenM` \ tau_ty -> + = dsHsType ty `thenM` \ tau_ty -> + checkWiredInTyCon parrTyCon `thenM_` returnM (mkPArrTy tau_ty) ds_type (HsTupleTy boxity tys) - = dsHsTypes tys `thenM` \ tau_tys -> - returnM (mkTupleTy boxity (length tys) tau_tys) + = dsHsTypes tys `thenM` \ tau_tys -> + checkWiredInTyCon tycon `thenM_` + returnM (mkTyConApp tycon tau_tys) + where + tycon = tupleTyCon boxity (length tys) ds_type (HsFunTy ty1 ty2) = dsHsType ty1 `thenM` \ tau_ty1 -> @@ -527,36 +544,12 @@ dsHsPred (HsIParam name ty) GADT constructor signatures \begin{code} -tcLHsConSig :: LHsType Name - -> TcM ([TcTyVar], TcThetaType, - [HsBang], [TcType], - TyCon, [TcType]) --- Take apart the type signature for a data constructor --- The difference is that there can be bangs at the top of --- the argument types, and kind-checking is the right place to check -tcLHsConSig sig@(L span (HsForAllTy exp tv_names ctxt ty)) - = setSrcSpan span $ - addErrCtxt (gadtSigCtxt sig) $ - tcTyVarBndrs tv_names $ \ tyvars -> - do { theta <- mappM dsHsLPred (unLoc ctxt) - ; (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty - ; return (tyvars, theta, bangs, arg_tys, tc, res_tys) } -tcLHsConSig ty - = do { (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty - ; return ([], [], bangs, arg_tys, tc, res_tys) } - --------- -tc_con_sig_tau (L _ (HsFunTy arg ty)) - = do { (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty - ; arg_ty <- tcHsBangType arg - ; return (getBangStrictness arg : bangs, - arg_ty : arg_tys, tc, res_tys) } - -tc_con_sig_tau ty - = do { (tc, res_tys) <- tc_con_res ty [] - ; return ([], [], tc, res_tys) } - --------- +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) } @@ -570,12 +563,14 @@ tc_con_res ty@(L _ (HsTyVar name)) res_tys tc_con_res ty _ = failWithTc (badGadtDecl ty) -gadtSigCtxt ty - = hang (ptext SLIT("In the signature of a data constructor:")) +gadtResCtxt ty + = hang (ptext SLIT("In the result type of a data constructor:")) 2 (ppr ty) badGadtDecl ty - = hang (ptext SLIT("Malformed constructor signature:")) + = hang (ptext SLIT("Malformed constructor result type:")) 2 (ppr ty) + +typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty) \end{code} %************************************************************************ @@ -592,8 +587,7 @@ kcHsTyVars :: [LHsTyVarBndr Name] -> TcM r kcHsTyVars tvs thing_inside = mappM (wrapLocM kcHsTyVar) tvs `thenM` \ bndrs -> - tcExtendKindEnv [(n,k) | L _ (KindedTyVar n k) <- bndrs] - (thing_inside bndrs) + tcExtendKindEnvTvs bndrs (thing_inside bndrs) kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) -- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it @@ -744,11 +738,11 @@ tcHsPatSigType ctxt hs_ty ; return (tyvars, sig_ty) } } -tcAddLetBoundTyVars :: LHsBinds Name -> TcM a -> TcM a +tcAddLetBoundTyVars :: [(RecFlag,LHsBinds Name)] -> TcM a -> TcM a -- Turgid funciton, used for type variables bound by the patterns of a let binding tcAddLetBoundTyVars binds thing_inside - = go (collectSigTysFromHsBinds (bagToList binds)) thing_inside + = go (concatMap (collectSigTysFromHsBinds . snd) binds) thing_inside where go [] thing_inside = thing_inside go (hs_ty:hs_tys) thing_inside @@ -775,7 +769,7 @@ been instantiated. \begin{code} data TcSigInfo = TcSigInfo { - sig_id :: TcId, -- *Polymorphic* binder for this value... + sig_id :: TcId, -- *Polymorphic* binder for this value... sig_scoped :: [Name], -- Names for any scoped type variables -- Invariant: correspond 1-1 with an initial @@ -818,9 +812,8 @@ instance Outputable TcSigInfo where = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau lookupSig :: [TcSigInfo] -> TcSigFun -- Search for a particular signature -lookupSig [] name = Nothing -lookupSig (sig : sigs) name - | name == idName (sig_id sig) = Just sig - | otherwise = lookupSig sigs name +lookupSig sigs = lookupNameEnv env + where + env = mkNameEnv [(idName (sig_id sig), sig) | sig <- sigs] \end{code}