[project @ 1999-12-07 15:03:08 by simonpj]

Derived instances should use *source* types not *representation*
types when doing their deriving stuff.  This bug prevented

	data F = F !Int deriving (Eq)

from working when -funbox-strict-fields was on

Simon

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index 0117a4f..8d2c071 100644 (file)
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -8,8 +8,8 @@ module DataCon (
        DataCon,
        ConTag, fIRST_TAG,
        mkDataCon,
        DataCon,
        ConTag, fIRST_TAG,
        mkDataCon,

-       dataConType, dataConSig, dataConName, dataConTag,
-       dataConArgTys, dataConTyCon,
+       dataConType, dataConSig, dataConName, dataConTag, dataConTyCon,
+       dataConArgTys, dataConOrigArgTys,

        dataConRawArgTys, dataConAllRawArgTys,
        dataConFieldLabels, dataConStrictMarks, dataConSourceArity,
        dataConNumFields, dataConNumInstArgs, dataConId, dataConRepStrictness,
        dataConRawArgTys, dataConAllRawArgTys,
        dataConFieldLabels, dataConStrictMarks, dataConSourceArity,
        dataConNumFields, dataConNumInstArgs, dataConId, dataConRepStrictness,

@@ -312,11 +312,15 @@ dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
 These two functions get the real argument types of the constructor,
 without substituting for any type variables.  dataConAllRawArgTys is
 like dataConRawArgTys except that the existential dictionary arguments
 These two functions get the real argument types of the constructor,
 without substituting for any type variables.  dataConAllRawArgTys is
 like dataConRawArgTys except that the existential dictionary arguments

-are included.
+are included.  dataConOrigArgTys is the same, but returns the types
+written by the programmer.

 
 \begin{code}
 
 \begin{code}

+dataConOrigArgTys :: DataCon -> [Type]
+dataConOrigArgTys dc = dcOrigArgTys dc
+

 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience

-dataConRawArgTys = dcRepArgTys
+dataConRawArgTys dc = dcRepArgTys dc

 
 dataConAllRawArgTys :: DataCon -> [TauType]
 dataConAllRawArgTys con = 
 
 dataConAllRawArgTys :: DataCon -> [TauType]
 dataConAllRawArgTys con = 

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index f3b7a7f..20e59eb 100644 (file)
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -39,7 +39,7 @@ import BasicTypes     ( RecFlag(..), Fixity(..), FixityDirection(..)
                        )
 import FieldLabel       ( fieldLabelName )
 import DataCon         ( isNullaryDataCon, dataConTag,
                        )
 import FieldLabel       ( fieldLabelName )
 import DataCon         ( isNullaryDataCon, dataConTag,

-                         dataConRawArgTys, fIRST_TAG,
+                         dataConOrigArgTys, dataConSourceArity, fIRST_TAG,

                          DataCon, ConTag,
                          dataConFieldLabels )
 import Name            ( getOccString, getOccName, getSrcLoc, occNameString, 
                          DataCon, ConTag,
                          dataConFieldLabels )
 import Name            ( getOccString, getOccName, getSrcLoc, occNameString, 

@@ -203,7 +203,7 @@ gen_Eq_binds tycon
            con_arity   = length tys_needed
            as_needed   = take con_arity as_RDRs
            bs_needed   = take con_arity bs_RDRs
            con_arity   = length tys_needed
            as_needed   = take con_arity as_RDRs
            bs_needed   = take con_arity bs_RDRs

-           tys_needed  = dataConRawArgTys data_con
+           tys_needed  = dataConOrigArgTys data_con

        in
        ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
       where
        in
        ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
       where

@@ -381,7 +381,7 @@ gen_Ord_binds tycon
            con_arity   = length tys_needed
            as_needed   = take con_arity as_RDRs
            bs_needed   = take con_arity bs_RDRs
            con_arity   = length tys_needed
            as_needed   = take con_arity as_RDRs
            bs_needed   = take con_arity bs_RDRs

-           tys_needed  = dataConRawArgTys data_con
+           tys_needed  = dataConOrigArgTys data_con

 
            nested_compare_expr [ty] [a] [b]
              = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
 
            nested_compare_expr [ty] [a] [b]
              = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)

@@ -565,7 +565,7 @@ gen_Bounded_binds tycon
     data_con_N_RDR = qual_orig_name data_con_N
 
     ----- single-constructor-flavored: -------------
     data_con_N_RDR = qual_orig_name data_con_N
 
     ----- single-constructor-flavored: -------------

-    arity         = argFieldCount data_con_1
+    arity         = dataConSourceArity data_con_1

 
     min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
                     mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
 
     min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
                     mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)

@@ -697,12 +697,12 @@ gen_Ix_binds tycon
     data_con
       =        case maybeTyConSingleCon tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
     data_con
       =        case maybeTyConSingleCon tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"

-         Just dc -> if (any isUnLiftedType (dataConRawArgTys dc)) then
+         Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then

                         error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
                     else
                         dc
 
                         error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
                     else
                         dc
 

-    con_arity    = argFieldCount data_con
+    con_arity    = dataConSourceArity data_con

     data_con_RDR = qual_orig_name data_con
 
     as_needed = take con_arity as_RDRs
     data_con_RDR = qual_orig_name data_con
 
     as_needed = take con_arity as_RDRs

@@ -801,7 +801,7 @@ gen_Read_binds fixities tycon
          where
           data_con_RDR = qual_orig_name data_con
           data_con_str = occNameUserString (getOccName data_con)
          where
           data_con_RDR = qual_orig_name data_con
           data_con_str = occNameUserString (getOccName data_con)

-          con_arity    = argFieldCount data_con
+          con_arity    = dataConSourceArity data_con

           con_expr     = mk_easy_App data_con_RDR as_needed
           nullary_con  = con_arity == 0
           labels       = dataConFieldLabels data_con
           con_expr     = mk_easy_App data_con_RDR as_needed
           nullary_con  = con_arity == 0
           labels       = dataConFieldLabels data_con

@@ -952,7 +952,7 @@ gen_Show_binds fixs_assoc tycon
                                 (HsPar (nested_compose_Expr show_thingies)))
            where
             data_con_RDR = qual_orig_name data_con
                                 (HsPar (nested_compose_Expr show_thingies)))
            where
             data_con_RDR = qual_orig_name data_con

-            con_arity    = argFieldCount data_con
+            con_arity    = dataConSourceArity data_con

             bs_needed    = take con_arity bs_RDRs
             con_pat      = ConPatIn data_con_RDR (map VarPatIn bs_needed)
             nullary_con  = con_arity == 0
             bs_needed    = take con_arity bs_RDRs
             con_pat      = ConPatIn data_con_RDR (map VarPatIn bs_needed)
             nullary_con  = con_arity == 0

@@ -1123,7 +1123,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
     mk_stuff var
       = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
       where
     mk_stuff var
       = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
       where

-       pat    = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
+       pat    = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)

        var_RDR = qual_orig_name var
 
 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
        var_RDR = qual_orig_name var
 
 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)

@@ -1283,11 +1283,6 @@ eq_Expr ty a b
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-argFieldCount :: DataCon -> Int        -- Works on data and newtype constructors
-argFieldCount con = length (dataConRawArgTys con)
-\end{code}
-
-\begin{code}

 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
 untag_Expr tycon [] expr = expr
 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
 untag_Expr tycon [] expr = expr
 untag_Expr tycon ((untag_this, put_tag_here) : more) expr