X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyDecls.lhs;h=84ad5faa803fd0832516d662042b8907bc1b5451;hb=37f34f85fc508414343fca7ef54626a9aa63e058;hp=8c03384c5ad30d3b78c2fca7a3184b29e1eb67ee;hpb=f9120c200bcf613b58d742802172fb4c08171f0d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 8c03384..84ad5fa 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -9,43 +9,67 @@ module TcTyDecls ( tcTyDecl, tcConDecl, - tcRecordSelectors + mkDataBinds ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), +import HsSyn ( TyDecl(..), ConDecl(..), ConDetails(..), BangType(..), HsExpr(..), Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), - HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, PolyType, - Bind(..), MonoBinds(..), Sig, - MonoType ) -import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..), - RnName{-instance Outputable-} + HsBinds(..), HsLit, Stmt, DoOrListComp, ArithSeqInfo, + SYN_IE(RecFlag), nonRecursive, andMonoBinds, + HsType, Fake, InPat, HsTyVar, Fixity, + MonoBinds(..), Sig ) -import TcHsSyn ( TcHsBinds(..), TcIdOcc(..), mkHsTyLam ) - -import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext ) -import TcType ( tcInstTyVars, tcInstType ) +import HsTypes ( getTyVarName ) +import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) ) +import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, + SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds) + ) +import Inst ( newDicts, InstOrigin(..), Inst ) +import TcMonoType ( tcHsTypeKind, tcHsType, tcContext ) +import TcSimplify ( tcSimplifyThetas ) +import TcType ( TcIdOcc(..), tcInstTyVars, tcInstType, tcInstId ) import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, - newLocalId + newLocalId, newLocalIds, tcLookupClassByKey ) import TcMonad import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind ) -import Id ( mkDataCon, dataConSig, mkRecordSelId, - dataConFieldLabels, StrictnessMark(..) +import PprType ( GenClass, GenType{-instance Outputable-}, + GenTyVar{-instance Outputable-}{-ToDo:possibly rm-} + ) +import CoreUnfold ( getUnfoldingTemplate ) +import Class ( GenClass{-instance Eq-}, classInstEnv, SYN_IE(Class) ) +import Id ( mkDataCon, dataConSig, mkRecordSelId, idType, + dataConFieldLabels, dataConStrictMarks, + StrictnessMark(..), getIdUnfolding, + GenId{-instance NamedThing-}, + SYN_IE(Id) ) import FieldLabel import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) -import SpecEnv ( SpecEnv(..), nullSpecEnv ) -import Name ( Name{-instance Ord3-} ) +import SpecEnv ( SpecEnv, nullSpecEnv ) +import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc, + OccName(..), Name{-instance Ord3-}, + NamedThing(..) + ) +import Outputable ( Outputable(..), interpp'SP ) import Pretty -import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, tyConDataCons ) -import Type ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon, - mkForAllTys, mkFunTy ) -import TyVar ( getTyVarKind, elementOfTyVarSet ) -import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) ) -import Util ( panic, equivClasses ) +import TyCon ( TyCon, NewOrData, mkSynTyCon, mkDataTyCon, isAlgTyCon, + isSynTyCon, tyConDataCons + ) +import Type ( GenType, -- instances + typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy, + applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy, + splitFunTy, mkTyVarTy, getTyVar_maybe, + SYN_IE(Type) + ) +import TyVar ( tyVarKind, elementOfTyVarSet, + GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) +import Unique ( Unique {- instance Eq -}, evalClassKey ) +import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) ) +import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic, Ord3(..) ) \end{code} \begin{code} @@ -61,11 +85,12 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc) tcAddErrCtxt (tySynCtxt tycon_name) $ -- Look up the pieces - tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) -> - mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) -> + tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) -> + mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names + `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) -> -- Look at the rhs - tcMonoTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) -> + tcHsTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) -> -- Unify tycon kind with (k1->...->kn->rhs) unifyKind tycon_kind @@ -78,8 +103,8 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc) -- but the simplest thing to do seems to be to get the Kind by (lazily) -- looking at the tyvars and rhs_ty. result_kind, final_tycon_kind :: Kind -- NB not TcKind! - result_kind = getTypeKind rhs_ty - final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars + result_kind = typeKind rhs_ty + final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars -- Construct the tycon tycon = mkSynTyCon (getName tycon_name) @@ -95,21 +120,15 @@ Algebraic data and newtype decls ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc) - = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc - -tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc) - = tcTyDataOrNew NewType context tycon_name tyvar_names con_decl derivings pragmas src_loc - - -tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc +tcTyDecl (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (tyDataCtxt tycon_name) $ -- Lookup the pieces - tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) -> - mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) -> - tc_derivs derivings `thenNF_Tc` \ derived_classes -> + tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) -> + mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) + tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) -> + tc_derivs derivings `thenTc` \ derived_classes -> -- Typecheck the context tcContext context `thenTc` \ ctxt -> @@ -125,7 +144,7 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra let -- Construct the tycon final_tycon_kind :: Kind -- NB not TcKind! - final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars + final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars tycon = mkDataTyCon (getName tycon_name) final_tycon_kind @@ -137,22 +156,40 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra in returnTc tycon -tc_derivs Nothing = returnNF_Tc [] -tc_derivs (Just ds) = mapNF_Tc tc_deriv ds +tc_derivs Nothing = returnTc [] +tc_derivs (Just ds) = mapTc tc_deriv ds tc_deriv name - = tcLookupClass name `thenNF_Tc` \ (_, clas) -> - returnNF_Tc clas + = tcLookupClass name `thenTc` \ (_, clas) -> + returnTc clas \end{code} -Generating selector bindings for record delarations -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generating constructor/selector bindings for data declarations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcRecordSelectors :: TyCon -> TcM s ([Id], TcHsBinds s) -tcRecordSelectors tycon - = mapAndUnzipTc (tcRecordSelector tycon) groups `thenTc` \ (ids, binds) -> - returnTc (ids, SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds))) +mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s) +mkDataBinds [] = returnTc ([], EmptyMonoBinds) +mkDataBinds (tycon : tycons) + | isSynTyCon tycon = mkDataBinds tycons + | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) -> + mkDataBinds tycons `thenTc` \ (ids2, b2) -> + returnTc (ids1++ids2, b1 `AndMonoBinds` b2) + +mkDataBinds_one tycon + = ASSERT( isAlgTyCon tycon ) + mapTc checkConstructorContext data_cons `thenTc_` + mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids -> + let + data_ids = data_cons ++ sel_ids + + -- For the locally-defined things + -- we need to turn the unfoldings inside the Ids into bindings, + binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id)) + | data_id <- data_ids, isLocallyDefined data_id + ] + in + returnTc (data_ids, andMonoBinds binds) where data_cons = tyConDataCons tycon fields = [ (con, field) | con <- data_cons, @@ -165,76 +202,56 @@ tcRecordSelectors tycon = fieldLabelName field1 `cmp` fieldLabelName field2 \end{code} -We're going to build a record selector that looks like this: - - data T a b c = T1 { op :: a, ...} - | T2 { op :: a, ...} - | T3 +-- Check that all the types of all the strict arguments are in Eval - sel :: forall a b c. T a b c -> a - sel = /\ a b c -> \ T1 { sel = x } -> x - T2 { sel = 2 } -> x +\begin{code} +checkConstructorContext con_id + | not (isLocallyDefined con_id) + = returnTc () -Note that the selector Id itself is used as the field -label; it has to be an Id, you see! + | otherwise -- It is locally defined + = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> + let + strict_marks = dataConStrictMarks con_id + (tyvars,theta,tau) = splitSigmaTy (idType con_id) + (arg_tys, result_ty) = splitFunTy tau + + eval_theta = [ (eval_clas,arg_ty) + | (arg_ty, MarkedStrict) <- zipEqual "strict_args" + arg_tys strict_marks + ] + in + tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' -> + checkTc (null eval_theta') + (missingEvalErr con_id eval_theta') +\end{code} \begin{code} -tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields) - = panic "tcRecordSelector: don't typecheck" -{- - = let - field_ty = fieldLabelType first_field_label - field_name = fieldLabelName first_field_label - other_tys = [fieldLabelType fl | (_, fl) <- fields] - (tyvars, _, _, _) = dataConSig first_con - -- tyvars of first_con may be free in first_ty - in - +mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) + -- These fields all have the same name, but are from + -- different constructors in the data type -- Check that all the fields in the group have the same type -- This check assumes that all the constructors of a given -- data type use the same type variables - checkTc (all (eqTy field_ty) other_tys) + = checkTc (all (eqTy field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` - - -- Create an Id for the field itself - tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) -> - tcInstType tenv field_ty `thenNF_Tc` \ field_ty' -> - let - data_ty' = applyTyCon tycon tyvar_tys - in - newLocalId SLIT("x") field_ty' `thenNF_Tc` \ field_id -> - newLocalId SLIT("r") data_ty' `thenNF_Tc` \ record_id -> - - -- Now build the selector - let - tycon_src_loc = getSrcLoc tycon - - selector_ty = mkForAllTys tyvars' $ - mkFunTy data_ty' $ - field_ty' + returnTc selector_id + 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 = applyTyCon 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 = mkRecordSelId first_field_label selector_ty - - -- HsSyn is dreadfully verbose for defining the selector! - selector_rhs = mkHsTyLam tyvars' $ - HsLam $ - PatMatch (VarPat record_id) $ - GRHSMatch $ - GRHSsAndBindsOut [OtherwiseGRHS selector_body tycon_src_loc] - EmptyBinds field_ty' - - selector_body = HsCase (HsVar record_id) (map mk_match fields) tycon_src_loc - - mk_match (con_id, field_label) - = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $ - GRHSMatch $ - GRHSsAndBindsOut [OtherwiseGRHS (HsVar field_id) - (getSrcLoc (fieldLabelName field_label))] - EmptyBinds - field_ty' - in - returnTc (selector_id, VarMonoBind selector_id selector_rhs) --} + selector_id :: Id + selector_id = mkRecordSelId first_field_label selector_ty \end{code} Constructors @@ -242,28 +259,28 @@ Constructors \begin{code} tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id -tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc) +tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc) = tcDataCon tycon tyvars ctxt name btys src_loc -tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc) +tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc) = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc -tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc) +tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc) = tcAddSrcLoc src_loc $ - tcMonoType ty `thenTc` \ arg_ty -> + tcHsType ty `thenTc` \ arg_ty -> let data_con = mkDataCon (getName name) [NotMarkedStrict] [{- No labelled fields -}] tyvars ctxt + [] [] -- Temporary [arg_ty] tycon - -- nullSpecEnv in returnTc data_con -tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc) +tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc) = tcAddSrcLoc src_loc $ mapTc tcField fields `thenTc` \ field_label_infos_s -> let @@ -272,40 +289,39 @@ tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc) arg_tys = [ty | (_, ty, _) <- field_label_infos] field_labels = [ mkFieldLabel (getName name) ty tag - | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags - ] + | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ] data_con = mkDataCon (getName name) stricts field_labels tyvars (thinContext arg_tys ctxt) + [] [] -- Temporary arg_tys tycon - -- nullSpecEnv in returnTc data_con tcField (field_label_names, bty) - = tcMonoType (get_ty bty) `thenTc` \ field_ty -> + = tcHsType (get_pty bty) `thenTc` \ field_ty -> returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names] tcDataCon tycon tyvars ctxt name btys src_loc = tcAddSrcLoc src_loc $ let stricts = map get_strictness btys - tys = map get_ty btys + tys = map get_pty btys in - mapTc tcMonoType tys `thenTc` \ arg_tys -> + mapTc tcHsType tys `thenTc` \ arg_tys -> let data_con = mkDataCon (getName name) stricts [{- No field labels -}] tyvars (thinContext arg_tys ctxt) + [] [] -- Temporary arg_tys tycon - -- nullSpecEnv in returnTc data_con @@ -317,11 +333,11 @@ thinContext arg_tys ctxt arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars -get_strictness (Banged ty) = MarkedStrict -get_strictness (Unbanged ty) = NotMarkedStrict +get_strictness (Banged _) = MarkedStrict +get_strictness (Unbanged _) = NotMarkedStrict -get_ty (Banged ty) = ty -get_ty (Unbanged ty) = ty +get_pty (Banged ty) = ty +get_pty (Unbanged ty) = ty \end{code} @@ -330,14 +346,19 @@ Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} tySynCtxt tycon_name sty - = ppCat [ppStr "In the type declaration for", ppr sty tycon_name] + = hsep [ptext SLIT("In the type declaration for"), ppr sty tycon_name] tyDataCtxt tycon_name sty - = ppCat [ppStr "In the data declaration for", ppr sty tycon_name] + = hsep [ptext SLIT("In the data declaration for"), ppr sty tycon_name] tyNewCtxt tycon_name sty - = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name] + = hsep [ptext SLIT("In the newtype declaration for"), ppr sty tycon_name] fieldTypeMisMatch field_name sty - = ppSep [ppStr "Declared types differ for field", ppr sty field_name] + = sep [ptext SLIT("Declared types differ for field"), ppr sty field_name] + +missingEvalErr con eval_theta sty + = hsep [ptext SLIT("Missing Eval context for constructor"), + ppr sty con, + char ':', ppr sty eval_theta] \end{code}