X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=1658e0bee65e9d11704200bd4d191fa5643da0b5;hb=2a9d13eca98b0cd5bf16bfc8dd16f74b2d2803e4;hp=6a6304f2201483655e513f287644e446746a843e;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 6a6304f..1658e0b 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -30,7 +30,8 @@ import Class import TyCon import DataCon import Id -import MkId ( rEC_SEL_ERROR_ID, mkDefaultMethodId ) +import MkId ( mkDefaultMethodId ) +import MkCore ( rEC_SEL_ERROR_ID ) import IdInfo import Var import VarSet @@ -255,7 +256,7 @@ tcFamInstDecl top_lvl (L loc decl) 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 @@ -349,7 +350,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; 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 @@ -710,7 +711,7 @@ tcTyClDecl1 parent _calc_isrec { 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 @@ -728,7 +729,7 @@ tcTyClDecl1 parent _calc_isrec -- 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 [] @@ -746,17 +747,18 @@ tcTyClDecl1 parent calc_isrec { 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) @@ -845,12 +847,12 @@ tcConDecl :: Bool -- True <=> -funbox-strict_fields -> 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 @@ -945,6 +947,21 @@ consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False 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 @@ -1179,9 +1196,9 @@ checkNewDataCon con ------------------------------- 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) @@ -1535,7 +1552,7 @@ badGadtDecl tc_name 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