[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.

diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index 1a56c35..01e98f7 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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