From: sewardj <unknown>
Date: Fri, 7 Apr 2000 11:57:31 +0000 (+0000)
Subject: [project @ 2000-04-07 11:57:31 by sewardj]
X-Git-Tag: Approximately_9120_patches~4775
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0ca608920476e03d994740db23bb86c3d87ecb13;p=ghc-hetmet.git

[project @ 2000-04-07 11:57:31 by sewardj]
Make datatype field selectors take (and ignore) dictionaries.
---

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index f44f932..e849e73 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -10,7 +10,7 @@ module DataCon (
 	mkDataCon,
 	dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
 	dataConArgTys, dataConOrigArgTys,
-	dataConRepArgTys,
+	dataConRepArgTys, dataConTheta,
 	dataConFieldLabels, dataConStrictMarks, 
 	dataConSourceArity, dataConRepArity,
 	dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness,
@@ -105,6 +105,9 @@ data DataCon
 	--	dcTyCon    = T
 
 	dcTyVars :: [TyVar], 		-- Type vars and context for the data type decl
+					-- These are ALWAYS THE SAME AS THE TYVARS 
+					-- FOR THE PARENT TyCon.  We occasionally rely on
+					-- this just to avoid redundant instantiation
 	dcTheta  ::  ClassContext,
 
 	dcExTyVars :: [TyVar], 		-- Ditto for the context of the constructor, 
@@ -353,6 +356,8 @@ dataConArgTys :: DataCon
 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
 \end{code}
 
 These two functions get the real argument types of the constructor,
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index bcae7ed..c83a230 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -52,7 +52,8 @@ import Module		( Module )
 import CoreUtils	( mkInlineMe )
 import CoreUnfold 	( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
 import Subst		( mkTopTyVarSubst, substClasses )
-import TyCon		( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon, isProductTyCon, isUnboxedTupleTyCon )
+import TyCon		( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon, 
+                          tyConTheta, isProductTyCon, isUnboxedTupleTyCon )
 import Class		( Class, classBigSig, classTyCon, classTyVars, classSelIds )
 import Var		( Id, TyVar )
 import VarSet		( isEmptyVarSet )
@@ -68,7 +69,8 @@ import PrimOp		( PrimOp(DataToTagOp, CCallOp),
 import Demand		( wwStrict, wwPrim )
 import DataCon		( DataCon, StrictnessMark(..), 
 			  dataConFieldLabels, dataConRepArity, dataConTyCon,
-			  dataConArgTys, dataConRepType, dataConRepStrictness, dataConName,
+			  dataConArgTys, dataConRepType, dataConRepStrictness, 
+                          dataConName, dataConTheta,
 			  dataConSig, dataConStrictMarks, dataConId
 			)
 import Id		( idType, mkId,
@@ -356,12 +358,24 @@ mkRecordSelId tycon field_label
     data_cons  = tyConDataCons tycon
     tyvars     = tyConTyVars tycon	-- These scope over the types in 
 					-- the FieldLabels of constructors of this type
+    tycon_theta	= tyConTheta tycon	-- The context on the data decl
+					--   eg data (Eq a, Ord b) => T a b = ...
 
     data_ty   = mkTyConApp tycon (mkTyVarTys tyvars)
     tyvar_tys = mkTyVarTys tyvars
 
+	-- Very tiresomely, the selectors are (unnecessarily!) overloaded over
+	-- just the dictionaries in the types of the constructors that contain
+	-- the relevant field.  Urgh.  
+	-- NB: this code relies on the fact that DataCons are quantified over
+	-- the identical type variables as their parent TyCon
+    dict_tys  = [mkDictTy cls tys | (cls, tys) <- tycon_theta, needed_dict (cls, tys)]
+    needed_dict pred = or [ pred `elem` (dataConTheta dc) 
+			  | (DataAlt dc, _, _) <- the_alts]
+
     selector_ty :: Type
-    selector_ty  = mkForAllTys tyvars (mkFunTy data_ty field_ty)
+    selector_ty  = mkForAllTys tyvars $ mkFunTys dict_tys $ 
+		   mkFunTy data_ty field_ty
       
     info = mkIdInfo (RecordSelId field_label)
 	   `setArityInfo`	exactArity 1
@@ -372,7 +386,7 @@ mkRecordSelId tycon field_label
     unfolding = mkTopUnfolding sel_rhs
 
 	
-    [data_id] = mkTemplateLocals [data_ty]
+    (data_id:dict_ids) = mkTemplateLocals (data_ty:dict_tys)
     alts      = map mk_maybe_alt data_cons
     the_alts  = catMaybes alts
     default_alt | all isJust alts = []	-- No default needed
@@ -381,8 +395,8 @@ mkRecordSelId tycon field_label
     sel_rhs | isNewTyCon tycon = new_sel_rhs
 	    | otherwise	       = data_sel_rhs
 
-    data_sel_rhs = mkLams tyvars $ Lam data_id $
-	 	     Case (Var data_id) data_id (the_alts ++ default_alt)
+    data_sel_rhs = mkLams tyvars $ mkLams dict_ids $ Lam data_id $
+	 	   Case (Var data_id) data_id (the_alts ++ default_alt)
 
     new_sel_rhs  = mkLams tyvars $ Lam data_id $
 		    Note (Coerce (unUsgTy field_ty) (unUsgTy data_ty)) (Var data_id)
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index a1711a2..36031cb 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -30,7 +30,7 @@ import TcMonad
 import TcUnify		( unifyKind )
 
 import Class		( Class )
-import DataCon		( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
+import DataCon		( DataCon, mkDataCon, isNullaryDataCon,
 			  dataConFieldLabels, dataConId, dataConWrapId,
 			  markedStrict, notMarkedStrict, markedUnboxed, dataConRepType
 			)