From: simonpj <unknown>
Date: Mon, 11 Jun 2001 12:21:17 +0000 (+0000)
Subject: [project @ 2001-06-11 12:21:17 by simonpj]
X-Git-Tag: Approximately_9120_patches~1781
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0004357ccaa3149cb112f5f5df1af60e65baad79;p=ghc-hetmet.git

[project @ 2001-06-11 12:21:17 by simonpj]
--------------------------
	Allow data type declarations
	to have zero constructors
	--------------------------

This allows

	data T a

as a data type declaration; i.e. allows zero constructors.
If there is an '=' sign there must be at least one constructor.


* Parser.y: parse the declaration
* HsDecls: print out the data type declaration right
* TyCon: don't ASSERT that the constructors are non-empty
---

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index fc136d3..28778b7 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -464,7 +464,7 @@ instance (NamedThing name, Outputable name, Outputable pat)
     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
 		 tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = ncons,
 		 tcdDerivs = derivings})
-      = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
+      = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars)
 		  (pp_condecls condecls ncons)
 		  derivings
       where
@@ -490,7 +490,7 @@ pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name]
 pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
 
 pp_condecls []     ncons = ptext SLIT("{- abstract with") <+> int ncons <+> ptext SLIT("constructors -}")
-pp_condecls (c:cs) ncons = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
+pp_condecls (c:cs) ncons = equals <+> sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
 
 pp_tydecl pp_head pp_decl_rhs derivings
   = hang pp_head 4 (sep [
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index e747d2c..872257f 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.66 2001/05/24 13:59:11 simonpj Exp $
+$Id: Parser.y,v 1.67 2001/06/11 12:21:17 simonpj Exp $
 
 Haskell grammar.
 
@@ -341,10 +341,10 @@ topdecl :: { RdrBinding }
 		-- Instead we just say b is out of scope
 		{ RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) }
 
-	| srcloc 'data' ctype '=' constrs deriving
+	| srcloc 'data' ctype constrs deriving
 		{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
 		   returnP (RdrHsDecl (TyClD
-		      (mkTyData DataType cs c ts (reverse $5) (length $5) $6 $1))) }
+		      (mkTyData DataType cs c ts (reverse $4) (length $4) $5 $1))) }
 
 	| srcloc 'newtype' ctype '=' newconstr deriving
 		{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
@@ -605,7 +605,11 @@ newconstr :: { RdrNameConDecl }
 				{ mkConDecl $2 [] [] (RecCon [([$4], unbangedType $6)]) $1 }
 
 constrs :: { [RdrNameConDecl] }
-	: constrs '|' constr		{ $3 : $1 }
+        : {- empty; a GHC extension -}  { [] }
+        | '=' constrs1                  { $2 }
+
+constrs1 :: { [RdrNameConDecl] }
+	: constrs1 '|' constr		{ $3 : $1 }
 	| constr			{ [$1] }
 
 constr :: { RdrNameConDecl }
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index b8a139b..015d0b3 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -414,8 +414,7 @@ isForeignTyCon other				      = False
 
 \begin{code}
 tyConDataCons :: TyCon -> [DataCon]
-tyConDataCons tycon = ASSERT2( not (null cons), ppr tycon ) 
-		      ASSERT2( length cons == tyConFamilySize tycon, ppr tycon )
+tyConDataCons tycon = ASSERT2( length cons == tyConFamilySize tycon, ppr tycon )
 		      cons
 		    where
 		      cons = tyConDataConsIfAvailable tycon