From 6cedde65ea072d74025da43ad8718acc28d599bb Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 6 May 2003 10:28:33 +0000 Subject: [PATCH] [project @ 2003-05-06 10:28:32 by simonpj] ------------------------------------- Implement deriving( Data ) ------------------------------------- Implements deriving( Data ), where the Data class is defined in Data.Generics; its the "scrap your boilerplate" Term class. Ralf is still converging on the exact definition of the Data class, so the details may change. --- ghc/compiler/prelude/PrelNames.lhs | 27 ++++---- ghc/compiler/typecheck/TcDeriv.lhs | 14 +++-- ghc/compiler/typecheck/TcGenDeriv.lhs | 111 ++++++++++++++++++++++++++++----- 3 files changed, 118 insertions(+), 34 deletions(-) diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 1a56c35..01e98f7 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -157,7 +157,7 @@ basicKnownKeyNames realFloatClassName, -- numeric cCallableClassName, -- mentioned, ccallish cReturnableClassName, -- mentioned, ccallish - traverseClassName, + dataClassName, typeableClassName, -- Numeric stuff @@ -256,7 +256,7 @@ pREL_FLOAT_Name = mkModuleName "GHC.Float" pREL_TOP_HANDLER_Name = mkModuleName "GHC.TopHandler" sYSTEM_IO_Name = mkModuleName "System.IO" dYNAMIC_Name = mkModuleName "Data.Dynamic" -tRAVERSE_Name = mkModuleName "Data.Traverse" +gENERICS_Name = mkModuleName "Data.Generics" rEAD_PREC_Name = mkModuleName "Text.ParserCombinators.ReadPrec" lEX_Name = mkModuleName "Text.Read.Lex" @@ -427,12 +427,17 @@ typeOf_RDR = varQual_RDR dYNAMIC_Name FSLIT("typeOf") mkTypeRep_RDR = varQual_RDR dYNAMIC_Name FSLIT("mkAppTy") mkTyConRep_RDR = varQual_RDR dYNAMIC_Name FSLIT("mkTyCon") -undefined_RDR = varQual_RDR pREL_ERR_Name FSLIT("undefined") +constr_RDR = dataQual_RDR gENERICS_Name FSLIT("Constr") +gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl") +gfoldr_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldr") +gunfold_RDR = varQual_RDR gENERICS_Name FSLIT("gunfold") +gmapT_RDR = varQual_RDR gENERICS_Name FSLIT("gmapT") +gmapQ_RDR = varQual_RDR gENERICS_Name FSLIT("gmapQ") +gmapM_RDR = varQual_RDR gENERICS_Name FSLIT("gmapM") +conOf_RDR = varQual_RDR gENERICS_Name FSLIT("conOf") +consOf_RDR = varQual_RDR gENERICS_Name FSLIT("consOf") -gmapQ_RDR = varQual_RDR tRAVERSE_Name FSLIT("gmapQ") -gmapT_RDR = varQual_RDR tRAVERSE_Name FSLIT("gmapT") -gmapM_RDR = varQual_RDR tRAVERSE_Name FSLIT("gmapM") -gfoldl_RDR = varQual_RDR tRAVERSE_Name FSLIT("gfoldl") +undefined_RDR = varQual_RDR pREL_ERR_Name FSLIT("undefined") \end{code} @@ -586,9 +591,9 @@ realFloatClassName = clsQual pREL_FLOAT_Name FSLIT("RealFloat") realFloatClassK -- Class Ix ixClassName = clsQual pREL_ARR_Name FSLIT("Ix") ixClassKey --- Class Typeable and Traverse -typeableClassName = clsQual dYNAMIC_Name FSLIT("Typeable") typeableClassKey -traverseClassName = clsQual tRAVERSE_Name FSLIT("Traverse") traverseClassKey +-- Class Typeable and Data +typeableClassName = clsQual dYNAMIC_Name FSLIT("Typeable") typeableClassKey +dataClassName = clsQual gENERICS_Name FSLIT("Data") dataClassKey -- Enum module (Enum, Bounded) enumClassName = clsQual pREL_ENUM_Name FSLIT("Enum") enumClassKey @@ -744,7 +749,7 @@ floatingClassKey = mkPreludeClassUnique 5 fractionalClassKey = mkPreludeClassUnique 6 integralClassKey = mkPreludeClassUnique 7 monadClassKey = mkPreludeClassUnique 8 -traverseClassKey = mkPreludeClassUnique 9 +dataClassKey = mkPreludeClassUnique 9 functorClassKey = mkPreludeClassUnique 10 numClassKey = mkPreludeClassUnique 11 ordClassKey = mkPreludeClassUnique 12 diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 5522743..3e02116 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -11,7 +11,7 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" import HsSyn ( HsBinds(..), MonoBinds(..), TyClDecl(..), - collectMonoBinders ) + andMonoBindList, collectMonoBinders ) import RdrHsSyn ( RdrNameMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl, RenamedHsPred ) import CmdLineOpts ( DynFlag(..) ) @@ -39,6 +39,7 @@ import MkId ( mkDictFunId ) import DataCon ( dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon ) import Maybes ( maybeToBool, catMaybes ) import Name ( Name, getSrcLoc, nameUnique ) +import Unique ( getUnique ) import NameSet import RdrName ( RdrName ) @@ -246,7 +247,7 @@ deriveOrdinaryStuff eqns let extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc - extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list + extra_mbinds = andMonoBindList extra_mbind_list mbinders = collectMonoBinders extra_mbinds in mappM gen_bind new_dfuns `thenM` \ rdr_name_inst_infos -> @@ -465,10 +466,10 @@ makeDerivEqns tycl_decls right_arity = length tys + 1 == classArity clas + -- Never derive Read,Show,Typeable,Data this way + non_iso_classes = [readClassKey, showClassKey, typeableClassKey, dataClassKey] can_derive_via_isomorphism - = not (clas `hasKey` readClassKey) -- Never derive Read,Show,Typeable this way - && not (clas `hasKey` showClassKey) - && not (clas `hasKey` typeableClassKey) + = not (getUnique clas `elem` non_iso_classes) && right_arity -- Well kinded; -- eg not: newtype T ... deriving( ST ) -- because ST needs *2* type params @@ -513,7 +514,7 @@ makeDerivEqns tycl_decls bale_out err = addErrTc err `thenM_` returnM (Nothing, Nothing) standard_class gla_exts clas = key `elem` derivableClassKeys - || (gla_exts && (key == typeableClassKey || key == traverseClassKey)) + || (gla_exts && (key == typeableClassKey || key == dataClassKey)) where key = classKey clas ------------------------------------------------------------------ @@ -708,6 +709,7 @@ gen_bind dfun ,(showClassKey, gen_Show_binds fix_env) ,(readClassKey, gen_Read_binds fix_env) ,(typeableClassKey,gen_Typeable_binds) + ,(dataClassKey, gen_Data_binds) ] in returnM (dfun, gen_binds_fn tycon) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 53a0e78..5c66111 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -17,6 +17,7 @@ module TcGenDeriv ( gen_Ord_binds, gen_Read_binds, gen_Show_binds, + gen_Data_binds, gen_Typeable_binds, gen_tag_n_con_monobind, @@ -512,8 +513,8 @@ gen_Bounded_binds tycon tycon_loc = getSrcLoc tycon ----- enum-flavored: --------------------------- - min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR) - max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR) + min_bound_enum = mkVarMonoBind tycon_loc minBound_RDR (HsVar data_con_1_RDR) + max_bound_enum = mkVarMonoBind tycon_loc maxBound_RDR (HsVar data_con_N_RDR) data_con_1 = head data_cons data_con_N = last data_cons @@ -523,9 +524,9 @@ gen_Bounded_binds tycon ----- single-constructor-flavored: ------------- arity = dataConSourceArity data_con_1 - min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $ + min_bound_1con = mkVarMonoBind tycon_loc minBound_RDR $ mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) - max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $ + max_bound_1con = mkVarMonoBind tycon_loc maxBound_RDR $ mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) \end{code} @@ -771,17 +772,17 @@ gen_Read_binds get_fixity tycon where ----------------------------------------------------------------------- default_binds - = mk_easy_FunMonoBind loc readList_RDR [] [] (HsVar readListDefault_RDR) + = mkVarMonoBind loc readList_RDR (HsVar readListDefault_RDR) `AndMonoBinds` - mk_easy_FunMonoBind loc readListPrec_RDR [] [] (HsVar readListPrecDefault_RDR) + mkVarMonoBind loc readListPrec_RDR (HsVar readListPrecDefault_RDR) ----------------------------------------------------------------------- loc = getSrcLoc tycon data_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons - read_prec = mk_easy_FunMonoBind loc readPrec_RDR [] [] - (HsApp (HsVar parens_RDR) read_cons) + read_prec = mkVarMonoBind loc readPrec_RDR + (HsApp (HsVar parens_RDR) read_cons) read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) read_non_nullary_cons = map read_non_nullary_con non_nullary_cons @@ -910,7 +911,7 @@ gen_Show_binds get_fixity tycon where tycon_loc = getSrcLoc tycon ----------------------------------------------------------------------- - show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] [] + show_list = mkVarMonoBind tycon_loc showList_RDR (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0)))) ----------------------------------------------------------------------- shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) @@ -1026,7 +1027,7 @@ Notice the use of lexically scoped type variables. \begin{code} gen_Typeable_binds :: TyCon -> RdrNameMonoBinds gen_Typeable_binds tycon - = mk_easy_FunMonoBind tycon_loc typeOf_RDR [WildPat placeHolderType] [] + = mk_easy_FunMonoBind tycon_loc typeOf_RDR [wildPat] [] (mkHsApps mkTypeRep_RDR [tycon_rep, arg_reps]) where tycon_loc = getSrcLoc tycon @@ -1042,6 +1043,77 @@ gen_Typeable_binds tycon %************************************************************************ %* * +\subsection{Data} +%* * +%************************************************************************ + +From the data type + + data T a b = T1 a b | T2 + +we generate + + instance (Data a, Data b) => Data (T a b) where + gfoldl k z (T1 a b) = z T `k` a `k` b + gfoldl k z T2 = z T2 + -- ToDo: add gmapT,Q,M, gfoldr + + gunfold k z _ (Constr "T1") = k (k (z T1)) + gunfold k z _ (Constr "T2") = z T2 + gunfold _ _ e _ = e + + conOf (T1 _ _) = Constr "T1" + conOf T2 = Constr "T2" + + consOf _ = [Constr "T1", Constr "T2"] + +ToDo: generate auxiliary bindings for the Constrs? + +\begin{code} +gen_Data_binds :: TyCon -> RdrNameMonoBinds +gen_Data_binds tycon + = andMonoBindList [gfoldl_bind, gunfold_bind, conOf_bind, consOf_bind] + where + tycon_loc = getSrcLoc tycon + data_cons = tyConDataCons tycon + + ------------ gfoldl + gfoldl_bind = mk_FunMonoBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons) + gfoldl_eqn con = ([VarPat k_RDR, VarPat z_RDR, mkConPat con_name as_needed], + foldl mk_k_app (HsVar z_RDR `HsApp` HsVar con_name) as_needed) + where + con_name :: RdrName + con_name = getRdrName con + as_needed = take (dataConSourceArity con) as_RDRs + mk_k_app e v = HsPar (mkHsOpApp e k_RDR (HsVar v)) + + ------------ gunfold + gunfold_bind = mk_FunMonoBind tycon_loc gunfold_RDR (map gunfold_eqn data_cons ++ [catch_all]) + gunfold_eqn con = ([VarPat k_RDR, VarPat z_RDR, wildPat, + ConPatIn constr_RDR (PrefixCon [LitPat (mk_constr_string con)])], + apN (dataConSourceArity con) + (\e -> HsVar k_RDR `HsApp` e) + (z_Expr `HsApp` HsVar (getRdrName con))) + catch_all = ([wildPat, wildPat, VarPat e_RDR, wildPat], HsVar e_RDR) + mk_constr_string con = mkHsString (occNameUserString (getOccName con)) + + ------------ conOf + conOf_bind = mk_FunMonoBind tycon_loc conOf_RDR (map conOf_eqn data_cons) + conOf_eqn con = ([mkWildConPat con], mk_constr con) + + ------------ consOf + consOf_bind = mk_easy_FunMonoBind tycon_loc consOf_RDR [wildPat] [] + (ExplicitList placeHolderType (map mk_constr data_cons)) + mk_constr con = HsVar constr_RDR `HsApp` (HsLit (mk_constr_string con)) + + +apN :: Int -> (a -> a) -> a -> a +apN 0 k z = z +apN n k z = apN (n-1) k (k z) +\end{code} + +%************************************************************************ +%* * \subsection{Generating extra binds (@con2tag@ and @tag2con@)} %* * %************************************************************************ @@ -1095,11 +1167,8 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr) - mk_stuff var - = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))) - where - pat = ConPatIn var_RDR (PrefixCon (nOfThem (dataConSourceArity var) wildPat)) - var_RDR = getRdrName var + mk_stuff con = ([mkWildConPat con], + HsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) = mk_FunMonoBind (getSrcLoc tycon) rdr_name @@ -1108,8 +1177,8 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) (HsTyVar (getRdrName tycon)))] gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) - = mk_easy_FunMonoBind (getSrcLoc tycon) - rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag))) + = mkVarMonoBind (getSrcLoc tycon) rdr_name + (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag))) where max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) @@ -1137,6 +1206,9 @@ multi-clause definitions; it generates: \end{verbatim} \begin{code} +mkVarMonoBind :: SrcLoc -> RdrName -> RdrNameHsExpr -> RdrNameMonoBinds +mkVarMonoBind loc var rhs = mk_easy_FunMonoBind loc var [] [] rhs + mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat] -> [RdrNameMonoBinds] -> RdrNameHsExpr -> RdrNameMonoBinds @@ -1178,6 +1250,7 @@ mkHsChar c = HsChar (ord c) mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars)) mkNullaryConPat con = ConPatIn con (PrefixCon []) +mkWildConPat con = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat)) \end{code} ToDo: Better SrcLocs. @@ -1348,6 +1421,9 @@ a_RDR = varUnqual FSLIT("a") b_RDR = varUnqual FSLIT("b") c_RDR = varUnqual FSLIT("c") d_RDR = varUnqual FSLIT("d") +e_RDR = varUnqual FSLIT("e") +k_RDR = varUnqual FSLIT("k") +z_RDR = varUnqual FSLIT("z") :: RdrName ah_RDR = varUnqual FSLIT("a#") bh_RDR = varUnqual FSLIT("b#") ch_RDR = varUnqual FSLIT("c#") @@ -1364,6 +1440,7 @@ a_Expr = HsVar a_RDR b_Expr = HsVar b_RDR c_Expr = HsVar c_RDR d_Expr = HsVar d_RDR +z_Expr = HsVar z_RDR ltTag_Expr = HsVar ltTag_RDR eqTag_Expr = HsVar eqTag_RDR gtTag_Expr = HsVar gtTag_RDR -- 1.7.10.4