X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;fp=compiler%2FbasicTypes%2FDataCon.lhs;h=af30dd1853d5a8c58446a3da594f40e233da017d;hp=d8fdfb55aeaea09ecbc125d014a99b681cafed1a;hb=3517c53d8a66149dcc3f971cf0577719e99d6d70;hpb=283e858564bb7979e59dcf00e852c2039aff231c

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index d8fdfb5..af30dd1 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -15,9 +15,11 @@ module DataCon (
 	
 	-- ** Type deconstruction
 	dataConRepType, dataConSig, dataConFullSig,
-	dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConUserType,
+	dataConName, dataConIdentity, dataConTag, dataConTyCon, 
+        dataConOrigTyCon, dataConUserType,
 	dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, 
-	dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta, dataConStupidTheta, 
+	dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta,
+	dataConStupidTheta,  
 	dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
 	dataConInstOrigArgTys, dataConRepArgTys, 
 	dataConFieldLabels, dataConFieldType,
@@ -563,6 +565,14 @@ dataConTag  = dcTag
 dataConTyCon :: DataCon -> TyCon
 dataConTyCon = dcRepTyCon
 
+-- | The original type constructor used in the definition of this data
+-- constructor.  In case of a data family instance, that will be the family
+-- type constructor.
+dataConOrigTyCon :: DataCon -> TyCon
+dataConOrigTyCon dc 
+  | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc
+  | otherwise                                          = dcRepTyCon dc
+
 -- | The representation type of the data constructor, i.e. the sort
 -- type that will represent values of this type at runtime
 dataConRepType :: DataCon -> Type