X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=27476db02f73a23c90bbc2c52908e581c38d3ce9;hb=13878c136b4e6b676dbc859f378809676f4d679c;hp=807787f42c813ce36f715b4a64186e5ed2822842;hpb=af93bb787305c0401eb658f149021e22d1ab98cc;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 807787f..27476db 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -25,17 +25,17 @@ import TcMonad
 import TcEnv		( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
 			  tcExtendKindEnv, tcLookup, tcExtendGlobalEnv,
 			  isLocalThing )
-import TcTyDecls	( tcTyDecl, kcConDetails, checkValidTyCon )
-import TcClassDcl	( tcClassDecl1, checkValidClass )
+import TcTyDecls	( tcTyDecl, kcConDetails )
+import TcClassDcl	( tcClassDecl1 )
 import TcInstDcls	( tcAddDeclCtxt )
 import TcMonoType	( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
-import TcMType		( newKindVar, zonkKindEnv )
+import TcMType		( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass )
 import TcUnify		( unifyKind )
 import TcType		( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
 import Type		( splitTyConApp_maybe )
 import Variance         ( calcTyConArgVrcs )
 import Class		( Class, mkClass, classTyCon )
-import TyCon		( TyCon, ArgVrcs, AlgTyConFlavour(..), 
+import TyCon		( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,
 			  tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
 			  mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon, 
 			)
@@ -267,7 +267,7 @@ kcTyClDecl (ForeignType {}) = returnTc ()
 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
   = kcTyClDeclBody decl			$ \ result_kind ->
     kcHsContext context			`thenTc_` 
-    mapTc_ kc_con_decl con_decls
+    mapTc_ kc_con_decl (visibleDataCons con_decls)
   where
     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
       = kcHsTyVars ex_tvs		`thenNF_Tc` \ kind_env ->
@@ -327,13 +327,16 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
         argvrcs		    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
-	          (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
-			   tcdNCons = nconstrs, tcdSysNames = sys_names})
+	          (TyData {tcdND = data_or_new, tcdName = tycon_name, 
+			   tcdTyVars = tyvar_names, tcdSysNames = sys_names})
   = ATyCon tycon
   where
 	tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
-			   data_cons nconstrs sel_ids
+			   data_cons sel_ids
 			   flavour is_rec gen_info
+	-- It's not strictly necesary to mark newtypes as
+	-- recursive if the loop is broken via a data type.
+	-- But I'm not sure it's worth the hassle of discovering that.
 
 	gen_info | not (dopt Opt_Generics dflags) = Nothing
 		 | otherwise = mkTyConGenInfo tycon sys_names
@@ -348,8 +351,11 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
 	-- so flavour has to be able to answer this question without consulting rec_details
 	flavour = case data_or_new of
 		    NewType  -> NewTyCon (mkNewTyConRep tycon)
-		    DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon
-	 		     | otherwise		     		-> DataTyCon
+		    DataType | all_nullary data_cons -> EnumTyCon
+	 		     | otherwise	     -> DataTyCon
+
+ 	all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
+	all_nullary other	    = False	-- Safe choice for unknown data types
 			-- NB (null . dataConOrigArgTys).  It used to say isNullaryDataCon
 			-- but that looks at the *representation* arity, and that in turn
 			-- depends on deciding whether to unpack the args, and that