{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}

module GHC.Tc.Validity (
  Rank(..), UserTypeCtxt(..), checkValidType, checkValidMonoType,
  checkValidTheta,
  checkValidInstance, checkValidInstHead, validDerivPred,
  checkTySynRhs, checkEscapingKind,
  checkValidCoAxiom, checkValidCoAxBranch,
  checkFamPatBinders, checkTyFamEqnValidityInfo,
  checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst,
  checkTyConTelescope,
  ) where

import GHC.Prelude
import GHC.Data.FastString

import GHC.Data.Maybe

-- friends:
import GHC.Tc.Utils.Unify    ( tcSubTypeAmbiguity )
import GHC.Tc.Solver         ( simplifyAmbiguityCheck )
import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo(..) )
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Rank
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Instance.FunDeps
import GHC.Tc.Instance.Family
import GHC.Tc.Zonk.TcType

import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Builtin.Uniques  ( mkAlphaTyVarUnique )

import GHC.Core.Type
import GHC.Core.Unify ( typesAreApart, tcMatchTyX_BM, BindFlag(..) )
import GHC.Core.Coercion
import GHC.Core.Coercion.Axiom
import GHC.Core.Class
import GHC.Core.TyCon
import GHC.Core.Predicate
import GHC.Core.TyCo.FVs
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
import GHC.Core.FamInstEnv ( isDominatedBy, injectiveBranches
                           , InjectivityCheckResult(..) )

import GHC.Hs
import GHC.Driver.Session
import qualified GHC.LanguageExtensions as LangExt

import GHC.Types.Error
import GHC.Types.Basic   ( TypeOrKind(..), UnboxedTupleOrSum(..)
                         , unboxedTupleOrSumExtension )
import GHC.Types.Name
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Var     ( VarBndr(..), isInvisibleFunArg, mkTyVar, tyVarName )
import GHC.Types.SourceFile
import GHC.Types.SrcLoc
import GHC.Types.TyThing ( TyThing(..) )
import GHC.Types.Unique.Set( isEmptyUniqSet )

import GHC.Utils.FV
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic

import GHC.Data.List.SetOps

import Language.Haskell.Syntax.Basic (FieldLabelString(..))

import Control.Monad
import Data.Foldable
import Data.Function
import Data.List        ( (\\) )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )

{-
************************************************************************
*                                                                      *
          Checking for ambiguity
*                                                                      *
************************************************************************

Note [The ambiguity check for type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
checkAmbiguity is a check on *user-supplied type signatures*.  It is
*purely* there to report functions that cannot possibly be called.  So for
example we want to reject:
   f :: C a => Int
The idea is there can be no legal calls to 'f' because every call will
give rise to an ambiguous constraint.  We could soundly omit the
ambiguity check on type signatures entirely, at the expense of
delaying ambiguity errors to call sites.  Indeed, the flag
-XAllowAmbiguousTypes switches off the ambiguity check.

What about things like this:
   class D a b | a -> b where ..
   h :: D Int b => Int
The Int may well fix 'b' at the call site, so that signature should
not be rejected.  Moreover, using *visible* fundeps is too
conservative.  Consider
   class X a b where ...
   class D a b | a -> b where ...
   instance D a b => X [a] b where...
   h :: X a b => a -> a
Here h's type looks ambiguous in 'b', but here's a legal call:
   ...(h [True])...
That gives rise to a (X [Bool] beta) constraint, and using the
instance means we need (D Bool beta) and that fixes 'beta' via D's
fundep!

Behind all these special cases there is a simple guiding principle.
Consider

  f :: <type>
  f = ...blah...

  g :: <type>
  g = f

You would think that the definition of g would surely typecheck!
After all f has exactly the same type, and g=f. But in fact f's type
is instantiated and the instantiated constraints are solved against
the originals, so in the case of an ambiguous type it won't work.
Consider our earlier example f :: C a => Int.  Then in g's definition,
we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a),
and fail.

So in fact we use this as our *definition* of ambiguity.  We use a
very similar test for *inferred* types, to ensure that they are
unambiguous. See Note [Impedance matching] in GHC.Tc.Gen.Bind.

This test is very conveniently implemented by calling
    tcSubType <type> <type>
This neatly takes account of the functional dependency stuff above,
and implicit parameter (see Note [Implicit parameters and ambiguity]).
And this is what checkAmbiguity does.

Note [The squishiness of the ambiguity check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What about this?
   g :: C [a] => Int
Is every call to 'g' ambiguous?  After all, we might have
   instance C [a] where ...
at the call site.  So maybe that type is ok!  Indeed even f's
quintessentially ambiguous type might, just possibly be callable:
with -XFlexibleInstances we could have
  instance C a where ...
and now a call could be legal after all!  Well, we'll reject this
unless the instance is available *here*.

But even that's not quite right. Even a function with an utterly-ambiguous
type like f :: Eq a => Int -> Int
is still callable if you are prepared to use visible type application,
thus (f @Bool x).

In short, the ambiguity check is a good-faith attempt to say "you are likely
to have trouble if your function has this type"; it is NOT the case that
"you can't call this function without giving a type error".

See also Note [Ambiguity check and deep subsumption] in GHC.Tc.Utils.Unify.

Note [When to call checkAmbiguity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We call checkAmbiguity
   (a) on user-specified type signatures
   (b) in checkValidType

Conncerning (b), you might wonder about nested foralls.  What about
    f :: forall b. (forall a. Eq a => b) -> b
The nested forall is ambiguous.  Originally we called checkAmbiguity
in the forall case of check_type, but that had two bad consequences:
  * We got two error messages about (Eq b) in a nested forall like this:
       g :: forall a. Eq a => forall b. Eq b => a -> a
  * If we try to check for ambiguity of a nested forall like
    (forall a. Eq a => b), the implication constraint doesn't bind
    all the skolems, which results in "No skolem info" in error
    messages (see #10432).

To avoid this, we call checkAmbiguity once, at the top, in checkValidType.
(I'm still a bit worried about unbound skolems when the type mentions
in-scope type variables.)

In fact, because of the co/contra-variance implemented in tcSubType,
this *does* catch function f above. too.

Concerning (a) the ambiguity check is only used for *user* types, not
for types coming from interface files.  The latter can legitimately
have ambiguous types. Example

   class S a where s :: a -> (Int,Int)
   instance S Char where s _ = (1,1)
   f:: S a => [a] -> Int -> (Int,Int)
   f (_::[a]) x = (a*x,b)
        where (a,b) = s (undefined::a)

Here the worker for f gets the type
        fw :: forall a. S a => Int -> (# Int, Int #)


Note [Implicit parameters and ambiguity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Only a *class* predicate can give rise to ambiguity
An *implicit parameter* cannot.  For example:
        foo :: (?x :: [a]) => Int
        foo = length ?x
is fine.  The call site will supply a particular 'x'

Furthermore, the type variables fixed by an implicit parameter
propagate to the others.  E.g.
        foo :: (Show a, ?x::[a]) => Int
        foo = show (?x++?x)
The type of foo looks ambiguous.  But it isn't, because at a call site
we might have
        let ?x = 5::Int in foo
and all is well.  In effect, implicit parameters are, well, parameters,
so we can take their type variables into account as part of the
"tau-tvs" stuff.  This is done in the function 'GHC.Tc.Instance.FunDeps.grow'.
-}

checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
checkAmbiguity UserTypeCtxt
ctxt Type
ty
  | UserTypeCtxt -> Bool
wantAmbiguityCheck UserTypeCtxt
ctxt
  = do { String -> SDoc -> TcM ()
traceTc String
"Ambiguity check for {" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
         -- Solve the constraints eagerly because an ambiguous type
         -- can cause a cascade of further errors.  Since the free
         -- tyvars are skolemised, we can safely use tcSimplifyTop
       ; allow_ambiguous <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.AllowAmbiguousTypes
       ; unless allow_ambiguous $
         do { (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $
                                 captureConstraints $
                                 tcSubTypeAmbiguity ctxt ty ty
                                 -- See Note [Ambiguity check and deep subsumption]
                                 -- in GHC.Tc.Utils.Unify
            ; simplifyAmbiguityCheck ty wanted }

       ; traceTc "} Done ambiguity check for" (ppr ty) }

  | Bool
otherwise
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where
   mk_msg :: Bool -> SDoc
mk_msg Bool
allow_ambiguous
     = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the ambiguity check for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
what
            , Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppUnless Bool
allow_ambiguous SDoc
ambig_msg ]
   ambig_msg :: SDoc
ambig_msg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"
   what :: SDoc
what | Just Name
n <- UserTypeCtxt -> Maybe Name
isSigMaybe UserTypeCtxt
ctxt = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
        | Bool
otherwise                 = UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt

wantAmbiguityCheck :: UserTypeCtxt -> Bool
wantAmbiguityCheck :: UserTypeCtxt -> Bool
wantAmbiguityCheck UserTypeCtxt
ctxt
  = case UserTypeCtxt
ctxt of  -- See Note [When we don't check for ambiguity]
      GhciCtxt {}  -> Bool
False
      TySynCtxt {} -> Bool
False
      UserTypeCtxt
TypeAppCtxt  -> Bool
False
      StandaloneKindSigCtxt{} -> Bool
False
      UserTypeCtxt
_            -> Bool
True

-- | Check whether the type signature contains custom type errors,
-- and fail if so.
--
-- Note that some custom type errors are acceptable:
--
--   - in the RHS of a type synonym, e.g. to allow users to define
--     type synonyms for custom type errors with large messages (#20181),
--   - inside a type family application, as a custom type error
--     might evaporate after performing type family reduction (#20241).
checkUserTypeError :: UserTypeCtxt -> Type -> TcM ()
-- Very unsatisfactorily (#11144) we need to tidy the type
-- because it may have come from an /inferred/ signature, not a
-- user-supplied one.  This is really only a half-baked fix;
-- the other errors in checkValidType don't do tidying, and so
-- may give bad error messages when given an inferred type.
checkUserTypeError :: UserTypeCtxt -> Type -> TcM ()
checkUserTypeError UserTypeCtxt
ctxt Type
ty
  | TySynCtxt {} <- UserTypeCtxt
ctxt  -- Do not complain about TypeError on the
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()             -- RHS of type synonyms. See #20181

  | Just Type
msg <- Type -> Maybe Type
deepUserTypeError_maybe Type
ty
  = do { env0 <- ZonkM TidyEnv -> TcM TidyEnv
forall a. ZonkM a -> TcM a
liftZonkM ZonkM TidyEnv
tcInitTidyEnv
       ; let (env1, tidy_msg) = tidyOpenType env0 msg
       ; failWithTcM (env1, TcRnUserTypeError tidy_msg) }
  | Bool
otherwise
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


{- Note [When we don't check for ambiguity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a few places we do not want to check a user-specified type for ambiguity

* GhciCtxt: Allow ambiguous types in GHCi's :kind command
  E.g.   type family T a :: *  -- T :: forall k. k -> *
  Then :k T should work in GHCi, not complain that
  (T k) is ambiguous!

* TySynCtxt: type T a b = C a b => blah
  It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow
  cure the ambiguity.  So we defer the ambiguity check to the use site.

  There is also an implementation reason (#11608).  In the RHS of
  a type synonym we don't (currently) instantiate 'a' and 'b' with
  TcTyVars before calling checkValidType, so we get assertion failures
  from doing an ambiguity check on a type with TyVars in it.  Fixing this
  would not be hard, but let's wait till there's a reason.

* TypeAppCtxt: visible type application
     f @ty
  No need to check ty for ambiguity

* StandaloneKindSigCtxt: type T :: ksig
  Kinds need a different ambiguity check than types, and the currently
  implemented check is only good for types. See #14419, in particular
  https://gitlab.haskell.org/ghc/ghc/issues/14419#note_160844

************************************************************************
*                                                                      *
          Checking validity of a user-defined type
*                                                                      *
************************************************************************

When dealing with a user-written type, we first translate it from an HsType
to a Type, performing kind checking, and then check various things that should
be true about it.  We don't want to perform these checks at the same time
as the initial translation because (a) they are unnecessary for interface-file
types and (b) when checking a mutually recursive group of type and class decls,
we can't "look" at the tycons/classes yet.  Also, the checks are rather
diverse, and used to really mess up the other code.

One thing we check for is 'rank'.

        Rank 0:         monotypes (no foralls)
        Rank 1:         foralls at the front only, Rank 0 inside
        Rank 2:         foralls at the front, Rank 1 on left of fn arrow,

        basic ::= tyvar | T basic ... basic

        r2  ::= forall tvs. cxt => r2a
        r2a ::= r1 -> r2a | basic
        r1  ::= forall tvs. cxt => r0
        r0  ::= r0 -> r0 | basic

Another thing is to check that type synonyms are saturated.
This might not necessarily show up in kind checking.
        type A i = i
        data T k = MkT (k Int)
        f :: T A        -- BAD!
-}

checkValidType :: UserTypeCtxt -> Type -> TcM ()
-- Checks that a user-written type is valid for the given context
-- Assumes argument is fully zonked
-- Assumes argument is well-kinded;
--    that is, checkValidType doesn't need to do kind checking
-- Not used for instance decls; checkValidInstance instead
checkValidType :: UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
ctxt Type
ty
  = do { String -> SDoc -> TcM ()
traceTc String
"checkValidType" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"::" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty))
       ; rankn_flag  <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RankNTypes
       ; impred_flag <- xoptM LangExt.ImpredicativeTypes
       ; let gen_rank :: Rank -> Rank
             gen_rank Rank
r | Bool
rankn_flag = Rank
ArbitraryRank
                        | Bool
otherwise  = Rank
r

             rank1 = Rank -> Rank
gen_rank Rank
r1
             rank0 = Rank -> Rank
gen_rank Rank
MonoTypeRankZero

             r1 = Bool -> Rank -> Rank
LimitedRank Bool
True Rank
MonoTypeRankZero

             rank
               = case UserTypeCtxt
ctxt of
                 UserTypeCtxt
DefaultDeclCtxt-> Rank
MustBeMonoType
                 UserTypeCtxt
PatSigCtxt     -> Rank
rank0
                 RuleSigCtxt {} -> Rank
rank1
                 TySynCtxt Name
_    -> Rank
rank0

                 ExprSigCtxt {} -> Rank
rank1
                 UserTypeCtxt
KindSigCtxt    -> Rank
rank1
                 StandaloneKindSigCtxt{} -> Rank
rank1
                 UserTypeCtxt
TypeAppCtxt | Bool
impred_flag -> Rank
ArbitraryRank
                             | Bool
otherwise   -> Rank
MonoTypeTyConArg
                    -- Normally, ImpredicativeTypes is handled in check_arg_type,
                    -- but visible type applications don't go through there.
                    -- So we do this check here.

                 FunSigCtxt {}  -> Rank
rank1
                 InfSigCtxt {}  -> Rank
rank1 -- Inferred types should obey the
                                         -- same rules as declared ones

                 ConArgCtxt Name
_   -> Rank
rank1 -- We are given the type of the entire
                                         -- constructor, hence rank 1
                 PatSynCtxt Name
_   -> Rank
rank1

                 ForSigCtxt Name
_   -> Rank
rank1
                 UserTypeCtxt
SpecInstCtxt   -> Rank
rank1
                 GhciCtxt {}    -> Rank
ArbitraryRank

                 TyVarBndrKindCtxt Name
_ -> Rank
rank0
                 DataKindCtxt Name
_      -> Rank
rank1
                 TySynKindCtxt Name
_     -> Rank
rank1
                 TyFamResKindCtxt Name
_  -> Rank
rank1

                 UserTypeCtxt
_              -> String -> Rank
forall a. HasCallStack => String -> a
panic String
"checkValidType"
                                          -- Can't happen; not used for *user* sigs

       ; env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)
       ; expand <- initialExpandMode
       ; let ve = ValidityEnv{ ve_tidy_env :: TidyEnv
ve_tidy_env = TidyEnv
env, ve_ctxt :: UserTypeCtxt
ve_ctxt = UserTypeCtxt
ctxt
                             , ve_rank :: Rank
ve_rank = Rank
rank, ve_expand :: ExpandMode
ve_expand = ExpandMode
expand }

       -- Check the internal validity of the type itself
       -- Fail if bad things happen, else we misleading
       -- (and more complicated) errors in checkAmbiguity
       ; checkNoErrs $
         do { check_type ve ty
            ; checkUserTypeError ctxt ty
            ; traceTc "done ct" (ppr ty) }

       -- Check for ambiguous types.  See Note [When to call checkAmbiguity]
       -- NB: this will happen even for monotypes, but that should be cheap;
       --     and there may be nested foralls for the subtype test to examine
       ; checkAmbiguity ctxt ty

       ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) }

checkValidMonoType :: Type -> TcM ()
-- Assumes argument is fully zonked
checkValidMonoType :: Type -> TcM ()
checkValidMonoType Type
ty
  = do { env <- ZonkM TidyEnv -> TcM TidyEnv
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM TidyEnv -> TcM TidyEnv) -> ZonkM TidyEnv -> TcM TidyEnv
forall a b. (a -> b) -> a -> b
$ [Var] -> ZonkM TidyEnv
tcInitOpenTidyEnv (Type -> [Var]
tyCoVarsOfTypeList Type
ty)
       ; expand <- initialExpandMode
       ; let ve = ValidityEnv{ ve_tidy_env :: TidyEnv
ve_tidy_env = TidyEnv
env, ve_ctxt :: UserTypeCtxt
ve_ctxt = UserTypeCtxt
SigmaCtxt
                             , ve_rank :: Rank
ve_rank = Rank
MustBeMonoType, ve_expand :: ExpandMode
ve_expand = ExpandMode
expand }
       ; check_type ve ty }

checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()
checkTySynRhs :: UserTypeCtxt -> Type -> TcM ()
checkTySynRhs UserTypeCtxt
ctxt Type
ty
  | Type -> Bool
returnsConstraintKind Type
actual_kind
  = do { ck <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ConstraintKinds
       ; if ck
         then  when (isConstraintLikeKind actual_kind)
                    (do { dflags <- getDynFlags
                        ; expand <- initialExpandMode
                        ; check_pred_ty emptyTidyEnv dflags ctxt expand ty })
         else addErrTcM ( emptyTidyEnv
                        , TcRnIllegalConstraintSynonymOfKind (tidyType emptyTidyEnv actual_kind)
                        ) }

  | Bool
otherwise
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    actual_kind :: Type
actual_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty

{- Note [Check for escaping result kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider:
  type T :: TYPE (BoxedRep l)
  data T = MkT
This is not OK: we get
  MkT :: forall l. T @l :: TYPE (BoxedRep l)
which is ill-kinded.

For ordinary /user-written/ type signatures f :: blah, we make this
check as part of kind-checking the type signature in tcHsSigType; see
Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType.

But in two other places we need to check for an escaping result kind:

* For data constructors we check the type piecemeal, and there is no
  very convenient place to do it.  For example, note that it only
  applies for /nullary/ constructors.  If we had
    data T = MkT Int
  then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine.

  So we make the check in checkValidDataCon.

* When inferring the type of a function, there is no user-written type
  that we are checking.  Forgetting this led to #22743.  Now we call
  checkEscapingKind in GHC.Tc.Gen.Bind.mkInferredPolyId

Historical note: we used to do the escaping-kind check in
checkValidType (#20929 discusses), but that is now redundant.
-}

checkEscapingKind :: Type -> TcM ()
-- Give a sigma-type (forall a1 .. an. ty), where (ty :: ki),
-- check that `ki` does not mention any of the binders a1..an.
-- Otherwise the type is ill-kinded
-- See Note [Check for escaping result kind]
checkEscapingKind :: Type -> TcM ()
checkEscapingKind Type
poly_ty
  | ([Var]
tvs, Type
tau) <- Type -> ([Var], Type)
splitForAllTyVars Type
poly_ty
  , let tau_kind :: Type
tau_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
tau
  , Maybe Type
Nothing <- [Var] -> Type -> Maybe Type
occCheckExpand [Var]
tvs Type
tau_kind
    -- Ensure that none of the tvs occur in the kind of the forall
    -- /after/ expanding type synonyms.
    -- See Note [Phantom type variables in kinds] in GHC.Core.Type
  = TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> TcRnMessage
TcRnForAllEscapeError Type
poly_ty Type
tau_kind
  | Bool
otherwise
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result
funArgResRank :: Rank -> (Rank, Rank)
funArgResRank (LimitedRank Bool
_ Rank
arg_rank) = (Rank
arg_rank, Bool -> Rank -> Rank
LimitedRank (Rank -> Bool
forAllAllowed Rank
arg_rank) Rank
arg_rank)
funArgResRank Rank
other_rank               = (Rank
other_rank, Rank
other_rank)

forAllAllowed :: Rank -> Bool
forAllAllowed :: Rank -> Bool
forAllAllowed Rank
ArbitraryRank             = Bool
True
forAllAllowed (LimitedRank Bool
forall_ok Rank
_) = Bool
forall_ok
forAllAllowed Rank
_                         = Bool
False

-- | Indicates whether a 'UserTypeCtxt' represents type-level contexts,
-- kind-level contexts, or both.
data TypeOrKindCtxt
  = OnlyTypeCtxt
    -- ^ A 'UserTypeCtxt' that only represents type-level positions.
  | OnlyKindCtxt
    -- ^ A 'UserTypeCtxt' that only represents kind-level positions.
  | BothTypeAndKindCtxt
    -- ^ A 'UserTypeCtxt' that can represent both type- and kind-level positions.
  deriving TypeOrKindCtxt -> TypeOrKindCtxt -> Bool
(TypeOrKindCtxt -> TypeOrKindCtxt -> Bool)
-> (TypeOrKindCtxt -> TypeOrKindCtxt -> Bool) -> Eq TypeOrKindCtxt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeOrKindCtxt -> TypeOrKindCtxt -> Bool
== :: TypeOrKindCtxt -> TypeOrKindCtxt -> Bool
$c/= :: TypeOrKindCtxt -> TypeOrKindCtxt -> Bool
/= :: TypeOrKindCtxt -> TypeOrKindCtxt -> Bool
Eq

instance Outputable TypeOrKindCtxt where
  ppr :: TypeOrKindCtxt -> SDoc
ppr TypeOrKindCtxt
ctxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ case TypeOrKindCtxt
ctxt of
    TypeOrKindCtxt
OnlyTypeCtxt        -> String
"OnlyTypeCtxt"
    TypeOrKindCtxt
OnlyKindCtxt        -> String
"OnlyKindCtxt"
    TypeOrKindCtxt
BothTypeAndKindCtxt -> String
"BothTypeAndKindCtxt"

-- | Determine whether a 'UserTypeCtxt' can represent type-level contexts,
-- kind-level contexts, or both.
typeOrKindCtxt :: UserTypeCtxt -> TypeOrKindCtxt
typeOrKindCtxt :: UserTypeCtxt -> TypeOrKindCtxt
typeOrKindCtxt (FunSigCtxt {})      = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (InfSigCtxt {})      = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (ExprSigCtxt {})     = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (TypeAppCtxt {})     = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (PatSynCtxt {})      = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (PatSigCtxt {})      = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (RuleSigCtxt {})     = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (ForSigCtxt {})      = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (DefaultDeclCtxt {}) = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (InstDeclCtxt {})    = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (SpecInstCtxt {})    = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (GenSigCtxt {})      = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (ClassSCCtxt {})     = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (SigmaCtxt {})       = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (DataTyCtxt {})      = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (DerivClauseCtxt {}) = TypeOrKindCtxt
OnlyTypeCtxt
typeOrKindCtxt (ConArgCtxt {})      = TypeOrKindCtxt
OnlyTypeCtxt
  -- Although data constructors can be promoted with DataKinds, we always
  -- validity-check them as though they are the types of terms. We may need
  -- to revisit this decision if we ever allow visible dependent quantification
  -- in the types of data constructors.

typeOrKindCtxt (KindSigCtxt {})           = TypeOrKindCtxt
OnlyKindCtxt
typeOrKindCtxt (StandaloneKindSigCtxt {}) = TypeOrKindCtxt
OnlyKindCtxt
typeOrKindCtxt (TyVarBndrKindCtxt {})     = TypeOrKindCtxt
OnlyKindCtxt
typeOrKindCtxt (DataKindCtxt {})          = TypeOrKindCtxt
OnlyKindCtxt
typeOrKindCtxt (TySynKindCtxt {})         = TypeOrKindCtxt
OnlyKindCtxt
typeOrKindCtxt (TyFamResKindCtxt {})      = TypeOrKindCtxt
OnlyKindCtxt

-- These cases are also described in Note [No constraints in kinds], so any
-- change here should be reflected in that note.
typeOrKindCtxt (TySynCtxt {}) = TypeOrKindCtxt
BothTypeAndKindCtxt
  -- Type synonyms can have types and kinds on their RHSs
typeOrKindCtxt (GhciCtxt {})  = TypeOrKindCtxt
BothTypeAndKindCtxt
  -- GHCi's :kind command accepts both types and kinds

-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the
-- context for a kind of a type.
-- If the 'UserTypeCtxt' can refer to both types and kinds, this function
-- conservatively returns 'True'.
--
-- An example of something that is unambiguously the kind of a type is the
-- @Show a => a -> a@ in @type Foo :: Show a => a -> a@. On the other hand, the
-- same type in @foo :: Show a => a -> a@ is unambiguously the type of a term,
-- not the kind of a type, so it is permitted.
typeLevelUserTypeCtxt :: UserTypeCtxt -> Bool
typeLevelUserTypeCtxt :: UserTypeCtxt -> Bool
typeLevelUserTypeCtxt UserTypeCtxt
ctxt = case UserTypeCtxt -> TypeOrKindCtxt
typeOrKindCtxt UserTypeCtxt
ctxt of
  TypeOrKindCtxt
OnlyTypeCtxt        -> Bool
True
  TypeOrKindCtxt
OnlyKindCtxt        -> Bool
False
  TypeOrKindCtxt
BothTypeAndKindCtxt -> Bool
True

-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the
-- context for a kind of a type, where the arbitrary use of constraints is
-- currently disallowed.
allConstraintsAllowed :: UserTypeCtxt -> Bool
allConstraintsAllowed :: UserTypeCtxt -> Bool
allConstraintsAllowed = UserTypeCtxt -> Bool
typeLevelUserTypeCtxt

-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the
-- context for a kind of a type, where all function arrows currently
-- must be unrestricted.
linearityAllowed :: UserTypeCtxt -> Bool
linearityAllowed :: UserTypeCtxt -> Bool
linearityAllowed = UserTypeCtxt -> Bool
typeLevelUserTypeCtxt

-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the
-- context for the type of a term, where visible, dependent quantification is
-- currently disallowed. If the 'UserTypeCtxt' can refer to both types and
-- kinds, this function conservatively returns 'True'.
--
-- An example of something that is unambiguously the type of a term is the
-- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the
-- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the
-- kind of a type, not the type of a term, so it is permitted.
--
-- For more examples, see
-- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places
-- where VDQ is permitted) and
-- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where
-- VDQ is disallowed).
vdqAllowed :: UserTypeCtxt -> Bool
vdqAllowed :: UserTypeCtxt -> Bool
vdqAllowed UserTypeCtxt
ctxt = case UserTypeCtxt -> TypeOrKindCtxt
typeOrKindCtxt UserTypeCtxt
ctxt of
  TypeOrKindCtxt
OnlyTypeCtxt        -> Bool
False
  TypeOrKindCtxt
OnlyKindCtxt        -> Bool
True
  TypeOrKindCtxt
BothTypeAndKindCtxt -> Bool
True

{-
Note [Correctness and performance of type synonym validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the type A arg1 arg2, where A is a type synonym. How should we check
this type for validity? We have three distinct choices, corresponding to the
three constructors of ExpandMode:

1. Expand the application of A, and check the resulting type (`Expand`).
2. Don't expand the application of A. Only check the arguments (`NoExpand`).
3. Check the arguments *and* check the expanded type (`Both`).

It's tempting to think that we could always just pick choice (3), but this
results in serious performance issues when checking a type like in the
signature for `f` below:

  type S = ...
  f :: S (S (S (S (S (S ....(S Int)...))))

When checking the type of `f`, we'll check the outer `S` application with and
without expansion, and in *each* of those checks, we'll check the next `S`
application with and without expansion... the result is exponential blowup! So
clearly we don't want to use `Both` 100% of the time.

On the other hand, neither is it correct to use exclusively `Expand` or
exclusively `NoExpand` 100% of the time:

* If one always expands, then one can miss erroneous programs like the one in
  the `tcfail129` test case:

    type Foo a = String -> Maybe a
    type Bar m = m Int
    blah = undefined :: Bar Foo

  If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type
  synonyms is unsaturated.
* If one never expands and only checks the arguments, then one can miss
  erroneous programs like the one in #16059:

    type Foo b = Eq b => b
    f :: forall b (a :: Foo b). Int

  The kind of `a` contains a constraint, which is illegal, but this will only
  be caught if `Foo b` is expanded.

Therefore, it's impossible to have these validity checks be simultaneously
correct and performant if one sticks exclusively to a single `ExpandMode`. In
that case, the solution is to vary the `ExpandMode`s! In more detail:

1. When we start validity checking, we start with `Expand` if
   LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we
   do this), and we start with `Both` otherwise. The `initialExpandMode`
   function is responsible for this.
2. When expanding an application of a type synonym (in `check_syn_tc_app`), we
   determine which things to check based on the current `ExpandMode` argument.
   Importantly, if the current mode is `Both`, then we check the arguments in
   `NoExpand` mode and check the expanded type in `Both` mode.

   Switching to `NoExpand` when checking the arguments is vital to avoid
   exponential blowup. One consequence of this choice is that if you have
   the following type synonym in one module (with RankNTypes enabled):

     {-# LANGUAGE RankNTypes #-}
     module A where
     type A = forall a. a

   And you define the following in a separate module *without* RankNTypes
   enabled:

     module B where

     import A

     type Const a b = a
     f :: Const Int A -> Int

   Then `f` will be accepted, even though `A` (which is technically a rank-n
   type) appears in its type. We view this as an acceptable compromise, since
   `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in
   a type post-expansion, such as in the following variant:

     g :: Const A A -> Int

   Then that would be rejected unless RankNTypes were enabled.
-}

-- | When validity-checking an application of a type synonym, should we
-- check the arguments, check the expanded type, or both?
-- See Note [Correctness and performance of type synonym validity checking]
data ExpandMode
  = Expand   -- ^ Only check the expanded type.
  | NoExpand -- ^ Only check the arguments.
  | Both     -- ^ Check both the arguments and the expanded type.

instance Outputable ExpandMode where
  ppr :: ExpandMode -> SDoc
ppr ExpandMode
e = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ case ExpandMode
e of
                   ExpandMode
Expand   -> String
"Expand"
                   ExpandMode
NoExpand -> String
"NoExpand"
                   ExpandMode
Both     -> String
"Both"

-- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the
-- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start
-- in 'Both' mode.
initialExpandMode :: TcM ExpandMode
initialExpandMode :: TcM ExpandMode
initialExpandMode = do
  liberal_flag <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.LiberalTypeSynonyms
  pure $ if liberal_flag then Expand else Both

-- | Information about a type being validity-checked.
data ValidityEnv = ValidityEnv
  { ValidityEnv -> TidyEnv
ve_tidy_env :: TidyEnv
  , ValidityEnv -> UserTypeCtxt
ve_ctxt     :: UserTypeCtxt
  , ValidityEnv -> Rank
ve_rank     :: Rank
  , ValidityEnv -> ExpandMode
ve_expand   :: ExpandMode }

instance Outputable ValidityEnv where
  ppr :: ValidityEnv -> SDoc
ppr (ValidityEnv{ ve_tidy_env :: ValidityEnv -> TidyEnv
ve_tidy_env = TidyEnv
env, ve_ctxt :: ValidityEnv -> UserTypeCtxt
ve_ctxt = UserTypeCtxt
ctxt
                  , ve_rank :: ValidityEnv -> Rank
ve_rank = Rank
rank, ve_expand :: ValidityEnv -> ExpandMode
ve_expand = ExpandMode
expand }) =
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ValidityEnv")
       Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ve_tidy_env" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TidyEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TidyEnv
env
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ve_ctxt"     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ve_rank"     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Rank -> SDoc
forall a. Outputable a => a -> SDoc
ppr Rank
rank
               , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ve_expand"   SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ExpandMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpandMode
expand ])

----------------------------------------
check_type :: ValidityEnv -> Type -> TcM ()
-- The args say what the *type context* requires, independent
-- of *flag* settings.  You test the flag settings at usage sites.
--
-- Rank is allowed rank for function args
-- Rank 0 means no for-alls anywhere

check_type :: ValidityEnv -> Type -> TcM ()
check_type ValidityEnv
_ (TyVarTy Var
_)
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

check_type ValidityEnv
ve (AppTy Type
ty1 Type
ty2)
  = do  { ValidityEnv -> Type -> TcM ()
check_type ValidityEnv
ve Type
ty1
        ; Bool -> ValidityEnv -> Type -> TcM ()
check_arg_type Bool
False ValidityEnv
ve Type
ty2 }

check_type ValidityEnv
ve ty :: Type
ty@(TyConApp TyCon
tc [Type]
tys)
  | TyCon -> Bool
isTypeSynonymTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
  = ValidityEnv -> Type -> TyCon -> [Type] -> TcM ()
check_syn_tc_app ValidityEnv
ve Type
ty TyCon
tc [Type]
tys

  -- Check for unboxed tuples and unboxed sums: these
  -- require the corresponding extension to be enabled.
  | TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc
  = UnboxedTupleOrSum -> ValidityEnv -> Type -> [Type] -> TcM ()
check_ubx_tuple_or_sum UnboxedTupleOrSum
UnboxedTupleType ValidityEnv
ve Type
ty [Type]
tys
  | TyCon -> Bool
isUnboxedSumTyCon TyCon
tc
  = UnboxedTupleOrSum -> ValidityEnv -> Type -> [Type] -> TcM ()
check_ubx_tuple_or_sum UnboxedTupleOrSum
UnboxedSumType   ValidityEnv
ve Type
ty [Type]
tys

  | Bool
otherwise
  = do { -- We require DataKinds to use a type constructor in a kind, unless it
         -- is exempted (e.g., Type, TYPE, etc., which is checked by
         -- isKindTyCon) or a `type data` type constructor.
         -- See Note [Checking for DataKinds].
         Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TyCon -> Bool
isKindTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isTypeDataTyCon TyCon
tc) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
         ValidityEnv -> Type -> TcM ()
checkDataKinds ValidityEnv
ve Type
ty
       ; (Type -> TcM ()) -> [Type] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> ValidityEnv -> Type -> TcM ()
check_arg_type Bool
False ValidityEnv
ve) [Type]
tys }

check_type ValidityEnv
ve ty :: Type
ty@(LitTy {}) =
  -- Type-level literals are forbidden from appearing in kinds unless DataKinds
  -- is enabled. See Note [Checking for DataKinds].
  ValidityEnv -> Type -> TcM ()
checkDataKinds ValidityEnv
ve Type
ty

check_type ValidityEnv
ve (CastTy Type
ty KindCoercion
_) = ValidityEnv -> Type -> TcM ()
check_type ValidityEnv
ve Type
ty

-- Check for rank-n types, such as (forall x. x -> x) or (Show x => x).
--
-- Critically, this case must come *after* the case for TyConApp.
-- See Note [Liberal type synonyms].
check_type ve :: ValidityEnv
ve@(ValidityEnv{ ve_tidy_env :: ValidityEnv -> TidyEnv
ve_tidy_env = TidyEnv
env
                          , ve_rank :: ValidityEnv -> Rank
ve_rank = Rank
rank, ve_expand :: ValidityEnv -> ExpandMode
ve_expand = ExpandMode
expand }) Type
ty
  | Bool -> Bool
not ([TyVarBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBinder]
tvbs Bool -> Bool -> Bool
&& [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta)
  = do  { String -> SDoc -> TcM ()
traceTc String
"check_type" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Rank -> SDoc
forall a. Outputable a => a -> SDoc
ppr Rank
rank)
        ; Bool -> (TidyEnv, TcRnMessage) -> TcM ()
checkTcM (Rank -> Bool
forAllAllowed Rank
rank) (TidyEnv
env, Rank -> Type -> TcRnMessage
TcRnForAllRankErr Rank
rank (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty))
                -- Reject e.g. (Maybe (?x::Int => Int)),
                -- with a decent error message

        ; ValidityEnv -> [Type] -> Type -> TcM ()
checkConstraintsOK ValidityEnv
ve [Type]
theta Type
ty
                -- Reject forall (a :: Eq b => b). blah
                -- In a kind signature we don't allow constraints

        ; ValidityEnv -> [TyVarBinder] -> Type -> TcM ()
checkVdqOK ValidityEnv
ve [TyVarBinder]
tvbs Type
ty
                -- Reject visible, dependent quantification in the type of a
                -- term (e.g., `f :: forall a -> a -> Maybe a`)

        ; TidyEnv -> UserTypeCtxt -> ExpandMode -> [Type] -> TcM ()
check_valid_theta TidyEnv
env' UserTypeCtxt
SigmaCtxt ExpandMode
expand [Type]
theta
                -- Allow     type T = ?x::Int => Int -> Int
                -- but not   type T = ?x::Int

        ; ValidityEnv -> Type -> TcM ()
check_type (ValidityEnv
ve{ve_tidy_env = env'}) Type
tau
                -- Allow foralls to right of arrow

        -- Note: skolem-escape in types (e.g. forall r (a::r). a) is handled
        --       by tcHsSigType and the constraint solver, so no need to
        --       check it here; c.f. #20929
        }
  where
    ([TyVarBinder]
tvbs, Type
phi)   = Type -> ([TyVarBinder], Type)
tcSplitForAllTyVarBinders Type
ty
    ([Type]
theta, Type
tau)  = Type -> ([Type], Type)
tcSplitPhiTy Type
phi
    (TidyEnv
env', [TyVarBinder]
_)     = TidyEnv -> [TyVarBinder] -> (TidyEnv, [TyVarBinder])
forall vis.
TidyEnv -> [VarBndr Var vis] -> (TidyEnv, [VarBndr Var vis])
tidyForAllTyBinders TidyEnv
env [TyVarBinder]
tvbs

check_type (ve :: ValidityEnv
ve@ValidityEnv{ ve_tidy_env :: ValidityEnv -> TidyEnv
ve_tidy_env = TidyEnv
env, ve_ctxt :: ValidityEnv -> UserTypeCtxt
ve_ctxt = UserTypeCtxt
ctxt
                          , ve_rank :: ValidityEnv -> Rank
ve_rank = Rank
rank })
           ty :: Type
ty@(FunTy FunTyFlag
_ Type
mult Type
arg_ty Type
res_ty)
  = do  { Bool -> (TidyEnv, TcRnMessage) -> TcM ()
failIfTcM (Bool -> Bool
not (UserTypeCtxt -> Bool
linearityAllowed UserTypeCtxt
ctxt) Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isManyTy Type
mult))
                     (TidyEnv
env, Type -> TcRnMessage
TcRnLinearFuncInKind (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty))
        ; ValidityEnv -> Type -> TcM ()
check_type (ValidityEnv
ve{ve_rank = arg_rank}) Type
arg_ty
        ; ValidityEnv -> Type -> TcM ()
check_type (ValidityEnv
ve{ve_rank = res_rank}) Type
res_ty }
  where
    (Rank
arg_rank, Rank
res_rank) = Rank -> (Rank, Rank)
funArgResRank Rank
rank

check_type ValidityEnv
_ ty :: Type
ty@(ForAllTy {}) = String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"check_type" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
check_type ValidityEnv
_ ty :: Type
ty@(CoercionTy {}) = String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"check_type" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

----------------------------------------
check_syn_tc_app :: ValidityEnv
                 -> KindOrType -> TyCon -> [KindOrType] -> TcM ()
-- Used for type synonyms and type synonym families,
-- which must be saturated,
-- but not data families, which need not be saturated
check_syn_tc_app :: ValidityEnv -> Type -> TyCon -> [Type] -> TcM ()
check_syn_tc_app (ve :: ValidityEnv
ve@ValidityEnv{ ve_ctxt :: ValidityEnv -> UserTypeCtxt
ve_ctxt = UserTypeCtxt
ctxt, ve_expand :: ValidityEnv -> ExpandMode
ve_expand = ExpandMode
expand })
                 Type
ty TyCon
tc [Type]
tys
  | [Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
tc_arity   -- Saturated
       -- Check that the synonym has enough args
       -- This applies equally to open and closed synonyms
       -- It's OK to have an *over-applied* type synonym
       --      data Tree a b = ...
       --      type Foo a = Tree [a]
       --      f :: Foo a b -> ...
  = case ExpandMode
expand of
      ExpandMode
_ |  TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
        -> ExpandMode -> TcM ()
check_args_only ExpandMode
expand
      -- See Note [Correctness and performance of type synonym validity
      --           checking]
      ExpandMode
Expand   -> ExpandMode -> TcM ()
check_expansion_only ExpandMode
expand
      ExpandMode
NoExpand -> ExpandMode -> TcM ()
check_args_only ExpandMode
expand
      ExpandMode
Both     -> ExpandMode -> TcM ()
check_args_only ExpandMode
NoExpand TcM () -> TcM () -> TcM ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ExpandMode -> TcM ()
check_expansion_only ExpandMode
Both

  | GhciCtxt Bool
True <- UserTypeCtxt
ctxt  -- Accept outermost under-saturated type synonym or
                           -- type family constructors in GHCi :kind commands.
                           -- See Note [Unsaturated type synonyms in GHCi]
  = ExpandMode -> TcM ()
check_args_only ExpandMode
expand

  | Bool
otherwise
  = TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (TyCon -> [Type] -> TcRnMessage
tyConArityErr TyCon
tc [Type]
tys)
  where
    tc_arity :: Int
tc_arity  = TyCon -> Int
tyConArity TyCon
tc

    check_arg :: ExpandMode -> KindOrType -> TcM ()
    check_arg :: ExpandMode -> Type -> TcM ()
check_arg ExpandMode
expand =
      Bool -> ValidityEnv -> Type -> TcM ()
check_arg_type (TyCon -> Bool
isTypeSynonymTyCon TyCon
tc) (ValidityEnv
ve{ve_expand = expand})

    check_args_only, check_expansion_only :: ExpandMode -> TcM ()
    check_args_only :: ExpandMode -> TcM ()
check_args_only ExpandMode
expand = (Type -> TcM ()) -> [Type] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ExpandMode -> Type -> TcM ()
check_arg ExpandMode
expand) [Type]
tys

    check_expansion_only :: ExpandMode -> TcM ()
check_expansion_only ExpandMode
expand
      = Bool -> SDoc -> TcM () -> TcM ()
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyCon -> Bool
isTypeSynonymTyCon TyCon
tc) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
        case Type -> Maybe Type
coreView Type
ty of
         Just Type
ty' -> let err_ctxt :: SDoc
err_ctxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the expansion of type synonym"
                                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
                     in SDoc -> TcM () -> TcM ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
err_ctxt (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
                        ValidityEnv -> Type -> TcM ()
check_type (ValidityEnv
ve{ve_expand = expand}) Type
ty'
         Maybe Type
Nothing  -> String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"check_syn_tc_app" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

{-
Note [Unsaturated type synonyms in GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Generally speaking, GHC disallows unsaturated uses of type synonyms or type
families. For instance, if one defines `type Const a b = a`, then GHC will not
permit using `Const` unless it is applied to (at least) two arguments. There is
an exception to this rule, however: GHCi's :kind command. For instance, it
is quite common to look up the kind of a type constructor like so:

  λ> :kind Const
  Const :: j -> k -> j
  λ> :kind Const Int
  Const Int :: k -> Type

Strictly speaking, the two uses of `Const` above are unsaturated, but this
is an extremely benign (and useful) example of unsaturation, so we allow it
here as a special case.

That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise,
this GHCi interaction would be possible:

  λ> newtype Fix f = MkFix (f (Fix f))
  λ> type Id a = a
  λ> :kind Fix Id
  Fix Id :: Type

This is rather dodgy, so we move to disallow this. We only permit unsaturated
synonyms in GHCi if they are *top-level*—that is, if the synonym is the
outermost type being applied. This allows `Const` and `Const Int` in the
first example, but not `Fix Id` in the second example, as `Id` is not the
outermost type being applied (`Fix` is).

We track this outermost property in the GhciCtxt constructor of UserTypeCtxt.
A field of True in GhciCtxt indicates that we're in an outermost position. Any
time we invoke `check_arg` to check the validity of an argument, we switch the
field to False.
-}

----------------------------------------
check_ubx_tuple_or_sum :: UnboxedTupleOrSum -> ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()
check_ubx_tuple_or_sum :: UnboxedTupleOrSum -> ValidityEnv -> Type -> [Type] -> TcM ()
check_ubx_tuple_or_sum UnboxedTupleOrSum
tup_or_sum (ve :: ValidityEnv
ve@ValidityEnv{ve_tidy_env :: ValidityEnv -> TidyEnv
ve_tidy_env = TidyEnv
env}) Type
ty [Type]
tys
  = do  { ub_thing_allowed <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM (Extension -> TcRnIf TcGblEnv TcLclEnv Bool)
-> Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall a b. (a -> b) -> a -> b
$ UnboxedTupleOrSum -> Extension
unboxedTupleOrSumExtension UnboxedTupleOrSum
tup_or_sum
        ; checkTcM ub_thing_allowed
            (env, TcRnUnboxedTupleOrSumTypeFuncArg tup_or_sum (tidyType env ty))

          -- Unboxed tuples and sums are forbidden from appearing in kinds
          -- unless DataKinds is enabled. See Note [Checking for DataKinds].
        ; checkDataKinds ve ty

        ; impred <- xoptM LangExt.ImpredicativeTypes
        ; let rank' = if Bool
impred then Rank
ArbitraryRank else Rank
MonoTypeTyConArg
                -- c.f. check_arg_type
                -- However, args are allowed to be unlifted, or
                -- more unboxed tuples or sums, so can't use check_arg_ty
        ; mapM_ (check_type (ve{ve_rank = rank'})) tys }

----------------------------------------
check_arg_type
  :: Bool -- ^ Is this the argument to a type synonym?
  -> ValidityEnv -> KindOrType -> TcM ()
-- The sort of type that can instantiate a type variable,
-- or be the argument of a type constructor.
-- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
-- Other unboxed types are very occasionally allowed as type
-- arguments depending on the kind of the type constructor
--
-- For example, we want to reject things like:
--
--      instance Ord a => Ord (forall s. T s a)
-- and
--      g :: T s (forall b.b)
--
-- NB: unboxed tuples can have polymorphic or unboxed args.
--     This happens in the workers for functions returning
--     product types with polymorphic components.
--     But not in user code.
-- Anyway, they are dealt with by a special case in check_tau_type

check_arg_type :: Bool -> ValidityEnv -> Type -> TcM ()
check_arg_type Bool
_ ValidityEnv
_ (CoercionTy {}) = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

check_arg_type Bool
type_syn (ve :: ValidityEnv
ve@ValidityEnv{ve_ctxt :: ValidityEnv -> UserTypeCtxt
ve_ctxt = UserTypeCtxt
ctxt, ve_rank :: ValidityEnv -> Rank
ve_rank = Rank
rank}) Type
ty
  = do  { impred <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ImpredicativeTypes
        ; let rank' = case Rank
rank of          -- Predictive => must be monotype
                        -- Rank-n arguments to type synonyms are OK, provided
                        -- that LiberalTypeSynonyms is enabled.
                        Rank
_ | Bool
type_syn       -> Rank
MonoTypeSynArg
                        Rank
MustBeMonoType     -> Rank
MustBeMonoType  -- Monotype, regardless
                        Rank
_other | Bool
impred    -> Rank
ArbitraryRank
                               | Bool
otherwise -> Rank
MonoTypeTyConArg
                        -- Make sure that MustBeMonoType is propagated,
                        -- so that we don't suggest -XImpredicativeTypes in
                        --    (Ord (forall a.a)) => a -> a
                        -- and so that if it Must be a monotype, we check that it is!
              ctxt' :: UserTypeCtxt
              ctxt'
                | GhciCtxt Bool
_ <- UserTypeCtxt
ctxt = Bool -> UserTypeCtxt
GhciCtxt Bool
False
                    -- When checking an argument, set the field of GhciCtxt to
                    -- False to indicate that we are no longer in an outermost
                    -- position (and thus unsaturated synonyms are no longer
                    -- allowed).
                    -- See Note [Unsaturated type synonyms in GHCi]
                | Bool
otherwise          = UserTypeCtxt
ctxt

        ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty }

----------------------------------------
checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM ()
checkConstraintsOK :: ValidityEnv -> [Type] -> Type -> TcM ()
checkConstraintsOK ValidityEnv
ve [Type]
theta Type
ty
  | [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta                         = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | UserTypeCtxt -> Bool
allConstraintsAllowed (ValidityEnv -> UserTypeCtxt
ve_ctxt ValidityEnv
ve) = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise -- We are unambiguously in a kind; see
              -- Note [No constraints in kinds]
  = (TidyEnv, TcRnMessage) -> TcM ()
forall a. (TidyEnv, TcRnMessage) -> TcM a
failWithTcM (TidyEnv
env, Type -> TcRnMessage
TcRnConstraintInKind (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty))
  where env :: TidyEnv
env = ValidityEnv -> TidyEnv
ve_tidy_env ValidityEnv
ve

checkVdqOK :: ValidityEnv -> [TyVarBinder] -> Type -> TcM ()
checkVdqOK :: ValidityEnv -> [TyVarBinder] -> Type -> TcM ()
checkVdqOK ValidityEnv
ve [TyVarBinder]
tvbs Type
ty = do
  required_type_arguments <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RequiredTypeArguments
  checkTcM (required_type_arguments || vdqAllowed ctxt || no_vdq)
           (env, TcRnVDQInTermType (Just (tidyType env ty)))
  where
    no_vdq :: Bool
no_vdq = (TyVarBinder -> Bool) -> [TyVarBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ForAllTyFlag -> Bool
isInvisibleForAllTyFlag (ForAllTyFlag -> Bool)
-> (TyVarBinder -> ForAllTyFlag) -> TyVarBinder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBinder -> ForAllTyFlag
forall tv argf. VarBndr tv argf -> argf
binderFlag) [TyVarBinder]
tvbs
    ValidityEnv{ve_tidy_env :: ValidityEnv -> TidyEnv
ve_tidy_env = TidyEnv
env, ve_ctxt :: ValidityEnv -> UserTypeCtxt
ve_ctxt = UserTypeCtxt
ctxt} = ValidityEnv
ve

-- | Check for a DataKinds violation in a kind context.
-- See @Note [Checking for DataKinds]@.
--
-- Note that emitting DataKinds errors from the typechecker is a fairly recent
-- addition to GHC (introduced in GHC 9.10), and in order to prevent these new
-- errors from breaking users' code, we temporarily downgrade these errors to
-- warnings. (This is why we use 'diagnosticTcM' below.) See
-- @Note [Checking for DataKinds] (Wrinkle: Migration story for DataKinds
-- typechecker errors)@.
checkDataKinds :: ValidityEnv -> Type -> TcM ()
checkDataKinds :: ValidityEnv -> Type -> TcM ()
checkDataKinds (ValidityEnv{ ve_ctxt :: ValidityEnv -> UserTypeCtxt
ve_ctxt = UserTypeCtxt
ctxt, ve_tidy_env :: ValidityEnv -> TidyEnv
ve_tidy_env = TidyEnv
env }) Type
ty = do
  data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
  diagnosticTcM
    (not (data_kinds || typeLevelUserTypeCtxt ctxt)) $
    (env, TcRnDataKindsError KindLevel (Right (tidyType env ty)))

{- Note [No constraints in kinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC does not allow constraints in kinds. Equality constraints
in kinds were allowed from GHC 8.0, but this "feature" was removed
as part of Proposal #547 (https://github.com/ghc-proposals/ghc-proposals/pull/547),
which contains further context and motivation for the removal.

The lack of constraints in kinds is enforced by checkConstraintsOK, which
uses the UserTypeCtxt to determine if we are unambiguously checking a kind.
There are two ambiguous contexts (constructor BothTypeAndKindCtxt of TypeOrKindCtxt)
as written in typeOfKindCtxt:
  - TySynCtxt: this is the RHS of a type synonym. We check the expansion of type
    synonyms for constraints, so this is handled at the usage site of the synonym.
  - GhciCtxt: This is the type in a :kind command. A constraint here does not cause
    any trouble, because the type cannot be used to classify a type.

Beyond these two cases, we also promote data constructors. We check for constraints
in data constructor types in GHC.Tc.Gen.HsType.tcTyVar.

Note [Liberal type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*
doing validity checking.  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
               type S m   = m ()
               f :: S (T Int)
Here, T is partially applied, so it's illegal in H98.  But if you
expand S first, then T we get just
               f :: Int
which is fine.

IMPORTANT: suppose T is a type synonym.  Then we must do validity
checking on an application (T ty1 ty2)

        *either* before expansion (i.e. check ty1, ty2)
        *or* after expansion (i.e. expand T ty1 ty2, and then check)
        BUT NOT BOTH

If we do both, we get exponential behaviour!!

  data TIACons1 i r c = c i ::: r c
  type TIACons2 t x = TIACons1 t (TIACons1 t x)
  type TIACons3 t x = TIACons2 t (TIACons1 t x)
  type TIACons4 t x = TIACons2 t (TIACons2 t x)
  type TIACons7 t x = TIACons4 t (TIACons3 t x)

The order in which you do validity checking is also somewhat delicate. Consider
the `check_type` function, which drives the validity checking for unsaturated
uses of type synonyms. There is a special case for rank-n types, such as
(forall x. x -> x) or (Show x => x), since those require at least one language
extension to use. It used to be the case that this case came before every other
case, but this can lead to bugs. Imagine you have this scenario (from #15954):

  type A a = Int
  type B (a :: Type -> Type) = forall x. x -> x
  type C = B A

If the rank-n case came first, then in the process of checking for `forall`s
or contexts, we would expand away `B A` to `forall x. x -> x`. This is because
the functions that split apart `forall`s/contexts
(tcSplitForAllTyVarBinders/tcSplitPhiTy) expand type synonyms! If `B A` is expanded
away to `forall x. x -> x` before the actually validity checks occur, we will
have completely obfuscated the fact that we had an unsaturated application of
the `A` type synonym.

We have since learned from our mistakes and now put this rank-n case /after/
the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be
caught properly. But be careful! We can't make the rank-n case /last/ either,
as the FunTy case must came after the rank-n case. Otherwise, something like
(Eq a => Int) would be treated as a function type (FunTy), which just
wouldn't do.

Note [Checking for DataKinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Checking whether a piece of code requires -XDataKinds or not is surprisingly
complicated, so here is a specification (adapted from #22141) for what
-XDataKinds does and does not allow. First, some definitions:

* A user-written type (i.e. part of the source text of a program) is in a
  /kind context/ if it follows a `::` in:
  * A standalone kind signature, e.g.,
      type T :: Nat -> Type
  * A kind signature in a type, e.g.:
    - forall (a :: Nat -> Type). blah
    - type F = G :: Nat -> Type
    - etc.
  * A result kind signature in a type declaration, e.g.:
    - data T a :: Nat -> Type where ...
    - type family Fam :: Nat -> Type
    - etc.

* All other contexts where types can appear are referred to as /type contexts/.

* The /kind type constructors/ are (see GHC.Core.TyCon.isKindTyCon):
  * TYPE and Type
  * CONSTRAINT and Constraint
  * LiftedRep
  * RuntimeRep, Levity, and their data constructors
  * Multiplicity and its data construtors
  * VecCount, VecElem, and their data constructors

* A `type data` type constructor is defined using the -XTypeData extension, such
  as the T in `type data T = A | B`.

* The following are rejected in type contexts unless -XDataKinds is enabled:
  * Promoted data constructors (e.g., 'Just), except for those data constructors
    listed under /kind type constructors/
  * Promoted list or tuple syntax (e.g., '[Int, Bool] or '(Int, Bool))
  * Type-level literals (e.g., 42, "hello", or 'a' at the type level)

* The following are rejected in kind contexts unless -XDataKinds is enabled:
  * Everything that is rejected in a type context.
  * Any type constructor that is not a kind type constructor or a `type data`
    type constructor (e.g., Maybe, [], Char, Nat, Symbol, etc.)

    Note that this includes rejecting occurrences of non-kind type construtors
    in type synomym (or type family) applications, even it the expansion would
    be legal. For example:

      type T a = Type
      f :: forall (x :: T Int). blah

    Here the `Int` in `T Int` is rejected even though the expansion is just
    `Type`. This is consistent with, for example, rejecting `T (forall a. a->a)`
    without -XImpredicativeTypes.

    This check only occurs in kind contexts. It is always permissible to mention
    type synonyms in a type context without enabling -XDataKinds, even if the
    type synonym expands to something that would otherwise require -XDataKinds.

Because checking for DataKinds in a kind context requires looking beneath type
synonyms, it is natural to implement these checks in checkValidType, which has
the necessary machinery to check for language extensions in the presence of
type synonyms. For the exact same reason, checkValidType is *not* a good place
to check for DataKinds in a type context, since we deliberately do not want to
look beneath type synonyms there. As a result, we check for DataKinds in two
different places in the code:

* We check for DataKinds violations in kind contexts in the typechecker. See
  checkDataKinds in this module.
* We check for DataKinds violations in type contexts in the renamer. See
  checkDataKinds in GHC.Rename.HsType and check_data_kinds in GHC.Rename.Pat.

  Note that the renamer can also catch "obvious" kind-level violations such as
  `data Dat :: Proxy 42 -> Type` (where 42 is not hidden beneath a type
  synonym), so we also catch a subset of kind-level violations in the renamer
  to allow for earlier reporting of these errors.

-----
-- Wrinkle: Migration story for DataKinds typechecker errors
-----

As mentioned above, DataKinds is checked in two different places: the renamer
and the typechecker. The checks in the renamer have been around since DataKinds
was introduced. The checks in the typechecker, on the other hand, are a fairly
recent addition, having been introduced in GHC 9.10. As such, it is possible
that there are some programs in the wild that (1) do not enable DataKinds, and
(2) were accepted by a previous GHC version, but would now be rejected by the
new DataKinds checks in the typechecker.

To prevent the new DataKinds checks in the typechecker from breaking users'
code, we temporarily allow programs to compile if they violate a DataKinds
check in the typechecker, but GHC will emit a warning if such a violation
occurs. Users can then silence the warning by enabling DataKinds in the module
where the affected code lives. It is fairly straightforward to distinguish
between DataKinds violations arising from the renamer versus the typechecker,
as TcRnDataKindsError (the error message type classifying all DataKinds errors)
stores an Either field that is Left when the error comes from the renamer and
Right when the error comes from the typechecker.

************************************************************************
*                                                                      *
\subsection{Checking a theta or source type}
*                                                                      *
************************************************************************

Note [Implicit parameters in instance decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Implicit parameters _only_ allowed in type signatures; not in instance
decls, superclasses etc. The reason for not allowing implicit params in
instances is a bit subtle.  If we allowed
  instance (?x::Int, Eq a) => Foo [a] where ...
then when we saw
     (e :: (?x::Int) => t)
it would be unclear how to discharge all the potential uses of the ?x
in e.  For example, a constraint Foo [Int] might come out of e, and
applying the instance decl would show up two uses of ?x.  #8912.
-}

checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
-- Assumes argument is fully zonked
checkValidTheta :: UserTypeCtxt -> [Type] -> TcM ()
checkValidTheta UserTypeCtxt
ctxt [Type]
theta
  = (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM () -> TcM ()
forall a. (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (UserTypeCtxt -> [Type] -> TidyEnv -> ZonkM (TidyEnv, SDoc)
checkThetaCtxt UserTypeCtxt
ctxt [Type]
theta) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
    do { env <- ZonkM TidyEnv -> TcM TidyEnv
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM TidyEnv -> TcM TidyEnv) -> ZonkM TidyEnv -> TcM TidyEnv
forall a b. (a -> b) -> a -> b
$ [Var] -> ZonkM TidyEnv
tcInitOpenTidyEnv ([Type] -> [Var]
tyCoVarsOfTypesList [Type]
theta)
       ; expand <- initialExpandMode
       ; check_valid_theta env ctxt expand theta }

-------------------------
check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode
                  -> [PredType] -> TcM ()
check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode -> [Type] -> TcM ()
check_valid_theta TidyEnv
_ UserTypeCtxt
_ ExpandMode
_ []
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check_valid_theta TidyEnv
env UserTypeCtxt
ctxt ExpandMode
expand [Type]
theta
  = do { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; traceTc "check_valid_theta" (ppr theta)
       ; mapM_ (check_pred_ty env dflags ctxt expand) theta }

-------------------------
{- Note [Validity checking for constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We look through constraint synonyms so that we can see the underlying
constraint(s).  For example
   type Foo = ?x::Int
   instance Foo => C T
We should reject the instance because it has an implicit parameter in
the context.

But we record, in 'under_syn', whether we have looked under a synonym
to avoid requiring language extensions at the use site.  Main example
(#9838):

   {-# LANGUAGE ConstraintKinds #-}
   module A where
      type EqShow a = (Eq a, Show a)

   module B where
      import A
      foo :: EqShow a => a -> String

We don't want to require ConstraintKinds in module B.
-}

check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode
              -> PredType -> TcM ()
-- Check the validity of a predicate in a signature
-- See Note [Validity checking for constraints]
check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode -> Type -> TcM ()
check_pred_ty TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt ExpandMode
expand Type
pred
  = do { ValidityEnv -> Type -> TcM ()
check_type ValidityEnv
ve Type
pred
       ; Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> Type -> TcM ()
check_pred_help Bool
False TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred }
  where
    rank :: Rank
rank | Extension -> DynFlags -> Bool
xopt Extension
LangExt.QuantifiedConstraints DynFlags
dflags
         = Rank
ArbitraryRank
         | Bool
otherwise
         = Rank
MonoTypeConstraint

    ve :: ValidityEnv
    ve :: ValidityEnv
ve = ValidityEnv{ ve_tidy_env :: TidyEnv
ve_tidy_env = TidyEnv
env
                    , ve_ctxt :: UserTypeCtxt
ve_ctxt     = UserTypeCtxt
SigmaCtxt
                    , ve_rank :: Rank
ve_rank     = Rank
rank
                    , ve_expand :: ExpandMode
ve_expand   = ExpandMode
expand }

check_pred_help :: Bool    -- True <=> under a type synonym
                -> TidyEnv
                -> DynFlags -> UserTypeCtxt
                -> PredType -> TcM ()
check_pred_help :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> Type -> TcM ()
check_pred_help Bool
under_syn TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred
  | Just Type
pred' <- Type -> Maybe Type
coreView Type
pred  -- Switch on under_syn when going under a
                                 -- synonym (#9838, yuk)
  = Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> Type -> TcM ()
check_pred_help Bool
True TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred'

  | Bool
otherwise  -- A bit like classifyPredType, but not the same
               -- E.g. we treat (~) like (~#); and we look inside tuples
  = case Type -> Pred
classifyPredType Type
pred of
      ClassPred Class
cls [Type]
tys
        | Class -> Bool
isCTupleClass Class
cls   -> Bool
-> TidyEnv -> DynFlags -> UserTypeCtxt -> Type -> [Type] -> TcM ()
check_tuple_pred Bool
under_syn TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred [Type]
tys
        | Bool
otherwise           -> TidyEnv
-> DynFlags -> UserTypeCtxt -> Type -> Class -> [Type] -> TcM ()
check_class_pred TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred Class
cls [Type]
tys

      EqPred EqRel
_ Type
_ Type
_      -> String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"check_pred_help" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred)
              -- EqPreds, such as (t1 ~# t2) or (t1 ~R# t2), don't even have kind Constraint
              -- and should never appear before the '=>' of a type.  Thus
              --     f :: (a ~# b) => blah
              -- is wrong.  For user written signatures, it'll be rejected by kind-checking
              -- well before we get to validity checking.  For inferred types we are careful
              -- to box such constraints in GHC.Tc.Utils.TcType.pickQuantifiablePreds, as described
              -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Solver

      ForAllPred [Var]
_ [Type]
theta Type
head -> TidyEnv
-> DynFlags -> UserTypeCtxt -> Type -> [Type] -> Type -> TcM ()
check_quant_pred TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred [Type]
theta Type
head
      Pred
_                       -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
                 -> PredType -> ThetaType -> PredType -> TcM ()
check_quant_pred :: TidyEnv
-> DynFlags -> UserTypeCtxt -> Type -> [Type] -> Type -> TcM ()
check_quant_pred TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred [Type]
theta Type
head_pred
  = SDoc -> TcM () -> TcM ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the quantified constraint" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred)) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
    do { -- Check the instance head
         case Type -> Pred
classifyPredType Type
head_pred of
                                 -- SigmaCtxt tells checkValidInstHead that
                                 -- this is the head of a quantified constraint
            ClassPred Class
cls [Type]
tys -> do { UserTypeCtxt -> Class -> [Type] -> TcM ()
checkValidInstHead UserTypeCtxt
SigmaCtxt Class
cls [Type]
tys
                                    ; Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> Type -> TcM ()
check_pred_help Bool
False TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
head_pred }
                               -- need check_pred_help to do extra pred-only validity
                               -- checks, such as for (~). Otherwise, we get #17563
                               -- NB: checks for the context are covered by the check_type
                               -- in check_pred_ty
            IrredPred {}      | Type -> Bool
hasTyVarHead Type
head_pred
                              -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Pred
_                 -> (TidyEnv, TcRnMessage) -> TcM ()
forall a. (TidyEnv, TcRnMessage) -> TcM a
failWithTcM (TidyEnv
env, Type -> TcRnMessage
TcRnBadQuantPredHead (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
pred))

         -- Check for termination
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Extension -> DynFlags -> Bool
xopt Extension
LangExt.UndecidableInstances DynFlags
dflags) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
         [Type] -> Type -> TcM ()
checkInstTermination [Type]
theta Type
head_pred
    }

check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
check_tuple_pred :: Bool
-> TidyEnv -> DynFlags -> UserTypeCtxt -> Type -> [Type] -> TcM ()
check_tuple_pred Bool
under_syn TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred [Type]
ts
  = do { -- See Note [ConstraintKinds in predicates]
         Bool -> (TidyEnv, TcRnMessage) -> TcM ()
checkTcM (Bool
under_syn Bool -> Bool -> Bool
|| Extension -> DynFlags -> Bool
xopt Extension
LangExt.ConstraintKinds DynFlags
dflags)
                  (TidyEnv
env, Type -> TcRnMessage
TcRnIllegalTupleConstraint (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
pred))
       ; (Type -> TcM ()) -> [Type] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> Type -> TcM ()
check_pred_help Bool
under_syn TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt) [Type]
ts }
    -- This case will not normally be executed because without
    -- -XConstraintKinds tuple types are only kind-checked as *

{- Note [ConstraintKinds in predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Don't check for -XConstraintKinds under a type synonym, because that
was done at the type synonym definition site; see #9838
e.g.   module A where
          type C a = (Eq a, Ix a)   -- Needs -XConstraintKinds
       module B where
          import A
          f :: C a => a -> a        -- Does *not* need -XConstraintKinds
-}

-------------------------
check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
                 -> PredType -> Class -> [TcType] -> TcM ()
check_class_pred :: TidyEnv
-> DynFlags -> UserTypeCtxt -> Type -> Class -> [Type] -> TcM ()
check_class_pred TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred Class
cls [Type]
tys
  | Class -> Bool
isEqualityClass Class
cls  -- (~) and (~~) and Coercible are classified as classes,
                         -- but here we want to treat them as equalities
  = -- Equational constraints are valid in all contexts, and
    -- we do not need to check e.g. for FlexibleContexts here, so just do nothing
    -- We used to require TypeFamilies/GADTs for equality constraints,
    -- but not anymore (GHC Proposal #371)
   () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  | Class -> Bool
isIPClass Class
cls
  = do { TcM ()
check_arity
       ; Bool -> (TidyEnv, TcRnMessage) -> TcM ()
checkTcM (UserTypeCtxt -> Bool
okIPCtxt UserTypeCtxt
ctxt) (TidyEnv
env, Type -> TcRnMessage
TcRnIllegalImplicitParam (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
pred)) }

  | Bool
otherwise     -- Includes Coercible
  = do { TcM ()
check_arity
       ; TidyEnv -> DynFlags -> UserTypeCtxt -> Class -> [Type] -> TcM ()
checkSimplifiableClassConstraint TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Class
cls [Type]
tys
       ; Bool -> (TidyEnv, TcRnMessage) -> TcM ()
checkTcM Bool
arg_tys_ok (TidyEnv
env, Type -> TcRnMessage
TcRnNonTypeVarArgInConstraint (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
pred)) }
  where
    check_arity :: TcM ()
check_arity = Bool -> TcRnMessage -> TcM ()
checkTc ([Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Class -> Int
classArity Class
cls)
                          (TyCon -> [Type] -> TcRnMessage
tyConArityErr (Class -> TyCon
classTyCon Class
cls) [Type]
tys)

    -- Check the arguments of a class constraint
    flexible_contexts :: Bool
flexible_contexts = Extension -> DynFlags -> Bool
xopt Extension
LangExt.FlexibleContexts     DynFlags
dflags
    arg_tys_ok :: Bool
arg_tys_ok = case UserTypeCtxt
ctxt of
        UserTypeCtxt
SpecInstCtxt -> Bool
True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine
        InstDeclCtxt {} -> Bool -> Class -> [Type] -> Bool
checkValidClsArgs Bool
flexible_contexts Class
cls [Type]
tys
                                -- Further checks on head and theta
                                -- in checkInstTermination
        UserTypeCtxt
_               -> Bool -> Class -> [Type] -> Bool
checkValidClsArgs Bool
flexible_contexts Class
cls [Type]
tys

checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt
                                 -> Class -> [TcType] -> TcM ()
-- See Note [Simplifiable given constraints]
checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt -> Class -> [Type] -> TcM ()
checkSimplifiableClassConstraint TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Class
cls [Type]
tys
  | Bool -> Bool
not (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnSimplifiableClassConstraints DynFlags
dflags)
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Extension -> DynFlags -> Bool
xopt Extension
LangExt.MonoLocalBinds DynFlags
dflags
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  | DataTyCtxt {} <- UserTypeCtxt
ctxt   -- Don't do this check for the "stupid theta"
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()               -- of a data type declaration

  | Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleTyConKey
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()   -- Oddly, we treat (Coercible t1 t2) as unconditionally OK
                -- matchGlobalInst will reply "yes" because we can reduce
                -- (Coercible a b) to (a ~R# b)

  | Bool
otherwise
  = do { result <- DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchGlobalInst DynFlags
dflags Bool
False Class
cls [Type]
tys
       ; case result of
           OneInst { cir_what :: ClsInstResult -> InstanceWhat
cir_what = InstanceWhat
what }
              -> TcRnMessage -> TcM ()
addDiagnosticTc (Type -> InstanceWhat -> TcRnMessage
TcRnSimplifiableConstraint Type
pred InstanceWhat
what)
           ClsInstResult
_  -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () }
  where
    pred :: Type
pred = TidyEnv -> Type -> Type
tidyType TidyEnv
env (Class -> [Type] -> Type
mkClassPred Class
cls [Type]
tys)

{- Note [Simplifiable given constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A type signature like
   f :: Eq [(a,b)] => a -> b
is very fragile, for reasons described at length in GHC.Tc.Solver.Dict
Note [Instance and Given overlap].  As that Note discusses, for the
most part the clever stuff in GHC.Tc.Solver.Dict means that we don't use a
top-level instance if a local Given might fire, so there is no
fragility. But if we /infer/ the type of a local let-binding, things
can go wrong (#11948 is an example, discussed in the Note).

So this warning is switched on only if we have NoMonoLocalBinds; in
that case the warning discourages users from writing simplifiable
class constraints.

The warning only fires if the constraint in the signature
matches the top-level instances in only one way, and with no
unifiers -- that is, under the same circumstances that
GHC.Tc.Instance.Class.matchInstEnv fires an interaction with the top
level instances.  For example (#13526), consider

  instance {-# OVERLAPPABLE #-} Eq (T a) where ...
  instance                   Eq (T Char) where ..
  f :: Eq (T a) => ...

We don't want to complain about this, even though the context
(Eq (T a)) matches an instance, because the user may be
deliberately deferring the choice so that the Eq (T Char)
has a chance to fire when 'f' is called.  And the fragility
only matters when there's a risk that the instance might
fire instead of the local 'given'; and there is no such
risk in this case.  Just use the same rules as for instance
firing!
-}

-------------------------
okIPCtxt :: UserTypeCtxt -> Bool
  -- See Note [Implicit parameters in instance decls]
okIPCtxt :: UserTypeCtxt -> Bool
okIPCtxt (FunSigCtxt {})        = Bool
True
okIPCtxt (InfSigCtxt {})        = Bool
True
okIPCtxt (ExprSigCtxt {})       = Bool
True
okIPCtxt UserTypeCtxt
TypeAppCtxt            = Bool
True
okIPCtxt UserTypeCtxt
PatSigCtxt             = Bool
True
okIPCtxt UserTypeCtxt
GenSigCtxt             = Bool
True
okIPCtxt (ConArgCtxt {})        = Bool
True
okIPCtxt (ForSigCtxt {})        = Bool
True  -- ??
okIPCtxt (GhciCtxt {})          = Bool
True
okIPCtxt UserTypeCtxt
SigmaCtxt              = Bool
True
okIPCtxt (DataTyCtxt {})        = Bool
True
okIPCtxt (PatSynCtxt {})        = Bool
True
okIPCtxt (TySynCtxt {})         = Bool
True   -- e.g.   type Blah = ?x::Int
                                         -- #11466

okIPCtxt (KindSigCtxt {})       = Bool
False
okIPCtxt (StandaloneKindSigCtxt {}) = Bool
False
okIPCtxt (ClassSCCtxt {})       = Bool
False
okIPCtxt (InstDeclCtxt {})      = Bool
False
okIPCtxt (SpecInstCtxt {})      = Bool
False
okIPCtxt (RuleSigCtxt {})       = Bool
False
okIPCtxt UserTypeCtxt
DefaultDeclCtxt        = Bool
False
okIPCtxt UserTypeCtxt
DerivClauseCtxt        = Bool
False
okIPCtxt (TyVarBndrKindCtxt {}) = Bool
False
okIPCtxt (DataKindCtxt {})      = Bool
False
okIPCtxt (TySynKindCtxt {})     = Bool
False
okIPCtxt (TyFamResKindCtxt {})  = Bool
False

{-
Note [Kind polymorphic type classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
MultiParam check:

    class C f where...   -- C :: forall k. k -> Constraint
    instance C Maybe where...

  The dictionary gets type [C * Maybe] even if it's not a MultiParam
  type class.

Flexibility check:

    class C f where...   -- C :: forall k. k -> Constraint
    data D a = D a
    instance C D where

  The dictionary gets type [C * (D *)]. IA0_TODO it should be
  generalized actually.
-}

checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> ZonkM (TidyEnv, SDoc)
checkThetaCtxt :: UserTypeCtxt -> [Type] -> TidyEnv -> ZonkM (TidyEnv, SDoc)
checkThetaCtxt UserTypeCtxt
ctxt [Type]
theta TidyEnv
env
  = (TidyEnv, SDoc) -> ZonkM (TidyEnv, SDoc)
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
env
           , [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the context:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
pprTheta (TidyEnv -> [Type] -> [Type]
tidyTypes TidyEnv
env [Type]
theta)
                  , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"While checking" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt ] )

tyConArityErr :: TyCon -> [TcType] -> TcRnMessage
-- For type-constructor arity errors, be careful to report
-- the number of /visible/ arguments required and supplied,
-- ignoring the /invisible/ arguments, which the user does not see.
-- (e.g. #10516)
tyConArityErr :: TyCon -> [Type] -> TcRnMessage
tyConArityErr TyCon
tc [Type]
tks
  = TyThing -> Int -> Int -> TcRnMessage
TcRnArityMismatch (TyCon -> TyThing
ATyCon TyCon
tc) Int
tc_type_arity Int
tc_type_args
  where
    vis_tks :: [Type]
vis_tks = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
tc [Type]
tks

    -- tc_type_arity = number of *type* args expected
    -- tc_type_args  = number of *type* args encountered
    tc_type_arity :: Int
tc_type_arity = (VarBndr Var TyConBndrVis -> Bool)
-> [VarBndr Var TyConBndrVis] -> Int
forall a. (a -> Bool) -> [a] -> Int
count VarBndr Var TyConBndrVis -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder (TyCon -> [VarBndr Var TyConBndrVis]
tyConBinders TyCon
tc)
    tc_type_args :: Int
tc_type_args  = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
vis_tks

{-
************************************************************************
*                                                                      *
\subsection{Checking for a decent instance head type}
*                                                                      *
************************************************************************

@checkValidInstHead@ checks the type {\em and} its syntactic constraints:
it must normally look like: @instance Foo (Tycon a b c ...) ...@

The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
flag is on, or (2)~the instance is imported (they must have been
compiled elsewhere). In these cases, we let them go through anyway.

We can also have instances for functions: @instance Foo (a -> b) ...@.
-}

checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
checkValidInstHead UserTypeCtxt
ctxt Class
clas [Type]
cls_args
  = do { dflags   <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; hsc_src  <- tcHscSource
       ; check_special_inst_head dflags hsc_src ctxt clas cls_args
       ; checkValidTypePats (classTyCon clas) cls_args
       }

{-

Note [Instances of built-in classes in signature files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

User defined instances for KnownNat, KnownSymbol, KnownChar,
and Typeable are disallowed
  -- they are generated when needed by GHC itself, on-the-fly.

However, if they occur in a Backpack signature file, they have an
entirely different meaning. To illustrate, suppose in M.hsig we see

  signature M where
    data T :: Nat
    instance KnownNat T

That says that any module satisfying M.hsig must provide a KnownNat
instance for T.  We absolutely need that instance when compiling a
module that imports M.hsig: see #15379 and
Note [Fabricating Evidence for Literals in Backpack] in GHC.Tc.Instance.Class.

Hence, checkValidInstHead accepts a user-written instance declaration
in hsig files, where `is_sig` is True.

-}

check_special_inst_head :: DynFlags -> HscSource -> UserTypeCtxt
                        -> Class -> [Type] -> TcM ()
-- Wow!  There are a surprising number of ad-hoc special cases here.
-- TODO: common up the logic for special typeclasses (see GHC ticket #20441).
check_special_inst_head :: DynFlags -> HscSource -> UserTypeCtxt -> Class -> [Type] -> TcM ()
check_special_inst_head DynFlags
dflags HscSource
hs_src UserTypeCtxt
ctxt Class
clas [Type]
cls_args

  -- Abstract classes cannot have instances, except in hs-boot or signature files.
  | Class -> Bool
isAbstractClass Class
clas
  , HscSource
hs_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile
  = IllegalClassInstanceReason -> TcM ()
fail_with_inst_err (IllegalClassInstanceReason -> TcM ())
-> IllegalClassInstanceReason -> TcM ()
forall a b. (a -> b) -> a -> b
$ IllegalInstanceHeadReason -> IllegalClassInstanceReason
IllegalInstanceHead
                       (IllegalInstanceHeadReason -> IllegalClassInstanceReason)
-> IllegalInstanceHeadReason -> IllegalClassInstanceReason
forall a b. (a -> b) -> a -> b
$ Class -> IllegalInstanceHeadReason
InstHeadAbstractClass Class
clas

  -- Complain about hand-written instances of built-in classes
  -- Typeable, KnownNat, KnownSymbol, Coercible, HasField.

  -- Disallow hand-written Typeable instances, except that we
  -- allow a standalone deriving declaration: they are no-ops,
  -- and we warn about them in GHC.Tc.Deriv.deriveStandalone.
  | Name
clas_nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName
  , Bool -> Bool
not (HscSource
hs_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile)
    -- Note [Instances of built-in classes in signature files]
  , Bool
hand_written_bindings
  = IllegalClassInstanceReason -> TcM ()
fail_with_inst_err (IllegalClassInstanceReason -> TcM ())
-> IllegalClassInstanceReason -> TcM ()
forall a b. (a -> b) -> a -> b
$ Class -> Bool -> IllegalClassInstanceReason
IllegalSpecialClassInstance Class
clas Bool
False

  -- Handwritten instances of KnownNat/KnownChar/KnownSymbol
  -- are forbidden outside of signature files (#12837).
  -- Derived instances are forbidden completely (#21087).
     -- FIXME: DataToTag instances in signature files don't actually work yet
  | Name
clas_nm Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Name
knownNatClassName, Name
knownSymbolClassName
                   , Name
knownCharClassName, Name
dataToTagClassName ]
  , (Bool -> Bool
not (HscSource
hs_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile) Bool -> Bool -> Bool
&& Bool
hand_written_bindings) Bool -> Bool -> Bool
|| Bool
derived_instance
    -- Note [Instances of built-in classes in signature files]
  = IllegalClassInstanceReason -> TcM ()
fail_with_inst_err (IllegalClassInstanceReason -> TcM ())
-> IllegalClassInstanceReason -> TcM ()
forall a b. (a -> b) -> a -> b
$ Class -> Bool -> IllegalClassInstanceReason
IllegalSpecialClassInstance Class
clas Bool
False

  -- For the most part we don't allow
  -- instances for (~), (~~), or Coercible;
  -- but we DO want to allow them in quantified constraints:
  --   f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m...
  | Name
clas_nm Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
    [ Name
heqTyConName, Name
eqTyConName, Name
coercibleTyConName
    , Name
withDictClassName, Name
unsatisfiableClassName ]
  , Bool -> Bool
not Bool
quantified_constraint
  = IllegalClassInstanceReason -> TcM ()
fail_with_inst_err (IllegalClassInstanceReason -> TcM ())
-> IllegalClassInstanceReason -> TcM ()
forall a b. (a -> b) -> a -> b
$ Class -> Bool -> IllegalClassInstanceReason
IllegalSpecialClassInstance Class
clas Bool
False

  -- Check for hand-written Generic instances (disallowed in Safe Haskell)
  | Name
clas_nm Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
genericClassNames
  , Bool
hand_written_bindings
  =  do { Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
safeLanguageOn DynFlags
dflags) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
           IllegalClassInstanceReason -> TcM ()
fail_with_inst_err (IllegalClassInstanceReason -> TcM ())
-> IllegalClassInstanceReason -> TcM ()
forall a b. (a -> b) -> a -> b
$ Class -> Bool -> IllegalClassInstanceReason
IllegalSpecialClassInstance Class
clas Bool
True
        ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
safeInferOn DynFlags
dflags) (Messages TcRnMessage -> TcM ()
recordUnsafeInfer Messages TcRnMessage
forall e. Messages e
emptyMessages) }

  | Name
clas_nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
hasFieldClassName
  , Bool -> Bool
not Bool
quantified_constraint
  -- Don't do any validity checking for HasField contexts
  -- inside quantified constraints (#20989): the validity checks
  -- only apply to user-written instances.
  = Class -> [Type] -> TcM ()
checkHasFieldInst Class
clas [Type]
cls_args

  | Class -> Bool
isCTupleClass Class
clas
  = do
    -- Since we're now declaring instances for constraint tuples in
    -- GHC.Classes, this check must exclude that file.
    this_mod <- (TcGblEnv -> Module)
-> IOEnv (Env TcGblEnv TcLclEnv) TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) Module
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> Module
tcg_mod IOEnv (Env TcGblEnv TcLclEnv) TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
    when (this_mod /= gHC_CLASSES) (failWithTc (TcRnTupleConstraintInst clas))

  -- Check language restrictions on the args to the class
  | Bool
check_h98_arg_shape
  , Just IllegalInstanceHeadReason
illegal_head <- Maybe IllegalInstanceHeadReason
mb_ty_args_type
  = IllegalClassInstanceReason -> TcM ()
fail_with_inst_err (IllegalClassInstanceReason -> TcM ())
-> IllegalClassInstanceReason -> TcM ()
forall a b. (a -> b) -> a -> b
$ IllegalInstanceHeadReason -> IllegalClassInstanceReason
IllegalInstanceHead IllegalInstanceHeadReason
illegal_head

  | Bool
otherwise
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where

    fail_with_inst_err :: IllegalClassInstanceReason -> TcM ()
fail_with_inst_err IllegalClassInstanceReason
err =
      TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance
                 (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ TypedThing -> IllegalClassInstanceReason -> IllegalInstanceReason
IllegalClassInstance
                    (Type -> TypedThing
TypeThing (Type -> TypedThing) -> Type -> TypedThing
forall a b. (a -> b) -> a -> b
$ Class -> [Type] -> Type
mkClassPred Class
clas [Type]
cls_args)
                 (IllegalClassInstanceReason -> IllegalInstanceReason)
-> IllegalClassInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$ IllegalClassInstanceReason
err

    clas_nm :: Name
clas_nm = Class -> Name
forall a. NamedThing a => a -> Name
getName Class
clas
    ty_args :: [Type]
ty_args = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
clas) [Type]
cls_args

    hand_written_bindings :: Bool
hand_written_bindings
      = case UserTypeCtxt
ctxt of
          InstDeclCtxt Bool
standalone -> Bool -> Bool
not Bool
standalone
          UserTypeCtxt
SpecInstCtxt            -> Bool
False
          UserTypeCtxt
DerivClauseCtxt         -> Bool
False
          UserTypeCtxt
SigmaCtxt               -> Bool
False
          UserTypeCtxt
_                       -> Bool
True

    derived_instance :: Bool
derived_instance
      = case UserTypeCtxt
ctxt of
            InstDeclCtxt Bool
standalone -> Bool
standalone
            UserTypeCtxt
DerivClauseCtxt         -> Bool
True
            UserTypeCtxt
_                       -> Bool
False

    check_h98_arg_shape :: Bool
check_h98_arg_shape = case UserTypeCtxt
ctxt of
                            UserTypeCtxt
SpecInstCtxt    -> Bool
False
                            UserTypeCtxt
DerivClauseCtxt -> Bool
False
                            UserTypeCtxt
SigmaCtxt       -> Bool
False
                            UserTypeCtxt
_               -> Bool
True
        -- SigmaCtxt: once we are in quantified-constraint land, we
        -- aren't so picky about enforcing H98-language restrictions
        -- E.g. we want to allow a head like Coercible (m a) (m b)


    -- When we are looking at the head of a quantified constraint,
    -- check_quant_pred sets ctxt to SigmaCtxt
    quantified_constraint :: Bool
quantified_constraint = case UserTypeCtxt
ctxt of
                              UserTypeCtxt
SigmaCtxt -> Bool
True
                              UserTypeCtxt
_         -> Bool
False

    mb_ty_args_type :: Maybe IllegalInstanceHeadReason
mb_ty_args_type
      | Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.TypeSynonymInstances DynFlags
dflags)
      , Bool -> Bool
not ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
tcInstHeadTyNotSynonym [Type]
ty_args)
      = IllegalInstanceHeadReason -> Maybe IllegalInstanceHeadReason
forall a. a -> Maybe a
Just IllegalInstanceHeadReason
InstHeadTySynArgs

      | Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.FlexibleInstances DynFlags
dflags)
      , Bool -> Bool
not ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
tcInstHeadTyAppAllTyVars [Type]
ty_args)
      = IllegalInstanceHeadReason -> Maybe IllegalInstanceHeadReason
forall a. a -> Maybe a
Just IllegalInstanceHeadReason
InstHeadNonTyVarArgs

      | [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ty_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
      , Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.MultiParamTypeClasses DynFlags
dflags)
      , Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.NullaryTypeClasses DynFlags
dflags Bool -> Bool -> Bool
&& [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ty_args)
      = IllegalInstanceHeadReason -> Maybe IllegalInstanceHeadReason
forall a. a -> Maybe a
Just IllegalInstanceHeadReason
InstHeadMultiParam

      | Bool
otherwise
      = Maybe IllegalInstanceHeadReason
forall a. Maybe a
Nothing

tcInstHeadTyNotSynonym :: Type -> Bool
-- Used in Haskell-98 mode, for the argument types of an instance head
-- These must not be type synonyms, but everywhere else type synonyms
-- are transparent, so we need a special function here
tcInstHeadTyNotSynonym :: Type -> Bool
tcInstHeadTyNotSynonym Type
ty
  = case Type
ty of  -- Do not use splitTyConApp,
                -- because that expands synonyms!
        TyConApp TyCon
tc [Type]
_ -> Bool -> Bool
not (TyCon -> Bool
isTypeSynonymTyCon TyCon
tc) Bool -> Bool -> Bool
|| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unrestrictedFunTyCon
                -- Allow (->), e.g. instance Category (->),
                -- even though it's a type synonym for FUN 'Many
        Type
_ -> Bool
True

tcInstHeadTyAppAllTyVars :: Type -> Bool
-- Used in Haskell-98 mode, for the argument types of an instance head
-- These must be a constructor applied to type variable arguments
-- or a type-level literal.
-- But we allow
-- 1) kind instantiations
-- 2) the type (->) = FUN 'Many, even though it's not in this form.
tcInstHeadTyAppAllTyVars :: Type -> Bool
tcInstHeadTyAppAllTyVars Type
ty
  | Just (TyCon
tc, [Type]
tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (Type -> Type
dropCasts Type
ty)
  = let tys' :: [Type]
tys' = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
tc [Type]
tys  -- avoid kinds
        tys'' :: [Type]
tys'' | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
fUNTyConKey
              , Type
ManyTy : [Type]
tys_t <- [Type]
tys'
              = [Type]
tys_t
              | Bool
otherwise = [Type]
tys'
    in [Type] -> Bool
ok [Type]
tys''
  | LitTy TyLit
_ <- Type
ty = Bool
True  -- accept type literals (#13833)
  | Bool
otherwise
  = Bool
False
  where
        -- Check that all the types are type variables,
        -- and that each is distinct
    ok :: [Type] -> Bool
ok [Type]
tys = [Var] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Var]
tvs [Type]
tys Bool -> Bool -> Bool
&& [Var] -> Bool
forall a. Eq a => [a] -> Bool
hasNoDups [Var]
tvs
           where
             tvs :: [Var]
tvs = (Type -> Maybe Var) -> [Type] -> [Var]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Type -> Maybe Var
getTyVar_maybe [Type]
tys

dropCasts :: Type -> Type
-- See Note [Casts during validity checking]
-- This function can turn a well-kinded type into an ill-kinded
-- one, so I've kept it local to this module
-- To consider: drop only HoleCo casts
dropCasts :: Type -> Type
dropCasts (CastTy Type
ty KindCoercion
_)       = Type -> Type
dropCasts Type
ty
dropCasts (AppTy Type
t1 Type
t2)       = Type -> Type -> Type
mkAppTy (Type -> Type
dropCasts Type
t1) (Type -> Type
dropCasts Type
t2)
dropCasts ty :: Type
ty@(FunTy FunTyFlag
_ Type
w Type
t1 Type
t2)  = Type
ty { ft_mult = dropCasts w, ft_arg = dropCasts t1, ft_res = dropCasts t2 }
dropCasts (TyConApp TyCon
tc [Type]
tys)   = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
dropCasts [Type]
tys)
dropCasts (ForAllTy TyVarBinder
b Type
ty)     = TyVarBinder -> Type -> Type
ForAllTy (TyVarBinder -> TyVarBinder
dropCastsB TyVarBinder
b) (Type -> Type
dropCasts Type
ty)
dropCasts Type
ty                  = Type
ty  -- LitTy, TyVarTy, CoercionTy

dropCastsB :: TyVarBinder -> TyVarBinder
dropCastsB :: TyVarBinder -> TyVarBinder
dropCastsB TyVarBinder
b = TyVarBinder
b   -- Don't bother in the kind of a forall

-- | See Note [Validity checking of HasField instances]
checkHasFieldInst :: Class -> [Type] -> TcM ()
checkHasFieldInst :: Class -> [Type] -> TcM ()
checkHasFieldInst Class
cls tys :: [Type]
tys@[Type
_k_ty, Type
lbl_ty, Type
r_ty, Type
_a_ty] =
  case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
r_ty of
    Maybe (TyCon, [Type])
Nothing -> IllegalHasFieldInstance -> TcM ()
add_err IllegalHasFieldInstance
IllegalHasFieldInstanceNotATyCon
    Just (TyCon
tc, [Type]
_)
      | TyCon -> Bool
isFamilyTyCon TyCon
tc
                  -> IllegalHasFieldInstance -> TcM ()
add_err IllegalHasFieldInstance
IllegalHasFieldInstanceFamilyTyCon
      | Bool
otherwise -> case Type -> Maybe FastString
isStrLitTy Type
lbl_ty of
       Just FastString
lbl
         | let lbl_str :: FieldLabelString
lbl_str = FastString -> FieldLabelString
FieldLabelString FastString
lbl
         , Maybe FieldLabel -> Bool
forall a. Maybe a -> Bool
isJust (FieldLabelString -> TyCon -> Maybe FieldLabel
lookupTyConFieldLabel FieldLabelString
lbl_str TyCon
tc)
         -> IllegalHasFieldInstance -> TcM ()
add_err (IllegalHasFieldInstance -> TcM ())
-> IllegalHasFieldInstance -> TcM ()
forall a b. (a -> b) -> a -> b
$ TyCon -> FieldLabelString -> IllegalHasFieldInstance
IllegalHasFieldInstanceTyConHasField TyCon
tc FieldLabelString
lbl_str
         | Bool
otherwise
         -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Maybe FastString
Nothing
         -- If the label is not a literal, we need to ensure it can't unify
         -- with any of the field labels of the TyCon.
         | [FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [FieldLabel]
tyConFieldLabels TyCon
tc)
           -- No field labels at all: nothing to check.
         Bool -> Bool -> Bool
|| Type -> Type -> Bool
typesAreApart (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
lbl_ty) Type
typeSymbolKind
           -- If the label has a type whose kind can't unify with Symbol,
           -- then it definitely can't unify with any of the field labels.
         -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         | Bool
otherwise
         -> IllegalHasFieldInstance -> TcM ()
add_err (IllegalHasFieldInstance -> TcM ())
-> IllegalHasFieldInstance -> TcM ()
forall a b. (a -> b) -> a -> b
$ TyCon -> Type -> IllegalHasFieldInstance
IllegalHasFieldInstanceTyConHasFields TyCon
tc Type
lbl_ty
  where
    add_err :: IllegalHasFieldInstance -> TcM ()
add_err IllegalHasFieldInstance
err = TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance
                           (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ TypedThing -> IllegalClassInstanceReason -> IllegalInstanceReason
IllegalClassInstance
                               (Type -> TypedThing
TypeThing (Type -> TypedThing) -> Type -> TypedThing
forall a b. (a -> b) -> a -> b
$ Class -> [Type] -> Type
mkClassPred Class
cls [Type]
tys)
                           (IllegalClassInstanceReason -> IllegalInstanceReason)
-> IllegalClassInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$ IllegalHasFieldInstance -> IllegalClassInstanceReason
IllegalHasFieldInstance IllegalHasFieldInstance
err

checkHasFieldInst Class
_ [Type]
tys = String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"checkHasFieldInst" ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys)

{- Note [Casts during validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the (bogus)
     instance Eq Char#
We elaborate to  'Eq (Char# |> UnivCo(hole))'  where the hole is an
insoluble equality constraint for Type ~ TYPE WordRep.  We'll report the insoluble
constraint separately, but we don't want to *also* complain that Eq is
not applied to a type constructor.  So we look gaily look through
CastTys here.

Another example:  Eq (Either a).  Then we actually get a cast in
the middle:
   Eq ((Either |> g) a)


Note [Validity checking of HasField instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The HasField class has magic constraint solving behaviour (see Note
[HasField instances] in GHC.Tc.Instance.Class).  However, we permit users to
declare their own instances, provided they do not clash with the
built-in behaviour.  In particular, we forbid:

  1. `HasField _ r _` where r is a variable

  2. `HasField _ (T ...) _` if T is a data family
     (because it might have fields introduced later)

  3. `HasField x (T ...) _` where x is a variable,
      if T has any fields at all

  4. `HasField "foo" (T ...) _` if T has a "foo" field

The usual functional dependency checks also apply.


Note [Valid 'deriving' predicate]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a 'derived' instance declaration, we *infer* the context. It's a bit unclear
what rules we should apply for this; the Haskell report is silent. Obviously,
constraints like `Eq a` are fine, but what about

  data T f a = MkT (f a) deriving Eq

where we'd get an `Eq (f a)` constraint. That's probably fine too.

On the other hand, we don't want to allow *every* inferred constraint, as there
are some particularly complex constraints that are tricky to handle. If GHC
encounters a constraint that is too complex, it will reject it, and you will
have to use StandaloneDeriving to manually specify the instance context that
you want.

There are two criteria for a constraint inferred by a `deriving` clause to be
considered valid, which are described below as (VD1) and (VD2). (Here, "VD"
stands for "valid deriving".) `validDerivPred` implements these checks. While
`validDerivPred` is similar to other things defined in GHC.Tc.Deriv.Infer, we
define it here in GHC.Tc.Validity because it is quite similar to
`checkInstTermination`.

-----------------------------------
-- (VD1) The Paterson conditions --
-----------------------------------

Constraints must satisfy the Paterson conditions (see Note [Paterson
conditions]) to be valid. Not only does this check for termination (of course),
but it also deals with a nasty corner case:

  instance C a b => D (T a) where ...

Note that `b` isn't a parameter of T.  This gives rise to all sorts of
problems; in particular, it's hard to compare solutions for equality when
finding the fixpoint, and that means the
GHC.Tc.Deriv.Infer.simplifyInstanceContexts loop does not converge.
See #5287 and #21302.

Another common situation in which a derived instance's context fails to meet
the Paterson conditions is when a constraint mentions a type variable more
often than the instance head, e.g.,

  data Fix f = In (f (Fix f)) deriving Eq

This would result in the following derived `Eq` instance:

  instance Eq (f (Fix f)) => Eq (Fix f)

Because `f` is mentioned more often in the `Eq (f (Fix f))` constraint than in
the instance head `Eq (Fix f)`, GHC rejects this instance.

This is a somewhat contentious restriction, and some have suggested that
instances like this one should be accepted if UndecidableInstances is enabled
(see #15868 for one such discussion). If we *do* lift this restriction in the
future, we should make sure to still meet the termination conditions. If not,
the deriving mechanism generates larger and larger constraints. Example:

  data Succ a = S a
  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show

Note the lack of a Show instance for Succ.  First we'll generate:

  instance (Show (Succ a), Show a) => Show (Seq a)

and then:

  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)

and so on. Instead we want to complain of no instance for (Show (Succ a)).

---------------------------------
-- (VD2) No exotic constraints --
---------------------------------

A constraint must satisfy one of the following properties in order to be valid:

* It is a `ClassPred` of the form `C a_1 ... a_n`, where C is a type class
  constructor and a_1, ..., a_n are either raw type variables or applications
  of type variables (e.g., `f a`).
* It is an `IrredPred` of the form `c a_1 ... a_n`, where `c` is a raw type
  variable and a_1, ..., a_n are either raw type variables or applications of
  type variables (e.g., `f a`).

If a constraint does not meet either of these properties, it is considered
*exotic*. A constraint will be exotic if it contains:

* Other type constructors (besides the class in a `ClassPred`),
* Foralls, or
* Equalities

A common form of exotic constraint is one that mentions another type
constructor. For example, given the following:

  data NotAShowInstance
  data Foo = MkFoo Int NotAShowInstance deriving Show

GHC would attempt to generate the following derived `Show` instance:

  instance (Show Int, Show NotAShowInstance) => Show Foo

Note that because there is a top-level `Show Int` instance, GHC is able to
simplify away the inferred `Show Int` constraint. However, it cannot do the
same for the `Show NotAShowInstance` constraint. One possibility would be to
generate this instance:

  instance Show NotAShowInstance => Show Foo

But this is almost surely not what we want most of the time. For this reason,
we reject the constraint above as being exotic.

Here are some other interesting examples:

* Derived instances whose instance context would mention TypeError, such as the
  code from the deriving/should_fail/T14339 test case, are exotic. For example:

    newtype Foo = Foo Int

    class Bar a where
      bar :: a

    instance (TypeError (Text "Boo")) => Bar Foo where
      bar = undefined

    newtype Baz = Baz Foo
      deriving Bar

  The `deriving Bar` clause would generate this instance:

    instance TypeError (Text "Boo") => Bar Baz

  The instance context is exotic, as `TypeError` is not a type constructor, and
  `Text "Boo"` is not an application of type variables. As such, GHC rejects
  it. This has the desirable side effect of causing the TypeError to fire in
  the resulting error message.

* The following `IrredPred`s are not exotic:

    instance c => C (T c a)
    instance c a => C (T c a)

  This `IrredPred`, however, *is* exotic:

    instance c NotAShowInstance => C (T c)

  This is rejected for the same reasons that we do not permit a `ClassPred`
  with a type constructor argument, such as the `Show NotAShowInstance` example
  above.

As part of implementing this check, GHC calls `tyConsOfType` on the arguments
of the constraint, ensuring that there are no other type constructors.
Wrinkle: for `ClassPred`s, we look only at the /visible/ arguments of the class
type constructor. Including the non-visible arguments can cause the following,
perfectly valid instance to be rejected:

  class Category (cat :: k -> k -> Type) where ...
  newtype T (c :: Type -> Type -> Type) a b = MkT (c a b)
  instance Category c => Category (T c) where ...

since the first argument to `Category` is a non-visible `Type`, which has a type
constructor! See #11833.

Note [Equality class instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We can't have users writing instances for the equality classes. But we
still need to be able to write instances for them ourselves. So we allow
instances only in the defining module.
-}

validDerivPred :: PatersonSize -> PredType -> Bool
-- See Note [Valid 'deriving' predicate]
validDerivPred :: PatersonSize -> Type -> Bool
validDerivPred PatersonSize
head_size Type
pred
  = case Type -> Pred
classifyPredType Type
pred of
            EqPred {}     -> Bool
False  -- Reject equality constraints (VD2)
            ForAllPred {} -> Bool
False  -- Rejects quantified predicates (VD2)

            ClassPred Class
cls [Type]
tys -> PatersonSize -> Bool
check_size (Class -> [Type] -> PatersonSize
pSizeClassPred Class
cls [Type]
tys)        -- (VD1)
                              Bool -> Bool -> Bool
&& UniqSet TyCon -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet ([Type] -> UniqSet TyCon
tyConsOfTypes [Type]
visible_tys) -- (VD2)
                where
                  -- See the wrinkle about visible arguments in (VD2)
                  visible_tys :: [Type]
visible_tys = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [Type]
tys

            IrredPred {} -> PatersonSize -> Bool
check_size (Type -> PatersonSize
pSizeType Type
pred)        -- (VD1)
                         Bool -> Bool -> Bool
&& UniqSet TyCon -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet (Type -> UniqSet TyCon
tyConsOfType Type
pred) -- (VD2)

  where
    check_size :: PatersonSize -> Bool
check_size PatersonSize
pred_size = Maybe PatersonCondFailure -> Bool
forall a. Maybe a -> Bool
isNothing (PatersonSize
pred_size PatersonSize -> PatersonSize -> Maybe PatersonCondFailure
`ltPatersonSize` PatersonSize
head_size)
        -- Check (VD1)

{-
************************************************************************
*                                                                      *
\subsection{Checking instance for termination}
*                                                                      *
************************************************************************
-}

{- Note [Paterson conditions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Paterson Conditions ensure termination of instance resolution.
Given an instance declaration
   instance (..., C t1.. tn, ...) => D s1 .. sm

we check that each constraint in the context of the instance is
"Paterson-smaller" than the instance head.  The underlying idea of
Paterson-smaller is that

    For any ground substitution S, for each constraint P in the
    context, S(P) has fewer type constructors, counting repetitions,
    than the head S(H)

We implement this check by checking the following syntactic conditions:

(PC1) No type variable has more (shallow) occurrences in P than in H.

      (If not, a substitution that replaces that variable with a big type
      would make P have many more type constructors than H. Side note: we
      could in principle skip this test for a variable of kind Bool,
      since there are no big ground types we can substitute for it.)

(PC2) The constraint P has fewer constructors and variables (taken
      together and counting repetitions) than the head H.  This size
      metric is computed by sizeType.

      (A substitution that replaces each variable with Int demonstrates
      the need.)

(PC3) The constraint P mentions no type functions.

      (A type function application can in principle expand to a type of
      arbitrary size, and so are rejected out of hand.  See #15172.)

(See Section 5 of "Understanding functional dependencies via Constraint
Handling Rules", JFP Jan 2007; and the user manual section "Instance
termination rules".)

We measure "size" with the data type PatersonSize, in GHC.Tc.Utils.TcType.
  data PatersonSize
    = PS_TyFam TyCon
    | PS_Vanilla { ps_tvs :: [TyVar]  -- Free tyvars, including repetitions;
                 , ps_size :: Int}    -- Number of type constructors and variables

* ps_tvs deals with (PC1)
* ps_size deals with (PC2)
* PS_TyFam deals with (PC3)

Note [Tuples in checkInstTermination]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider these two ways of giving the same instance decl (#8359):

   instance (Eq a, Num a) => C (T a)

   type X a = (Eq a, Num a)
   instance X a => C (T a)

In the former, `checkInstTermination` will check the size of two predicates:
(Eq a) and (Num a). In the latter, it will see only one: (X a). But we want
to treat the latter like the former.

So the `check` function in `checkInstTermination`, we simply recurse
if we find a constraint tuple.
-}


checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()
checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()
checkValidInstance UserTypeCtxt
ctxt LHsSigType GhcRn
hs_type Type
ty = case Type
tau of
  -- See Note [Instances and constraint synonyms]
  TyConApp TyCon
tc [Type]
inst_tys
    | Just Class
clas <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc
    -> do
        { EpAnn AnnListItem -> TcM () -> TcM ()
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn AnnListItem
head_loc (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
          UserTypeCtxt -> Class -> [Type] -> TcM ()
checkValidInstHead UserTypeCtxt
ctxt Class
clas [Type]
inst_tys

        ; String -> SDoc -> TcM ()
traceTc String
"checkValidInstance {" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

        ; env0 <- ZonkM TidyEnv -> TcM TidyEnv
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM TidyEnv -> TcM TidyEnv) -> ZonkM TidyEnv -> TcM TidyEnv
forall a b. (a -> b) -> a -> b
$ ZonkM TidyEnv
tcInitTidyEnv
        ; expand <- initialExpandMode
        ; check_valid_theta env0 ctxt expand theta

        -- The Termination and Coverage Conditions
        -- Check that instance inference will terminate (if we care)
        -- For Haskell 98 this will already have been done by checkValidTheta,
        -- but as we may be using other extensions we need to check.
        --
        -- Note that the Termination Condition is *more conservative* than
        -- the checkAmbiguity test we do on other type signatures
        --   e.g.  Bar a => Bar Int is ambiguous, but it also fails
        --   the termination condition, because 'a' appears more often
        --   in the constraint than in the head
        ; undecidable_ok <- xoptM LangExt.UndecidableInstances
        ; if undecidable_ok
          then checkAmbiguity ctxt ty
          else checkInstTermination theta tau

        ; traceTc "cvi 2" (ppr ty)

        ; case checkInstCoverage undecidable_ok clas theta inst_tys of
            Validity' CoverageProblem
IsValid
              -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()   -- Check succeeded
            NotValid CoverageProblem
coverageInstErr
              -> TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ IllegalClassInstanceReason -> TcRnMessage
mk_err
                          (IllegalClassInstanceReason -> TcRnMessage)
-> IllegalClassInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ Class -> CoverageProblem -> IllegalClassInstanceReason
IllegalInstanceFailsCoverageCondition Class
clas CoverageProblem
coverageInstErr

        ; traceTc "End checkValidInstance }" empty }
    | Bool
otherwise
    -> TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ IllegalClassInstanceReason -> TcRnMessage
mk_err (IllegalClassInstanceReason -> TcRnMessage)
-> IllegalClassInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalInstanceHeadReason -> IllegalClassInstanceReason
IllegalInstanceHead
                           (IllegalInstanceHeadReason -> IllegalClassInstanceReason)
-> IllegalInstanceHeadReason -> IllegalClassInstanceReason
forall a b. (a -> b) -> a -> b
$ Maybe TyCon -> IllegalInstanceHeadReason
InstHeadNonClass (TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc)
  Type
_ -> TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ IllegalClassInstanceReason -> TcRnMessage
mk_err (IllegalClassInstanceReason -> TcRnMessage)
-> IllegalClassInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalInstanceHeadReason -> IllegalClassInstanceReason
IllegalInstanceHead
                           (IllegalInstanceHeadReason -> IllegalClassInstanceReason)
-> IllegalInstanceHeadReason -> IllegalClassInstanceReason
forall a b. (a -> b) -> a -> b
$ Maybe TyCon -> IllegalInstanceHeadReason
InstHeadNonClass Maybe TyCon
forall a. Maybe a
Nothing
  where
    ([Type]
theta, Type
tau) = Type -> ([Type], Type)
splitInstTyForValidity Type
ty

    mk_err :: IllegalClassInstanceReason -> TcRnMessage
mk_err IllegalClassInstanceReason
err = IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance
               (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ TypedThing -> IllegalClassInstanceReason -> IllegalInstanceReason
IllegalClassInstance (Type -> TypedThing
TypeThing Type
tau) IllegalClassInstanceReason
err

        -- The location of the "head" of the instance
    head_loc :: EpAnn AnnListItem
head_loc = GenLocated (EpAnn AnnListItem) (HsType GhcRn) -> EpAnn AnnListItem
forall l e. GenLocated l e -> l
getLoc (LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead LHsSigType GhcRn
hs_type)

-- | Split an instance type of the form @forall tvbs. inst_ctxt => inst_head@
-- and return @(inst_ctxt, inst_head)@. This function makes no attempt to look
-- through type synonyms. See @Note [Instances and constraint synonyms]@.
splitInstTyForValidity :: Type -> (ThetaType, Type)
splitInstTyForValidity :: Type -> ([Type], Type)
splitInstTyForValidity = [Type] -> Type -> ([Type], Type)
split_context [] (Type -> ([Type], Type))
-> (Type -> Type) -> Type -> ([Type], Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
drop_foralls
  where
    -- This is like 'dropForAlls', except that it does not look through type
    -- synonyms.
    drop_foralls :: Type -> Type
    drop_foralls :: Type -> Type
drop_foralls (ForAllTy (Bndr Var
_tv ForAllTyFlag
argf) Type
ty)
      | ForAllTyFlag -> Bool
isInvisibleForAllTyFlag ForAllTyFlag
argf = Type -> Type
drop_foralls Type
ty
    drop_foralls Type
ty = Type
ty

    -- This is like 'tcSplitPhiTy', except that it does not look through type
    -- synonyms.
    split_context :: ThetaType -> Type -> (ThetaType, Type)
    split_context :: [Type] -> Type -> ([Type], Type)
split_context [Type]
preds (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af, ft_arg :: Type -> Type
ft_arg = Type
pred, ft_res :: Type -> Type
ft_res = Type
tau })
      | FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af = [Type] -> Type -> ([Type], Type)
split_context (Type
predType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
preds) Type
tau
    split_context [Type]
preds Type
ty = ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
preds, Type
ty)

checkInstTermination :: ThetaType -> TcPredType -> TcM ()
-- See Note [Paterson conditions]
checkInstTermination :: [Type] -> Type -> TcM ()
checkInstTermination [Type]
theta Type
head_pred
  = VarSet -> [Type] -> TcM ()
check_preds VarSet
emptyVarSet [Type]
theta
  where
   head_size :: PatersonSize
head_size = Type -> PatersonSize
pSizeType Type
head_pred
   -- This is inconsistent and probably wrong.  pSizeType does not filter out
   -- invisible type args (making the instance head look big), whereas the use of
   -- pSizeClassPredX below /does/ filter them out (making the tested constraints
   -- look smaller). I'm sure there is non termination lurking here, but see #15177
   -- for why I didn't change it. See Note [Invisible arguments and termination]
   -- in GHC.Tc.Utils.TcType

   check_preds :: VarSet -> [PredType] -> TcM ()
   check_preds :: VarSet -> [Type] -> TcM ()
check_preds VarSet
foralld_tvs [Type]
preds = (Type -> TcM ()) -> [Type] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> Type -> TcM ()
check VarSet
foralld_tvs) [Type]
preds

   check :: VarSet -> PredType -> TcM ()
   check :: VarSet -> Type -> TcM ()
check VarSet
foralld_tvs Type
pred
     = case Type -> Pred
classifyPredType Type
pred of
         EqPred {}      -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- See #4200.
         IrredPred {}   -> PatersonSize -> TcM ()
check2 (VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
foralld_tvs Type
pred)

         ClassPred Class
cls [Type]
tys
           | Class -> Bool
isCTupleClass Class
cls  -- See Note [Tuples in checkInstTermination]
           -> VarSet -> [Type] -> TcM ()
check_preds VarSet
foralld_tvs [Type]
tys

           | Bool
otherwise          -- Other ClassPreds
           -> PatersonSize -> TcM ()
check2 (VarSet -> Class -> [Type] -> PatersonSize
pSizeClassPredX VarSet
foralld_tvs Class
cls [Type]
tys)

         ForAllPred [Var]
tvs [Type]
_ Type
head_pred'
           -> VarSet -> Type -> TcM ()
check (VarSet
foralld_tvs VarSet -> [Var] -> VarSet
`extendVarSetList` [Var]
tvs) Type
head_pred'
              -- Termination of the quantified predicate itself is checked
              -- when the predicates are individually checked for validity

      where
        check2 :: PatersonSize -> TcM ()
check2 PatersonSize
pred_size
          = case PatersonSize
pred_size PatersonSize -> PatersonSize -> Maybe PatersonCondFailure
`ltPatersonSize` PatersonSize
head_size of
              Just PatersonCondFailure
pc_failure -> TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ PatersonCondFailure
-> PatersonCondFailureContext -> Type -> Type -> TcRnMessage
TcRnPatersonCondFailure PatersonCondFailure
pc_failure PatersonCondFailureContext
InInstanceDecl Type
pred Type
head_pred
              Maybe PatersonCondFailure
Nothing         -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{- Note [Instances and constraint synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Currently, we don't allow instances for constraint synonyms at all.
Consider these (#13267):
  type C1 a = Show (a -> Bool)
  instance C1 Int where    -- I1
    show _ = "ur"

This elicits "show is not a (visible) method of class C1", which isn't
a great message. But it comes from the renamer, so it's hard to improve.

This needs a bit more care:
  type C2 a = (Show a, Show Int)
  instance C2 Int           -- I2

If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose
the instance head, we'll expand the synonym on fly, and it'll look like
  instance (%,%) (Show Int, Show Int)
and we /really/ don't want that.  So we carefully do /not/ expand
synonyms, by matching on TyConApp directly.

For similar reasons, we do not use tcSplitSigmaTy when decomposing the instance
context, as the looks through type synonyms. If we looked through type
synonyms, then it could be possible to write an instance for a type synonym
involving a quantified constraint (see #22570). Instead, we define
splitInstTyForValidity, a specialized version of tcSplitSigmaTy (local to
GHC.Tc.Validity) that does not expand type synonyms.
-}


{-
************************************************************************
*                                                                      *
        Checking type instance well-formedness and termination
*                                                                      *
************************************************************************
-}

checkValidCoAxiom :: CoAxiom Branched -> TcM ()
checkValidCoAxiom :: CoAxiom Branched -> TcM ()
checkValidCoAxiom ax :: CoAxiom Branched
ax@(CoAxiom { co_ax_tc :: forall (br :: BranchFlag). CoAxiom br -> TyCon
co_ax_tc = TyCon
fam_tc, co_ax_branches :: forall (br :: BranchFlag). CoAxiom br -> Branches br
co_ax_branches = Branches Branched
branches })
  = do { (CoAxBranch -> TcM ()) -> [CoAxBranch] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyCon -> CoAxBranch -> TcM ()
checkValidCoAxBranch TyCon
fam_tc) [CoAxBranch]
branch_list
       ; ([CoAxBranch]
 -> CoAxBranch -> IOEnv (Env TcGblEnv TcLclEnv) [CoAxBranch])
-> [CoAxBranch] -> [CoAxBranch] -> TcM ()
forall (m :: * -> *) (t :: * -> *) a b.
(Monad m, Foldable t) =>
(a -> b -> m a) -> a -> t b -> m ()
foldlM_ [CoAxBranch]
-> CoAxBranch -> IOEnv (Env TcGblEnv TcLclEnv) [CoAxBranch]
check_branch_compat [] [CoAxBranch]
branch_list }
  where
    branch_list :: [CoAxBranch]
branch_list = Branches Branched -> [CoAxBranch]
forall (br :: BranchFlag). Branches br -> [CoAxBranch]
fromBranches Branches Branched
branches
    injectivity :: Injectivity
injectivity = TyCon -> Injectivity
tyConInjectivityInfo TyCon
fam_tc

    check_branch_compat :: [CoAxBranch]    -- previous branches in reverse order
                        -> CoAxBranch      -- current branch
                        -> TcM [CoAxBranch]-- current branch : previous branches
    -- Check for
    --   (a) this branch is dominated by previous ones
    --   (b) failure of injectivity
    check_branch_compat :: [CoAxBranch]
-> CoAxBranch -> IOEnv (Env TcGblEnv TcLclEnv) [CoAxBranch]
check_branch_compat [CoAxBranch]
prev_branches CoAxBranch
cur_branch
      | CoAxBranch
cur_branch CoAxBranch -> [CoAxBranch] -> Bool
`isDominatedBy` [CoAxBranch]
prev_branches
      = do { let dia :: TcRnMessage
dia = TyCon -> CoAxBranch -> TcRnMessage
TcRnInaccessibleCoAxBranch TyCon
fam_tc CoAxBranch
cur_branch
           ; SrcSpan -> TcRnMessage -> TcM ()
addDiagnosticAt (CoAxBranch -> SrcSpan
coAxBranchSpan CoAxBranch
cur_branch) TcRnMessage
dia
           ; [CoAxBranch] -> IOEnv (Env TcGblEnv TcLclEnv) [CoAxBranch]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [CoAxBranch]
prev_branches }
      | Bool
otherwise
      = do { [CoAxBranch] -> CoAxBranch -> TcM ()
check_injectivity [CoAxBranch]
prev_branches CoAxBranch
cur_branch
           ; [CoAxBranch] -> IOEnv (Env TcGblEnv TcLclEnv) [CoAxBranch]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoAxBranch
cur_branch CoAxBranch -> [CoAxBranch] -> [CoAxBranch]
forall a. a -> [a] -> [a]
: [CoAxBranch]
prev_branches) }

     -- Injectivity check: check whether a new (CoAxBranch) can extend
     -- already checked equations without violating injectivity
     -- annotation supplied by the user.
     -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv
    check_injectivity :: [CoAxBranch] -> CoAxBranch -> TcM ()
check_injectivity [CoAxBranch]
prev_branches CoAxBranch
cur_branch
      | Injective [Bool]
inj <- Injectivity
injectivity
      = do { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
           ; let conflicts =
                     ([CoAxBranch], Int) -> [CoAxBranch]
forall a b. (a, b) -> a
fst (([CoAxBranch], Int) -> [CoAxBranch])
-> ([CoAxBranch], Int) -> [CoAxBranch]
forall a b. (a -> b) -> a -> b
$ (([CoAxBranch], Int) -> CoAxBranch -> ([CoAxBranch], Int))
-> ([CoAxBranch], Int) -> [CoAxBranch] -> ([CoAxBranch], Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Bool]
-> [CoAxBranch]
-> CoAxBranch
-> ([CoAxBranch], Int)
-> CoAxBranch
-> ([CoAxBranch], Int)
gather_conflicts [Bool]
inj [CoAxBranch]
prev_branches CoAxBranch
cur_branch)
                                 ([], Int
0) [CoAxBranch]
prev_branches
           ; reportConflictingInjectivityErrs fam_tc conflicts cur_branch
           ; reportInjectivityErrors dflags ax cur_branch inj }
      | Bool
otherwise
      = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    gather_conflicts :: [Bool]
-> [CoAxBranch]
-> CoAxBranch
-> ([CoAxBranch], Int)
-> CoAxBranch
-> ([CoAxBranch], Int)
gather_conflicts [Bool]
inj [CoAxBranch]
prev_branches CoAxBranch
cur_branch ([CoAxBranch]
acc, Int
n) CoAxBranch
branch
               -- n is 0-based index of branch in prev_branches
      = case [Bool] -> CoAxBranch -> CoAxBranch -> InjectivityCheckResult
injectiveBranches [Bool]
inj CoAxBranch
cur_branch CoAxBranch
branch of
           -- Case 1B2 in Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv
          InjectivityUnified CoAxBranch
ax1 CoAxBranch
ax2
            | CoAxBranch
ax1 CoAxBranch -> [CoAxBranch] -> Bool
`isDominatedBy` ([CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]
replace_br [CoAxBranch]
prev_branches Int
n CoAxBranch
ax2)
                -> ([CoAxBranch]
acc, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            | Bool
otherwise
                -> (CoAxBranch
branch CoAxBranch -> [CoAxBranch] -> [CoAxBranch]
forall a. a -> [a] -> [a]
: [CoAxBranch]
acc, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          InjectivityCheckResult
InjectivityAccepted -> ([CoAxBranch]
acc, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

    -- Replace n-th element in the list. Assumes 0-based indexing.
    replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]
    replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]
replace_br [CoAxBranch]
brs Int
n CoAxBranch
br = Int -> [CoAxBranch] -> [CoAxBranch]
forall a. Int -> [a] -> [a]
take Int
n [CoAxBranch]
brs [CoAxBranch] -> [CoAxBranch] -> [CoAxBranch]
forall a. [a] -> [a] -> [a]
++ [CoAxBranch
br] [CoAxBranch] -> [CoAxBranch] -> [CoAxBranch]
forall a. [a] -> [a] -> [a]
++ Int -> [CoAxBranch] -> [CoAxBranch]
forall a. Int -> [a] -> [a]
drop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [CoAxBranch]
brs


-- Check that a "type instance" is well-formed (which includes decidability
-- unless -XUndecidableInstances is given).
--
-- See also the separate 'checkFamPatBinders' which performs scoping checks
-- on a type family equation.
-- (It's separate because it expects 'TyFamEqnValidityInfo', which comes from a
-- separate place e.g. for associated type defaults.)
checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM ()
checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM ()
checkValidCoAxBranch TyCon
fam_tc
                    (CoAxBranch { cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
typats
                                , cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs, cab_loc :: CoAxBranch -> SrcSpan
cab_loc = SrcSpan
loc })
  = SrcSpan -> TcM () -> TcM ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
    TyCon -> [Type] -> Type -> TcM ()
checkValidTyFamEqn TyCon
fam_tc [Type]
typats Type
rhs

-- | Do validity checks on a type family equation, including consistency
-- with any enclosing class instance head, termination, and lack of
-- polytypes.
--
-- See also the separate 'checkFamPatBinders' which performs scoping checks
-- on a type family equation.
-- (It's separate because it expects 'TyFamEqnValidityInfo', which comes from a
-- separate place e.g. for associated type defaults.)
checkValidTyFamEqn :: TyCon    -- ^ of the type family
                   -> [Type]   -- ^ Type patterns
                   -> Type     -- ^ Rhs
                   -> TcM ()
checkValidTyFamEqn :: TyCon -> [Type] -> Type -> TcM ()
checkValidTyFamEqn TyCon
fam_tc [Type]
typats Type
rhs
  = do { TyCon -> [Type] -> TcM ()
checkValidTypePats TyCon
fam_tc [Type]
typats

         -- Check for oversaturated visible kind arguments in a type family
         -- equation.
         -- See Note [Oversaturated type family equations]
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isTypeFamilyTyCon TyCon
fam_tc) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
           case Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop (TyCon -> Int
tyConArity TyCon
fam_tc) [Type]
typats of
             [] -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
             Type
spec_arg:[Type]
_ ->
               TcRnMessage -> TcM ()
addErr (Type -> TcRnMessage
TcRnOversaturatedVisibleKindArg Type
spec_arg)

         -- The argument patterns, and RHS, are all boxed tau types
         -- E.g  Reject type family F (a :: k1) :: k2
         --             type instance F (forall a. a->a) = ...
         --             type instance F Int#             = ...
         --             type instance F Int              = forall a. a->a
         --             type instance F Int              = Int#
         -- See #9357
       ; Type -> TcM ()
checkValidMonoType Type
rhs

         -- We have a decidable instance unless otherwise permitted
       ; undecidable_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UndecidableInstances
       ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs))
       ; unless undecidable_ok $
         mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) }

-- | Checks that an associated type family default:
--
-- 1. Only consists of arguments that are bare type variables, and
--
-- 2. Has a distinct type variable in each argument.
--
-- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl".
checkValidAssocTyFamDeflt :: TyCon  -- ^ of the type family
                          -> [Type] -- ^ Type patterns
                          -> TcM ()
checkValidAssocTyFamDeflt :: TyCon -> [Type] -> TcM ()
checkValidAssocTyFamDeflt TyCon
fam_tc [Type]
pats =
  do { cpt_tvs <- (Type -> ForAllTyFlag -> IOEnv (Env TcGblEnv TcLclEnv) Var)
-> [Type] -> [ForAllTyFlag] -> IOEnv (Env TcGblEnv TcLclEnv) [Var]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Type -> ForAllTyFlag -> IOEnv (Env TcGblEnv TcLclEnv) Var
extract_tv [Type]
pats [ForAllTyFlag]
pats_vis
     ; check_all_distinct_tvs $ zip cpt_tvs pats_vis }
  where
    pats_vis :: [ForAllTyFlag]
    pats_vis :: [ForAllTyFlag]
pats_vis = TyCon -> [Type] -> [ForAllTyFlag]
tyConForAllTyFlags TyCon
fam_tc [Type]
pats

    -- Checks that a pattern on the LHS of a default is a type
    -- variable. If so, return the underlying type variable, and if
    -- not, throw an error.
    -- See Note [Type-checking default assoc decls]
    extract_tv :: Type          -- The particular type pattern from which to
                                -- extrace its underlying type variable
               -> ForAllTyFlag  -- The visibility of the type pattern
                                -- (only used for error message purposes)
               -> TcM TyVar
    extract_tv :: Type -> ForAllTyFlag -> IOEnv (Env TcGblEnv TcLclEnv) Var
extract_tv Type
pat ForAllTyFlag
pat_vis =
      case Type -> Maybe Var
getTyVar_maybe Type
pat of
        Just Var
tv -> Var -> IOEnv (Env TcGblEnv TcLclEnv) Var
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Var
tv
        Maybe Var
Nothing -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) Var
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) Var)
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) Var
forall a b. (a -> b) -> a -> b
$ IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance
                              (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance
                              (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssoc -> IllegalFamilyInstanceReason
InvalidAssoc (InvalidAssoc -> IllegalFamilyInstanceReason)
-> InvalidAssoc -> IllegalFamilyInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssocDefault -> InvalidAssoc
InvalidAssocDefault
                              (InvalidAssocDefault -> InvalidAssoc)
-> InvalidAssocDefault -> InvalidAssoc
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> AssocDefaultBadArgs -> InvalidAssocDefault
AssocDefaultBadArgs TyCon
fam_tc [Type]
pats
                              (AssocDefaultBadArgs -> InvalidAssocDefault)
-> AssocDefaultBadArgs -> InvalidAssocDefault
forall a b. (a -> b) -> a -> b
$ (Type, ForAllTyFlag) -> AssocDefaultBadArgs
AssocDefaultNonTyVarArg (Type
pat, ForAllTyFlag
pat_vis)

    -- Checks that no type variables in an associated default declaration are
    -- duplicated. If that is the case, throw an error.
    -- See Note [Type-checking default assoc decls]
    check_all_distinct_tvs ::
         [(TyVar, ForAllTyFlag)] -- The type variable arguments in the associated
                            -- default declaration, along with their respective
                            -- visibilities (the latter are only used for error
                            -- message purposes)
      -> TcM ()
    check_all_distinct_tvs :: [(Var, ForAllTyFlag)] -> TcM ()
check_all_distinct_tvs [(Var, ForAllTyFlag)]
cpt_tvs_vis =
      let dups :: [NonEmpty (Var, ForAllTyFlag)]
dups = ((Var, ForAllTyFlag) -> (Var, ForAllTyFlag) -> Bool)
-> [(Var, ForAllTyFlag)] -> [NonEmpty (Var, ForAllTyFlag)]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Var -> Var -> Bool)
-> ((Var, ForAllTyFlag) -> Var)
-> (Var, ForAllTyFlag)
-> (Var, ForAllTyFlag)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Var, ForAllTyFlag) -> Var
forall a b. (a, b) -> a
fst) [(Var, ForAllTyFlag)]
cpt_tvs_vis in
      (NonEmpty (Var, ForAllTyFlag) -> IOEnv (Env TcGblEnv TcLclEnv) Any)
-> [NonEmpty (Var, ForAllTyFlag)] -> TcM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
        (\NonEmpty (Var, ForAllTyFlag)
d -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) Any
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) Any)
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) Any
forall a b. (a -> b) -> a -> b
$ IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance
                          (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance
                          (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssoc -> IllegalFamilyInstanceReason
InvalidAssoc (InvalidAssoc -> IllegalFamilyInstanceReason)
-> InvalidAssoc -> IllegalFamilyInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssocDefault -> InvalidAssoc
InvalidAssocDefault
                          (InvalidAssocDefault -> InvalidAssoc)
-> InvalidAssocDefault -> InvalidAssoc
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> AssocDefaultBadArgs -> InvalidAssocDefault
AssocDefaultBadArgs TyCon
fam_tc [Type]
pats
                          (AssocDefaultBadArgs -> InvalidAssocDefault)
-> AssocDefaultBadArgs -> InvalidAssocDefault
forall a b. (a -> b) -> a -> b
$ NonEmpty (Var, ForAllTyFlag) -> AssocDefaultBadArgs
AssocDefaultDuplicateTyVars NonEmpty (Var, ForAllTyFlag)
d)
        [NonEmpty (Var, ForAllTyFlag)]
dups

checkFamInstRhs :: TyCon -> [Type]         -- LHS
                -> [(TyCon, [Type])]       -- type family calls in RHS
                -> [TcRnMessage]
-- Ensure that the type family instance terminates. Specifically:
-- ensure that each type family application in the RHS is
--    (TF1) a call to a stuck family like (TypeError ...) or Any
--          See Note [Stuck type families] in GHC.Tc.Utils.TcType
-- or (TF2) obeys the Paterson conditions, namely:
--          - strictly smaller than the lhs,
--          - mentions no type variable more often than the lhs, and
--          - does not contain any further type family applications
checkFamInstRhs :: TyCon -> [Type] -> [(TyCon, [Type])] -> [TcRnMessage]
checkFamInstRhs TyCon
lhs_tc [Type]
lhs_tys [(TyCon, [Type])]
famInsts
  = ((TyCon, [Type]) -> Maybe TcRnMessage)
-> [(TyCon, [Type])] -> [TcRnMessage]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TyCon, [Type]) -> Maybe TcRnMessage
check [(TyCon, [Type])]
famInsts
  where
   lhs_size :: PatersonSize
lhs_size = [Type] -> PatersonSize
pSizeTypes [Type]
lhs_tys
   check :: (TyCon, [Type]) -> Maybe TcRnMessage
check (TyCon
tc, [Type]
tys)
      | Bool -> Bool
not (TyCon -> Bool
isStuckTypeFamily TyCon
tc)                                   -- (TF1)
      , Just PatersonCondFailure
pc_failure <- [Type] -> PatersonSize
pSizeTypes [Type]
tys PatersonSize -> PatersonSize -> Maybe PatersonCondFailure
`ltPatersonSize` PatersonSize
lhs_size  -- (TF2)
      = TcRnMessage -> Maybe TcRnMessage
forall a. a -> Maybe a
Just (TcRnMessage -> Maybe TcRnMessage)
-> TcRnMessage -> Maybe TcRnMessage
forall a b. (a -> b) -> a -> b
$ PatersonCondFailure
-> PatersonCondFailureContext -> Type -> Type -> TcRnMessage
TcRnPatersonCondFailure PatersonCondFailure
pc_failure PatersonCondFailureContext
InTyFamEquation (TyCon -> [Type] -> Type
TyConApp TyCon
lhs_tc [Type]
lhs_tys) (TyCon -> [Type] -> Type
TyConApp TyCon
tc [Type]
tys)
      | Bool
otherwise
      = Maybe TcRnMessage
forall a. Maybe a
Nothing

-----------------

-- | Perform scoping check on a type family equation.
--
-- See 'TyFamEqnValidityInfo'.
checkTyFamEqnValidityInfo :: TyCon -> TyFamEqnValidityInfo -> TcM ()
checkTyFamEqnValidityInfo :: TyCon -> TyFamEqnValidityInfo -> TcM ()
checkTyFamEqnValidityInfo TyCon
fam_tc = \ case
  TyFamEqnValidityInfo
NoVI -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  VI { vi_loc :: TyFamEqnValidityInfo -> SrcSpan
vi_loc          = SrcSpan
loc
     , vi_qtvs :: TyFamEqnValidityInfo -> [Var]
vi_qtvs         = [Var]
qtvs
     , vi_non_user_tvs :: TyFamEqnValidityInfo -> VarSet
vi_non_user_tvs = VarSet
non_user_tvs
     , vi_pats :: TyFamEqnValidityInfo -> [Type]
vi_pats         = [Type]
pats
     , vi_rhs :: TyFamEqnValidityInfo -> Type
vi_rhs          = Type
rhs } ->
    SrcSpan -> TcM () -> TcM ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
    TyCon -> [Var] -> VarSet -> [Type] -> Type -> TcM ()
checkFamPatBinders TyCon
fam_tc [Var]
qtvs VarSet
non_user_tvs [Type]
pats Type
rhs

-- | Check binders for a type or data family declaration.
--
-- Specifically, this function checks for:
--
--  - type variables used on the RHS but not bound (explicitly or implicitly)
--    in the LHS,
--  - variables bound by a forall in the LHS but not used in the RHS.
--
-- See Note [Check type family instance binders].
checkFamPatBinders :: TyCon
                   -> [TcTyVar]   -- ^ Bound on LHS of family instance
                   -> TyVarSet    -- ^ non-user-written tyvars
                   -> [TcType]    -- ^ LHS patterns
                   -> TcType      -- ^ RHS
                   -> TcM ()
checkFamPatBinders :: TyCon -> [Var] -> VarSet -> [Type] -> Type -> TcM ()
checkFamPatBinders TyCon
fam_tc [Var]
qtvs VarSet
non_user_tvs [Type]
pats Type
rhs
  = do { String -> SDoc -> TcM ()
traceTc String
"checkFamPatBinders" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Type -> SDoc
debugPprType (TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
pats)
              , Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
pats)
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rhs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"qtvs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
qtvs
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rhs_fvs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FV -> VarSet
fvVarSet FV
rhs_fvs)
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cpt_tvs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
cpt_tvs
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"inj_cpt_tvs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
inj_cpt_tvs
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bad_rhs_tvs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
bad_rhs_tvs
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bad_qtvs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((InvalidFamInstQTv -> Var) -> [InvalidFamInstQTv] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map InvalidFamInstQTv -> Var
ifiqtv [InvalidFamInstQTv]
bad_qtvs) ]

         -- Check for implicitly-bound tyvars, mentioned on the
         -- RHS but not bound on the LHS
         --    data T            = MkT (forall (a::k). blah)
         --    data family D Int = MkD (forall (a::k). blah)
         -- In both cases, 'k' is not bound on the LHS, but is used on the RHS
         -- We catch the former in kcDeclHeader, and the latter right here
         -- See Note [Check type family instance binders]
       ; (NonEmpty Name -> IllegalFamilyInstanceReason) -> [Name] -> TcM ()
forall {a}.
NamedThing a =>
(NonEmpty a -> IllegalFamilyInstanceReason) -> [a] -> TcM ()
check_tvs (Maybe (TyCon, [Type], VarSet)
-> NonEmpty Name -> IllegalFamilyInstanceReason
FamInstRHSOutOfScopeTyVars ((TyCon, [Type], VarSet) -> Maybe (TyCon, [Type], VarSet)
forall a. a -> Maybe a
Just (TyCon
fam_tc, [Type]
pats, VarSet
dodgy_tvs)))
                   ((Var -> Name) -> [Var] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Name
tyVarName [Var]
bad_rhs_tvs)

         -- Check for explicitly forall'd variable that is not bound on LHS
         --    data instance forall a.  T Int = MkT Int
         -- See Note [Unused explicitly bound variables in a family pattern]
         -- See Note [Check type family instance binders]
       ; (NonEmpty InvalidFamInstQTv -> IllegalFamilyInstanceReason)
-> [InvalidFamInstQTv] -> TcM ()
forall {a}.
NamedThing a =>
(NonEmpty a -> IllegalFamilyInstanceReason) -> [a] -> TcM ()
check_tvs NonEmpty InvalidFamInstQTv -> IllegalFamilyInstanceReason
FamInstLHSUnusedBoundTyVars [InvalidFamInstQTv]
bad_qtvs
       }
  where
    rhs_fvs :: FV
rhs_fvs = Type -> FV
tyCoFVsOfType Type
rhs

    cpt_tvs :: VarSet
cpt_tvs     = [Type] -> VarSet
tyCoVarsOfTypes [Type]
pats
    inj_cpt_tvs :: VarSet
inj_cpt_tvs = FV -> VarSet
fvVarSet (FV -> VarSet) -> FV -> VarSet
forall a b. (a -> b) -> a -> b
$ Bool -> [Type] -> FV
injectiveVarsOfTypes Bool
False [Type]
pats
      -- The type variables that are in injective positions.
      -- See Note [Dodgy binding sites in type family instances]
      -- NB: The False above is irrelevant, as we never have type families in
      -- patterns.
      --
      -- NB: It's OK to use the nondeterministic `fvVarSet` function here,
      -- since the order of `inj_cpt_tvs` is never revealed in an error
      -- message.

    -- Bound but not used at all
    bad_qtvs :: [InvalidFamInstQTv]
bad_qtvs    = (Var -> Maybe InvalidFamInstQTv) -> [Var] -> [InvalidFamInstQTv]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Var -> Maybe InvalidFamInstQTv
bad_qtv_maybe [Var]
qtvs

    bad_qtv_maybe :: Var -> Maybe InvalidFamInstQTv
bad_qtv_maybe Var
qtv
      | Bool
not_bound_in_pats
      = let reason :: InvalidFamInstQTvReason
reason
              | Bool
dodgy
              = InvalidFamInstQTvReason
InvalidFamInstQTvDodgy
              | Bool
used_in_rhs
              = InvalidFamInstQTvReason
InvalidFamInstQTvNotBoundInPats
              | Bool
otherwise
              = InvalidFamInstQTvReason
InvalidFamInstQTvNotUsedInRHS
        in InvalidFamInstQTv -> Maybe InvalidFamInstQTv
forall a. a -> Maybe a
Just (InvalidFamInstQTv -> Maybe InvalidFamInstQTv)
-> InvalidFamInstQTv -> Maybe InvalidFamInstQTv
forall a b. (a -> b) -> a -> b
$ InvalidFamInstQTv
                    { ifiqtv :: Var
ifiqtv = Var
qtv
                    , ifiqtv_user_written :: Bool
ifiqtv_user_written = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Var
qtv Var -> VarSet -> Bool
`elemVarSet` VarSet
non_user_tvs
                    , ifiqtv_reason :: InvalidFamInstQTvReason
ifiqtv_reason = InvalidFamInstQTvReason
reason
                    }
      | Bool
otherwise
      = Maybe InvalidFamInstQTv
forall a. Maybe a
Nothing
        where
          not_bound_in_pats :: Bool
not_bound_in_pats = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Var
qtv Var -> VarSet -> Bool
`elemVarSet` VarSet
inj_cpt_tvs
          dodgy :: Bool
dodgy             = Bool
not_bound_in_pats Bool -> Bool -> Bool
&& Var
qtv Var -> VarSet -> Bool
`elemVarSet` VarSet
cpt_tvs
          used_in_rhs :: Bool
used_in_rhs       = Var
qtv Var -> VarSet -> Bool
`elemVarSet` FV -> VarSet
fvVarSet FV
rhs_fvs

    -- Used on RHS but not bound on LHS
    bad_rhs_tvs :: [Var]
bad_rhs_tvs = (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ((Var -> VarSet -> Bool
`elemVarSet` VarSet
inj_cpt_tvs) (Var -> Bool) -> (Var -> Bool) -> Var -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Var -> [Var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Var]
qtvs)) (FV -> [Var]
fvVarList FV
rhs_fvs)

    dodgy_tvs :: VarSet
dodgy_tvs   = VarSet
cpt_tvs VarSet -> VarSet -> VarSet
`minusVarSet` VarSet
inj_cpt_tvs

    check_tvs :: (NonEmpty a -> IllegalFamilyInstanceReason) -> [a] -> TcM ()
check_tvs NonEmpty a -> IllegalFamilyInstanceReason
mk_err [a]
tvs
      = Maybe (NonEmpty a) -> (NonEmpty a -> TcM ()) -> TcM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [a]
tvs) ((NonEmpty a -> TcM ()) -> TcM ())
-> (NonEmpty a -> TcM ()) -> TcM ()
forall a b. (a -> b) -> a -> b
$ \ ne_tvs :: NonEmpty a
ne_tvs@(a
tv0 :| [a]
_) ->
        SrcSpan -> TcRnMessage -> TcM ()
addErrAt (a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
tv0) (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$
        IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$
        NonEmpty a -> IllegalFamilyInstanceReason
mk_err NonEmpty a
ne_tvs

-- | Checks that a list of type patterns is valid in a matching (LHS)
-- position of a class instances or type/data family instance.
--
-- Specifically:
--    * All monotypes
--    * No type-family applications
checkValidTypePats :: TyCon -> [Type] -> TcM ()
checkValidTypePats :: TyCon -> [Type] -> TcM ()
checkValidTypePats TyCon
tc [Type]
pat_ty_args
  = do { -- Check that each of pat_ty_args is a monotype.
         -- One could imagine generalising to allow
         --      instance C (forall a. a->a)
         -- but we don't know what all the consequences might be.
         (Type -> TcM ()) -> [Type] -> TcM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Type -> TcM ()
checkValidMonoType [Type]
pat_ty_args

       -- Ensure that no type family applications occur a type pattern
       ; case TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVis TyCon
tc [Type]
pat_ty_args of
            [] -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ((Bool
tf_is_invis_arg, TyCon
tf_tc, [Type]
tf_args):[(Bool, TyCon, [Type])]
_) ->
              TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
                Type -> Bool -> TyCon -> [Type] -> IllegalInstanceReason
IllegalFamilyApplicationInInstance Type
inst_ty
                  Bool
tf_is_invis_arg TyCon
tf_tc [Type]
tf_args }
  where
    inst_ty :: Type
inst_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
pat_ty_args

-------------------------
checkConsistentFamInst :: AssocInstInfo
                       -> TyCon     -- ^ Family tycon
                       -> CoAxBranch
                       -> TcM ()
-- See Note [Checking consistent instantiation]

checkConsistentFamInst :: AssocInstInfo -> TyCon -> CoAxBranch -> TcM ()
checkConsistentFamInst AssocInstInfo
NotAssociated TyCon
_ CoAxBranch
_
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkConsistentFamInst (InClsInst { ai_class :: AssocInstInfo -> Class
ai_class = Class
clas
                                  , ai_tyvars :: AssocInstInfo -> [Var]
ai_tyvars = [Var]
inst_tvs
                                  , ai_inst_env :: AssocInstInfo -> VarEnv Type
ai_inst_env = VarEnv Type
mini_env })
                       TyCon
fam_tc CoAxBranch
branch
  = do { String -> SDoc -> TcM ()
traceTc String
"checkConsistentFamInst" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
inst_tvs
                                                , [(Type, Type, ForAllTyFlag)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Type, Type, ForAllTyFlag)]
arg_triples
                                                , VarEnv Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarEnv Type
mini_env
                                                , [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
ax_tvs
                                                , [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
ax_arg_tys
                                                , [(Type, Type, ForAllTyFlag)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Type, Type, ForAllTyFlag)]
arg_triples ])
       -- Check that the associated type indeed comes from this class
       -- See [Mismatched class methods and associated type families]
       -- in TcInstDecls.
       ; Bool -> TcRnMessage -> TcM ()
checkTc (TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just (Class -> TyCon
classTyCon Class
clas) Maybe TyCon -> Maybe TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Maybe TyCon
tyConAssoc_maybe TyCon
fam_tc) (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$
          IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$
            InvalidAssoc -> IllegalFamilyInstanceReason
InvalidAssoc (InvalidAssoc -> IllegalFamilyInstanceReason)
-> InvalidAssoc -> IllegalFamilyInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssocInstance -> InvalidAssoc
InvalidAssocInstance (InvalidAssocInstance -> InvalidAssoc)
-> InvalidAssocInstance -> InvalidAssoc
forall a b. (a -> b) -> a -> b
$
            Class -> TyCon -> InvalidAssocInstance
AssocNotInThisClass Class
clas TyCon
fam_tc

       ; [(Type, Type, ForAllTyFlag)] -> TcM ()
check_match [(Type, Type, ForAllTyFlag)]
arg_triples
       }
  where
    ([Var]
ax_tvs, [Type]
ax_arg_tys, Type
_) = CoAxBranch -> ([Var], [Type], Type)
etaExpandCoAxBranch CoAxBranch
branch

    arg_triples :: [(Type,Type, ForAllTyFlag)]
    arg_triples :: [(Type, Type, ForAllTyFlag)]
arg_triples = [ (Type
cls_arg_ty, Type
at_arg_ty, ForAllTyFlag
vis)
                  | (Var
fam_tc_tv, ForAllTyFlag
vis, Type
at_arg_ty)
                       <- [Var] -> [ForAllTyFlag] -> [Type] -> [(Var, ForAllTyFlag, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (TyCon -> [Var]
tyConTyVars TyCon
fam_tc)
                               (TyCon -> [Type] -> [ForAllTyFlag]
tyConForAllTyFlags TyCon
fam_tc [Type]
ax_arg_tys)
                               [Type]
ax_arg_tys
                  , Just Type
cls_arg_ty <- [VarEnv Type -> Var -> Maybe Type
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv VarEnv Type
mini_env Var
fam_tc_tv] ]

    -- Fiddling around to arrange that wildcards unconditionally print as "_"
    -- We only need to print the LHS, not the RHS at all
    -- See Note [Printing conflicts with class header]
    (TidyEnv
tidy_env1, [Var]
_) = TidyEnv -> [Var] -> (TidyEnv, [Var])
tidyVarBndrs TidyEnv
emptyTidyEnv [Var]
inst_tvs
    (TidyEnv
tidy_env2, [Var]
_) = TidyEnv -> [Var] -> (TidyEnv, [Var])
tidyCoAxBndrsForUser TidyEnv
tidy_env1 ([Var]
ax_tvs [Var] -> [Var] -> [Var]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Var]
inst_tvs)

    mk_wildcard :: Var -> Type
mk_wildcard Var
at_tv = Var -> Type
mkTyVarTy (Name -> Type -> Var
mkTyVar Name
tv_name (Var -> Type
tyVarKind Var
at_tv))
    tv_name :: Name
tv_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Int -> Unique
mkAlphaTyVarUnique Int
1) (FastString -> OccName
mkTyVarOccFS (String -> FastString
fsLit String
"_")) SrcSpan
noSrcSpan

    -- For check_match, bind_me, see
    -- Note [Matching in the consistent-instantiation check]
    check_match :: [(Type,Type,ForAllTyFlag)] -> TcM ()
    check_match :: [(Type, Type, ForAllTyFlag)] -> TcM ()
check_match [(Type, Type, ForAllTyFlag)]
triples = Subst -> Subst -> [(Type, Type, ForAllTyFlag)] -> TcM ()
go Subst
emptySubst Subst
emptySubst [(Type, Type, ForAllTyFlag)]
triples

    go :: Subst -> Subst -> [(Type, Type, ForAllTyFlag)] -> TcM ()
go Subst
_ Subst
_ [] = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go Subst
lr_subst Subst
rl_subst ((Type
ty1,Type
ty2,ForAllTyFlag
vis):[(Type, Type, ForAllTyFlag)]
triples)
      | Just Subst
lr_subst1 <- BindFun -> Subst -> Type -> Type -> Maybe Subst
tcMatchTyX_BM BindFun
bind_me Subst
lr_subst Type
ty1 Type
ty2
      , Just Subst
rl_subst1 <- BindFun -> Subst -> Type -> Type -> Maybe Subst
tcMatchTyX_BM BindFun
bind_me Subst
rl_subst Type
ty2 Type
ty1
      = Subst -> Subst -> [(Type, Type, ForAllTyFlag)] -> TcM ()
go Subst
lr_subst1 Subst
rl_subst1 [(Type, Type, ForAllTyFlag)]
triples
      | Bool
otherwise
      = TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance
                 (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssoc -> IllegalFamilyInstanceReason
InvalidAssoc (InvalidAssoc -> IllegalFamilyInstanceReason)
-> InvalidAssoc -> IllegalFamilyInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssocInstance -> InvalidAssoc
InvalidAssocInstance
                 (InvalidAssocInstance -> InvalidAssoc)
-> InvalidAssocInstance -> InvalidAssoc
forall a b. (a -> b) -> a -> b
$ ForAllTyFlag -> TyCon -> [Type] -> [Type] -> InvalidAssocInstance
AssocTyVarsDontMatch ForAllTyFlag
vis TyCon
fam_tc [Type]
exp_tys [Type]
act_tys

    -- Expected/actual family argument types (for error messages)
    exp_tys :: [Type]
exp_tys =
      [ case VarEnv Type -> Var -> Maybe Type
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv VarEnv Type
mini_env Var
at_tv of
          Just Type
cls_arg_ty -> TidyEnv -> Type -> Type
tidyType TidyEnv
tidy_env2 Type
cls_arg_ty
          Maybe Type
Nothing         -> Var -> Type
mk_wildcard Var
at_tv
      | Var
at_tv <- TyCon -> [Var]
tyConTyVars TyCon
fam_tc ]
    act_tys :: [Type]
act_tys = TidyEnv -> [Type] -> [Type]
tidyTypes TidyEnv
tidy_env2 [Type]
ax_arg_tys

    -- The /scoped/ type variables from the class-instance header
    -- should not be alpha-renamed.  Inferred ones can be.
    no_bind_set :: VarSet
no_bind_set = [Var] -> VarSet
mkVarSet [Var]
inst_tvs
    bind_me :: BindFun
bind_me Var
tv Type
_ty | Var
tv Var -> VarSet -> Bool
`elemVarSet` VarSet
no_bind_set = BindFlag
Apart
                   | Bool
otherwise                   = BindFlag
BindMe


{- Note [Check type family instance binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a type family instance, we require (of course), type variables
used on the RHS are matched on the LHS. This is checked by
checkFamPatBinders.  Here is an interesting example:

    type family   T :: k
    type instance T = (Nothing :: Maybe a)

Upon a cursory glance, it may appear that the kind variable `a` is unbound
since there are no (visible) LHS patterns in `T`. However, there is an
*invisible* pattern due to the return kind, so inside of GHC, the instance
looks closer to this:

    type family T @k :: k
    type instance T @(Maybe a) = (Nothing :: Maybe a)

Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in
fact not unbound. Contrast that with this example (#13985)

    type instance T = Proxy (Nothing :: Maybe a)

This would looks like this inside of GHC:

    type instance T @(*) = Proxy (Nothing :: Maybe a)

So this time, `a` is neither bound by a visible nor invisible type pattern on
the LHS, so `a` would be reported as not in scope.

Finally, here's one more brain-teaser (from #9574). In the example below:

    class Funct f where
      type Codomain f :: *
    instance Funct ('KProxy :: KProxy o) where
      type Codomain 'KProxy = NatTr (Proxy :: o -> *)

As it turns out, `o` is in scope in this example. That is because `o` is
bound by the kind signature of the LHS type pattern 'KProxy. To make this more
obvious, one can also write the instance like so:

    instance Funct ('KProxy :: KProxy o) where
      type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)

Note [Dodgy binding sites in type family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following example (from #7536):

  type T a = Int
  type instance F (T a) = a

This `F` instance is extremely fishy, since the RHS, `a`, purports to be
"bound" by the LHS pattern `T a`. "Bound" has scare quotes around it because
`T a` expands to `Int`, which doesn't mention at all, so it's as if one had
actually written:

  type instance F Int = a

That is clearly bogus, so to reject this, we check that every type variable
that is mentioned on the RHS is /actually/ bound on the LHS. In other words,
we need to do something slightly more sophisticated that just compute the free
variables of the LHS patterns.

It's tempting to just expand all type synonyms on the LHS and then compute
their free variables, but even that isn't sophisticated enough. After all,
an impish user could write the following (#17008):

  type family ConstType (a :: Type) :: Type where
    ConstType _ = Type

  type family F (x :: ConstType a) :: Type where
    F (x :: ConstType a) = a

Just like in the previous example, the `a` on the RHS isn't actually bound
on the LHS, but this time a type family is responsible for the deception, not
a type synonym.

We avoid both issues by requiring that all RHS type variables are mentioned
in injective positions on the left-hand side (by way of
`injectiveVarsOfTypes`). For instance, the `a` in `T a` is not in an injective
position, as `T` is not an injective type constructor, so we do not count that.
Similarly for the `a` in `ConstType a`.

Note [Matching in the consistent-instantiation check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Matching the class-instance header to family-instance tyvars is
tricker than it sounds.  Consider (#13972)
    class C (a :: k) where
      type T k :: Type
    instance C Left where
      type T (a -> Either a b) = Int

Here there are no lexically-scoped variables from (C Left).
Yet the real class-instance header is   C @(p -> Either @p @q)) (Left @p @q)
while the type-family instance is       T (a -> Either @a @b)
So we allow alpha-renaming of variables that don't come
from the class-instance header.

We track the lexically-scoped type variables from the
class-instance header in ai_tyvars.

Here's another example (#14045a)
    class C (a :: k) where
      data S (a :: k)
    instance C (z :: Bool) where
      data S :: Bool -> Type where

Again, there is no lexical connection, but we will get
   class-instance header:   C @Bool (z::Bool)
   family instance          S @Bool (a::Bool)

When looking for mis-matches, we check left-to-right,
kinds first.  If we look at types first, we'll fail to
suggest -fprint-explicit-kinds for a mis-match with
      T @k    vs    T @Type
somewhere deep inside the type

Note [Checking consistent instantiation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #11450 for background discussion on this check.

  class C a b where
    type T a x b

With this class decl, if we have an instance decl
  instance C ty1 ty2 where ...
then the type instance must look like
     type T ty1 v ty2 = ...
with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'.
For example:

  instance C [p] Int
    type T [p] y Int = (p,y,y)

Note that

* We used to allow completely different bound variables in the
  associated type instance; e.g.
    instance C [p] Int
      type T [q] y Int = ...
  But from GHC 8.2 onwards, we don't.  It's much simpler this way.
  See #11450.

* When the class variable isn't used on the RHS of the type instance,
  it's tempting to allow wildcards, thus
    instance C [p] Int
      type T [_] y Int = (y,y)
  But it's awkward to do the test, and it doesn't work if the
  variable is repeated:
    instance C (p,p) Int
      type T (_,_) y Int = (y,y)
  Even though 'p' is not used on the RHS, we still need to use 'p'
  on the LHS to establish the repeated pattern.  So to keep it simple
  we just require equality.

* For variables in associated type families that are not bound by the class
  itself, we do _not_ check if they are over-specific. In other words,
  it's perfectly acceptable to have an instance like this:

    instance C [p] Int where
      type T [p] (Maybe x) Int = x

  While the first and third arguments to T are required to be exactly [p] and
  Int, respectively, since they are bound by C, the second argument is allowed
  to be more specific than just a type variable. Furthermore, it is permissible
  to define multiple equations for T that differ only in the non-class-bound
  argument:

    instance C [p] Int where
      type T [p] (Maybe x)    Int = x
      type T [p] (Either x y) Int = x -> y

  We once considered requiring that non-class-bound variables in associated
  type family instances be instantiated with distinct type variables. However,
  that requirement proved too restrictive in practice, as there were examples
  of extremely simple associated type family instances that this check would
  reject, and fixing them required tiresome boilerplate in the form of
  auxiliary type families. For instance, you would have to define the above
  example as:

    instance C [p] Int where
      type T [p] x Int = CAux x

    type family CAux x where
      CAux (Maybe x)    = x
      CAux (Either x y) = x -> y

  We decided that this restriction wasn't buying us much, so we opted not
  to pursue that design (see also GHC #13398).

Implementation
  * Form the mini-envt from the class type variables a,b
    to the instance decl types [p],Int:   [a->[p], b->Int]

  * Look at the tyvars a,x,b of the type family constructor T
    (it shares tyvars with the class C)

  * Apply the mini-evnt to them, and check that the result is
    consistent with the instance types [p] y Int. (where y can be any type, as
    it is not scoped over the class type variables.

We make all the instance type variables scope over the
type instances, of course, which picks up non-obvious kinds.  Eg
   class Foo (a :: k) where
      type F a
   instance Foo (b :: k -> k) where
      type F b = Int
Here the instance is kind-indexed and really looks like
      type F (k->k) (b::k->k) = Int
But if the 'b' didn't scope, we would make F's instance too
poly-kinded.

Note [Printing conflicts with class header]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's remarkably painful to give a decent error message for conflicts
with the class header.  Consider
   class C b where
     type F a b c
   instance C [b] where
     type F x Int _ _ = ...

Here we want to report a conflict between
    Expected: F _ [b] _
    Actual:   F x Int _ _

But if the type instance shadows the class variable like this
(rename/should_fail/T15828):
   instance C [b] where
     type forall b. F x (Tree b) _ _ = ...

then we must use a fresh variable name
    Expected: F _ [b] _
    Actual:   F x [b1] _ _

Notice that:
  - We want to print an underscore in the "Expected" type in
    positions where the class header has no influence over the
    parameter.  Hence the fancy footwork in pp_expected_ty

  - Although the binders in the axiom are already tidy, we must
    re-tidy them to get a fresh variable name when we shadow

  - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the
    class-instance variables a second time, from 'a' to 'a1' say.
    Remember, the ax_tvs of the axiom share identity with the
    class-instance variables, inst_tvs..

  - We use tidyCoAxBndrsForUser to get underscores rather than
    _1, _2, etc in the axiom tyvars; see the definition of
    tidyCoAxBndrsForUser

This all seems absurdly complicated.

Note [Unused explicitly bound variables in a family pattern]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Why is 'unusedExplicitForAllErr' not just a warning?

Consider the following examples:

  type instance F a = Maybe b
  type instance forall b. F a = Bool
  type instance forall b. F a = Maybe b

In every case, b is a type variable not determined by the LHS pattern. The
first is caught by the renamer, but we catch the last two here. Perhaps one
could argue that the second should be accepted, albeit with a warning, but
consider the fact that in a type family instance, there is no way to interact
with such a variable. At least with @x :: forall a. Int@ we can use visible
type application, like @x \@Bool 1@. (Of course it does nothing, but it is
permissible.) In the type family case, the only sensible explanation is that
the user has made a mistake -- thus we throw an error.

Note [Oversaturated type family equations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Type family tycons have very rigid arities. We want to reject something like
this:

  type family Foo :: Type -> Type where
    Foo x = ...

Because Foo has arity zero (i.e., it doesn't bind anything to the left of the
double colon), we want to disallow any equation for Foo that has more than zero
arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an
equation has more arguments than the arity of the type family, reject.

Things get trickier when visible kind application enters the picture. Consider
the following example:

  type family Bar (x :: j) :: forall k. Either j k where
    Bar 5 @Symbol = ...

The arity of Bar is two, since it binds two variables, `j` and `x`. But even
though Bar's equation has two arguments, it's still invalid. Imagine the same
equation in Core:

    Bar Nat 5 Symbol = ...

Here, it becomes apparent that Bar is actually taking /three/ arguments! So
we can't just rely on a simple counting argument to reject
`Bar 5 @Symbol = ...`, since it only has two user-written arguments.
Moreover, there's one explicit argument (5) and one visible kind argument
(@Symbol), which matches up perfectly with the fact that Bar has one required
binder (x) and one specified binder (j), so that's not a valid way to detect
oversaturation either.

To solve this problem in a robust way, we do the following:

1. When kind-checking, we count the number of user-written *required*
   arguments and check if there is an equal number of required tycon binders.
   If not, reject. (See `wrongNumberOfParmsErr` in GHC.Tc.TyCl.)

   We perform this step during kind-checking, not during validity checking,
   since we can give better error messages if we catch it early.
2. When validity checking, take all of the (Core) type patterns from on
   equation, drop the first n of them (where n is the arity of the type family
   tycon), and check if there are any types leftover. If so, reject.

   Why does this work? We know that after dropping the first n type patterns,
   none of the leftover types can be required arguments, since step (1) would
   have already caught that. Moreover, the only places where visible kind
   applications should be allowed are in the first n types, since those are the
   only arguments that can correspond to binding forms. Therefore, the
   remaining arguments must correspond to oversaturated uses of visible kind
   applications, which are precisely what we want to reject.

Note that we only perform this check for type families, and not for data
families. This is because it is perfectly acceptable to oversaturate data
family instance equations: see Note [Arity of data families] in GHC.Core.FamInstEnv.

************************************************************************
*                                                                      *
   Telescope checking
*                                                                      *
************************************************************************

Note [Bad TyCon telescopes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Now that we can mix type and kind variables, there are an awful lot of
ways to shoot yourself in the foot. Here are some.

  data SameKind :: k -> k -> *   -- just to force unification

1.  data T1 a k (b :: k) (x :: SameKind a b)

The problem here is that we discover that a and b should have the same
kind. But this kind mentions k, which is bound *after* a.
(Testcase: dependent/should_fail/BadTelescope)

2.  data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)

Note that b is not bound. Yet its kind mentions a. Because we have
a nice rule that all implicitly bound variables come before others,
this is bogus.

To catch these errors, we call checkTyConTelescope during kind-checking
datatype declarations.  This checks for

* Ill-scoped binders. From (1) and (2) above we can get putative
  kinds like
       T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> *
  where 'k' is mentioned a's kind before k is bound

  This is easy to check for: just look for
  out-of-scope variables in the kind

* We should arguably also check for ambiguous binders
  but we don't.  See Note [Ambiguous kind vars].

See also
  * Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl.
  * Note [Checking telescopes] in GHC.Tc.Types.Constraint discusses how
    this check works for `forall x y z.` written in a type.

Note [Ambiguous kind vars]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to be concerned about ambiguous binders. Suppose we have the kind
     S1 :: forall k -> * -> *
     S2 :: forall k. * -> *
Here S1 is OK, because k is Required, and at a use of S1 we will
see (S1 *) or (S1 (*->*)) or whatever.

But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and
we have no way (ever) to figure out how 'k' should be instantiated.
For example if we see (S2 Int), that tells us nothing about k's
instantiation.  (In this case we'll instantiate it to Any, but that
seems wrong.)  This is really the same test as we make for ambiguous
type in term type signatures.

Now, it's impossible for a Specified variable not to occur
at all in the kind -- after all, it is Specified so it must have
occurred.  (It /used/ to be possible; see tests T13983 and T7873.  But
with the advent of the forall-or-nothing rule for kind variables,
those strange cases went away. See Note [forall-or-nothing rule] in
GHC.Hs.Type.)

But one might worry about
    type v k = *
    S3 :: forall k. V k -> *
which appears to mention 'k' but doesn't really.  Or
    S4 :: forall k. F k -> *
where F is a type function.  But we simply don't check for
those cases of ambiguity, yet anyway.  The worst that can happen
is ambiguity at the call sites.

Historical note: this test used to be called reportFloatingKvs.
-}

-- | Check a list of binders to see if they make a valid telescope.
-- See Note [Bad TyCon telescopes]
type TelescopeAcc
      = ( TyVarSet   -- Bound earlier in the telescope
        , Bool       -- At least one binder occurred (in a kind) before
                     -- it was bound in the telescope.  E.g.
        )            --    T :: forall (a::k) k. blah

checkTyConTelescope :: TyCon -> TcM ()
checkTyConTelescope :: TyCon -> TcM ()
checkTyConTelescope TyCon
tc
  | Bool
bad_scope
  = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes]
    TcRnMessage -> TcM ()
addErr (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ TyCon -> TcRnMessage
TcRnBadTyConTelescope TyCon
tc

  | Bool
otherwise
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    tcbs :: [VarBndr Var TyConBndrVis]
tcbs = TyCon -> [VarBndr Var TyConBndrVis]
tyConBinders TyCon
tc

    (VarSet
_, Bool
bad_scope) = ((VarSet, Bool) -> VarBndr Var TyConBndrVis -> (VarSet, Bool))
-> (VarSet, Bool) -> [VarBndr Var TyConBndrVis] -> (VarSet, Bool)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (VarSet, Bool) -> VarBndr Var TyConBndrVis -> (VarSet, Bool)
add_one (VarSet
emptyVarSet, Bool
False) [VarBndr Var TyConBndrVis]
tcbs

    add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc
    add_one :: (VarSet, Bool) -> VarBndr Var TyConBndrVis -> (VarSet, Bool)
add_one (VarSet
bound, Bool
bad_scope) VarBndr Var TyConBndrVis
tcb
      = ( VarSet
bound VarSet -> Var -> VarSet
`extendVarSet` Var
tv
        , Bool
bad_scope Bool -> Bool -> Bool
|| Bool -> Bool
not (VarSet -> Bool
isEmptyVarSet (VarSet
fkvs VarSet -> VarSet -> VarSet
`minusVarSet` VarSet
bound)) )
      where
        tv :: Var
tv = VarBndr Var TyConBndrVis -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar VarBndr Var TyConBndrVis
tcb
        fkvs :: VarSet
fkvs = Type -> VarSet
tyCoVarsOfType (Var -> Type
tyVarKind Var
tv)