[project @ 2004-03-23 10:03:18 by simonmar]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcGenDeriv.lhs

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index e922146..b9b9ae1 100644 (file)
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -50,7 +50,7 @@ import TysWiredIn
 import MkId            ( eRROR_ID )
 import PrimOp          ( PrimOp(..) )
 import SrcLoc          ( Located(..), noLoc, srcLocSpan )
-import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
+import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity,
                          maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName
                        )
 import TcType          ( isUnLiftedType, tcEqType, Type )
@@ -993,27 +993,30 @@ From the data type
 
 we generate
 
-       instance (Typeable a, Typeable b) => Typeable (T a b) where
-               typeOf _ = mkTypeRep (mkTyConRep "T")
-                                    [typeOf (undefined::a),
-                                     typeOf (undefined::b)]
+       instance Typeable2 T where
+               typeOf2 _ = mkTyConApp (mkTyConRep "T") []
 
-Notice the use of lexically scoped type variables.
+We are passed the Typeable2 class as well as T
 
 \begin{code}
 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
 gen_Typeable_binds tycon
   = unitBag $
-       mk_easy_FunBind tycon_loc typeOf_RDR [wildPat] emptyBag
-               (nlHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
+       mk_easy_FunBind tycon_loc 
+               (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
+               [wildPat] emptyBag
+               (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
   where
     tycon_loc = getSrcSpan tycon
-    tyvars    = tyConTyVars tycon
     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
-    arg_reps  = nlList (map mk tyvars)
-    mk tyvar  = nlHsApp (nlHsVar typeOf_RDR) 
-                     (noLoc (ExprWithTySig (nlHsVar undefined_RDR)
-                                           (nlHsTyVar (getRdrName tyvar))))
+
+mk_typeOf_RDR :: TyCon -> RdrName
+-- Use the arity of the TyCon to make the right typeOfn function
+mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_Name (mkFastString ("typeOf" ++ suffix))
+               where
+                 arity = tyConArity tycon
+                 suffix | arity == 0 = ""
+                        | otherwise  = show arity
 \end{code}
 
 
@@ -1030,9 +1033,10 @@ From the data type
 
 we generate
 
-  $cT1 = mkConstr 1 "T1" Prefix
-  $cT2 = mkConstr 2 "T2" Prefix
-  $dT  = mkDataType [$con_T1, $con_T2]
+  $cT1 = mkDataCon $dT "T1" Prefix
+  $cT2 = mkDataCon $dT "T2" Prefix
+  $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
+  -- the [] is for field labels.
 
   instance (Data a, Data b) => Data (T a b) where
     gfoldl k z (T1 a b) = z T `k` a `k` b
@@ -1085,25 +1089,41 @@ gen_Data_binds fix_env tycon
     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
     
        ------------ dataTypeOf
-    dataTypeOf_bind = mk_easy_FunBind tycon_loc dataTypeOf_RDR [wildPat] 
-                                         emptyBag (nlHsVar data_type_name)
+    dataTypeOf_bind = mk_easy_FunBind
+                        tycon_loc
+                        dataTypeOf_RDR
+                       [wildPat]
+                        emptyBag
+                        (nlHsVar data_type_name)
 
        ------------ $dT
+
     data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
-    datatype_bind  = mkVarBind tycon_loc data_type_name
-                                  (nlHsVar mkDataType_RDR `nlHsApp` 
-                                   nlList constrs)
+    datatype_bind  = mkVarBind
+                       tycon_loc
+                       data_type_name
+                      (           nlHsVar mkDataType_RDR 
+                         `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
+                         `nlHsApp` nlList constrs
+                       )
     constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
 
 
        ------------ $cT1 etc
     mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
-    mk_con_bind dc = mkVarBind tycon_loc (mk_constr_name dc) 
-                                            (nlHsApps mkConstr_RDR (constr_args dc))
-    constr_args dc = [nlHsIntLit (toInteger (dataConTag dc)),          -- Tag
-                     nlHsLit (mkHsString (occNameUserString dc_occ)),  -- String name
-                     nlHsVar fixity]                                   -- Fixity
+    mk_con_bind dc = mkVarBind
+                       tycon_loc
+                       (mk_constr_name dc) 
+                      (nlHsApps mkConstr_RDR (constr_args dc))
+    constr_args dc =
+        [ -- nlHsIntLit (toInteger (dataConTag dc)),           -- Tag
+          nlHsVar data_type_name,                              -- DataType
+          nlHsLit (mkHsString (occNameUserString dc_occ)),     -- String name
+           nlList  labels,                                     -- Field labels
+          nlHsVar fixity]                                      -- Fixity
        where
+          labels   = map (nlHsLit . mkHsString . getOccString . fieldLabelName)
+                         (dataConFieldLabels dc)
          dc_occ   = getOccName dc
          is_infix = isDataSymOcc dc_occ
          fixity | is_infix  = infix_RDR
@@ -1115,7 +1135,7 @@ toConstr_RDR   = varQual_RDR gENERICS_Name FSLIT("toConstr")
 dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
 mkConstr_RDR   = varQual_RDR gENERICS_Name FSLIT("mkConstr")
 mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
-conIndex_RDR   = varQual_RDR gENERICS_Name FSLIT("conIndex")
+conIndex_RDR   = varQual_RDR gENERICS_Name FSLIT("constrIndex")
 prefix_RDR     = dataQual_RDR gENERICS_Name FSLIT("Prefix")
 infix_RDR      = dataQual_RDR gENERICS_Name FSLIT("Infix")
 \end{code}