X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsType.lhs;h=5f186d1d6761574d9e73935c35cdcea62d4aa81a;hb=89627230a1b0e25a148621509d19297454f692eb;hp=81558201607b39a9bb5baffab2508d5b990cd97f;hpb=75649bccc12b26d31a055acb510badfd03621a98;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 8155820..5f186d1 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -24,11 +24,11 @@ module TcHsType ( #include "HsVersions.h" import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, HsBang, - LHsContext, HsPred(..), LHsPred, LHsBinds, + LHsContext, HsPred(..), LHsPred, LHsBinds, HsExplicitForAll(..), getBangStrictness, collectSigTysFromHsBinds ) import RnHsSyn ( extractHsTyVars ) import TcRnMonad -import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, +import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnvTvs, tcLookup, tcLookupClass, tcLookupTyCon, TyThing(..), getInLocalScope, wrongThingErr ) @@ -36,12 +36,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 +51,11 @@ 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 TysWiredIn ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon ) import Bag ( bagToList ) -import BasicTypes ( Boxity(..) ) +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 -> @@ -576,6 +593,8 @@ gadtSigCtxt ty badGadtDecl ty = hang (ptext SLIT("Malformed constructor signature:")) 2 (ppr ty) + +typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty) \end{code} %************************************************************************ @@ -592,8 +611,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 +762,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 +793,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 +836,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}