X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=a04f28f28e0587e498bfcd82b33ec44afae170fe;hp=f87397734370559665b9fde9a3888a1f3933cb34;hb=80c89b80c355b2aaebcd53330e6c6170c3f05aca;hpb=a4572b40a9668d949b906c000e40d65ca9dc2798

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index f873977..a04f28f 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -11,6 +11,7 @@ module DataCon (
 	dataConRepType, dataConSig, dataConFullSig,
 	dataConName, dataConTag, dataConTyCon, dataConUserType,
 	dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys,
+	dataConInstTys,
 	dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, 
 	dataConInstArgTys, dataConOrigArgTys, 
 	dataConInstOrigArgTys, dataConRepArgTys, 
@@ -38,7 +39,7 @@ import Type		( Type, ThetaType,
 import Coercion		( isEqPred, mkEqPred )
 import TyCon		( TyCon, FieldLabel, tyConDataCons, 
 			  isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
-                          isNewTyCon, isRecursiveTyCon )
+                          isNewTyCon, isRecursiveTyCon, tyConFamily_maybe )
 import Class		( Class, classTyCon )
 import Name		( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName )
 import Var		( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique,
@@ -335,9 +336,13 @@ data DataCon
 	-- An entirely separate wrapper function is built in TcTyDecls
 	dcIds :: DataConIds,
 
-	dcInfix :: Bool		-- True <=> declared infix
+	dcInfix :: Bool,	-- True <=> declared infix
 				-- Used for Template Haskell and 'deriving' only
 				-- The actual fixity is stored elsewhere
+
+        dcInstTys :: Maybe [Type]  -- If this data constructor is part of a
+				   -- data instance, then these are the type
+				   -- patterns of the instance.
   }
 
 data DataConIds
@@ -433,6 +438,7 @@ mkDataCon :: Name
 	  -> [TyVar] -> [TyVar] 
 	  -> [(TyVar,Type)] -> ThetaType
 	  -> [Type] -> TyCon
+	  -> Maybe [Type]
 	  -> ThetaType -> DataConIds
 	  -> DataCon
   -- Can get the tag from the TyCon
@@ -443,6 +449,7 @@ mkDataCon name declared_infix
 	  univ_tvs ex_tvs 
 	  eq_spec theta
 	  orig_arg_tys tycon
+	  mb_typats
 	  stupid_theta ids
   = ASSERT( not (any isEqPred theta) )
 	-- We don't currently allow any equality predicates on
@@ -459,9 +466,11 @@ mkDataCon name declared_infix
 		  dcStupidTheta = stupid_theta, dcTheta = theta,
 		  dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, 
 		  dcRepArgTys = rep_arg_tys,
-		  dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts,
+		  dcStrictMarks = arg_stricts, 
+		  dcRepStrictness = rep_arg_stricts,
 		  dcFields = fields, dcTag = tag, dcRepType = ty,
-		  dcIds = ids }
+		  dcIds = ids,
+		  dcInstTys = mb_typats }
 
 	-- Strictness marks for source-args
 	--	*after unboxing choices*, 
@@ -600,20 +609,32 @@ dataConResTys dc = [substTyVar env tv | tv <- dcUnivTyVars dc]
   where
     env = mkTopTvSubst (dcEqSpec dc)
 
+dataConInstTys :: DataCon -> Maybe [Type]
+dataConInstTys = dcInstTys
+
 dataConUserType :: DataCon -> Type
 -- The user-declared type of the data constructor
 -- in the nice-to-read form 
 --	T :: forall a. a -> T [a]
 -- rather than
 --	T :: forall b. forall a. (a=[b]) => a -> T b
+-- NB: If the constructor is part of a data instance, the result type
+-- mentions the family tycon, not the internal one.
 dataConUserType  (MkData { dcUnivTyVars = univ_tvs, 
 			   dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
 			   dcTheta = theta, dcOrigArgTys = arg_tys,
-			   dcTyCon = tycon })
+			   dcTyCon = tycon, dcInstTys = mb_insttys })
   = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
     mkFunTys (mkPredTys theta) $
     mkFunTys arg_tys $
-    mkTyConApp tycon (map (substTyVar subst) univ_tvs)
+    case mb_insttys of
+      Nothing      -> mkTyConApp tycon (map (substTyVar subst) univ_tvs)
+      Just insttys -> mkTyConApp ftycon insttys	    -- data instance
+        where
+	  ftycon = case tyConFamily_maybe tycon of
+		     Just ftycon -> ftycon
+		     Nothing     -> panic err
+          err    = "dataConUserType: type patterns without family tycon"
   where
     subst = mkTopTvSubst eq_spec