X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyDecls.lhs;h=0eff0ad51c5bf9ba73d099aaeaa86ed5b200df60;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=8c03384c5ad30d3b78c2fca7a3184b29e1eb67ee;hpb=f9120c200bcf613b58d742802172fb4c08171f0d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 8c03384..0eff0ad 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -9,43 +9,62 @@ module TcTyDecls ( tcTyDecl, tcConDecl, - tcRecordSelectors + mkDataBinds ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), - HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, PolyType, + HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo, + PolyType, Fake, InPat, Bind(..), MonoBinds(..), Sig, MonoType ) import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..), RnName{-instance Outputable-} ) -import TcHsSyn ( TcHsBinds(..), TcIdOcc(..), mkHsTyLam ) - -import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext ) -import TcType ( tcInstTyVars, tcInstType ) +import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, + SYN_IE(TcHsBinds), TcIdOcc(..) + ) +import Inst ( newDicts, InstOrigin(..), Inst ) +import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext ) +import TcSimplify ( tcSimplifyThetas ) +import TcType ( tcInstTyVars, tcInstType, tcInstId ) import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, - newLocalId + newLocalId, newLocalIds, tcLookupClassByKey ) -import TcMonad +import TcMonad hiding ( rnMtoTcM ) 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 Class ( GenClass{-instance Eq-}, classInstEnv ) +import Id ( mkDataCon, dataConSig, mkRecordSelId, idType, + dataConFieldLabels, dataConStrictMarks, + StrictnessMark(..), + GenId{-instance NamedThing-} ) import FieldLabel import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) -import SpecEnv ( SpecEnv(..), nullSpecEnv ) -import Name ( Name{-instance Ord3-} ) +import SpecEnv ( SpecEnv, nullSpecEnv ) +import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc, + Name{-instance Ord3-} + ) +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, isDataTyCon, + isNewTyCon, isSynTyCon, tyConDataCons + ) +import Type ( GenType, -- instances + typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy, + applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy, + splitFunTy, mkTyVarTy, getTyVar_maybe + ) +import TyVar ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} ) +import Unique ( Unique {- instance Eq -}, evalClassKey ) +import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) ) +import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic ) \end{code} \begin{code} @@ -78,8 +97,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) @@ -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 @@ -145,14 +164,28 @@ tc_deriv name returnNF_Tc 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], TcHsBinds s) +mkDataBinds [] = returnTc ([], EmptyBinds) +mkDataBinds (tycon : tycons) + | isSynTyCon tycon = mkDataBinds tycons + | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) -> + mkDataBinds tycons `thenTc` \ (ids2, b2) -> + returnTc (ids1++ids2, b1 `ThenBinds` b2) + +mkDataBinds_one tycon + = ASSERT( isDataTyCon tycon || isNewTyCon tycon ) + mapAndUnzipTc mkConstructor data_cons `thenTc` \ (con_ids, con_binds) -> + mapAndUnzipTc (mkRecordSelector tycon) groups `thenTc` \ (sel_ids, sel_binds) -> + returnTc (con_ids ++ sel_ids, + SingleBind $ NonRecBind $ + foldr AndMonoBinds + (foldr AndMonoBinds EmptyMonoBinds sel_binds) + con_binds + ) where data_cons = tyConDataCons tycon fields = [ (con, field) | con <- data_cons, @@ -165,6 +198,85 @@ tcRecordSelectors tycon = fieldLabelName field1 `cmp` fieldLabelName field2 \end{code} +We're going to build a constructor that looks like: + + data (Data a, C b) => T a b = T1 !a !Int b + + T1 = /\ a b -> + \d1::Data a, d2::C b -> + \p q r -> case p of { p -> + case q of { q -> + HsCon T1 [a,b] [p,q,r]}} + +Notice that + +* d2 is thrown away --- a context in a data decl is used to make sure + one *could* construct dictionaries at the site the constructor + is used, but the dictionary isn't actually used. + +* We have to check that we can construct Data dictionaries for + the types a and Int. Once we've done that we can throw d1 away too. + +* We use (case p of ...) to evaluate p, rather than "seq" because + all that matters is that the arguments are evaluated. "seq" is + very careful to preserve evaluation order, which we don't need + to be here. + +\begin{code} +mkConstructor con_id + | not (isLocallyDefinedName (getName con_id)) + = returnTc (con_id, EmptyMonoBinds) + + | otherwise -- It is locally defined + = tcInstId con_id `thenNF_Tc` \ (tc_tyvars, tc_theta, tc_tau) -> + newDicts DataDeclOrigin tc_theta `thenNF_Tc` \ (_, dicts) -> + let + (tc_arg_tys, tc_result_ty) = splitFunTy tc_tau + n_args = length tc_arg_tys + in + newLocalIds (nOfThem n_args SLIT("con")) tc_arg_tys `thenNF_Tc` \ args -> + + -- Check that all the types of all the strict arguments are in Eval + tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> + let + (_,theta,tau) = splitSigmaTy (idType con_id) + (arg_tys, _) = splitFunTy tau + strict_marks = dataConStrictMarks con_id + 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') `thenTc_` + + -- Build the data constructor + let + con_rhs = mkHsTyLam tc_tyvars $ + mkHsDictLam dicts $ + mk_pat_match args $ + mk_case (zipEqual "strict_args" args strict_marks) $ + HsCon con_id (mkTyVarTys tc_tyvars) (map HsVar args) + + mk_pat_match [] body = body + mk_pat_match (arg:args) body = HsLam $ + PatMatch (VarPat arg) $ + SimpleMatch (mk_pat_match args body) + + mk_case [] body = body + mk_case ((arg,MarkedStrict):args) body = HsCase (HsVar arg) + [PatMatch (VarPat arg) $ + SimpleMatch (mk_case args body)] + src_loc + mk_case (_:args) body = mk_case args body + + src_loc = nameSrcLoc (getName con_id) + in + + returnTc (con_id, VarMonoBind (RealId con_id) con_rhs) +\end{code} + We're going to build a record selector that looks like this: data T a b c = T1 { op :: a, ...} @@ -179,15 +291,14 @@ Note that the selector Id itself is used as the field label; it has to be an Id, you see! \begin{code} -tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields) - = panic "tcRecordSelector: don't typecheck" -{- +mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) = let field_ty = fieldLabelType first_field_label field_name = fieldLabelName first_field_label - other_tys = [fieldLabelType fl | (_, fl) <- fields] + other_tys = [fieldLabelType fl | (_, fl) <- other_fields] (tyvars, _, _, _) = dataConSig first_con - -- tyvars of first_con may be free in first_ty + data_ty = applyTyCon tycon (mkTyVarTys tyvars) + -- tyvars of first_con may be free in field_ty in -- Check that all the fields in the group have the same type @@ -200,41 +311,38 @@ tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields) tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) -> tcInstType tenv field_ty `thenNF_Tc` \ field_ty' -> let - data_ty' = applyTyCon tycon tyvar_tys + 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' + selector_ty :: Type + selector_ty = mkForAllTys tyvars $ + mkFunTy data_ty $ + field_ty + selector_id :: Id 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' + SimpleMatch $ + selector_body - selector_body = HsCase (HsVar record_id) (map mk_match fields) tycon_src_loc + selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon) 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' + SimpleMatch $ + HsVar field_id in - returnTc (selector_id, VarMonoBind selector_id selector_rhs) --} + returnTc (selector_id, if isLocallyDefinedName (getName tycon) + then VarMonoBind (RealId selector_id) selector_rhs + else EmptyMonoBinds) \end{code} Constructors @@ -272,8 +380,7 @@ 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 @@ -287,16 +394,16 @@ tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc) returnTc data_con tcField (field_label_names, bty) - = tcMonoType (get_ty bty) `thenTc` \ field_ty -> + = tcPolyType (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 tcPolyType tys `thenTc` \ arg_tys -> let data_con = mkDataCon (getName name) stricts @@ -317,11 +424,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} @@ -340,4 +447,9 @@ tyNewCtxt tycon_name sty fieldTypeMisMatch field_name sty = ppSep [ppStr "Declared types differ for field", ppr sty field_name] + +missingEvalErr con eval_theta sty + = ppCat [ppStr "Missing Eval context for constructor", + ppQuote (ppr sty con), + ppStr ":", ppr sty eval_theta] \end{code}