X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyDecls.lhs;h=450dad952c46465bb45262a215f73b95473a6614;hb=bebb2614af8819da9298fb537d2a777743b3fabb;hp=1a3c2c3e63712e1e7e87ffdb13811a15237b7d14;hpb=266fadd93461d4317967df08cd641e965cd8769a;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 1a3c2c3..450dad9 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -7,7 +7,7 @@ module TcTyDecls ( tcTyDecl, kcTyDecl, tcConDecl, - mkDataBinds + mkImplicitDataBinds, mkNewTyConRep ) where #include "HsVersions.h" @@ -17,11 +17,11 @@ import HsSyn ( MonoBinds(..), andMonoBindList ) import RnHsSyn ( RenamedTyClDecl, RenamedConDecl ) -import TcHsSyn ( TcMonoBinds ) +import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) import BasicTypes ( RecFlag(..), NewOrData(..) ) import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope, - tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType, + tcHsTypeKind, kcHsType, tcHsTopType, tcHsTopBoxedType, tcContext, tcHsTopTypeKind ) import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints ) @@ -30,30 +30,31 @@ import TcMonad import TcUnify ( unifyKind ) import Class ( Class ) -import DataCon ( DataCon, dataConSig, mkDataCon, isNullaryDataCon, - dataConFieldLabels, dataConId, - markedStrict, notMarkedStrict, markedUnboxed +import DataCon ( DataCon, mkDataCon, isNullaryDataCon, + dataConFieldLabels, dataConId, dataConWrapId, + markedStrict, notMarkedStrict, markedUnboxed, dataConRepType ) -import MkId ( mkDataConId, mkRecordSelId, mkNewTySelId ) -import Id ( getIdUnfolding ) -import CoreUnfold ( unfoldingTemplate ) +import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId ) import FieldLabel import Var ( Id, TyVar ) import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique ) import Outputable -import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isAlgTyCon, - isSynTyCon, tyConDataCons, isNewTyCon +import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon, + tyConDataCons, tyConTyVars, + isSynTyCon, isNewTyCon ) -import Type ( getTyVar, tyVarsOfTypes, +import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys, mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy, - mkTyVarTy, + mkTyVarTy, splitAlgTyConApp_maybe, mkArrowKind, mkArrowKinds, boxedTypeKind, isUnboxedType, Type, ThetaType, classesOfPreds ) +import TysWiredIn ( unitTy ) import Var ( tyVarKind ) import VarSet ( intersectVarSet, isEmptyVarSet ) import Util ( equivClasses ) import FiniteMap ( FiniteMap, lookupWithDefaultFM ) +import CmdLineOpts ( opt_GlasgowExts ) \end{code} %************************************************************************ @@ -78,7 +79,7 @@ kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ src_loc) mapTc kcConDecl con_decls `thenTc_` returnTc () -kcConDecl (ConDecl _ ex_tvs ex_ctxt details loc) +kcConDecl (ConDecl _ _ ex_tvs ex_ctxt details loc) = tcAddSrcLoc loc ( tcExtendTyVarScope ex_tvs ( \ tyvars -> tcContext ex_ctxt `thenTc_` @@ -88,12 +89,12 @@ kcConDecl (ConDecl _ ex_tvs ex_ctxt details loc) where kc_con (VanillaCon btys) = mapTc kc_bty btys `thenTc_` returnTc () kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2] `thenTc_` returnTc () - kc_con (NewCon ty _) = tcHsType ty `thenTc_` returnTc () + kc_con (NewCon ty _) = kcHsType ty kc_con (RecCon flds) = mapTc kc_field flds `thenTc_` returnTc () - kc_bty (Banged ty) = tcHsType ty - kc_bty (Unbanged ty) = tcHsType ty - kc_bty (Unpacked ty) = tcHsType ty + kc_bty (Banged ty) = kcHsType ty + kc_bty (Unbanged ty) = kcHsType ty + kc_bty (Unpacked ty) = kcHsType ty kc_field (_, bty) = kc_bty bty \end{code} @@ -112,6 +113,10 @@ tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc) = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, Just arity, _) -> tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ -> tcHsTopTypeKind rhs `thenTc` \ (_, rhs_ty) -> + -- If the RHS mentions tyvars that aren't in scope, we'll + -- quantify over them. With gla-exts that's right, but for H98 + -- we should complain. We can't do that here without falling into + -- a black hole, so we do it in rnDecl (TySynonym case) let -- Construct the tycon argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name) @@ -134,10 +139,10 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ let -- Construct the tycon - real_data_or_new = case data_or_new of - NewType -> NewType - DataType | all isNullaryDataCon data_cons -> EnumType - | otherwise -> DataType + flavour = case data_or_new of + NewType -> NewTyCon (mkNewTyConRep tycon) + DataType | all isNullaryDataCon data_cons -> EnumTyCon + | otherwise -> DataTyCon argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name) tycon_name @@ -145,8 +150,7 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs data_cons derived_classes - Nothing -- Not a dictionary - real_data_or_new is_rec + flavour is_rec in returnTc tycon where @@ -157,6 +161,27 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ returnTc clas \end{code} +\begin{code} +mkNewTyConRep :: TyCon -> Type +-- Find the representation type for this newtype TyCon +-- The trick is to to deal correctly with recursive newtypes +-- such as newtype T = MkT T + +mkNewTyConRep tc + = mkForAllTys tvs (loop [] (mkTyConApp tc (mkTyVarTys tvs))) + where + tvs = tyConTyVars tc + loop tcs ty = case splitAlgTyConApp_maybe ty of { + Nothing -> ty ; + Just (tc, tys, data_cons) | not (isNewTyCon tc) -> ty + | tc `elem` tcs -> unitTy + | otherwise -> + + case splitFunTy (applyTys (dataConRepType (head data_cons)) tys) of + (rep_ty, _) -> loop (tc:tcs) rep_ty + } +\end{code} + %************************************************************************ %* * @@ -167,14 +192,16 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ \begin{code} tcConDecl :: TyCon -> [TyVar] -> [(Class,[Type])] -> RenamedConDecl -> TcM s DataCon -tcConDecl tycon tyvars ctxt (ConDecl name ex_tvs ex_ctxt details src_loc) +tcConDecl tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc) = tcAddSrcLoc src_loc $ tcExtendTyVarScope ex_tvs $ \ ex_tyvars -> tcContext ex_ctxt `thenTc` \ ex_theta -> - let ex_ctxt' = classesOfPreds ex_theta in - tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_ctxt' details + let + ex_ctxt' = classesOfPreds ex_theta + in + tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_ctxt' details -tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details +tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_theta details = case details of VanillaCon btys -> tc_datacon btys InfixCon bty1 bty2 -> tc_datacon [bty1,bty2] @@ -197,7 +224,7 @@ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details field_label = case mb_f of Nothing -> [] - Just f -> [mkFieldLabel (getName f) arg_ty (head allFieldLabelTags)] + Just f -> [mkFieldLabel (getName f) tycon arg_ty (head allFieldLabelTags)] in mk_data_con [notMarkedStrict] [arg_ty] field_label @@ -209,7 +236,7 @@ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details arg_stricts = [strict | (_, _, strict) <- field_label_infos] arg_tys = [ty | (_, ty, _) <- field_label_infos] - field_labels = [ mkFieldLabel (getName name) ty tag + field_labels = [ mkFieldLabel (getName name) tycon ty tag | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ] in mk_data_con arg_stricts arg_tys field_labels @@ -231,8 +258,9 @@ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details tyvars (thinContext arg_tys ctxt) ex_tyvars' ex_theta' arg_tys - tycon data_con_id - data_con_id = mkDataConId data_con + tycon data_con_id data_con_wrap_id + data_con_id = mkDataConId wkr_name data_con + data_con_wrap_id = mkDataConWrapId data_con in returnNF_Tc data_con @@ -263,31 +291,32 @@ get_pty (Unpacked ty) = ty %************************************************************************ \begin{code} -mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds) -mkDataBinds [] = returnTc ([], EmptyMonoBinds) -mkDataBinds (tycon : tycons) - | isSynTyCon tycon = mkDataBinds tycons - | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) -> - mkDataBinds tycons `thenTc` \ (ids2, b2) -> +mkImplicitDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds) +mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds) +mkImplicitDataBinds (tycon : tycons) + | isSynTyCon tycon = mkImplicitDataBinds tycons + | otherwise = mkImplicitDataBinds_one tycon `thenTc` \ (ids1, b1) -> + mkImplicitDataBinds tycons `thenTc` \ (ids2, b2) -> returnTc (ids1++ids2, b1 `AndMonoBinds` b2) -mkDataBinds_one tycon +mkImplicitDataBinds_one tycon = mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids -> let - data_ids = map dataConId data_cons ++ sel_ids + unf_ids = sel_ids ++ data_con_wrapper_ids + all_ids = map dataConId data_cons ++ unf_ids -- For the locally-defined things - -- we need to turn the unfoldings inside the Ids into bindings, - binds | isLocallyDefined tycon - = [ CoreMonoBind data_id (unfoldingTemplate (getIdUnfolding data_id)) - | data_id <- data_ids, isLocallyDefined data_id - ] - | otherwise - = [] + -- we need to turn the unfoldings inside the selector Ids into bindings, + -- and build bindigns for the constructor wrappers + binds | isLocallyDefined tycon = idsToMonoBinds unf_ids + | otherwise = EmptyMonoBinds in - returnTc (data_ids, andMonoBindList binds) + returnTc (all_ids, binds) where data_cons = tyConDataCons tycon + + data_con_wrapper_ids = map dataConWrapId data_cons + fields = [ (con, field) | con <- data_cons, field <- dataConFieldLabels con ] @@ -307,25 +336,11 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) -- data type use the same type variables = checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` - returnTc selector_id + returnTc (mkRecordSelId tycon first_field_label) where field_ty = fieldLabelType first_field_label field_name = fieldLabelName first_field_label other_tys = [fieldLabelType fl | (_, fl) <- other_fields] - (tyvars, _, _, _, _, _) = dataConSig first_con - data_ty = mkTyConApp tycon (mkTyVarTys tyvars) - -- tyvars of first_con may be free in field_ty - -- Now build the selector - - selector_ty :: Type - selector_ty = mkForAllTys tyvars $ - mkFunTy data_ty $ - field_ty - - selector_id :: Id - selector_id - | isNewTyCon tycon = mkNewTySelId first_field_label selector_ty - | otherwise = mkRecordSelId first_field_label selector_ty \end{code}