X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=fc7a8486f9a35df58d16a48e2cd2e2686758e262;hb=b99310f05faee2abec850da4349fcd5c0498f7ca;hp=8411631d8a6ca56536757572d70a61dc35f04846;hpb=f8171baf9ad2158d214945ffa4d38fc4616b2296;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 8411631..fc7a848 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -1,11 +1,13 @@ - +% +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} module TcHsType ( - tcHsSigType, tcHsDeriv, + tcHsSigType, tcHsDeriv, + tcHsInstHead, tcHsQuantifiedType, UserTypeCtxt(..), -- Kind checking @@ -23,41 +25,26 @@ module TcHsType ( #include "HsVersions.h" -import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, - LHsContext, HsPred(..), LHsPred ) -import RnHsSyn ( extractHsTyVars ) +import HsSyn +import RnHsSyn import TcRnMonad -import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnvTvs, - tcLookup, tcLookupClass, tcLookupTyCon, - TyThing(..), getInLocalScope, getScopedTyVarBinds, - wrongThingErr - ) -import TcMType ( newKindVar, - zonkTcKindToKind, - tcInstBoxyTyVar, readFilledBox, - checkValidType - ) -import TcUnify ( boxyUnify, unifyFunKind, checkExpectedKind ) -import TcIface ( checkWiredInTyCon ) -import TcType ( Type, PredType(..), ThetaType, BoxySigmaType, - TcType, TcKind, isRigidTy, - UserTypeCtxt(..), pprUserTypeCtxt, - substTyWith, mkTyVarTys, tcEqType, - tcIsTyVarTy, mkFunTy, mkSigmaTy, mkPredTy, - mkTyConApp, mkAppTys, typeKind ) -import Kind ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind, - openTypeKind, argTypeKind, splitKindFunTys ) -import Var ( TyVar, mkTyVar, tyVarName ) -import TyCon ( TyCon, tyConKind ) -import Class ( Class, classTyCon ) -import Name ( Name, mkInternalName ) -import OccName ( mkOccName, tvName ) +import TcEnv +import TcMType +import TcUnify +import TcIface +import TcType +import {- Kind parts of -} Type +import Var +import TyCon +import Class +import Name +import OccName import NameSet -import PrelNames ( genUnitTyConName ) -import TysWiredIn ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon ) -import BasicTypes ( Boxity(..) ) -import SrcLoc ( Located(..), unLoc, noLoc, getLoc, srcSpanStart ) -import UniqSupply ( uniqsFromSupply ) +import PrelNames +import TysWiredIn +import BasicTypes +import SrcLoc +import UniqSupply import Outputable \end{code} @@ -157,6 +144,24 @@ tcHsSigType ctxt hs_ty ; checkValidType ctxt ty ; returnM ty } +tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Type) +-- Typecheck an instance head. We can't use +-- tcHsSigType, because it's not a valid user type. +tcHsInstHead hs_ty + = do { kinded_ty <- kcHsSigType hs_ty + ; poly_ty <- tcHsKindedType kinded_ty + ; return (tcSplitSigmaTy poly_ty) } + +tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type) +-- Behave very like type-checking (HsForAllTy sig_tvs hs_ty), +-- except that we want to keep the tvs separate +tcHsQuantifiedType tv_names hs_ty + = kcHsTyVars tv_names $ \ tv_names' -> + do { kc_ty <- kcHsSigType hs_ty + ; tcTyVarBndrs tv_names' $ \ tvs -> + do { ty <- dsHsType kc_ty + ; return (tvs, ty) } } + -- Used for the deriving(...) items tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type]) tcHsDeriv = addLocM (tc_hs_deriv []) @@ -357,6 +362,10 @@ kc_hs_type (HsBangTy b ty) kc_hs_type ty@(HsSpliceTy _) = failWithTc (ptext SLIT("Unexpected type splice:") <+> ppr ty) +-- remove the doc nodes here, no need to worry about the location since +-- its the same for a doc node and it's child type node +kc_hs_type (HsDocTy ty _) + = kc_hs_type (unLoc ty) --------------------------- kcApps :: TcKind -- Function kind @@ -398,13 +407,21 @@ kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind) -- Does *not* check for a saturated -- application (reason: used from TcDeriv) kc_pred pred@(HsIParam name ty) - = kcHsType ty `thenM` \ (ty', kind) -> - returnM (HsIParam name ty', kind) - + = do { (ty', kind) <- kcHsType ty + ; returnM (HsIParam name ty', kind) + } kc_pred pred@(HsClassP cls tys) - = kcClass cls `thenM` \ kind -> - kcApps kind (ppr cls) tys `thenM` \ (tys', res_kind) -> - returnM (HsClassP cls tys', res_kind) + = do { kind <- kcClass cls + ; (tys', res_kind) <- kcApps kind (ppr cls) tys + ; returnM (HsClassP cls tys', res_kind) + } +kc_pred pred@(HsEqualP ty1 ty2) + = do { (ty1', kind1) <- kcHsType ty1 + ; checkExpectedKind ty1 kind1 liftedTypeKind + ; (ty2', kind2) <- kcHsType ty2 + ; checkExpectedKind ty2 kind2 liftedTypeKind + ; returnM (HsEqualP ty1 ty2, liftedTypeKind) + } --------------------------- kcTyVar :: Name -> TcM TcKind @@ -508,6 +525,9 @@ ds_type full_ty@(HsForAllTy exp tv_names ctxt ty) ds_type (HsSpliceTy {}) = panic "ds_type: HsSpliceTy" +ds_type (HsDocTy ty _) -- Remove the doc comment + = dsHsType ty + dsHsTypes arg_tys = mappM dsHsType arg_tys \end{code} @@ -544,13 +564,19 @@ dsHsLPred :: LHsPred Name -> TcM PredType dsHsLPred pred = dsHsPred (unLoc pred) dsHsPred pred@(HsClassP class_name tys) - = dsHsTypes tys `thenM` \ arg_tys -> - tcLookupClass class_name `thenM` \ clas -> - returnM (ClassP clas arg_tys) - + = do { arg_tys <- dsHsTypes tys + ; clas <- tcLookupClass class_name + ; returnM (ClassP clas arg_tys) + } +dsHsPred pred@(HsEqualP ty1 ty2) + = do { arg_ty1 <- dsHsType ty1 + ; arg_ty2 <- dsHsType ty2 + ; returnM (EqPred arg_ty1 arg_ty2) + } dsHsPred (HsIParam name ty) - = dsHsType ty `thenM` \ arg_ty -> - returnM (IParam name arg_ty) + = do { arg_ty <- dsHsType ty + ; returnM (IParam name arg_ty) + } \end{code} GADT constructor signatures @@ -622,7 +648,7 @@ tcTyVarBndrs bndrs thing_inside where zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind ; return (mkTyVar name kind') } - zonk (UserTyVar name) = pprTrace "Un-kinded tyvar" (ppr name) $ + zonk (UserTyVar name) = WARN( True, ptext SLIT("Un-kinded tyvar") <+> ppr name ) return (mkTyVar name liftedTypeKind) ----------------------------------- @@ -630,15 +656,15 @@ tcDataKindSig :: Maybe Kind -> TcM [TyVar] -- 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 * +-- the argument kinds, and checks that the result kind is indeed *. +-- We use it also to make up argument type variables for for data instances. tcDataKindSig Nothing = return [] tcDataKindSig (Just kind) = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind) ; span <- getSrcSpanM ; us <- newUniqueSupply - ; let loc = srcSpanStart span - uniqs = uniqsFromSupply us - ; return [ mk_tv loc uniq str kind + ; let uniqs = uniqsFromSupply us + ; return [ mk_tv span uniq str kind | ((kind, str), uniq) <- arg_kinds `zip` names `zip` uniqs ] } where (arg_kinds, res_kind) = splitKindFunTys kind @@ -717,16 +743,10 @@ tcHsPatSigType ctxt hs_ty | n <- nameSetToList (extractHsTyVars hs_ty), not (in_scope n) ] - -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty), - -- except that we want to keep the tvs separate - ; (kinded_tvs, kinded_ty) <- kcHsTyVars sig_tvs $ \ kinded_tvs -> do - { kinded_ty <- kcTypeType hs_ty - ; return (kinded_tvs, kinded_ty) } - ; tcTyVarBndrs kinded_tvs $ \ tyvars -> do - { sig_ty <- dsHsType kinded_ty + ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty ; checkValidType ctxt sig_ty ; return (tyvars, sig_ty) - } } + } tcPatSig :: UserTypeCtxt -> LHsType Name @@ -809,7 +829,6 @@ pprHsSigCtxt ctxt hs_ty = vcat [ ptext SLIT("In") <+> pprUserTypeCtxt ctxt <> co pp_sig (FunSigCtxt n) = pp_n_colon n pp_sig (ConArgCtxt n) = pp_n_colon n pp_sig (ForSigCtxt n) = pp_n_colon n - pp_sig (RuleSigCtxt n) = pp_n_colon n pp_sig other = ppr (unLoc hs_ty) pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty)