From: simonmar <unknown>
Date: Thu, 17 Aug 2000 15:00:13 +0000 (+0000)
Subject: [project @ 2000-08-17 15:00:13 by simonmar]
X-Git-Tag: Approximately_9120_patches~3876
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=3b90e6e7cc87014153a5827c1003708de2d8c9f8;p=ghc-hetmet.git

[project @ 2000-08-17 15:00:13 by simonmar]
unboxing strict fields, bug #1:

	desugaring a record pattern used the
	rep args rather than the original args when
	expanding the pattern into a ConPat.
---

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index be1cf56..0419228 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -9,7 +9,7 @@ module DataCon (
 	ConTag, fIRST_TAG,
 	mkDataCon,
 	dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
-	dataConArgTys, dataConOrigArgTys,
+	dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys,
 	dataConRepArgTys, dataConTheta,
 	dataConFieldLabels, dataConStrictMarks, 
 	dataConSourceArity, dataConRepArity,
@@ -28,7 +28,6 @@ module DataCon (
 import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
 
 import CmdLineOpts	( opt_DictsStrict )
-import TysPrim
 import Type		( Type, ThetaType, TauType, ClassContext,
 			  mkForAllTys, mkFunTys, mkTyConApp, 
 			  mkTyVarTys, mkDictTys,
@@ -46,7 +45,6 @@ import Outputable
 import Unique		( Unique, Uniquable(..) )
 import CmdLineOpts	( opt_UnboxStrictFields )
 import PprType		()	-- Instances
-import UniqSet
 import Maybes		( maybeToBool )
 import Maybe
 import Util		( assoc )
@@ -357,7 +355,15 @@ dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
 		       dcExTyVars = ex_tyvars}) inst_tys
  = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
 
-dataConTheta (MkData {dcTheta = theta}) = theta
+dataConTheta :: DataCon -> ClassContext
+dataConTheta dc = dcTheta dc
+
+-- And the same deal for the original arg tys:
+
+dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
+dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars, 
+		       dcExTyVars = ex_tyvars}) inst_tys
+ = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
 \end{code}
 
 These two functions get the real argument types of the constructor,
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 9a18871..5fd2b0d 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -21,7 +21,7 @@ import DsMonad
 import DsGRHSs		( dsGRHSs )
 import DsUtils
 import Id		( idType, recordSelectorFieldLabel, Id )
-import DataCon		( dataConFieldLabels, dataConArgTys )
+import DataCon		( dataConFieldLabels, dataConInstOrigArgTys )
 import MatchCon		( matchConFamily )
 import MatchLit		( matchLiterals )
 import PrelInfo		( pAT_ERROR_ID )
@@ -466,7 +466,7 @@ tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result
 
 	-- Boring stuff to find the arg-tys of the constructor
     (_, inst_tys, _) = splitAlgTyConApp pat_ty
-    con_arg_tys'     = dataConArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
+    con_arg_tys'     = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
     tagged_arg_tys   = con_arg_tys' `zip` (dataConFieldLabels data_con)
 
 	-- mk_pat picks a WildPat of the appropriate type for absent fields,