-- 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 | gla_exts = Arbitrary
+ rank | rankn = Arbitrary
+ | rank2 = Rank 2
| otherwise
= case ctxt of -- Haskell 98
GenPatCtxt -> Rank 0
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
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_`
&& 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
}
| 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
= 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
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
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
-------------------------
\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)))
check_inst_head dflags clas tys
-- If GlasgowExts then check at least one isn't a type variable
- | dopt Opt_GlasgowExts dflags
- = mapM_ check_one tys
-
- -- WITH HASKELL 98, MUST HAVE C (T a b c)
- | otherwise
- = checkTc (isSingleton tys && tcValidInstHeadTy first_ty)
- (instTypeErr (pprClassPred clas tys) head_shape_msg)
-
+ = do checkTc (dopt Opt_TypeSynonymInstances dflags ||
+ all tcInstHeadTyNotSynonym tys)
+ (instTypeErr (pprClassPred clas tys) head_type_synonym_msg)
+ checkTc (dopt Opt_FlexibleInstances dflags ||
+ all tcInstHeadTyAppAllTyVars tys)
+ (instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg)
+ checkTc (dopt Opt_MultiParamTypeClasses dflags ||
+ isSingleton tys)
+ (instTypeErr (pprClassPred clas tys) head_one_type_msg)
+ mapM_ check_one tys
where
- (first_ty : _) = tys
+ head_type_synonym_msg = parens (
+ text "All instance types must be of the form (T t1 ... tn)" $$
+ text "where T is not a synonym." $$
+ text "Use -XTypeSynonymInstances if you want to disable this.")
+
+ head_type_args_tyvars_msg = parens (
+ text "All instance types must be of the form (T a1 ... an)" $$
+ text "where a1 ... an are distinct type *variables*" $$
+ text "Use -XFlexibleInstances if you want to disable this.")
- head_shape_msg = parens (text "The instance type must be of form (T a1 ... an)" $$
- text "where T is not a synonym, and a1 ... an are distinct type *variables*")
+ head_one_type_msg = parens (
+ text "Only one type can be given in an instance head." $$
+ text "Use -XMultiParamTypeClasses if you want to allow more.")
-- For now, I only allow tau-types (not polytypes) in
-- the head of an instance decl.
\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