X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=191e546eeb01b14d01ac5bb74299e16ed0a07bd9;hb=68f606a04198beb15b577ebc951d34a313710cdc;hp=5f7a680b4291a524f69b5031b2e049dca31ad3ca;hpb=923ee9d360ed15331ac6faf8a6b4aca334fc0cee;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 5f7a680..191e546 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -314,7 +314,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 		 case new_or_data of
 		   DataType -> return (mkDataTyConRhs data_cons)
 		   NewType  -> ASSERT( isSingleton data_cons )
-			       mkNewTyConRhs tc_name tycon (head data_cons)
+			       mkNewTyConRhs rep_tc_name tycon (head data_cons)
 	     ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
 			     False h98_syntax (Just (family, t_typats))
                  -- We always assume that indexed types are recursive.  Why?
@@ -568,7 +568,8 @@ 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 (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) }
+    kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
+					   ; return (ConDeclField fld bty' d) }
 
     kc_larg_ty bty = case new_or_data of
 			DataType -> kcHsSigType bty
@@ -657,10 +658,11 @@ tcTyClDecl1 calc_isrec
   ; want_generic <- doptM Opt_Generics
   ; unbox_strict <- doptM Opt_UnboxStrictFields
   ; gla_exts     <- doptM Opt_GlasgowExts
+  ; gadt_ok      <- doptM Opt_GADTs
   ; is_boot	 <- tcIsHsBoot	-- Are we compiling an hs-boot file?
 
 	-- Check that we don't use GADT syntax in H98 world
-  ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name)
+  ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name)
 
 	-- Check that we don't use kind signatures without Glasgow extensions
   ; checkTc (gla_exts || isNothing mb_ksig) (badSigTyDecl tc_name)
@@ -775,8 +777,8 @@ tcConDecl unbox_strict 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 [ (n, t) | HsRecField n t _ <- fields ] 
-                              
+			      field_names = map cd_fld_name fields
+			      btys        = map cd_fld_type fields
     }
 
 tcResultType :: TyCon
@@ -1008,7 +1010,8 @@ checkNewDataCon con
 		-- Return type is (T a b c)
 	; checkTc (null ex_tvs && null theta) (newtypeExError con)
 		-- No existentials
-	; checkTc (null (dataConStrictMarks con)) (newtypeStrictError con)
+	; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) 
+		  (newtypeStrictError con)
 		-- No strictness
     }
   where
@@ -1141,7 +1144,7 @@ badDataConTyCon data_con
 
 badGadtDecl tc_name
   = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
-	 , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ]
+	 , nest 2 (parens $ ptext SLIT("Use -X=GADT to allow GADTs")) ]
 
 badStupidTheta tc_name
   = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)
@@ -1174,7 +1177,7 @@ badSigTyDecl tc_name
 badFamInstDecl tc_name
   = vcat [ ptext SLIT("Illegal family instance for") <+>
 	   quotes (ppr tc_name)
-	 , nest 2 (parens $ ptext SLIT("Use -ftype-families to allow indexed type families")) ]
+	 , nest 2 (parens $ ptext SLIT("Use -X=TypeFamilies to allow indexed type families")) ]
 
 badGadtIdxTyDecl tc_name
   = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+>