module TcValidity (
Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
ContextKind(..), expectedKindInCtxt,
checkValidTheta, checkValidFamPats,
checkValidInstance, validDerivPred,
checkInstTermination,
ClsInfo, checkValidCoAxiom, checkValidCoAxBranch,
checkValidTyFamEqn,
checkConsistentFamInst,
arityErr, badATErr,
checkValidTelescope, checkZonkValidTelescope, checkValidInferredKinds
) where
#include "HsVersions.h"
import TcUnify ( tcSubType_NC )
import TcSimplify ( simplifyAmbiguityCheck )
import TyCoRep
import TcType hiding ( sizeType, sizeTypes )
import TcMType
import PrelNames
import Type
import Coercion
import Unify( tcMatchTyX )
import Kind
import CoAxiom
import Class
import TyCon
import HsSyn
import TcRnMonad
import FunDeps
import FamInstEnv ( isDominatedBy, injectiveBranches,
InjectivityCheckResult(..) )
import FamInst ( makeInjectivityErrors )
import Name
import VarEnv
import VarSet
import ErrUtils
import DynFlags
import Util
import ListSetOps
import SrcLoc
import Outputable
import FastString
import BasicTypes
import Module
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Maybe
import Data.List ( (\\) )
checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
checkAmbiguity ctxt ty
| wantAmbiguityCheck ctxt
= do { traceTc "Ambiguity check for" (ppr ty)
; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $
captureConstraints $
tcSubType_NC ctxt ty ty
; simplifyAmbiguityCheck ty wanted
; traceTc "Done ambiguity check for" (ppr ty) }
| otherwise
= return ()
where
mk_msg allow_ambiguous
= vcat [ ptext (sLit "In the ambiguity check for") <+> what
, ppUnless allow_ambiguous ambig_msg ]
ambig_msg = ptext (sLit "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes")
what | Just n <- isSigMaybe ctxt = quotes (ppr n)
| otherwise = pprUserTypeCtxt ctxt
wantAmbiguityCheck :: UserTypeCtxt -> Bool
wantAmbiguityCheck ctxt
= case ctxt of
GhciCtxt -> False
_ -> True
checkUserTypeError :: Type -> TcM ()
checkUserTypeError = check
where
check ty
| Just msg <- userTypeError_maybe ty = fail_with msg
| Just (_,ts) <- splitTyConApp_maybe ty = mapM_ check ts
| Just (t1,t2) <- splitAppTy_maybe ty = check t1 >> check t2
| Just (_,t1) <- splitForAllTy_maybe ty = check t1
| otherwise = return ()
fail_with msg = do { env0 <- tcInitTidyEnv
; let (env1, tidy_msg) = tidyOpenType env0 msg
; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) }
checkValidType :: UserTypeCtxt -> Type -> TcM ()
checkValidType ctxt ty
= do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))
; rankn_flag <- xoptM LangExt.RankNTypes
; let gen_rank :: Rank -> Rank
gen_rank r | rankn_flag = ArbitraryRank
| otherwise = r
rank1 = gen_rank r1
rank0 = gen_rank r0
r0 = rankZeroMonoType
r1 = LimitedRank True r0
rank
= case ctxt of
DefaultDeclCtxt-> MustBeMonoType
ResSigCtxt -> MustBeMonoType
PatSigCtxt -> rank0
RuleSigCtxt _ -> rank1
TySynCtxt _ -> rank0
ExprSigCtxt -> rank1
TypeAppCtxt -> rank0
FunSigCtxt {} -> rank1
InfSigCtxt _ -> ArbitraryRank
ConArgCtxt _ -> rank1
ForSigCtxt _ -> rank1
SpecInstCtxt -> rank1
ThBrackCtxt -> rank1
GhciCtxt -> ArbitraryRank
_ -> panic "checkValidType"
; env <- tcInitOpenTidyEnv (tyCoVarsOfType ty)
; check_type env ctxt rank ty
; check_kind env ctxt ty
; checkUserTypeError ty
; checkAmbiguity ctxt ty
; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) }
checkValidMonoType :: Type -> TcM ()
checkValidMonoType ty
= do { env <- tcInitOpenTidyEnv (tyCoVarsOfType ty)
; check_type env SigmaCtxt MustBeMonoType ty }
check_kind :: TidyEnv -> UserTypeCtxt -> TcType -> TcM ()
check_kind env ctxt ty
| TySynCtxt {} <- ctxt
, returnsConstraintKind actual_kind
= do { ck <- xoptM LangExt.ConstraintKinds
; if ck
then when (isConstraintKind actual_kind)
(do { dflags <- getDynFlags
; check_pred_ty env dflags ctxt ty })
else addErrTcM (constraintSynErr env actual_kind) }
| otherwise
= case expectedKindInCtxt ctxt of
TheKind k -> checkTcM (tcEqType actual_kind k) (kindErr env actual_kind)
OpenKind -> checkTcM (classifiesTypeWithValues actual_kind) (kindErr env actual_kind)
AnythingKind -> return ()
where
actual_kind = typeKind ty
data ContextKind = TheKind Kind
| AnythingKind
| OpenKind
expectedKindInCtxt :: UserTypeCtxt -> ContextKind
expectedKindInCtxt (TySynCtxt _) = AnythingKind
expectedKindInCtxt ThBrackCtxt = AnythingKind
expectedKindInCtxt GhciCtxt = AnythingKind
expectedKindInCtxt DefaultDeclCtxt = AnythingKind
expectedKindInCtxt TypeAppCtxt = AnythingKind
expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind
expectedKindInCtxt InstDeclCtxt = TheKind constraintKind
expectedKindInCtxt SpecInstCtxt = TheKind constraintKind
expectedKindInCtxt _ = OpenKind
data Rank = ArbitraryRank
| LimitedRank
Bool
Rank
| MonoType SDoc
| MustBeMonoType
rankZeroMonoType, tyConArgMonoType, synArgMonoType :: Rank
rankZeroMonoType = MonoType (ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types"))
tyConArgMonoType = MonoType (ptext (sLit "GHC doesn't yet support impredicative polymorphism"))
synArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use LiberalTypeSynonyms"))
funArgResRank :: Rank -> (Rank, Rank)
funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)
funArgResRank other_rank = (other_rank, other_rank)
forAllAllowed :: Rank -> Bool
forAllAllowed ArbitraryRank = True
forAllAllowed (LimitedRank forall_ok _) = forall_ok
forAllAllowed _ = False
check_lifted :: TidyEnv -> Type -> TcM ()
check_lifted env ty
= checkTcM (not (isUnLiftedType ty)) (unliftedArgErr env ty)
check_type :: TidyEnv -> UserTypeCtxt -> Rank -> Type -> TcM ()
check_type env ctxt rank ty
| not (null tvs && null theta)
= do { checkTcM (forAllAllowed rank) (forAllTyErr env' rank ty)
; check_valid_theta env' SigmaCtxt theta
; check_type env' ctxt rank tau
; checkTcM (not (any (`elemVarSet` tyCoVarsOfType tau_kind) tvs))
(forAllEscapeErr env' ty tau_kind)
}
where
(tvs, theta, tau) = tcSplitSigmaTy ty
tau_kind = typeKind tau
(env', _) = tidyTyCoVarBndrs env tvs
check_type _ _ _ (TyVarTy _) = return ()
check_type env ctxt rank (ForAllTy (Anon arg_ty) res_ty)
= do { check_type env ctxt arg_rank arg_ty
; check_type env ctxt res_rank res_ty }
where
(arg_rank, res_rank) = funArgResRank rank
check_type env ctxt rank (AppTy ty1 ty2)
= do { check_arg_type env ctxt rank ty1
; check_arg_type env ctxt rank ty2 }
check_type env ctxt rank ty@(TyConApp tc tys)
| isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
= check_syn_tc_app env ctxt rank ty tc tys
| isUnboxedTupleTyCon tc = check_ubx_tuple env ctxt ty tys
| otherwise = mapM_ (check_arg_type env ctxt rank) tys
check_type _ _ _ (LitTy {}) = return ()
check_type env ctxt rank (CastTy ty _) = check_type env ctxt rank ty
check_type _ _ _ ty = pprPanic "check_type" (ppr ty)
check_syn_tc_app :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType
-> TyCon -> [KindOrType] -> TcM ()
check_syn_tc_app env ctxt rank ty tc tys
| tc_arity <= length tys
= do {
; liberal <- xoptM LangExt.LiberalTypeSynonyms
; if not liberal || isTypeFamilyTyCon tc then
mapM_ check_arg tys
else
case coreView ty of
Just ty' -> check_type env ctxt rank ty'
Nothing -> pprPanic "check_tau_type" (ppr ty) }
| GhciCtxt <- ctxt
= mapM_ check_arg tys
| otherwise
= failWithTc (tyConArityErr tc tys)
where
tc_arity = tyConArity tc
check_arg | isTypeFamilyTyCon tc = check_arg_type env ctxt rank
| otherwise = check_type env ctxt synArgMonoType
check_ubx_tuple :: TidyEnv -> UserTypeCtxt -> KindOrType
-> [KindOrType] -> TcM ()
check_ubx_tuple env ctxt ty tys
= do { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples
; checkTcM ub_tuples_allowed (ubxArgTyErr env ty)
; impred <- xoptM LangExt.ImpredicativeTypes
; let rank' = if impred then ArbitraryRank else tyConArgMonoType
; mapM_ (check_type env ctxt rank') tys }
check_arg_type :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType -> TcM ()
check_arg_type _ _ _ (CoercionTy {}) = return ()
check_arg_type env ctxt rank ty
= do { impred <- xoptM LangExt.ImpredicativeTypes
; let rank' = case rank of
MustBeMonoType -> MustBeMonoType
_other | impred -> ArbitraryRank
| otherwise -> tyConArgMonoType
; check_type env ctxt rank' ty
; check_lifted env ty }
forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)
forAllTyErr env rank ty
= ( env
, vcat [ hang (ptext (sLit "Illegal polymorphic or qualified type:")) 2 (ppr_tidy env ty)
, suggestion ] )
where
suggestion = case rank of
LimitedRank {} -> ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types")
MonoType d -> d
_ -> Outputable.empty
forAllEscapeErr :: TidyEnv -> Type -> Kind -> (TidyEnv, SDoc)
forAllEscapeErr env ty tau_kind
= ( env
, hang (vcat [ text "Quantified type's kind mentions quantified type variable"
, text "(skolem escape)" ])
2 (vcat [ text " type:" <+> ppr_tidy env ty
, text "of kind:" <+> ppr_tidy env tau_kind ]) )
unliftedArgErr, ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
unliftedArgErr env ty = (env, sep [ptext (sLit "Illegal unlifted type:"), ppr_tidy env ty])
ubxArgTyErr env ty = (env, sep [ptext (sLit "Illegal unboxed tuple type as function argument:"), ppr_tidy env ty])
kindErr :: TidyEnv -> Kind -> (TidyEnv, SDoc)
kindErr env kind = (env, sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr_tidy env kind])
checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
checkValidTheta ctxt theta
= do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypes theta)
; addErrCtxtM (checkThetaCtxt ctxt theta) $
check_valid_theta env ctxt theta }
check_valid_theta :: TidyEnv -> UserTypeCtxt -> [PredType] -> TcM ()
check_valid_theta _ _ []
= return ()
check_valid_theta env ctxt theta
= do { dflags <- getDynFlags
; warnTcM (wopt Opt_WarnDuplicateConstraints dflags &&
notNull dups) (dupPredWarn env dups)
; traceTc "check_valid_theta" (ppr theta)
; mapM_ (check_pred_ty env dflags ctxt) theta }
where
(_,dups) = removeDups cmpType theta
check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
check_pred_ty env dflags ctxt pred
= do { check_type env SigmaCtxt MustBeMonoType pred
; check_pred_help False env dflags ctxt pred }
check_pred_help :: Bool
-> TidyEnv
-> DynFlags -> UserTypeCtxt
-> PredType -> TcM ()
check_pred_help under_syn env dflags ctxt pred
| Just pred' <- coreView pred
= check_pred_help True env dflags ctxt pred'
| otherwise
= case splitTyConApp_maybe pred of
Just (tc, tys)
| isTupleTyCon tc
-> check_tuple_pred under_syn env dflags ctxt pred tys
| tc `hasKey` heqTyConKey ||
tc `hasKey` eqTyConKey ||
tc `hasKey` eqPrimTyConKey
-> check_eq_pred env dflags pred tc tys
| Just cls <- tyConClass_maybe tc
-> check_class_pred env dflags ctxt pred cls tys
_ -> check_irred_pred under_syn env dflags ctxt pred
check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TyCon -> [TcType] -> TcM ()
check_eq_pred env dflags pred tc tys
=
do { checkTc (length tys == tyConArity tc) (tyConArityErr tc tys)
; checkTcM (xopt LangExt.TypeFamilies dflags
|| xopt LangExt.GADTs dflags)
(eqPredTyErr env pred) }
check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
check_tuple_pred under_syn env dflags ctxt pred ts
= do {
checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)
(predTupleErr env pred)
; mapM_ (check_pred_help under_syn env dflags ctxt) ts }
check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
check_irred_pred under_syn env dflags ctxt pred
= do {
failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)
&& hasTyVarHead pred)
(predIrredErr env pred)
; failIfTcM (is_superclass ctxt
&& not (xopt LangExt.UndecidableInstances dflags)
&& has_tyfun_head pred)
(predSuperClassErr env pred) }
where
is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False }
has_tyfun_head ty
= case tcSplitTyConApp_maybe ty of
Just (tc, _) -> isTypeFamilyTyCon tc
Nothing -> False
check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM ()
check_class_pred env dflags ctxt pred cls tys
| isIPClass cls
= do { check_arity
; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }
| otherwise
= do { check_arity
; checkTcM arg_tys_ok (env, predTyVarErr (tidyType env pred)) }
where
check_arity = checkTc (classArity cls == length tys)
(tyConArityErr (classTyCon cls) tys)
flexible_contexts = xopt LangExt.FlexibleContexts dflags
undecidable_ok = xopt LangExt.UndecidableInstances dflags
arg_tys_ok = case ctxt of
SpecInstCtxt -> True
InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys
_ -> checkValidClsArgs flexible_contexts cls tys
okIPCtxt :: UserTypeCtxt -> Bool
okIPCtxt (FunSigCtxt {}) = True
okIPCtxt (InfSigCtxt {}) = True
okIPCtxt ExprSigCtxt = True
okIPCtxt TypeAppCtxt = True
okIPCtxt PatSigCtxt = True
okIPCtxt ResSigCtxt = True
okIPCtxt GenSigCtxt = True
okIPCtxt (ConArgCtxt {}) = True
okIPCtxt (ForSigCtxt {}) = True
okIPCtxt ThBrackCtxt = True
okIPCtxt GhciCtxt = True
okIPCtxt SigmaCtxt = True
okIPCtxt (DataTyCtxt {}) = True
okIPCtxt (PatSynCtxt {}) = True
okIPCtxt (ClassSCCtxt {}) = False
okIPCtxt (InstDeclCtxt {}) = False
okIPCtxt (SpecInstCtxt {}) = False
okIPCtxt (TySynCtxt {}) = False
okIPCtxt (RuleSigCtxt {}) = False
okIPCtxt DefaultDeclCtxt = False
badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)
badIPPred env pred
= ( env
, ptext (sLit "Illegal implicit parameter") <+> quotes (ppr_tidy env pred) )
checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc)
checkThetaCtxt ctxt theta env
= return ( env
, vcat [ ptext (sLit "In the context:") <+> pprTheta (tidyTypes env theta)
, ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ] )
eqPredTyErr, predTupleErr, predIrredErr, predSuperClassErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
eqPredTyErr env pred
= ( env
, ptext (sLit "Illegal equational constraint") <+> ppr_tidy env pred $$
parens (ptext (sLit "Use GADTs or TypeFamilies to permit this")) )
predTupleErr env pred
= ( env
, hang (ptext (sLit "Illegal tuple constraint:") <+> ppr_tidy env pred)
2 (parens constraintKindsMsg) )
predIrredErr env pred
= ( env
, hang (ptext (sLit "Illegal constraint:") <+> ppr_tidy env pred)
2 (parens constraintKindsMsg) )
predSuperClassErr env pred
= ( env
, hang (ptext (sLit "Illegal constraint") <+> quotes (ppr_tidy env pred)
<+> ptext (sLit "in a superclass context"))
2 (parens undecidableMsg) )
predTyVarErr :: PredType -> SDoc
predTyVarErr pred
= vcat [ hang (ptext (sLit "Non type-variable argument"))
2 (ptext (sLit "in the constraint:") <+> ppr pred)
, parens (ptext (sLit "Use FlexibleContexts to permit this")) ]
constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
constraintSynErr env kind
= ( env
, hang (ptext (sLit "Illegal constraint synonym of kind:") <+> quotes (ppr_tidy env kind))
2 (parens constraintKindsMsg) )
dupPredWarn :: TidyEnv -> [[PredType]] -> (TidyEnv, SDoc)
dupPredWarn env dups
= ( env
, text "Duplicate constraint" <> plural primaryDups <> text ":"
<+> pprWithCommas (ppr_tidy env) primaryDups )
where
primaryDups = map head dups
tyConArityErr :: TyCon -> [TcType] -> SDoc
tyConArityErr tc tks
= arityErr (tyConFlavour tc) (tyConName tc)
tc_type_arity tc_type_args
where
vis_tks = filterOutInvisibleTypes tc tks
tc_type_arity = count isVisibleBinder $ fst $ splitPiTys (tyConKind tc)
tc_type_args = length vis_tks
arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc
arityErr what name n m
= hsep [ ptext (sLit "The") <+> text what, quotes (ppr name), ptext (sLit "should have"),
n_arguments <> comma, text "but has been given",
if m==0 then text "none" else int m]
where
n_arguments | n == 0 = ptext (sLit "no arguments")
| n == 1 = ptext (sLit "1 argument")
| True = hsep [int n, ptext (sLit "arguments")]
checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
checkValidInstHead ctxt clas cls_args
= do { dflags <- getDynFlags
; mod <- getModule
; checkTc (getUnique clas `notElem` abstractClassKeys ||
nameModule (getName clas) == mod)
(instTypeErr clas cls_args abstract_class_msg)
; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
; unless spec_inst_prag $
do { checkTc (xopt LangExt.TypeSynonymInstances dflags ||
all tcInstHeadTyNotSynonym ty_args)
(instTypeErr clas cls_args head_type_synonym_msg)
; checkTc (xopt LangExt.FlexibleInstances dflags ||
all tcInstHeadTyAppAllTyVars ty_args)
(instTypeErr clas cls_args head_type_args_tyvars_msg)
; checkTc (xopt LangExt.MultiParamTypeClasses dflags ||
length ty_args == 1 ||
(xopt LangExt.NullaryTypeClasses dflags &&
null ty_args))
(instTypeErr clas cls_args head_one_type_msg) }
; mapM_ checkTyFamFreeness ty_args
; mapM_ checkValidMonoType ty_args
; env <- tcInitOpenTidyEnv (tyCoVarsOfTypes ty_args)
; mapM_ (check_lifted env) ty_args
}
where
spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }
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 TypeSynonymInstances if you want to disable this.")
head_type_args_tyvars_msg = parens (vcat [
text "All instance types must be of the form (T a1 ... an)",
text "where a1 ... an are *distinct type variables*,",
text "and each type variable appears at most once in the instance head.",
text "Use FlexibleInstances if you want to disable this."])
head_one_type_msg = parens (
text "Only one type can be given in an instance head." $$
text "Use MultiParamTypeClasses if you want to allow more, or zero.")
abstract_class_msg =
text "Manual instances of this class are not permitted."
abstractClassKeys :: [Unique]
abstractClassKeys = [ heqTyConKey
, eqTyConKey
, coercibleTyConKey
]
instTypeErr :: Class -> [Type] -> SDoc -> SDoc
instTypeErr cls tys msg
= hang (hang (ptext (sLit "Illegal instance declaration for"))
2 (quotes (pprClassPred cls tys)))
2 msg
validDerivPred :: TyVarSet -> PredType -> Bool
validDerivPred tv_set pred
= case classifyPredType pred of
ClassPred cls _ -> cls `hasKey` typeableClassKey
|| check_tys
EqPred {} -> False
_ -> True
where
check_tys = hasNoDups fvs
&& sizePred pred == fromIntegral (length fvs)
&& all (`elemVarSet` tv_set) fvs
fvs = fvType pred
checkValidInstance :: UserTypeCtxt -> LHsSigType Name -> Type
-> TcM ([TyVar], ThetaType, Class, [Type])
checkValidInstance ctxt hs_type ty
| Just (clas,inst_tys) <- getClassPredTys_maybe tau
, inst_tys `lengthIs` classArity clas
= do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys)
; checkValidTheta ctxt theta
; undecidable_ok <- xoptM LangExt.UndecidableInstances
; traceTc "cvi" (ppr undecidable_ok $$ ppr ty)
; if undecidable_ok
then checkAmbiguity ctxt ty
else checkInstTermination inst_tys theta
; case (checkInstCoverage undecidable_ok clas theta inst_tys) of
IsValid -> return ()
NotValid msg -> addErrTc (instTypeErr clas inst_tys msg)
; return (tvs, theta, clas, inst_tys) }
| otherwise
= failWithTc (ptext (sLit "Malformed instance head:") <+> ppr tau)
where
(tvs, theta, tau) = tcSplitSigmaTy ty
head_loc = case splitLHsInstDeclTy hs_type of
(_, _, L loc _) -> loc
checkInstTermination :: [TcType] -> ThetaType -> TcM ()
checkInstTermination tys theta
= check_preds theta
where
head_fvs = fvTypes tys
head_size = sizeTypes tys
check_preds :: [PredType] -> TcM ()
check_preds preds = mapM_ check preds
check :: PredType -> TcM ()
check pred
= case classifyPredType pred of
EqPred {} -> return ()
IrredPred {} -> check2 pred (sizeType pred)
ClassPred cls tys
| isTerminatingClass cls
-> return ()
| isCTupleClass cls
-> check_preds tys
| otherwise
-> check2 pred (sizeTypes $ filterOutInvisibleTypes (classTyCon cls) tys)
check2 pred pred_size
| not (null bad_tvs) = addErrTc (noMoreMsg bad_tvs what)
| pred_size >= head_size = addErrTc (smallerMsg what)
| otherwise = return ()
where
what = ptext (sLit "constraint") <+> quotes (ppr pred)
bad_tvs = fvType pred \\ head_fvs
smallerMsg :: SDoc -> SDoc
smallerMsg what
= vcat [ hang (ptext (sLit "The") <+> what)
2 (ptext (sLit "is no smaller than the instance head"))
, parens undecidableMsg ]
noMoreMsg :: [TcTyVar] -> SDoc -> SDoc
noMoreMsg tvs what
= vcat [ hang (ptext (sLit "Variable") <> plural tvs <+> quotes (pprWithCommas ppr tvs)
<+> occurs <+> ptext (sLit "more often"))
2 (sep [ ptext (sLit "in the") <+> what
, ptext (sLit "than in the instance head") ])
, parens undecidableMsg ]
where
occurs = if isSingleton tvs then ptext (sLit "occurs")
else ptext (sLit "occur")
undecidableMsg, constraintKindsMsg :: SDoc
undecidableMsg = ptext (sLit "Use UndecidableInstances to permit this")
constraintKindsMsg = ptext (sLit "Use ConstraintKinds to permit this")
type ClsInfo = (Class, VarEnv Type)
checkConsistentFamInst
:: Maybe ClsInfo
-> TyCon
-> [TyVar]
-> [Type]
-> TcM ()
checkConsistentFamInst Nothing _ _ _ = return ()
checkConsistentFamInst (Just (clas, mini_env)) fam_tc at_tvs at_tys
= do {
checkTc (Just clas == tyConAssoc_maybe fam_tc)
(badATErr (className clas) (tyConName fam_tc))
; discardResult $ foldrM check_arg emptyTCvSubst $
tyConTyVars fam_tc `zip` at_tys }
where
at_tv_set = mkVarSet at_tvs
check_arg :: (TyVar, Type) -> TCvSubst -> TcM TCvSubst
check_arg (fam_tc_tv, at_ty) subst
| Just inst_ty <- lookupVarEnv mini_env fam_tc_tv
= case tcMatchTyX at_tv_set subst at_ty inst_ty of
Just subst | all_distinct subst -> return subst
_ -> failWithTc $ wrongATArgErr at_ty inst_ty
| otherwise
= return subst
all_distinct :: TCvSubst -> Bool
all_distinct subst = go [] at_tvs
where
go _ [] = True
go acc (tv:tvs) = case lookupTyVar subst tv of
Nothing -> go acc tvs
Just ty | Just tv' <- tcGetTyVar_maybe ty
, tv' `notElem` acc
-> go (tv' : acc) tvs
_other -> False
badATErr :: Name -> Name -> SDoc
badATErr clas op
= hsep [ptext (sLit "Class"), quotes (ppr clas),
ptext (sLit "does not have an associated type"), quotes (ppr op)]
wrongATArgErr :: Type -> Type -> SDoc
wrongATArgErr ty instTy =
sep [ ptext (sLit "Type indexes must match class instance head")
, ptext (sLit "Found") <+> quotes (ppr ty)
<+> ptext (sLit "but expected") <+> quotes (ppr instTy)
]
checkValidCoAxiom :: CoAxiom Branched -> TcM ()
checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
= do { mapM_ (checkValidCoAxBranch Nothing fam_tc) branch_list
; foldlM_ check_branch_compat [] branch_list }
where
branch_list = fromBranches branches
injectivity = familyTyConInjectivityInfo fam_tc
check_branch_compat :: [CoAxBranch]
-> CoAxBranch
-> TcM [CoAxBranch]
check_branch_compat prev_branches cur_branch
| cur_branch `isDominatedBy` prev_branches
= do { addWarnAt (coAxBranchSpan cur_branch) $
inaccessibleCoAxBranch ax cur_branch
; return prev_branches }
| otherwise
= do { check_injectivity prev_branches cur_branch
; return (cur_branch : prev_branches) }
check_injectivity prev_branches cur_branch
| Injective inj <- injectivity
= do { let conflicts =
fst $ foldl (gather_conflicts inj prev_branches cur_branch)
([], 0) prev_branches
; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)
(makeInjectivityErrors ax cur_branch inj conflicts) }
| otherwise
= return ()
gather_conflicts inj prev_branches cur_branch (acc, n) branch
= case injectiveBranches inj cur_branch branch of
InjectivityUnified ax1 ax2
| ax1 `isDominatedBy` (replace_br prev_branches n ax2)
-> (acc, n + 1)
| otherwise
-> (branch : acc, n + 1)
InjectivityAccepted -> (acc, n + 1)
replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]
replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs
checkValidCoAxBranch :: Maybe ClsInfo
-> TyCon -> CoAxBranch -> TcM ()
checkValidCoAxBranch mb_clsinfo fam_tc
(CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
, cab_lhs = typats
, cab_rhs = rhs, cab_loc = loc })
= checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc
checkValidTyFamEqn :: Maybe ClsInfo
-> TyCon
-> [TyVar]
-> [CoVar]
-> [Type]
-> Type
-> SrcSpan
-> TcM ()
checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc
= setSrcSpan loc $
do { checkValidFamPats fam_tc tvs cvs typats
; env <- tcInitOpenTidyEnv (tyCoVarsOfTypes (rhs : typats))
; mapM_ checkValidMonoType typats
; mapM_ (check_lifted env) typats
; checkValidMonoType rhs
; check_lifted env rhs
; undecidable_ok <- xoptM LangExt.UndecidableInstances
; unless undecidable_ok $
mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs))
; checkConsistentFamInst mb_clsinfo fam_tc tvs typats }
checkFamInstRhs :: [Type]
-> [(TyCon, [Type])]
-> [MsgDoc]
checkFamInstRhs lhsTys famInsts
= mapMaybe check famInsts
where
size = sizeTypes lhsTys
fvs = fvTypes lhsTys
check (tc, tys)
| not (all isTyFamFree tys) = Just (nestedMsg what)
| not (null bad_tvs) = Just (noMoreMsg bad_tvs what)
| size <= sizeTypes tys = Just (smallerMsg what)
| otherwise = Nothing
where
what = ptext (sLit "type family application") <+> quotes (pprType (TyConApp tc tys))
bad_tvs = fvTypes tys \\ fvs
checkValidFamPats :: TyCon -> [TyVar] -> [CoVar] -> [Type] -> TcM ()
checkValidFamPats fam_tc tvs cvs ty_pats
= do {
checkTc (length ty_pats == fam_arity) $
wrongNumberOfParmsErr (fam_arity count isInvisibleBinder fam_bndrs)
; mapM_ checkTyFamFreeness ty_pats
; let unbound_tcvs = filterOut (`elemVarSet` exactTyCoVarsOfTypes ty_pats) (tvs ++ cvs)
; checkTc (null unbound_tcvs) (famPatErr fam_tc unbound_tcvs ty_pats) }
where fam_arity = tyConArity fam_tc
fam_bndrs = take fam_arity $ fst $ splitPiTys (tyConKind fam_tc)
wrongNumberOfParmsErr :: Arity -> SDoc
wrongNumberOfParmsErr exp_arity
= ptext (sLit "Number of parameters must match family declaration; expected")
<+> ppr exp_arity
checkTyFamFreeness :: Type -> TcM ()
checkTyFamFreeness ty
= checkTc (isTyFamFree ty) $
tyFamInstIllegalErr ty
isTyFamFree :: Type -> Bool
isTyFamFree = null . tcTyFamInsts
inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc
inaccessibleCoAxBranch fi_ax cur_branch
= ptext (sLit "Type family instance equation is overlapped:") $$
nest 2 (pprCoAxBranch fi_ax cur_branch)
tyFamInstIllegalErr :: Type -> SDoc
tyFamInstIllegalErr ty
= hang (ptext (sLit "Illegal type synonym family application in instance") <>
colon) 2 $
ppr ty
nestedMsg :: SDoc -> SDoc
nestedMsg what
= sep [ ptext (sLit "Illegal nested") <+> what
, parens undecidableMsg ]
famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc
famPatErr fam_tc tvs pats
= hang (ptext (sLit "Family instance purports to bind type variable") <> plural tvs
<+> pprQuotedList tvs)
2 (hang (ptext (sLit "but the real LHS (expanding synonyms) is:"))
2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+> ptext (sLit "= ...")))
checkValidTelescope :: SDoc
-> [TyVar]
-> SDoc
-> TcM ()
checkValidTelescope hs_tvs orig_tvs extra
= discardResult $ checkZonkValidTelescope hs_tvs orig_tvs extra
checkZonkValidTelescope :: SDoc
-> [TyVar]
-> SDoc
-> TcM [TyVar]
checkZonkValidTelescope hs_tvs orig_tvs extra
= do { orig_tvs <- mapM zonkTyCoVarKind orig_tvs
; let (_, sorted_tidied_tvs) = tidyTyCoVarBndrs emptyTidyEnv $
toposortTyVars orig_tvs
; unless (go [] emptyVarSet orig_tvs) $
addErr $
vcat [ hang (text "These kind and type variables:" <+> hs_tvs $$
text "are out of dependency order. Perhaps try this ordering:")
2 (sep (map pprTvBndr sorted_tidied_tvs))
, extra ]
; return orig_tvs }
where
go :: [TyVar]
-> TyVarSet -> [TyVar] -> Bool
go errs in_scope [] = null (filter (`elemVarSet` in_scope) errs)
go errs in_scope (tv:tvs)
= let bad_tvs = tyCoVarsOfType (tyVarKind tv) `minusVarSet` in_scope in
go (varSetElems bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs
checkValidInferredKinds :: [TyVar]
-> TyVarSet
-> SDoc
-> TcM ()
checkValidInferredKinds orig_kvs out_of_scope extra
= do { let bad_pairs = [ (tv, kv)
| kv <- orig_kvs
, Just tv <- map (lookupVarSet out_of_scope)
(tyCoVarsOfTypeList (tyVarKind kv)) ]
report (tidyTyVarOcc env -> tv, tidyTyVarOcc env -> kv)
= addErr $
text "The kind of variable" <+>
quotes (ppr kv) <> text ", namely" <+>
quotes (ppr (tyVarKind kv)) <> comma $$
text "depends on variable" <+>
quotes (ppr tv) <+> text "from an inner scope" $$
text "Perhaps bind" <+> quotes (ppr kv) <+>
text "sometime after binding" <+>
quotes (ppr tv) $$
extra
; mapM_ report bad_pairs }
where
(env1, _) = tidyTyCoVarBndrs emptyTidyEnv orig_kvs
(env, _) = tidyTyCoVarBndrs env1 (varSetElems out_of_scope)
fvType :: Type -> [TyCoVar]
fvType ty | Just exp_ty <- coreView ty = fvType exp_ty
fvType (TyVarTy tv) = [tv]
fvType (TyConApp _ tys) = fvTypes tys
fvType (LitTy {}) = []
fvType (AppTy fun arg) = fvType fun ++ fvType arg
fvType (ForAllTy bndr ty)
= fvType (binderType bndr) ++
caseBinder bndr (\tv -> filter (/= tv)) (const id) (fvType ty)
fvType (CastTy ty co) = fvType ty ++ fvCo co
fvType (CoercionTy co) = fvCo co
fvTypes :: [Type] -> [TyVar]
fvTypes tys = concat (map fvType tys)
fvCo :: Coercion -> [TyCoVar]
fvCo (Refl _ ty) = fvType ty
fvCo (TyConAppCo _ _ args) = concatMap fvCo args
fvCo (AppCo co arg) = fvCo co ++ fvCo arg
fvCo (ForAllCo tv h co) = filter (/= tv) (fvCo co) ++ fvCo h
fvCo (CoVarCo v) = [v]
fvCo (AxiomInstCo _ _ args) = concatMap fvCo args
fvCo (UnivCo p _ t1 t2) = fvProv p ++ fvType t1 ++ fvType t2
fvCo (SymCo co) = fvCo co
fvCo (TransCo co1 co2) = fvCo co1 ++ fvCo co2
fvCo (NthCo _ co) = fvCo co
fvCo (LRCo _ co) = fvCo co
fvCo (InstCo co arg) = fvCo co ++ fvCo arg
fvCo (CoherenceCo co1 co2) = fvCo co1 ++ fvCo co2
fvCo (KindCo co) = fvCo co
fvCo (SubCo co) = fvCo co
fvCo (AxiomRuleCo _ cs) = concatMap fvCo cs
fvProv :: UnivCoProvenance -> [TyCoVar]
fvProv UnsafeCoerceProv = []
fvProv (PhantomProv co) = fvCo co
fvProv (ProofIrrelProv co) = fvCo co
fvProv (PluginProv _) = []
fvProv (HoleProv h) = pprPanic "fvProv falls into a hole" (ppr h)
sizeType :: Type -> Int
sizeType ty | Just exp_ty <- coreView ty = sizeType exp_ty
sizeType (TyVarTy {}) = 1
sizeType (TyConApp _ tys) = sizeTypes tys + 1
sizeType (LitTy {}) = 1
sizeType (AppTy fun arg) = sizeType fun + sizeType arg
sizeType (ForAllTy (Anon arg) res)
= sizeType arg + sizeType res + 1
sizeType (ForAllTy (Named {}) ty)
= sizeType ty
sizeType (CastTy ty _) = sizeType ty
sizeType (CoercionTy _) = 1
sizeTypes :: [Type] -> Int
sizeTypes = sum . map sizeType
sizePred :: PredType -> Int
sizePred ty = goClass ty
where
goClass p = go (classifyPredType p)
go (ClassPred cls tys')
| isTerminatingClass cls = 0
| otherwise = sizeTypes tys'
go (EqPred {}) = 0
go (IrredPred ty) = sizeType ty
isTerminatingClass :: Class -> Bool
isTerminatingClass cls
= isIPClass cls
|| cls `hasKey` typeableClassKey
|| cls `hasKey` coercibleTyConKey
|| cls `hasKey` eqTyConKey
|| cls `hasKey` heqTyConKey
ppr_tidy :: TidyEnv -> Type -> SDoc
ppr_tidy env ty = pprType (tidyType env ty)