import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
ConDecl(..), Sig(..), , NewOrData(..), ResType(..),
- tyClDeclTyVars, isSynDecl,
+ tyClDeclTyVars, isSynDecl, hsConArgs,
LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
)
import HsTypes ( HsBang(..), getBangStrictness )
import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType,
kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext,
kcHsSigType, tcHsBangType, tcLHsConResTy, tcDataKindSig )
-import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness,
+import TcMType ( newKindVar, checkValidTheta, checkValidType,
+ -- checkFreeness,
UserTypeCtxt(..), SourceTyCtxt(..) )
import TcType ( TcKind, TcType, tyVarsOfType, mkPhiTy,
mkArrowKind, liftedTypeKind, mkTyVarTys,
tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe )
-import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
+import Type ( splitTyConApp_maybe,
+ -- pprParendType, pprThetaArrow
+ )
import Kind ( mkArrowKinds, splitKindFunTys )
import Generics ( validGenericMethodType, canDoGenerics )
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ),
tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
- tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName )
-import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig,
+ tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName )
+import DataCon ( DataCon, dataConWrapId, dataConName,
dataConFieldLabels, dataConTyCon,
dataConTyVars, dataConFieldType, dataConResTys )
import Var ( TyVar, idType, idName )
import VarSet ( elemVarSet, mkVarSet )
-import Name ( Name )
+import Name ( Name, getSrcLoc )
import Outputable
-import Maybe ( isJust, fromJust )
+import Maybe ( isJust )
+import Maybes ( expectJust )
import Unify ( tcMatchTys, tcMatchTyX )
import Util ( zipLazy, isSingleton, notNull, sortLe )
import List ( partition )
-import SrcLoc ( Located(..), unLoc, getLoc )
+import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan )
import ListSetOps ( equivClasses )
import List ( delete )
import Digraph ( SCC(..) )
; checkTc (not (null cons) || gla_exts || is_boot)
(emptyConDeclsErr tc_name)
+ -- Check that a newtype has exactly one constructor
+ ; 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))
tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes
(ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
- = ASSERT( null ex_tvs && null (unLoc ex_ctxt) )
- do { let tc_datacon field_lbls arg_ty
+ = do { let tc_datacon field_lbls arg_ty
= do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype
; buildDataCon (unLoc name) False {- Prefix -}
True {- Vanilla -} [NotMarkedStrict]
(map unLoc field_lbls)
tc_tvs [] [arg_ty']
tycon (mkTyVarTys tc_tvs) }
+
+ -- Check that a newtype has no existential stuff
+ ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name)
+
; 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)
mappM_ check_fields groups
where
- syn_ctxt = TySynCtxt name
- name = tyConName tc
- (_, syn_rhs) = getSynTyConDefn tc
- data_cons = tyConDataCons tc
+ syn_ctxt = TySynCtxt name
+ name = tyConName tc
+ syn_rhs = synTyConRhs tc
+ data_cons = tyConDataCons tc
groups = equivClasses cmp_fld (concatMap get_fields data_cons)
cmp_fld (f1,_) (f2,_) = f1 `compare` f2
; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
where
mb_subst1 = tcMatchTys tvs1 res1 res2
- mb_subst2 = tcMatchTyX tvs1 (fromJust mb_subst1) fty1 fty2
+ mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
-------------------------------
checkValidDataCon :: TyCon -> DataCon -> TcM ()
checkValidDataCon tc con
- = addErrCtxt (dataConCtxt con) $
+ = setSrcSpan (srcLocSpan (getSrcLoc con)) $
+ addErrCtxt (dataConCtxt con) $
do { checkTc (dataConTyCon con == tc) (badDataConTyCon con)
; checkValidType ctxt (idType (dataConWrapId con)) }
= sep [ptext SLIT("Constructors") <+> ppr con1 <+> ptext SLIT("and") <+> ppr con2,
ptext SLIT("give different types for field"), quotes (ppr field_name)]
-dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
- nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
- where
- (ex_tvs, ex_theta, arg_tys, _, _) = dataConSig con
- ex_part | null ex_tvs = empty
- | otherwise = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot
- -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote
- -- data T a = Eq a => T a a
- -- So we make sure to print it
-
- fields = dataConFieldLabels con
- arg_part | null fields = sep (map pprParendType arg_tys)
- | otherwise = braces (sep (punctuate comma
- [ ppr n <+> dcolon <+> ppr ty
- | (n,ty) <- fields `zip` arg_tys]))
+dataConCtxt con = ptext SLIT("In the definition of data constructor") <+> quotes (ppr con)
classOpCtxt sel_id tau = sep [ptext SLIT("When checking the class method:"),
nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
= 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 ]
+
+newtypeExError con
+ = sep [ptext SLIT("A newtype constructor cannot have an existential context,"),
+ nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")]
+
+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}
projects / ghc-hetmet.git / blobdiff