From: simonmar <unknown>
Date: Thu, 6 Oct 2005 10:40:10 +0000 (+0000)
Subject: [project @ 2005-10-06 10:40:10 by simonmar]
X-Git-Tag: Initial_conversion_from_CVS_complete~188
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=4a6c92b6a377d02c2d925367fc599112f410d369;p=ghc-hetmet.git

[project @ 2005-10-06 10:40:10 by simonmar]
add dataConFieldType

From: Autrijus Tang <autrijus@autrijus.org>
---

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index 2cacc14..7905770 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -12,7 +12,8 @@ module DataCon (
 	dataConTyVars, dataConStupidTheta, 
 	dataConArgTys, dataConOrigArgTys, dataConResTy,
 	dataConInstOrigArgTys, dataConRepArgTys, 
-	dataConFieldLabels, dataConStrictMarks, dataConExStricts,
+	dataConFieldLabels, dataConFieldType,
+	dataConStrictMarks, dataConExStricts,
 	dataConSourceArity, dataConRepArity,
 	dataConIsInfix,
 	dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
@@ -40,6 +41,7 @@ import Outputable
 import Unique		( Unique, Uniquable(..) )
 import ListSetOps	( assoc )
 import Util		( zipEqual, zipWithEqual )
+import Maybes           ( expectJust )
 \end{code}
 
 
@@ -454,6 +456,10 @@ dataConImplicitIds dc = case dcIds dc of
 dataConFieldLabels :: DataCon -> [FieldLabel]
 dataConFieldLabels = dcFields
 
+dataConFieldType :: DataCon -> FieldLabel -> Type
+dataConFieldType con label = expectJust "unexpected label" $
+    lookup label (dcFields con `zip` dcOrigArgTys con)
+
 dataConStrictMarks :: DataCon -> [StrictnessMark]
 dataConStrictMarks = dcStrictMarks