X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=955d45c551c6a07d209d74bbd69161fc2a0e2400;hp=18e58fcc8ffa844d50c33e779c8b8203d6794081;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=597cbf7059161adfd8cbc935091d76aa4515f962 diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 18e58fc..955d45c 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -694,9 +694,10 @@ checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context checkValidType ctxt ty = traceTc (text "checkValidType" <+> ppr ty) `thenM_` - doptM Opt_GlasgowExts `thenM` \ gla_exts -> + doptM Opt_UnboxedTuples `thenM` \ unboxed -> doptM Opt_Rank2Types `thenM` \ rank2 -> doptM Opt_RankNTypes `thenM` \ rankn -> + doptM Opt_PolymorphicComponents `thenM` \ polycomp -> let rank | rankn = Arbitrary | rank2 = Rank 2 @@ -710,8 +711,11 @@ checkValidType ctxt ty TySynCtxt _ -> Rank 0 ExprSigCtxt -> Rank 1 FunSigCtxt _ -> Rank 1 - ConArgCtxt _ -> Rank 1 -- We are given the type of the entire - -- constructor, hence rank 1 + ConArgCtxt _ -> if polycomp + then Rank 2 + -- We are given the type of the entire + -- constructor, hence rank 1 + else Rank 1 ForSigCtxt _ -> Rank 1 SpecInstCtxt -> Rank 1 @@ -725,14 +729,10 @@ checkValidType ctxt ty ForSigCtxt _ -> isLiftedTypeKind actual_kind other -> isSubArgTypeKind actual_kind - ubx_tup | not gla_exts = UT_NotOk - | otherwise = case ctxt of - TySynCtxt _ -> UT_Ok - ExprSigCtxt -> UT_Ok - other -> UT_NotOk - -- Unboxed tuples ok in function results, - -- but for type synonyms we allow them even at - -- top level + ubx_tup = case ctxt of + TySynCtxt _ | unboxed -> UT_Ok + ExprSigCtxt | unboxed -> UT_Ok + _ -> UT_NotOk in -- Check that the thing has kind Type, and is lifted if necessary checkTc kind_ok (kindErr actual_kind) `thenM_` @@ -834,10 +834,9 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys) && tyConArity tc <= length tys) $ failWithTc arity_msg - ; gla_exts <- doptM Opt_GlasgowExts - ; if gla_exts && not (isOpenTyCon tc) then - -- If -fglasgow-exts then don't check the type arguments of - -- *closed* synonyms. + ; ok <- doptM Opt_PartiallyAppliedClosedTypeSynonyms + ; if ok && not (isOpenTyCon tc) then + -- Don't check the type arguments of *closed* synonyms. -- This allows us to instantiate a synonym defn with a -- for-all type, or with a partially-applied type synonym. -- e.g. type T a b = a @@ -854,8 +853,8 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys) } | isUnboxedTupleTyCon tc - = doptM Opt_GlasgowExts `thenM` \ gla_exts -> - checkTc (ubx_tup_ok gla_exts) ubx_tup_msg `thenM_` + = doptM Opt_UnboxedTuples `thenM` \ ub_tuples_allowed -> + checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg `thenM_` mappM_ (check_tau_type (Rank 0) UT_Ok) tys -- Args are allowed to be unlifted, or -- more unboxed tuples, so can't use check_arg_ty @@ -864,7 +863,7 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys) = mappM_ check_arg_type tys where - ubx_tup_ok gla_exts = case ubx_tup of { UT_Ok -> gla_exts; other -> False } + ubx_tup_ok ub_tuples_allowed = case ubx_tup of { UT_Ok -> ub_tuples_allowed; other -> False } n_args = length tys tc_arity = tyConArity tc @@ -943,7 +942,7 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys) arity = classArity cls n_tys = length tys arity_err = arityErr "Class" class_name arity n_tys - how_to_allow = parens (ptext SLIT("Use -fglasgow-exts to permit this")) + how_to_allow = parens (ptext SLIT("Use -XFlexibleContexts to permit this")) check_pred_ty dflags ctxt pred@(EqPred ty1 ty2) = do { -- Equational constraints are valid in all contexts if type @@ -975,12 +974,12 @@ check_pred_ty dflags ctxt sty = failWithTc (badPredTyErr sty) check_class_pred_tys dflags ctxt tys = case ctxt of TypeCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine - InstThetaCtxt -> gla_exts || undecidable_ok || all tcIsTyVarTy tys + InstThetaCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys -- Further checks on head and theta in -- checkInstTermination - other -> gla_exts || all tyvar_head tys + other -> flexible_contexts || all tyvar_head tys where - gla_exts = dopt Opt_GlasgowExts dflags + flexible_contexts = dopt Opt_FlexibleContexts dflags undecidable_ok = dopt Opt_AllowUndecidableInstances dflags ------------------------- @@ -1054,9 +1053,8 @@ even in a scope where b is in scope. \begin{code} checkFreeness forall_tyvars theta - = do { gla_exts <- doptM Opt_GlasgowExts - ; if gla_exts then return () -- New! Oct06 - else mappM_ complain (filter is_free theta) } + = do { flexible_contexts <- doptM Opt_FlexibleContexts + ; unless flexible_contexts $ mappM_ complain (filter is_free theta) } where is_free pred = not (isIPPred pred) && not (any bound_var (varSetElems (tyVarsOfPred pred))) @@ -1177,15 +1175,15 @@ instTypeErr pp_ty msg \begin{code} checkValidInstance :: [TyVar] -> ThetaType -> Class -> [TcType] -> TcM () checkValidInstance tyvars theta clas inst_tys - = do { gla_exts <- doptM Opt_GlasgowExts - ; undecidable_ok <- doptM Opt_AllowUndecidableInstances + = do { undecidable_ok <- doptM Opt_AllowUndecidableInstances ; checkValidTheta InstThetaCtxt theta ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys) -- Check that instance inference will terminate (if we care) - -- For Haskell 98, checkValidTheta has already done that - ; when (gla_exts && not undecidable_ok) $ + -- For Haskell 98 this will already have been done by checkValidTheta, + -- but as we may be using other extensions we need to check. + ; unless undecidable_ok $ mapM_ addErrTc (checkInstTermination inst_tys theta) -- The Coverage Condition