From 368eac75c490ef75495c48d4f98ce55865604d12 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 7 Dec 1999 15:03:09 +0000
Subject: [PATCH] [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
---
 ghc/compiler/basicTypes/DataCon.lhs   |   12 ++++++++----
 ghc/compiler/typecheck/TcGenDeriv.lhs |   23 +++++++++--------------
 2 files changed, 17 insertions(+), 18 deletions(-)

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index 0117a4f..8d2c071 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -8,8 +8,8 @@ module DataCon (
 	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,
@@ -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
-are included.
+are included.  dataConOrigArgTys is the same, but returns the types
+written by the programmer.
 
 \begin{code}
+dataConOrigArgTys :: DataCon -> [Type]
+dataConOrigArgTys dc = dcOrigArgTys dc
+
 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
-dataConRawArgTys = dcRepArgTys
+dataConRawArgTys dc = dcRepArgTys dc
 
 dataConAllRawArgTys :: DataCon -> [TauType]
 dataConAllRawArgTys con = 
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index f3b7a7f..20e59eb 100644
--- 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,
-			  dataConRawArgTys, fIRST_TAG,
+			  dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
 			  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
-	    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
@@ -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
-	    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)
@@ -565,7 +565,7 @@ gen_Bounded_binds tycon
     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)
@@ -697,12 +697,12 @@ gen_Ix_binds tycon
     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
 
-    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
@@ -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)
-	   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
@@ -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
-	     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
@@ -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
-	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)
@@ -1283,11 +1283,6 @@ eq_Expr ty a b
 \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
-- 
1.7.10.4