[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.

diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index b345b47..01c8043 100644 (file)
--- 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 7e2a261..844cc86 100644 (file)
--- 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 5df15c1..a300469 100644 (file)
--- 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}