X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FbasicTypes%2FDataCon.lhs;h=af30dd1853d5a8c58446a3da594f40e233da017d;hb=40b8f4c53505de002e92a33fc85f780fd83cbb9a;hp=df8af8e221045eadb411b98a3733ff9eb4b92549;hpb=7299e42cc5214458ba16034dbfbf58de55f7121b;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index df8af8e..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,
@@ -318,7 +320,6 @@ data DataCon
 	dcOrigArgTys :: [Type],		-- Original argument types
 					-- (before unboxing and flattening of strict fields)
 	dcOrigResTy :: Type,		-- Original result type, as seen by the user
-		-- INVARIANT: mentions only dcUnivTyVars
 		-- NB: for a data instance, the original user result type may 
 		-- differ from the DataCon's representation TyCon.  Example
 		--	data instance T [a] where MkT :: a -> T [a]
@@ -564,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
@@ -636,8 +645,10 @@ dataConFieldLabels = dcFields
 
 -- | Extract the type for any given labelled field of the 'DataCon'
 dataConFieldType :: DataCon -> FieldLabel -> Type
-dataConFieldType con label = expectJust "unexpected label" $
-    lookup label (dcFields con `zip` dcOrigArgTys con)
+dataConFieldType con label
+  = case lookup label (dcFields con `zip` dcOrigArgTys con) of
+      Just ty -> ty
+      Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
 
 -- | The strictness markings decided on by the compiler.  Does not include those for
 -- existential dictionaries.  The list is in one-to-one correspondence with the arity of the 'DataCon'
@@ -726,7 +737,7 @@ dataConUserType :: DataCon -> Type
 --
 -- rather than:
 --
--- > T :: forall a c. forall b. (c=[a]) => a -> b -> T c
+-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c
 --
 -- NB: If the constructor is part of a data instance, the result type
 -- mentions the family tycon, not the internal one.