[project @ 2005-11-16 17:45:38 by simonpj]

Better error reporting for newtypes with too many constructors,
or too many fields.  Instead of yielding a parse error, we
parse it like a data type declaration, and give a comprehensible
error message later.

A suggestion from Jan-Willem.

3 files changed, 27 insertions, 18 deletions

diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index b345b47d0a..01c8043e8e 100644
--- a/ghc/compiler/Makefile
+++ b/ghc/compiler/Makefile
@@ -733,6 +733,7 @@ endif
 # typecheck/TcUnify_HC_OPTS += -auto-all
 
 coreSyn/CorePrep_HC_OPTS += -auto-all
+# parser/Parser_HC_OPTS += -fasm
 
 #-----------------------------------------------------------------------------
 # Building the GHC package
diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp
index 7e2a26189d..844cc8670e 100644
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -34,9 +34,8 @@ import Module
 import StaticFlags	( opt_SccProfilingOn )
 import Type		( Kind, mkArrowKind, liftedTypeKind )
 import BasicTypes	( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-			  Activation(..), InlineSpec(..), defaultInlineSpec )
+			  Activation(..), defaultInlineSpec )
 import OrdList
-import Panic
 
 import FastString
 import Maybes		( orElse )
@@ -455,20 +454,16 @@ tycl_decl :: { LTyClDecl RdrName }
  		{% do { (tc,tvs) <- checkSynHdr $2
 		      ; return (LL (TySynonym tc tvs $4)) } }
 
-	| 'data' tycl_hdr constrs deriving
+	| data_or_newtype tycl_hdr constrs deriving
 		{ L (comb4 $1 $2 $3 $4)	-- We need the location on tycl_hdr 
 					-- in case constrs and deriving are both empty
-		    (mkTyData DataType (unLoc $2) Nothing (reverse (unLoc $3)) (unLoc $4)) }
+		    (mkTyData (unLoc $1) (unLoc $2) Nothing (reverse (unLoc $3)) (unLoc $4)) }
 
-        | 'data' tycl_hdr opt_kind_sig 
+        | data_or_newtype tycl_hdr opt_kind_sig 
 		 'where' gadt_constrlist
 		 deriving
 		{ L (comb4 $1 $2 $4 $5)
-		    (mkTyData DataType (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
-
-	| 'newtype' tycl_hdr '=' newconstr deriving
-		{ L (comb3 $1 $4 $5)
-		    (mkTyData NewType (unLoc $2) Nothing [$4] (unLoc $5)) }
+		    (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
 
 	| 'class' tycl_hdr fds where
 		{ let 
@@ -477,6 +472,10 @@ tycl_decl :: { LTyClDecl RdrName }
 	 	  L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs 
 					  binds) }
 
+data_or_newtype :: { Located NewOrData }
+	: 'data'	{ L1 DataType }
+	| 'newtype'	{ L1 NewType }
+
 opt_kind_sig :: { Maybe Kind }
 	: 				{ Nothing }
 	| '::' kind			{ Just $2 }
@@ -852,11 +851,6 @@ akind	:: { Kind }
 -----------------------------------------------------------------------------
 -- Datatype declarations
 
-newconstr :: { LConDecl RdrName }
-	: conid atype	{ LL $ ConDecl $1 Explicit [] (noLoc []) (PrefixCon [$2]) ResTyH98 }
-	| conid '{' var '::' ctype '}'
-			{ LL $ ConDecl $1 Explicit [] (noLoc []) (RecCon [($3, $5)]) ResTyH98 }
-
 gadt_constrlist :: { Located [LConDecl RdrName] }
 	: '{'            gadt_constrs '}'	{ LL (unLoc $2) }
 	|     vocurly    gadt_constrs close	{ $2 }
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 5df15c10e8..a300469ce8 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -12,7 +12,7 @@ module TcTyClsDecls (
 
 import HsSyn		( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
 			  ConDecl(..),   Sig(..), , NewOrData(..), ResType(..),
-			  tyClDeclTyVars, isSynDecl, 
+			  tyClDeclTyVars, isSynDecl, hsConArgs,
 			  LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
 			)
 import HsTypes          ( HsBang(..), getBangStrictness )
@@ -400,6 +400,9 @@ tcTyClDecl1 calc_vrcs calc_isrec
   ; checkTc (not (null cons) || gla_exts || is_boot)
 	    (emptyConDeclsErr tc_name)
     
+  ; checkTc (new_or_data == DataType || isSingleton cons) 
+	    (newtypeConError tc_name (length cons))
+
   ; tycon <- fixM (\ tycon -> do 
 	{ data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data 
 						 tycon final_tvs)) 
@@ -470,7 +473,10 @@ tcConDecl unbox_strict NewType tycon tc_tvs	-- Newtypes
 				    tycon (mkTyVarTys tc_tvs) }
 	; case details of
 	    PrefixCon [arg_ty] -> tc_datacon [] arg_ty
-	    RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty }
+	    RecCon [(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)
@@ -808,9 +814,17 @@ 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")) ]
 
+newtypeConError tycon n
+  = sep [ptext SLIT("A newtype must have exactly one constructor"),
+	 nest 2 $ ptext SLIT("but") <+> quotes (ppr tycon) <+> ptext SLIT("has") <+> speakN n ]
+
+newTypeFieldErr con_name n_flds
+  = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), 
+	 nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds]
+
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
-	 nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
+	 nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]
 
 badBootClassDeclErr = ptext SLIT("Illegal class declaration in hs-boot file")
 \end{code}