tcAddDeclCtxt decl $
do { -- type family instances require -XTypeFamilies
-- and can't (currently) be in an hs-boot file
- ; type_families <- doptM Opt_TypeFamilies
+ ; type_families <- xoptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl (tcdLName decl)
; checkTc (not is_boot) $ badBootFamInstDeclErr
; mapM_ checkTyFamFreeness t_typats
-- Check that we don't use GADT syntax in H98 world
- ; gadt_ok <- doptM Opt_GADTs
+ ; gadt_ok <- xoptM Opt_GADTs
; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
-- (b) a newtype has exactly one constructor
{ traceTc "type family:" (ppr tc_name)
-- Check that we don't use families without -XTypeFamilies
- ; idx_tys <- doptM Opt_TypeFamilies
+ ; idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
-- Check that we don't use families without -XTypeFamilies
- ; idx_tys <- doptM Opt_TypeFamilies
+ ; idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta <- tcHsKindedContext ctxt
- ; want_generic <- doptM Opt_Generics
+ ; want_generic <- xoptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
- ; empty_data_decls <- doptM Opt_EmptyDataDecls
- ; kind_signatures <- doptM Opt_KindSignatures
- ; existential_ok <- doptM Opt_ExistentialQuantification
- ; gadt_ok <- doptM Opt_GADTs
+ ; empty_data_decls <- xoptM Opt_EmptyDataDecls
+ ; kind_signatures <- xoptM Opt_KindSignatures
+ ; existential_ok <- xoptM Opt_ExistentialQuantification
+ ; gadt_ok <- xoptM Opt_GADTs
+ ; gadtSyntax_ok <- xoptM Opt_GADTSyntax
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
-- Check that we don't use GADT syntax in H98 world
- ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name)
+ ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
-> TcM DataCon
tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
- (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt
+ con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
, con_details = details, con_res = res_ty })
= addErrCtxt (dataConCtxt name) $
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
- ; checkTc (existential_ok || (null tvs && null (unLoc ctxt)))
+ ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
(badExistential name)
; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
; let
consUseH98Syntax _ = True
-- All constructors have same shape
+conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
+conRepresentibleWithH98Syntax
+ (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
+ = null tvs && null (unLoc ctxt)
+conRepresentibleWithH98Syntax
+ (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
+ = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
+ where -- Each type variable should be used exactly once in the
+ -- result type, and the result type must just be the type
+ -- constructor applied to type variables
+ f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs
+ = (v2 `elem` vs) && f t1 (delete v2 vs)
+ f (HsTyVar _) [] = True
+ f _ _ = False
+
-------------------
tcConArg :: Bool -- True <=> -funbox-strict_fields
-> LHsType Name
-------------------------------
checkValidClass :: Class -> TcM ()
checkValidClass cls
- = do { constrained_class_methods <- doptM Opt_ConstrainedClassMethods
- ; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses
- ; fundep_classes <- doptM Opt_FunctionalDependencies
+ = do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods
+ ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses
+ ; fundep_classes <- xoptM Opt_FunctionalDependencies
-- Check that the class is unary, unless GlaExs
; checkTc (notNull tyvars) (nullaryClassErr cls)
badExistential :: Located Name -> SDoc
badExistential con_name
= hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+>
- ptext (sLit "has existential type variables, or a context"))
+ ptext (sLit "has existential type variables, a context, or a specialised result type"))
2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this"))
badStupidTheta :: Name -> SDoc