From 491c85e7478f46d92166b938b4833504a28ff9d4 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 16 Nov 2005 17:45:39 +0000 Subject: [PATCH] [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. --- ghc/compiler/Makefile | 1 + ghc/compiler/parser/Parser.y.pp | 24 +++++++++--------------- ghc/compiler/typecheck/TcTyClsDecls.lhs | 20 +++++++++++++++++--- 3 files changed, 27 insertions(+), 18 deletions(-) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index b345b47..01c8043 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 7e2a261..844cc86 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 5df15c1..a300469 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} -- 1.7.10.4