X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=dee20eee880658acdd62024e2cd37ddd2d3c6093;hp=de5893b071b8732204cea4674333e39e39bef1a0;hb=190f24892156953d73b55401d0467a6f1a88ce5d;hpb=aa8e9422469f1ccb3c52444fa56aae34de799334

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index de5893b..dee20ee 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -11,7 +11,7 @@ module TcTyClsDecls (
 #include "HsVersions.h"
 
 import HsSyn		( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
-			  ConDecl(..),   Sig(..), NewOrData(..), ResType(..),
+			  ConDecl(..), HsRecField(..), Sig(..), NewOrData(..), ResType(..),
 			  tyClDeclTyVars, isSynDecl, isIdxTyDecl,
 			  isKindSigDecl, hsConArgs, LTyClDecl, tcdName,
 			  hsTyVarName, LHsTyVarBndr, LHsType
@@ -572,14 +572,15 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
 	; cons' <- mappM (wrapLocM kc_con_decl) cons
 	; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
   where
-    kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res) = do
+    -- doc comments are typechecked to Nothing here
+    kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) = do
       kcHsTyVars ex_tvs $ \ex_tvs' -> do
         ex_ctxt' <- kcHsContext ex_ctxt
         details' <- kc_con_details details 
         res'     <- case res of
           ResTyH98 -> return ResTyH98
           ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
-        return (ConDecl name expl ex_tvs' ex_ctxt' details' res')
+        return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing)
 
     kc_con_details (PrefixCon btys) 
 	= do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
@@ -588,7 +589,7 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
     kc_con_details (RecCon fields) 
 	= do { fields' <- mappM kc_field fields; return (RecCon fields') }
 
-    kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') }
+    kc_field (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) }
 
     kc_larg_ty bty = case new_or_data of
 			DataType -> kcHsSigType bty
@@ -769,7 +770,7 @@ tcConDecl :: Bool 		-- True <=> -funbox-strict_fields
 	  -> TcM DataCon
 
 tcConDecl unbox_strict NewType tycon tc_tvs	-- Newtypes
-	  (ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
+	  (ConDecl name _ ex_tvs ex_ctxt details ResTyH98 _)
   = do	{ let tc_datacon field_lbls arg_ty
 		= do { arg_ty' <- tcHsKindedType arg_ty	-- No bang on newtype
 		     ; buildDataCon (unLoc name) False {- Prefix -} 
@@ -785,14 +786,14 @@ tcConDecl unbox_strict NewType tycon tc_tvs	-- Newtypes
 
 	; case details of
 	    PrefixCon [arg_ty]           -> tc_datacon [] arg_ty
-	    RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty
+	    RecCon [HsRecField field_lbl arg_ty _] -> tc_datacon [field_lbl] arg_ty
 	    other                        -> 
 	      failWithTc (newtypeFieldErr name (length (hsConArgs details)))
 			-- Check that the constructor has exactly one field
 	}
 
 tcConDecl unbox_strict DataType tycon tc_tvs	-- Data types
-	  (ConDecl name _ tvs ctxt details res_ty)
+	  (ConDecl name _ tvs ctxt details res_ty _)
   = tcTyVarBndrs tvs		$ \ tvs' -> do 
     { ctxt' <- tcHsKindedContext ctxt
     ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty
@@ -815,7 +816,7 @@ tcConDecl unbox_strict DataType tycon tc_tvs	-- Data types
 	InfixCon bty1 bty2 -> tc_datacon True  [] [bty1,bty2]
 	RecCon fields      -> tc_datacon False field_names btys
 			   where
-			      (field_names, btys) = unzip fields
+			      (field_names, btys) = unzip [ (n, t) | HsRecField n t _ <- fields ] 
                               
     }