Commit 491c85e7 authored by simonpj's avatar simonpj

[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.
parent cdea9949
......@@ -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
......
......@@ -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 }
......
......@@ -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}
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment