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

{-# LANGUAGE CPP, TupleSections, ViewPatterns #-}

module TcValidity (
  Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
  checkValidTheta,
  checkValidInstance, checkValidInstHead, validDerivPred,
  checkTySynRhs,
  checkValidCoAxiom, checkValidCoAxBranch,
  checkValidTyFamEqn, checkConsistentFamInst,
  badATErr, arityErr,
  checkValidTelescope,
  allDistinctTyVars
  ) where

#include "HsVersions.h"

import GhcPrelude

import Maybes

-- friends:
import TcUnify    ( tcSubType_NC )
import TcSimplify ( simplifyAmbiguityCheck )
import ClsInst    ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) )
import TyCoRep
import TcType hiding ( sizeType, sizeTypes )
import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName )
import PrelNames
import Type
import Unify      ( tcMatchTyX_BM, BindFlag(..) )
import Coercion
import CoAxiom
import Class
import TyCon

-- others:
import IfaceType( pprIfaceType, pprIfaceTypeApp )
import ToIface( toIfaceType, toIfaceTyCon, toIfaceTcArgs )
import HsSyn            -- HsType
import TcRnMonad        -- TcType, amongst others
import TcEnv       ( tcInitTidyEnv, tcInitOpenTidyEnv )
import FunDeps
import FamInstEnv  ( isDominatedBy, injectiveBranches,
                     InjectivityCheckResult(..) )
import FamInst     ( makeInjectivityErrors )
import Name
import VarEnv
import VarSet
import Var         ( VarBndr(..), mkTyVar )
import Id          ( idType, idName )
import FV
import ErrUtils
import DynFlags
import Util
import ListSetOps
import SrcLoc
import Outputable
import Unique      ( mkAlphaTyVarUnique )
import Bag         ( emptyBag )
import qualified GHC.LanguageExtensions as LangExt

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

{-
************************************************************************
*                                                                      *
          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 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 TcBinds.

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

What about this, though?
   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*.

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 Trac #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 inteface 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 'FunDeps.grow'.
-}

checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
checkAmbiguity ctxt :: UserTypeCtxt
ctxt ty :: Type
ty
  | UserTypeCtxt -> Bool
wantAmbiguityCheck UserTypeCtxt
ctxt
  = do { String -> SDoc -> TcM ()
traceTc "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
       ; Bool
allow_ambiguous <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.AllowAmbiguousTypes
       ; (_wrap :: HsWrapper
_wrap, wanted :: WantedConstraints
wanted) <- SDoc
-> TcM (HsWrapper, WantedConstraints)
-> TcM (HsWrapper, WantedConstraints)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Bool -> SDoc
mk_msg Bool
allow_ambiguous) (TcM (HsWrapper, WantedConstraints)
 -> TcM (HsWrapper, WantedConstraints))
-> TcM (HsWrapper, WantedConstraints)
-> TcM (HsWrapper, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                            TcM HsWrapper -> TcM (HsWrapper, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM HsWrapper -> TcM (HsWrapper, WantedConstraints))
-> TcM HsWrapper -> TcM (HsWrapper, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                            UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSubType_NC UserTypeCtxt
ctxt Type
ty Type
ty
       ; Type -> WantedConstraints -> TcM ()
simplifyAmbiguityCheck Type
ty WantedConstraints
wanted

       ; String -> SDoc -> TcM ()
traceTc "Done ambiguity check for" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) }

  | Bool
otherwise
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where
   mk_msg :: Bool -> SDoc
mk_msg allow_ambiguous :: Bool
allow_ambiguous
     = [SDoc] -> SDoc
vcat [ String -> SDoc
text "In the ambiguity check for" SDoc -> SDoc -> SDoc
<+> SDoc
what
            , Bool -> SDoc -> SDoc
ppUnless Bool
allow_ambiguous SDoc
ambig_msg ]
   ambig_msg :: SDoc
ambig_msg = String -> SDoc
text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"
   what :: SDoc
what | Just n :: 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 ctxt :: UserTypeCtxt
ctxt
  = case UserTypeCtxt
ctxt of  -- See Note [When we don't check for ambiguity]
      GhciCtxt {}  -> Bool
False
      TySynCtxt {} -> Bool
False
      TypeAppCtxt  -> Bool
False
      _            -> Bool
True

checkUserTypeError :: Type -> TcM ()
-- Check to see if the type signature mentions "TypeError blah"
-- anywhere in it, and fail if so.
--
-- Very unsatisfactorily (Trac #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 :: Type -> TcM ()
checkUserTypeError = Type -> TcM ()
check
  where
  check :: Type -> TcM ()
check ty :: Type
ty
    | Just msg :: Type
msg     <- Type -> Maybe Type
userTypeError_maybe Type
ty  = Type -> TcM ()
forall b. Type -> IOEnv (Env TcGblEnv TcLclEnv) b
fail_with Type
msg
    | Just (_,ts :: [Type]
ts)  <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty  = (Type -> TcM ()) -> [Type] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Type -> TcM ()
check [Type]
ts
    | Just (t1 :: Type
t1,t2 :: Type
t2) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ty     = Type -> TcM ()
check Type
t1 TcM () -> TcM () -> TcM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> TcM ()
check Type
t2
    | Just (_,t1 :: Type
t1)  <- Type -> Maybe (TyCoVar, Type)
splitForAllTy_maybe Type
ty  = Type -> TcM ()
check Type
t1
    | Bool
otherwise                               = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  fail_with :: Type -> IOEnv (Env TcGblEnv TcLclEnv) b
fail_with msg :: Type
msg = do { TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
                     ; let (env1 :: TidyEnv
env1, tidy_msg :: Type
tidy_msg) = TidyEnv -> Type -> (TidyEnv, Type)
tidyOpenType TidyEnv
env0 Type
msg
                     ; (TidyEnv, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) b
forall a. (TidyEnv, SDoc) -> TcM a
failWithTcM (TidyEnv
env1, Type -> SDoc
pprUserTypeErrorTy Type
tidy_msg) }


{- 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 (Trac #11608).  In the RHS of
  a type synonym we don't (currently) instantiate 'a' and 'b' with
  TcTyVars before calling checkValidType, so we get asertion 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


************************************************************************
*                                                                      *
          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
-- Not used for instance decls; checkValidInstance instead
checkValidType :: UserTypeCtxt -> Type -> TcM ()
checkValidType ctxt :: UserTypeCtxt
ctxt ty :: Type
ty
  = do { String -> SDoc -> TcM ()
traceTc "checkValidType" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "::" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty))
       ; Bool
rankn_flag  <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RankNTypes
       ; Bool
impred_flag <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ImpredicativeTypes
       ; let gen_rank :: Rank -> Rank
             gen_rank :: Rank -> Rank
gen_rank r :: Rank
r | Bool
rankn_flag = Rank
ArbitraryRank
                        | Bool
otherwise  = Rank
r

             rank1 :: Rank
rank1 = Rank -> Rank
gen_rank Rank
r1
             rank0 :: Rank
rank0 = Rank -> Rank
gen_rank Rank
r0

             r0 :: Rank
r0 = Rank
rankZeroMonoType
             r1 :: Rank
r1 = Bool -> Rank -> Rank
LimitedRank Bool
True Rank
r0

             rank :: Rank
rank
               = case UserTypeCtxt
ctxt of
                 DefaultDeclCtxt-> Rank
MustBeMonoType
                 ResSigCtxt     -> Rank
MustBeMonoType
                 PatSigCtxt     -> Rank
rank0
                 RuleSigCtxt _  -> Rank
rank1
                 TySynCtxt _    -> Rank
rank0

                 ExprSigCtxt    -> Rank
rank1
                 KindSigCtxt    -> Rank
rank1
                 TypeAppCtxt | Bool
impred_flag -> Rank
ArbitraryRank
                             | Bool
otherwise   -> Rank
tyConArgMonoType
                    -- 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
ArbitraryRank        -- Inferred type
                 ConArgCtxt _   -> Rank
rank1 -- We are given the type of the entire
                                         -- constructor, hence rank 1
                 PatSynCtxt _   -> Rank
rank1

                 ForSigCtxt _   -> Rank
rank1
                 SpecInstCtxt   -> Rank
rank1
                 ThBrackCtxt    -> Rank
rank1
                 GhciCtxt {}    -> Rank
ArbitraryRank

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

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

       ; TidyEnv
env <- [TyCoVar] -> TcM TidyEnv
tcInitOpenTidyEnv (Type -> [TyCoVar]
tyCoVarsOfTypeList Type
ty)
       ; ExpandMode
expand <- TcM ExpandMode
initialExpandMode
       ; let ve :: ValidityEnv
ve = ValidityEnv :: TidyEnv -> UserTypeCtxt -> Rank -> ExpandMode -> ValidityEnv
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
       ; TcM () -> TcM ()
forall r. TcM r -> TcM r
checkNoErrs (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
         do { ValidityEnv -> Type -> TcM ()
check_type ValidityEnv
ve Type
ty
            ; Type -> TcM ()
checkUserTypeError Type
ty
            ; String -> SDoc -> TcM ()
traceTc "done ct" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
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
       ; UserTypeCtxt -> Type -> TcM ()
checkAmbiguity UserTypeCtxt
ctxt Type
ty

       ; String -> SDoc -> TcM ()
traceTc "checkValidType done" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "::" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty)) }

checkValidMonoType :: Type -> TcM ()
-- Assumes argument is fully zonked
checkValidMonoType :: Type -> TcM ()
checkValidMonoType ty :: Type
ty
  = do { TidyEnv
env <- [TyCoVar] -> TcM TidyEnv
tcInitOpenTidyEnv (Type -> [TyCoVar]
tyCoVarsOfTypeList Type
ty)
       ; ExpandMode
expand <- TcM ExpandMode
initialExpandMode
       ; let ve :: ValidityEnv
ve = ValidityEnv :: TidyEnv -> UserTypeCtxt -> Rank -> ExpandMode -> ValidityEnv
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 }
       ; ValidityEnv -> Type -> TcM ()
check_type ValidityEnv
ve Type
ty }

checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()
checkTySynRhs :: UserTypeCtxt -> Type -> TcM ()
checkTySynRhs ctxt :: UserTypeCtxt
ctxt ty :: Type
ty
  | Type -> Bool
tcReturnsConstraintKind Type
actual_kind
  = do { Bool
ck <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ConstraintKinds
       ; if Bool
ck
         then  Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Type -> Bool
tcIsConstraintKind Type
actual_kind)
                    (do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                        ; ExpandMode
expand <- TcM ExpandMode
initialExpandMode
                        ; TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode -> Type -> TcM ()
check_pred_ty TidyEnv
emptyTidyEnv DynFlags
dflags UserTypeCtxt
ctxt ExpandMode
expand Type
ty })
         else (TidyEnv, SDoc) -> TcM ()
addErrTcM (TidyEnv -> Type -> (TidyEnv, SDoc)
constraintSynErr TidyEnv
emptyTidyEnv Type
actual_kind) }

  | Bool
otherwise
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    actual_kind :: Type
actual_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty

{-
Note [Higher rank types]
~~~~~~~~~~~~~~~~~~~~~~~~
Technically
            Int -> forall a. a->a
is still a rank-1 type, but it's not Haskell 98 (Trac #5957).  So the
validity checker allow a forall after an arrow only if we allow it
before -- that is, with Rank2Types or RankNTypes
-}

data Rank = ArbitraryRank         -- Any rank ok

          | LimitedRank   -- Note [Higher rank types]
                 Bool     -- Forall ok at top
                 Rank     -- Use for function arguments

          | MonoType SDoc   -- Monotype, with a suggestion of how it could be a polytype

          | MustBeMonoType  -- Monotype regardless of flags

instance Outputable Rank where
  ppr :: Rank -> SDoc
ppr ArbitraryRank  = String -> SDoc
text "ArbitraryRank"
  ppr (LimitedRank top_forall_ok :: Bool
top_forall_ok r :: Rank
r)
                     = String -> SDoc
text "LimitedRank" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
top_forall_ok
                                          SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (Rank -> SDoc
forall a. Outputable a => a -> SDoc
ppr Rank
r)
  ppr (MonoType msg :: SDoc
msg) = String -> SDoc
text "MonoType" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens SDoc
msg
  ppr MustBeMonoType = String -> SDoc
text "MustBeMonoType"

rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank
rankZeroMonoType :: Rank
rankZeroMonoType   = SDoc -> Rank
MonoType (String -> SDoc
text "Perhaps you intended to use RankNTypes")
tyConArgMonoType :: Rank
tyConArgMonoType   = SDoc -> Rank
MonoType (String -> SDoc
text "GHC doesn't yet support impredicative polymorphism")
synArgMonoType :: Rank
synArgMonoType     = SDoc -> Rank
MonoType (String -> SDoc
text "Perhaps you intended to use LiberalTypeSynonyms")
constraintMonoType :: Rank
constraintMonoType = SDoc -> Rank
MonoType ([SDoc] -> SDoc
vcat [ String -> SDoc
text "A constraint must be a monotype"
                                    , String -> SDoc
text "Perhaps you intended to use QuantifiedConstraints" ])

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

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

constraintsAllowed :: UserTypeCtxt -> Bool
-- We don't allow constraints in kinds
constraintsAllowed :: UserTypeCtxt -> Bool
constraintsAllowed (TyVarBndrKindCtxt {}) = Bool
False
constraintsAllowed (DataKindCtxt {})      = Bool
False
constraintsAllowed (TySynKindCtxt {})     = Bool
False
constraintsAllowed (TyFamResKindCtxt {})  = Bool
False
constraintsAllowed _ = 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 Trac #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 e :: ExpandMode
e = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ case ExpandMode
e of
                   Expand   -> "Expand"
                   NoExpand -> "NoExpand"
                   Both     -> "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
  Bool
liberal_flag <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.LiberalTypeSynonyms
  ExpandMode -> TcM ExpandMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpandMode -> TcM ExpandMode) -> ExpandMode -> TcM ExpandMode
forall a b. (a -> b) -> a -> b
$ if Bool
liberal_flag then ExpandMode
Expand else ExpandMode
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
text "ValidityEnv")
       2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text "ve_tidy_env" SDoc -> SDoc -> SDoc
<+> TidyEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TidyEnv
env
               , String -> SDoc
text "ve_ctxt"     SDoc -> SDoc -> SDoc
<+> UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt
               , String -> SDoc
text "ve_rank"     SDoc -> SDoc -> SDoc
<+> Rank -> SDoc
forall a. Outputable a => a -> SDoc
ppr Rank
rank
               , String -> SDoc
text "ve_expand"   SDoc -> SDoc -> SDoc
<+> 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 _ (TyVarTy _) = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

check_type ve :: ValidityEnv
ve (AppTy ty1 :: Type
ty1 ty2 :: 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 ve :: ValidityEnv
ve ty :: Type
ty@(TyConApp tc :: TyCon
tc tys :: [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
  | TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc = ValidityEnv -> Type -> [Type] -> TcM ()
check_ubx_tuple ValidityEnv
ve Type
ty [Type]
tys
  | Bool
otherwise              = (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 _ (LitTy {}) = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

check_type ve :: ValidityEnv
ve (CastTy ty :: Type
ty _) = 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_ctxt :: ValidityEnv -> UserTypeCtxt
ve_ctxt = UserTypeCtxt
ctxt
                          , ve_rank :: ValidityEnv -> Rank
ve_rank = Rank
rank, ve_expand :: ValidityEnv -> ExpandMode
ve_expand = ExpandMode
expand }) ty :: Type
ty
  | Bool -> Bool
not ([TyVarBinder] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBinder]
tvbs Bool -> Bool -> Bool
&& [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta)
  = do  { String -> SDoc -> TcM ()
traceTc "check_type" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Rank -> Bool
forAllAllowed Rank
rank))
        ; Bool -> (TidyEnv, SDoc) -> TcM ()
checkTcM (Rank -> Bool
forAllAllowed Rank
rank) (TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)
forAllTyErr TidyEnv
env Rank
rank Type
ty)
                -- Reject e.g. (Maybe (?x::Int => Int)),
                -- with a decent error message

        ; Bool -> (TidyEnv, SDoc) -> TcM ()
checkTcM ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta Bool -> Bool -> Bool
|| UserTypeCtxt -> Bool
constraintsAllowed UserTypeCtxt
ctxt)
                   (TidyEnv -> Type -> (TidyEnv, SDoc)
constraintTyErr TidyEnv
env Type
ty)
                -- Reject forall (a :: Eq b => b). blah
                -- In a kind signature we don't allow constraints

        ; 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 :: TidyEnv
ve_tidy_env = TidyEnv
env'}) Type
tau
                -- Allow foralls to right of arrow

        ; Bool -> (TidyEnv, SDoc) -> TcM ()
checkTcM (Bool -> Bool
not ((TyCoVar -> Bool) -> [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyCoVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
phi_kind) [TyCoVar]
tvs))
                   (TidyEnv -> Type -> Type -> (TidyEnv, SDoc)
forAllEscapeErr TidyEnv
env' Type
ty Type
tau_kind)
        }
  where
    (tvbs :: [TyVarBinder]
tvbs, phi :: Type
phi)  = Type -> ([TyVarBinder], Type)
tcSplitForAllVarBndrs Type
ty
    (theta :: [Type]
theta, tau :: Type
tau) = Type -> ([Type], Type)
tcSplitPhiTy Type
phi

    tvs :: [TyCoVar]
tvs          = [TyVarBinder] -> [TyCoVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
tvbs
    (env' :: TidyEnv
env', _)    = TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
tidyVarBndrs TidyEnv
env [TyCoVar]
tvs

    tau_kind :: Type
tau_kind              = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
tau
    phi_kind :: Type
phi_kind | [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta = Type
tau_kind
             | Bool
otherwise  = Type
liftedTypeKind
        -- If there are any constraints, the kind is *. (#11405)

check_type (ve :: ValidityEnv
ve@ValidityEnv{ve_rank :: ValidityEnv -> Rank
ve_rank = Rank
rank}) (FunTy arg_ty :: Type
arg_ty res_ty :: Type
res_ty)
  = do  { ValidityEnv -> Type -> TcM ()
check_type (ValidityEnv
ve{ve_rank :: Rank
ve_rank = Rank
arg_rank}) Type
arg_ty
        ; ValidityEnv -> Type -> TcM ()
check_type (ValidityEnv
ve{ve_rank :: Rank
ve_rank = Rank
res_rank}) Type
res_ty }
  where
    (arg_rank :: Rank
arg_rank, res_rank :: Rank
res_rank) = Rank -> (Rank, Rank)
funArgResRank Rank
rank

check_type _ ty :: Type
ty = String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 })
                 ty :: Type
ty tc :: TyCon
tc tys :: [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
      _ |  TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
        -> ExpandMode -> TcM ()
check_args_only ExpandMode
expand
      -- See Note [Correctness and performance of type synonym validity
      --           checking]
      Expand   -> ExpandMode -> TcM ()
check_expansion_only ExpandMode
expand
      NoExpand -> ExpandMode -> TcM ()
check_args_only ExpandMode
expand
      Both     -> ExpandMode -> TcM ()
check_args_only ExpandMode
NoExpand TcM () -> TcM () -> TcM ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ExpandMode -> TcM ()
check_expansion_only ExpandMode
Both

  | GhciCtxt 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
  = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc (TyCon -> [Type] -> SDoc
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 expand :: ExpandMode
expand =
      Bool -> ValidityEnv -> Type -> TcM ()
check_arg_type (TyCon -> Bool
isTypeSynonymTyCon TyCon
tc) (ValidityEnv
ve{ve_expand :: ExpandMode
ve_expand = ExpandMode
expand})

    check_args_only, check_expansion_only :: ExpandMode -> TcM ()
    check_args_only :: ExpandMode -> TcM ()
check_args_only expand :: 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 expand :: ExpandMode
expand =
      case Type -> Maybe Type
tcView Type
ty of
         Just ty' :: Type
ty' -> let syn_tc :: TyCon
syn_tc = (TyCon, [Type]) -> TyCon
forall a b. (a, b) -> a
fst ((TyCon, [Type]) -> TyCon) -> (TyCon, [Type]) -> TyCon
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> (TyCon, [Type])
Type -> (TyCon, [Type])
tcRepSplitTyConApp Type
ty
                         err_ctxt :: SDoc
err_ctxt = String -> SDoc
text "In the expansion of type synonym"
                                    SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
syn_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 :: ExpandMode
ve_expand = ExpandMode
expand}) Type
ty'
         Nothing  -> String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()
check_ubx_tuple :: ValidityEnv -> Type -> [Type] -> TcM ()
check_ubx_tuple (ve :: ValidityEnv
ve@ValidityEnv{ve_tidy_env :: ValidityEnv -> TidyEnv
ve_tidy_env = TidyEnv
env}) ty :: Type
ty tys :: [Type]
tys
  = do  { Bool
ub_tuples_allowed <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UnboxedTuples
        ; Bool -> (TidyEnv, SDoc) -> TcM ()
checkTcM Bool
ub_tuples_allowed (TidyEnv -> Type -> (TidyEnv, SDoc)
ubxArgTyErr TidyEnv
env Type
ty)

        ; Bool
impred <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ImpredicativeTypes
        ; let rank' :: Rank
rank' = if Bool
impred then Rank
ArbitraryRank else Rank
tyConArgMonoType
                -- c.f. check_arg_type
                -- However, args are allowed to be unlifted, or
                -- more unboxed tuples, so can't use check_arg_ty
        ; (Type -> TcM ()) -> [Type] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ValidityEnv -> Type -> TcM ()
check_type (ValidityEnv
ve{ve_rank :: Rank
ve_rank = Rank
rank'})) [Type]
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 _ _ (CoercionTy {}) = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

check_arg_type type_syn :: Bool
type_syn (ve :: ValidityEnv
ve@ValidityEnv{ve_ctxt :: ValidityEnv -> UserTypeCtxt
ve_ctxt = UserTypeCtxt
ctxt, ve_rank :: ValidityEnv -> Rank
ve_rank = Rank
rank}) ty :: Type
ty
  = do  { Bool
impred <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ImpredicativeTypes
        ; let rank' :: Rank
rank' = case Rank
rank of          -- Predictive => must be monotype
                        -- Rank-n arguments to type synonyms are OK, provided
                        -- that LiberalTypeSynonyms is enabled.
                        _ | Bool
type_syn       -> Rank
synArgMonoType
                        MustBeMonoType     -> Rank
MustBeMonoType  -- Monotype, regardless
                        _other :: Rank
_other | Bool
impred    -> Rank
ArbitraryRank
                               | Bool
otherwise -> Rank
tyConArgMonoType
                        -- 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' :: UserTypeCtxt
ctxt'
                | GhciCtxt _ <- 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

        ; ValidityEnv -> Type -> TcM ()
check_type (ValidityEnv
ve{ve_ctxt :: UserTypeCtxt
ve_ctxt = UserTypeCtxt
ctxt', ve_rank :: Rank
ve_rank = Rank
rank'}) Type
ty }

----------------------------------------
forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)
forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)
forAllTyErr env :: TidyEnv
env rank :: Rank
rank ty :: Type
ty
   = ( TidyEnv
env
     , [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald 2 (TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
ty)
            , SDoc
suggestion ] )
  where
    (tvs :: [TyCoVar]
tvs, _theta :: [Type]
_theta, _tau :: Type
_tau) = Type -> ([TyCoVar], [Type], Type)
tcSplitSigmaTy Type
ty
    herald :: SDoc
herald | [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
tvs  = String -> SDoc
text "Illegal qualified type:"
           | Bool
otherwise = String -> SDoc
text "Illegal polymorphic type:"
    suggestion :: SDoc
suggestion = case Rank
rank of
                   LimitedRank {} -> String -> SDoc
text "Perhaps you intended to use RankNTypes"
                   MonoType d :: SDoc
d     -> SDoc
d
                   _              -> SDoc
Outputable.empty -- Polytype is always illegal

forAllEscapeErr :: TidyEnv -> Type -> Kind -> (TidyEnv, SDoc)
forAllEscapeErr :: TidyEnv -> Type -> Type -> (TidyEnv, SDoc)
forAllEscapeErr env :: TidyEnv
env ty :: Type
ty tau_kind :: Type
tau_kind
  = ( TidyEnv
env
    , SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
vcat [ String -> SDoc
text "Quantified type's kind mentions quantified type variable"
                 , String -> SDoc
text "(skolem escape)" ])
         2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text "   type:" SDoc -> SDoc -> SDoc
<+> TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
ty
                 , String -> SDoc
text "of kind:" SDoc -> SDoc -> SDoc
<+> TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
tau_kind ]) )

ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
ubxArgTyErr env :: TidyEnv
env ty :: Type
ty
  = ( TidyEnv
env, [SDoc] -> SDoc
vcat [ [SDoc] -> SDoc
sep [ String -> SDoc
text "Illegal unboxed tuple type as function argument:"
                      , TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
ty ]
                , String -> SDoc
text "Perhaps you intended to use UnboxedTuples" ] )

constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
constraintTyErr env :: TidyEnv
env ty :: Type
ty
  = (TidyEnv
env, String -> SDoc
text "Illegal constraint in a kind:" SDoc -> SDoc -> SDoc
<+> TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
ty)

{-
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 appliation (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
(tcSplitForAllVarBndrs/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.

************************************************************************
*                                                                      *
\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.  Trac #8912.
-}

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

-------------------------
check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode
                  -> [PredType] -> TcM ()
check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode -> [Type] -> TcM ()
check_valid_theta _ _ _ []
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check_valid_theta env :: TidyEnv
env ctxt :: UserTypeCtxt
ctxt expand :: ExpandMode
expand theta :: [Type]
theta
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM ()
warnTcM (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDuplicateConstraints)
                 (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnDuplicateConstraints DynFlags
dflags Bool -> Bool -> Bool
&& [NonEmpty Type] -> Bool
forall a. [a] -> Bool
notNull [NonEmpty Type]
dups)
                 (TidyEnv -> [NonEmpty Type] -> (TidyEnv, SDoc)
dupPredWarn TidyEnv
env [NonEmpty Type]
dups)
       ; String -> SDoc -> TcM ()
traceTc "check_valid_theta" ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
theta)
       ; (Type -> TcM ()) -> [Type] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode -> Type -> TcM ()
check_pred_ty TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt ExpandMode
expand) [Type]
theta }
  where
    (_,dups :: [NonEmpty Type]
dups) = (Type -> Type -> Ordering) -> [Type] -> ([Type], [NonEmpty Type])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups Type -> Type -> Ordering
nonDetCmpType [Type]
theta
    -- It's OK to use nonDetCmpType because dups only appears in the
    -- warning

-------------------------
{- 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
(Trac #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 env :: TidyEnv
env dflags :: DynFlags
dflags ctxt :: UserTypeCtxt
ctxt expand :: ExpandMode
expand pred :: 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
constraintMonoType

    ve :: ValidityEnv
    ve :: ValidityEnv
ve = ValidityEnv :: TidyEnv -> UserTypeCtxt -> Rank -> ExpandMode -> ValidityEnv
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 under_syn :: Bool
under_syn env :: TidyEnv
env dflags :: DynFlags
dflags ctxt :: UserTypeCtxt
ctxt pred :: Type
pred
  | Just pred' :: Type
pred' <- Type -> Maybe Type
tcView Type
pred  -- Switch on under_syn when going under a
                                 -- synonym (Trac #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 -> PredTree
classifyPredType Type
pred of
      ClassPred cls :: Class
cls tys :: [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 NomEq _ _  -> -- a ~# b
                           TidyEnv -> DynFlags -> Type -> TcM ()
check_eq_pred TidyEnv
env DynFlags
dflags Type
pred

      EqPred ReprEq _ _ -> -- Ugh!  When inferring types we may get
                           -- f :: (a ~R# b) => blha
                           -- And we want to treat that like (Coercible a b)
                           -- We should probably check argument shapes, but we
                           -- didn't do so before, so I'm leaving it for now
                           () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      ForAllPred _ theta :: [Type]
theta head :: Type
head -> TidyEnv
-> DynFlags -> UserTypeCtxt -> Type -> [Type] -> Type -> TcM ()
check_quant_pred TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred [Type]
theta Type
head
      IrredPred {}            -> Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> Type -> TcM ()
check_irred_pred Bool
under_syn TidyEnv
env DynFlags
dflags UserTypeCtxt
ctxt Type
pred

check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM ()
check_eq_pred :: TidyEnv -> DynFlags -> Type -> TcM ()
check_eq_pred env :: TidyEnv
env dflags :: DynFlags
dflags pred :: Type
pred
  =         -- Equational constraints are valid in all contexts if type
            -- families are permitted
    Bool -> (TidyEnv, SDoc) -> TcM ()
checkTcM (Extension -> DynFlags -> Bool
xopt Extension
LangExt.TypeFamilies DynFlags
dflags
              Bool -> Bool -> Bool
|| Extension -> DynFlags -> Bool
xopt Extension
LangExt.GADTs DynFlags
dflags)
             (TidyEnv -> Type -> (TidyEnv, SDoc)
eqPredTyErr TidyEnv
env Type
pred)

check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
                 -> PredType -> ThetaType -> PredType -> TcM ()
check_quant_pred :: TidyEnv
-> DynFlags -> UserTypeCtxt -> Type -> [Type] -> Type -> TcM ()
check_quant_pred env :: TidyEnv
env dflags :: DynFlags
dflags _ctxt :: UserTypeCtxt
_ctxt pred :: Type
pred theta :: [Type]
theta head_pred :: Type
head_pred
  = SDoc -> TcM () -> TcM ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
text "In the quantified constraint" SDoc -> SDoc -> SDoc
<+> 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 -> PredTree
classifyPredType Type
head_pred of
            ClassPred cls :: Class
cls tys :: [Type]
tys -> UserTypeCtxt -> Class -> [Type] -> TcM ()
checkValidInstHead UserTypeCtxt
SigmaCtxt Class
cls [Type]
tys
                                 -- SigmaCtxt tells checkValidInstHead that
                                 -- this is the head of a quantified constraint
            IrredPred {}      | Type -> Bool
hasTyVarHead Type
head_pred
                              -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            _                 -> (TidyEnv, SDoc) -> TcM ()
forall a. (TidyEnv, SDoc) -> TcM a
failWithTcM (TidyEnv -> Type -> (TidyEnv, SDoc)
badQuantHeadErr 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 under_syn :: Bool
under_syn env :: TidyEnv
env dflags :: DynFlags
dflags ctxt :: UserTypeCtxt
ctxt pred :: Type
pred ts :: [Type]
ts
  = do { -- See Note [ConstraintKinds in predicates]
         Bool -> (TidyEnv, SDoc) -> TcM ()
checkTcM (Bool
under_syn Bool -> Bool -> Bool
|| Extension -> DynFlags -> Bool
xopt Extension
LangExt.ConstraintKinds DynFlags
dflags)
                  (TidyEnv -> Type -> (TidyEnv, SDoc)
predTupleErr 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 *

check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> Type -> TcM ()
check_irred_pred under_syn :: Bool
under_syn env :: TidyEnv
env dflags :: DynFlags
dflags ctxt :: UserTypeCtxt
ctxt pred :: Type
pred
    -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint
    -- where X is a type function
  = do { -- If it looks like (x t1 t2), require ConstraintKinds
         --   see Note [ConstraintKinds in predicates]
         -- But (X t1 t2) is always ok because we just require ConstraintKinds
         -- at the definition site (Trac #9838)
        Bool -> (TidyEnv, SDoc) -> TcM ()
failIfTcM (Bool -> Bool
not Bool
under_syn Bool -> Bool -> Bool
&& Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.ConstraintKinds DynFlags
dflags)
                                Bool -> Bool -> Bool
&& Type -> Bool
hasTyVarHead Type
pred)
                  (TidyEnv -> Type -> (TidyEnv, SDoc)
predIrredErr TidyEnv
env Type
pred)

         -- Make sure it is OK to have an irred pred in this context
         -- See Note [Irreducible predicates in superclasses]
       ; Bool -> (TidyEnv, SDoc) -> TcM ()
failIfTcM (UserTypeCtxt -> Bool
is_superclass UserTypeCtxt
ctxt
                    Bool -> Bool -> Bool
&& Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.UndecidableInstances DynFlags
dflags)
                    Bool -> Bool -> Bool
&& Type -> Bool
has_tyfun_head Type
pred)
                   (TidyEnv -> Type -> (TidyEnv, SDoc)
predSuperClassErr TidyEnv
env Type
pred) }
  where
    is_superclass :: UserTypeCtxt -> Bool
is_superclass ctxt :: UserTypeCtxt
ctxt = case UserTypeCtxt
ctxt of { ClassSCCtxt _ -> Bool
True; _ -> Bool
False }
    has_tyfun_head :: Type -> Bool
has_tyfun_head ty :: Type
ty
      = case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
          Just (tc :: TyCon
tc, _) -> TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
          Nothing      -> Bool
False

{- Note [ConstraintKinds in predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Don't check for -XConstraintKinds under a type synonym, because that
was done at the type synonym definition site; see Trac #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

Note [Irreducible predicates in superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Allowing type-family calls in class superclasses is somewhat dangerous
because we can write:

 type family Fooish x :: * -> Constraint
 type instance Fooish () = Foo
 class Fooish () a => Foo a where

This will cause the constraint simplifier to loop because every time we canonicalise a
(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately
solved to add+canonicalise another (Foo a) constraint.  -}

-------------------------
check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
                 -> PredType -> Class -> [TcType] -> TcM ()
check_class_pred :: TidyEnv
-> DynFlags -> UserTypeCtxt -> Type -> Class -> [Type] -> TcM ()
check_class_pred env :: TidyEnv
env dflags :: DynFlags
dflags ctxt :: UserTypeCtxt
ctxt pred :: Type
pred cls :: Class
cls tys :: [Type]
tys
  |  Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey   -- (~) and (~~) are classified as classes,
  Bool -> Bool -> Bool
|| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey    -- but here we want to treat them as equalities
  = -- pprTrace "check_class" (ppr cls) $
    TidyEnv -> DynFlags -> Type -> TcM ()
check_eq_pred TidyEnv
env DynFlags
dflags Type
pred

  | Class -> Bool
isIPClass Class
cls
  = do { TcM ()
check_arity
       ; Bool -> (TidyEnv, SDoc) -> TcM ()
checkTcM (UserTypeCtxt -> Bool
okIPCtxt UserTypeCtxt
ctxt) (TidyEnv -> Type -> (TidyEnv, SDoc)
badIPPred 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, SDoc) -> TcM ()
checkTcM Bool
arg_tys_ok (TidyEnv -> Type -> (TidyEnv, SDoc)
predTyVarErr TidyEnv
env Type
pred) }
  where
    check_arity :: TcM ()
check_arity = Bool -> SDoc -> TcM ()
checkTc ([Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Class -> Int
classArity Class
cls)
                          (TyCon -> [Type] -> SDoc
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
    undecidable_ok :: Bool
undecidable_ok    = Extension -> DynFlags -> Bool
xopt Extension
LangExt.UndecidableInstances DynFlags
dflags
    arg_tys_ok :: Bool
arg_tys_ok = case UserTypeCtxt
ctxt of
        SpecInstCtxt -> Bool
True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine
        InstDeclCtxt {} -> Bool -> Class -> [Type] -> Bool
checkValidClsArgs (Bool
flexible_contexts Bool -> Bool -> Bool
|| Bool
undecidable_ok) Class
cls [Type]
tys
                                -- Further checks on head and theta
                                -- in checkInstTermination
        _               -> 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 env :: TidyEnv
env dflags :: DynFlags
dflags ctxt :: UserTypeCtxt
ctxt cls :: Class
cls tys :: [Type]
tys
  | Bool -> Bool
not (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnSimplifiableClassConstraints DynFlags
dflags)
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Extension -> DynFlags -> Bool
xopt Extension
LangExt.MonoLocalBinds DynFlags
dflags
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  | DataTyCtxt {} <- UserTypeCtxt
ctxt   -- Don't do this check for the "stupid theta"
  = () -> TcM ()
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 (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 { ClsInstResult
result <- DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchGlobalInst DynFlags
dflags Bool
False Class
cls [Type]
tys
       ; case ClsInstResult
result of
           OneInst { cir_what :: ClsInstResult -> InstanceWhat
cir_what = InstanceWhat
what }
              -> WarnReason -> SDoc -> TcM ()
addWarnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnSimplifiableClassConstraints)
                                   (InstanceWhat -> SDoc
simplifiable_constraint_warn InstanceWhat
what)
           _          -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
  where
    pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
cls [Type]
tys

    simplifiable_constraint_warn :: InstanceWhat -> SDoc
    simplifiable_constraint_warn :: InstanceWhat -> SDoc
simplifiable_constraint_warn what :: InstanceWhat
what
     = [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "The constraint" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
pred))
                    SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "matches")
                 2 (InstanceWhat -> SDoc
ppr_what InstanceWhat
what)
            , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "This makes type inference for inner bindings fragile;")
                 2 (String -> SDoc
text "either use MonoLocalBinds, or simplify it using the instance") ]

    ppr_what :: InstanceWhat -> SDoc
ppr_what BuiltinInstance = String -> SDoc
text "a built-in instance"
    ppr_what LocalInstance   = String -> SDoc
text "a locally-quantified instance"
    ppr_what (TopLevInstance { iw_dfun_id :: InstanceWhat -> TyCoVar
iw_dfun_id = TyCoVar
dfun })
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "instance" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprSigmaType (TyCoVar -> Type
idType TyCoVar
dfun))
           2 (String -> SDoc
text "--" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
pprDefinedAt (TyCoVar -> Name
idName TyCoVar
dfun))


{- Note [Simplifiable given constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A type signature like
   f :: Eq [(a,b)] => a -> b
is very fragile, for reasons described at length in TcInteract
Note [Instance and Given overlap].  As that Note discusses, for the
most part the clever stuff in TcInteract 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 (Trac #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
TcInteract.matchInstEnv fires an interaction with the top
level instances.  For example (Trac #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 TypeAppCtxt            = Bool
True
okIPCtxt PatSigCtxt             = Bool
True
okIPCtxt ResSigCtxt             = Bool
True
okIPCtxt GenSigCtxt             = Bool
True
okIPCtxt (ConArgCtxt {})        = Bool
True
okIPCtxt (ForSigCtxt {})        = Bool
True  -- ??
okIPCtxt ThBrackCtxt            = Bool
True
okIPCtxt (GhciCtxt {})          = Bool
True
okIPCtxt SigmaCtxt              = Bool
True
okIPCtxt (DataTyCtxt {})        = Bool
True
okIPCtxt (PatSynCtxt {})        = Bool
True
okIPCtxt (TySynCtxt {})         = Bool
True   -- e.g.   type Blah = ?x::Int
                                         -- Trac #11466

okIPCtxt (KindSigCtxt {})       = Bool
False
okIPCtxt (ClassSCCtxt {})       = Bool
False
okIPCtxt (InstDeclCtxt {})      = Bool
False
okIPCtxt (SpecInstCtxt {})      = Bool
False
okIPCtxt (RuleSigCtxt {})       = Bool
False
okIPCtxt DefaultDeclCtxt        = Bool
False
okIPCtxt 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 -> TcM (TidyEnv, SDoc)
checkThetaCtxt :: UserTypeCtxt -> [Type] -> TidyEnv -> TcM (TidyEnv, SDoc)
checkThetaCtxt ctxt :: UserTypeCtxt
ctxt theta :: [Type]
theta env :: TidyEnv
env
  = (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
env
           , [SDoc] -> SDoc
vcat [ String -> SDoc
text "In the context:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
pprTheta (TidyEnv -> [Type] -> [Type]
tidyTypes TidyEnv
env [Type]
theta)
                  , String -> SDoc
text "While checking" SDoc -> SDoc -> SDoc
<+> UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt ] )

eqPredTyErr, predTupleErr, predIrredErr,
   predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
badQuantHeadErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
badQuantHeadErr env :: TidyEnv
env pred :: Type
pred
  = ( TidyEnv
env
    , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Quantified predicate must have a class or type variable head:")
         2 (TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
pred) )
eqPredTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
eqPredTyErr  env :: TidyEnv
env pred :: Type
pred
  = ( TidyEnv
env
    , String -> SDoc
text "Illegal equational constraint" SDoc -> SDoc -> SDoc
<+> TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
pred SDoc -> SDoc -> SDoc
$$
      SDoc -> SDoc
parens (String -> SDoc
text "Use GADTs or TypeFamilies to permit this") )
predTupleErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
predTupleErr env :: TidyEnv
env pred :: Type
pred
  = ( TidyEnv
env
    , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Illegal tuple constraint:" SDoc -> SDoc -> SDoc
<+> TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
pred)
         2 (SDoc -> SDoc
parens SDoc
constraintKindsMsg) )
predIrredErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
predIrredErr env :: TidyEnv
env pred :: Type
pred
  = ( TidyEnv
env
    , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Illegal constraint:" SDoc -> SDoc -> SDoc
<+> TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
pred)
         2 (SDoc -> SDoc
parens SDoc
constraintKindsMsg) )
predSuperClassErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
predSuperClassErr env :: TidyEnv
env pred :: Type
pred
  = ( TidyEnv
env
    , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Illegal constraint" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
pred)
            SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "in a superclass context")
         2 (SDoc -> SDoc
parens SDoc
undecidableMsg) )

predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
predTyVarErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
predTyVarErr env :: TidyEnv
env pred :: Type
pred
  = (TidyEnv
env
    , [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Non type-variable argument")
                2 (String -> SDoc
text "in the constraint:" SDoc -> SDoc -> SDoc
<+> TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
pred)
           , SDoc -> SDoc
parens (String -> SDoc
text "Use FlexibleContexts to permit this") ])

badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)
badIPPred :: TidyEnv -> Type -> (TidyEnv, SDoc)
badIPPred env :: TidyEnv
env pred :: Type
pred
  = ( TidyEnv
env
    , String -> SDoc
text "Illegal implicit parameter" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
pred) )

constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
constraintSynErr env :: TidyEnv
env kind :: Type
kind
  = ( TidyEnv
env
    , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Illegal constraint synonym of kind:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env Type
kind))
         2 (SDoc -> SDoc
parens SDoc
constraintKindsMsg) )

dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc)
dupPredWarn :: TidyEnv -> [NonEmpty Type] -> (TidyEnv, SDoc)
dupPredWarn env :: TidyEnv
env dups :: [NonEmpty Type]
dups
  = ( TidyEnv
env
    , String -> SDoc
text "Duplicate constraint" SDoc -> SDoc -> SDoc
<> [Type] -> SDoc
forall a. [a] -> SDoc
plural [Type]
primaryDups SDoc -> SDoc -> SDoc
<> String -> SDoc
text ":"
      SDoc -> SDoc -> SDoc
<+> (Type -> SDoc) -> [Type] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (TidyEnv -> Type -> SDoc
ppr_tidy TidyEnv
env) [Type]
primaryDups )
  where
    primaryDups :: [Type]
primaryDups = (NonEmpty Type -> Type) -> [NonEmpty Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Type -> Type
forall a. NonEmpty a -> a
NE.head [NonEmpty Type]
dups

tyConArityErr :: TyCon -> [TcType] -> SDoc
-- 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. Trac #10516)
tyConArityErr :: TyCon -> [Type] -> SDoc
tyConArityErr tc :: TyCon
tc tks :: [Type]
tks
  = SDoc -> Name -> Int -> Int -> SDoc
forall a. Outputable a => SDoc -> a -> Int -> Int -> SDoc
arityErr (TyConFlavour -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> TyConFlavour
tyConFlavour TyCon
tc)) (TyCon -> Name
tyConName 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 TyCoVar TyConBndrVis -> Bool)
-> [VarBndr TyCoVar TyConBndrVis] -> Int
forall a. (a -> Bool) -> [a] -> Int
count VarBndr TyCoVar TyConBndrVis -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder (TyCon -> [VarBndr TyCoVar TyConBndrVis]
tyConBinders TyCon
tc)
    tc_type_args :: Int
tc_type_args  = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
vis_tks

arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc
arityErr :: SDoc -> a -> Int -> Int -> SDoc
arityErr what :: SDoc
what name :: a
name n :: Int
n m :: Int
m
  = [SDoc] -> SDoc
hsep [ String -> SDoc
text "The" SDoc -> SDoc -> SDoc
<+> SDoc
what, SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
name), String -> SDoc
text "should have",
           SDoc
n_arguments SDoc -> SDoc -> SDoc
<> SDoc
comma, String -> SDoc
text "but has been given",
           if Int
mInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==0 then String -> SDoc
text "none" else Int -> SDoc
int Int
m]
    where
        n_arguments :: SDoc
n_arguments | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = String -> SDoc
text "no arguments"
                    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = String -> SDoc
text "1 argument"
                    | Bool
True   = [SDoc] -> SDoc
hsep [Int -> SDoc
int Int
n, String -> SDoc
text "arguments"]

{-
************************************************************************
*                                                                      *
\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 ctxt :: UserTypeCtxt
ctxt clas :: Class
clas cls_args :: [Type]
cls_args
  = do { DynFlags
dflags   <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; Bool
is_boot  <- TcRnIf TcGblEnv TcLclEnv Bool
tcIsHsBootOrSig
       ; Bool
is_sig   <- TcRnIf TcGblEnv TcLclEnv Bool
tcIsHsig
       ; DynFlags
-> Bool -> Bool -> UserTypeCtxt -> Class -> [Type] -> TcM ()
check_special_inst_head DynFlags
dflags Bool
is_boot Bool
is_sig UserTypeCtxt
ctxt Class
clas [Type]
cls_args
       ; TyCon -> [Type] -> TcM ()
checkValidTypePats (Class -> TyCon
classTyCon Class
clas) [Type]
cls_args
       }

{-

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

User defined instances for KnownNat, KnownSymbol 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. 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 absolultely need that instance when compiling a
module that imports M.hsig: see Trac #15379 and
Note [Fabricating Evidence for Literals in Backpack] in ClsInst.

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

-}

check_special_inst_head :: DynFlags -> Bool -> Bool
                        -> UserTypeCtxt -> Class -> [Type] -> TcM ()
-- Wow!  There are a surprising number of ad-hoc special cases here.
check_special_inst_head :: DynFlags
-> Bool -> Bool -> UserTypeCtxt -> Class -> [Type] -> TcM ()
check_special_inst_head dflags :: DynFlags
dflags is_boot :: Bool
is_boot is_sig :: Bool
is_sig ctxt :: UserTypeCtxt
ctxt clas :: Class
clas cls_args :: [Type]
cls_args

  -- If not in an hs-boot file, abstract classes cannot have instances
  | Class -> Bool
isAbstractClass Class
clas
  , Bool -> Bool
not Bool
is_boot
  = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc SDoc
abstract_class_msg

  -- For Typeable, don't complain about instances for
  -- standalone deriving; they are no-ops, and we warn about
  -- it in TcDeriv.deriveStandalone.
  | Name
clas_nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName
  , Bool -> Bool
not Bool
is_sig
    -- Note [Instances of built-in classes in signature files]
  , Bool
hand_written_bindings
  = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc SDoc
rejected_class_msg

  -- Handwritten instances of KnownNat/KnownSymbol class
  -- are always forbidden (#12837)
  | Name
clas_nm Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Name
knownNatClassName, Name
knownSymbolClassName ]
  , Bool -> Bool
not Bool
is_sig
    -- Note [Instances of built-in classes in signature files]
  , Bool
hand_written_bindings
  = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc SDoc
rejected_class_msg

  -- 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Name
heqTyConName, Name
eqTyConName, Name
coercibleTyConName ]
  , Bool -> Bool
not Bool
quantified_constraint
  = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc SDoc
rejected_class_msg

  -- Check for hand-written Generic instances (disallowed in Safe Haskell)
  | Name
clas_nm Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
genericClassNames
  , Bool
hand_written_bindings
  =  do { Bool -> SDoc -> TcM ()
failIfTc (DynFlags -> Bool
safeLanguageOn DynFlags
dflags) SDoc
gen_inst_err
        ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
safeInferOn DynFlags
dflags) (WarningMessages -> TcM ()
recordUnsafeInfer WarningMessages
forall a. Bag a
emptyBag) }

  | Name
clas_nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
hasFieldClassName
  = Class -> [Type] -> TcM ()
checkHasFieldInst Class
clas [Type]
cls_args

  | Class -> Bool
isCTupleClass Class
clas
  = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc SDoc
tuple_class_msg

  -- Check language restrictions on the args to the class
  | Bool
check_h98_arg_shape
  , Just msg :: SDoc
msg <- Maybe SDoc
mb_ty_args_msg
  = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc (Class -> [Type] -> SDoc -> SDoc
instTypeErr Class
clas [Type]
cls_args SDoc
msg)

  | Bool
otherwise
  = () -> TcM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    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 stand_alone :: Bool
stand_alone -> Bool -> Bool
not Bool
stand_alone
            SpecInstCtxt             -> Bool
False
            DerivClauseCtxt          -> Bool
False
            _                        -> Bool
True

    check_h98_arg_shape :: Bool
check_h98_arg_shape = case UserTypeCtxt
ctxt of
                            SpecInstCtxt    -> Bool
False
                            DerivClauseCtxt -> Bool
False
                            SigmaCtxt       -> Bool
False
                            _               -> 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
                              SigmaCtxt -> Bool
True
                              _         -> Bool
False

    head_type_synonym_msg :: SDoc
head_type_synonym_msg = SDoc -> SDoc
parens (
                String -> SDoc
text "All instance types must be of the form (T t1 ... tn)" SDoc -> SDoc -> SDoc
$$
                String -> SDoc
text "where T is not a synonym." SDoc -> SDoc -> SDoc
$$
                String -> SDoc
text "Use TypeSynonymInstances if you want to disable this.")

    head_type_args_tyvars_msg :: SDoc
head_type_args_tyvars_msg = SDoc -> SDoc
parens ([SDoc] -> SDoc
vcat [
                String -> SDoc
text "All instance types must be of the form (T a1 ... an)",
                String -> SDoc
text "where a1 ... an are *distinct type variables*,",
                String -> SDoc
text "and each type variable appears at most once in the instance head.",
                String -> SDoc
text "Use FlexibleInstances if you want to disable this."])

    head_one_type_msg :: SDoc
head_one_type_msg = SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                        String -> SDoc
text "Only one type can be given in an instance head." SDoc -> SDoc -> SDoc
$$
                        String -> SDoc
text "Use MultiParamTypeClasses if you want to allow more, or zero."

    rejected_class_msg :: SDoc
rejected_class_msg = String -> SDoc
text "Class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
clas_nm)
                         SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "does not support user-specified instances"
    tuple_class_msg :: SDoc
tuple_class_msg    = String -> SDoc
text "You can't specify an instance for a tuple constraint"

    gen_inst_err :: SDoc
gen_inst_err = SDoc
rejected_class_msg SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 2 (String -> SDoc
text "(in Safe Haskell)")

    abstract_class_msg :: SDoc
abstract_class_msg = String -> SDoc
text "Cannot define instance for abstract class"
                         SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
clas_nm)

    mb_ty_args_msg :: Maybe SDoc
mb_ty_args_msg
      | 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)
      = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
head_type_synonym_msg

      | 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)
      = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
head_type_args_tyvars_msg

      | [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ty_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ty_args)
      = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
head_one_type_msg

      | Bool
otherwise
      = Maybe SDoc
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 ty :: Type
ty
  = case Type
ty of  -- Do not use splitTyConApp,
                -- because that expands synonyms!
        TyConApp tc :: TyCon
tc _ -> Bool -> Bool
not (TyCon -> Bool
isTypeSynonymTyCon TyCon
tc)
        _ -> 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 kind instantiations.
tcInstHeadTyAppAllTyVars :: Type -> Bool
tcInstHeadTyAppAllTyVars ty :: Type
ty
  | Just (tc :: TyCon
tc, tys :: [Type]
tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (Type -> Type
dropCasts Type
ty)
  = [Type] -> Bool
ok (TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
tc [Type]
tys)  -- avoid kinds
  | LitTy _ <- Type
ty = Bool
True  -- accept type literals (Trac #13833)
  | Bool
otherwise
  = Bool
False
  where
        -- Check that all the types are type variables,
        -- and that each is distinct
    ok :: [Type] -> Bool
ok tys :: [Type]
tys = [TyCoVar] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [TyCoVar]
tvs [Type]
tys Bool -> Bool -> Bool
&& [TyCoVar] -> Bool
forall a. Eq a => [a] -> Bool
hasNoDups [TyCoVar]
tvs
           where
             tvs :: [TyCoVar]
tvs = (Type -> Maybe TyCoVar) -> [Type] -> [TyCoVar]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Type -> Maybe TyCoVar
tcGetTyVar_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 ty :: Type
ty _)     = Type -> Type
dropCasts Type
ty
dropCasts (AppTy t1 :: Type
t1 t2 :: Type
t2)     = Type -> Type -> Type
mkAppTy (Type -> Type
dropCasts Type
t1) (Type -> Type
dropCasts Type
t2)
dropCasts (FunTy t1 :: Type
t1 t2 :: Type
t2)     = Type -> Type -> Type
mkFunTy (Type -> Type
dropCasts Type
t1) (Type -> Type
dropCasts Type
t2)
dropCasts (TyConApp tc :: TyCon
tc tys :: [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 b :: TyVarBinder
b ty :: Type
ty)   = TyVarBinder -> Type -> Type
ForAllTy (TyVarBinder -> TyVarBinder
dropCastsB TyVarBinder
b) (Type -> Type
dropCasts Type
ty)
dropCasts ty :: Type
ty                = Type
ty  -- LitTy, TyVarTy, CoercionTy

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

instTypeErr :: Class -> [Type] -> SDoc -> SDoc
instTypeErr :: Class -> [Type] -> SDoc -> SDoc
instTypeErr cls :: Class
cls tys :: [Type]
tys msg :: SDoc
msg
  = SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Illegal instance declaration for")
             2 (SDoc -> SDoc
quotes (Class -> [Type] -> SDoc
pprClassPred Class
cls [Type]
tys)))
       2 SDoc
msg

-- | See Note [Validity checking of HasField instances]
checkHasFieldInst :: Class -> [Type] -> TcM ()
checkHasFieldInst :: Class -> [Type] -> TcM ()
checkHasFieldInst cls :: Class
cls tys :: [Type]
tys@[_k_ty :: Type
_k_ty, x_ty :: Type
x_ty, r_ty :: Type
r_ty, _a_ty :: Type
_a_ty] =
  case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
r_ty of
    Nothing -> SDoc -> TcM ()
whoops (String -> SDoc
text "Record data type must be specified")
    Just (tc :: TyCon
tc, _)
      | TyCon -> Bool
isFamilyTyCon TyCon
tc
                  -> SDoc -> TcM ()
whoops (String -> SDoc
text "Record data type may not be a data family")
      | Bool
otherwise -> case Type -> Maybe FastString
isStrLitTy Type
x_ty of
       Just lbl :: FastString
lbl
         | Maybe FieldLabel -> Bool
forall a. Maybe a -> Bool
isJust (FastString -> TyCon -> Maybe FieldLabel
lookupTyConFieldLabel FastString
lbl TyCon
tc)
                     -> SDoc -> TcM ()
whoops (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "already has a field"
                                       SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
lbl))
         | Bool
otherwise -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Nothing
         | [FieldLabel] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [FieldLabel]
tyConFieldLabels TyCon
tc) -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         | Bool
otherwise -> SDoc -> TcM ()
whoops (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "has fields")
  where
    whoops :: SDoc -> TcM ()
whoops = SDoc -> TcM ()
addErrTc (SDoc -> TcM ()) -> (SDoc -> SDoc) -> SDoc -> TcM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> [Type] -> SDoc -> SDoc
instTypeErr Class
cls [Type]
tys
checkHasFieldInst _ tys :: [Type]
tys = String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 * ~ #.  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 TcInteract).  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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
validDerivPred checks for OK 'deriving' context.  See Note [Exotic
derived instance contexts] in TcDeriv.  However the predicate is
here because it uses sizeTypes, fvTypes.

It checks for three things

  * No repeated variables (hasNoDups fvs)

  * No type constructors.  This is done by comparing
        sizeTypes tys == length (fvTypes tys)
    sizeTypes counts variables and constructors; fvTypes returns variables.
    So if they are the same, there must be no constructors.  But there
    might be applications thus (f (g x)).

    Note that tys only includes 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 -> *) where ...
       newtype T (c :: * -> * -> *) a b = MkT (c a b)
       instance Category c => Category (T c) where ...
    since the first argument to Category is a non-visible *, which sizeTypes
    would count as a constructor! See Trac #11833.

  * Also check for a bizarre corner case, when the derived instance decl
    would look like
       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 inferContext loop does
    not converge.  See Trac #5287.

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 :: TyVarSet -> PredType -> Bool
-- See Note [Valid 'deriving' predicate]
validDerivPred :: VarSet -> Type -> Bool
validDerivPred tv_set :: VarSet
tv_set pred :: Type
pred
  = case Type -> PredTree
classifyPredType Type
pred of
       ClassPred cls :: Class
cls tys :: [Type]
tys -> Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
typeableClassKey
                -- Typeable constraints are bigger than they appear due
                -- to kind polymorphism, but that's OK
                       Bool -> Bool -> Bool
|| Class -> [Type] -> Bool
check_tys Class
cls [Type]
tys
       EqPred {}       -> Bool
False  -- reject equality constraints
       _               -> Bool
True   -- Non-class predicates are ok
  where
    check_tys :: Class -> [Type] -> Bool
check_tys cls :: Class
cls tys :: [Type]
tys
              = [TyCoVar] -> Bool
forall a. Eq a => [a] -> Bool
hasNoDups [TyCoVar]
fvs
                   -- use sizePred to ignore implicit args
                Bool -> Bool -> Bool
&& [TyCoVar] -> Int -> Bool
forall a. [a] -> Int -> Bool
lengthIs [TyCoVar]
fvs (Type -> Int
sizePred Type
pred)
                Bool -> Bool -> Bool
&& (TyCoVar -> Bool) -> [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TyCoVar -> VarSet -> Bool
`elemVarSet` VarSet
tv_set) [TyCoVar]
fvs
      where tys' :: [Type]
tys' = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [Type]
tys
            fvs :: [TyCoVar]
fvs  = [Type] -> [TyCoVar]
fvTypes [Type]
tys'

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

{- Note [Instances and constraint synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Currently, we don't allow instances for constraint synonyms at all.
Consider these (Trac #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.
-}

checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()
checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()
checkValidInstance ctxt :: UserTypeCtxt
ctxt hs_type :: LHsSigType GhcRn
hs_type ty :: Type
ty
  | Bool -> Bool
not Bool
is_tc_app
  = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Instance head is not headed by a class:")
                   2 ( Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tau))

  | Maybe Class -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Class
mb_cls
  = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc ([SDoc] -> SDoc
vcat [ String -> SDoc
text "Illegal instance for a" SDoc -> SDoc -> SDoc
<+> TyConFlavour -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> TyConFlavour
tyConFlavour TyCon
tc)
                     , String -> SDoc
text "A class instance must be for a class" ])

  | Bool -> Bool
not Bool
arity_ok
  = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc (String -> SDoc
text "Arity mis-match in instance head")

  | Bool
otherwise
  = do  { SrcSpan -> TcM () -> TcM ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
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 "checkValidInstance {" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

        ; TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
        ; ExpandMode
expand <- TcM ExpandMode
initialExpandMode
        ; TidyEnv -> UserTypeCtxt -> ExpandMode -> [Type] -> TcM ()
check_valid_theta TidyEnv
env0 UserTypeCtxt
ctxt ExpandMode
expand [Type]
theta

        -- The Termination and Coverate 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
        ; Bool
undecidable_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UndecidableInstances
        ; if Bool
undecidable_ok
          then UserTypeCtxt -> Type -> TcM ()
checkAmbiguity UserTypeCtxt
ctxt Type
ty
          else [Type] -> Type -> TcM ()
checkInstTermination [Type]
theta Type
tau

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

        ; case (Bool -> Class -> [Type] -> [Type] -> Validity
checkInstCoverage Bool
undecidable_ok Class
clas [Type]
theta [Type]
inst_tys) of
            IsValid      -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()   -- Check succeeded
            NotValid msg :: SDoc
msg -> SDoc -> TcM ()
addErrTc (Class -> [Type] -> SDoc -> SDoc
instTypeErr Class
clas [Type]
inst_tys SDoc
msg)

        ; String -> SDoc -> TcM ()
traceTc "End checkValidInstance }" SDoc
empty

        ; () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
  where
    (_tvs :: [TyCoVar]
_tvs, theta :: [Type]
theta, tau :: Type
tau)   = Type -> ([TyCoVar], [Type], Type)
tcSplitSigmaTy Type
ty
    is_tc_app :: Bool
is_tc_app            = case Type
tau of { TyConApp {} -> Bool
True; _ -> Bool
False }
    TyConApp tc :: TyCon
tc inst_tys :: [Type]
inst_tys = Type
tau   -- See Note [Instances and constraint synonyms]
    mb_cls :: Maybe Class
mb_cls               = TyCon -> Maybe Class
tyConClass_maybe TyCon
tc
    Just clas :: Class
clas            = Maybe Class
mb_cls
    arity_ok :: Bool
arity_ok             = [Type]
inst_tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Class -> Int
classArity Class
clas

        -- The location of the "head" of the instance
    head_loc :: SrcSpan
head_loc = LHsType GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsSigType GhcRn -> LHsType GhcRn
forall pass. LHsSigType pass -> LHsType pass
getLHsInstDeclHead LHsSigType GhcRn
hs_type)

{-
Note [Paterson conditions]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Termination test: the so-called "Paterson conditions" (see Section 5 of
"Understanding functional dependencies via Constraint Handling Rules,
JFP Jan 2007).

We check that each assertion in the context satisfies:
 (1) no variable has more occurrences in the assertion than in the head, and
 (2) the assertion has fewer constructors and variables (taken together
     and counting repetitions) than the head.
This is only needed with -fglasgow-exts, as Haskell 98 restrictions
(which have already been checked) guarantee termination.

The underlying idea is that

    for any ground substitution, each assertion in the
    context has fewer type constructors than the head.
-}

checkInstTermination :: ThetaType -> TcPredType -> TcM ()
-- See Note [Paterson conditions]
checkInstTermination :: [Type] -> Type -> TcM ()
checkInstTermination theta :: [Type]
theta head_pred :: Type
head_pred
  = VarSet -> [Type] -> TcM ()
check_preds VarSet
emptyVarSet [Type]
theta
  where
   head_fvs :: [TyCoVar]
head_fvs  = Type -> [TyCoVar]
fvType Type
head_pred
   head_size :: Int
head_size = Type -> Int
sizeType Type
head_pred

   check_preds :: VarSet -> [PredType] -> TcM ()
   check_preds :: VarSet -> [Type] -> TcM ()
check_preds foralld_tvs :: VarSet
foralld_tvs preds :: [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 foralld_tvs :: VarSet
foralld_tvs pred :: Type
pred
     = case Type -> PredTree
classifyPredType Type
pred of
         EqPred {}    -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- See Trac #4200.
         IrredPred {} -> VarSet -> Type -> Int -> TcM ()
check2 VarSet
foralld_tvs Type
pred (Type -> Int
sizeType Type
pred)
         ClassPred cls :: Class
cls tys :: [Type]
tys
           | Class -> Bool
isTerminatingClass Class
cls
           -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

           | Class -> Bool
isCTupleClass Class
cls  -- Look inside tuple predicates; Trac #8359
           -> VarSet -> [Type] -> TcM ()
check_preds VarSet
foralld_tvs [Type]
tys

           | Bool
otherwise          -- Other ClassPreds
           -> VarSet -> Type -> Int -> TcM ()
check2 VarSet
foralld_tvs Type
pred Int
bogus_size
           where
              bogus_size :: Int
bogus_size = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Type] -> Int
sizeTypes (TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [Type]
tys)
                               -- See Note [Invisible arguments and termination]

         ForAllPred tvs :: [TyVarBinder]
tvs _ head_pred' :: Type
head_pred'
           -> VarSet -> Type -> TcM ()
check (VarSet
foralld_tvs VarSet -> [TyCoVar] -> VarSet
`extendVarSetList` [TyVarBinder] -> [TyCoVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
tvs) Type
head_pred'
              -- Termination of the quantified predicate itself is checked
              -- when the predicates are individually checked for validity

   check2 :: VarSet -> Type -> Int -> TcM ()
check2 foralld_tvs :: VarSet
foralld_tvs pred :: Type
pred pred_size :: Int
pred_size
     | Bool -> Bool
not ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
bad_tvs)     = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc ([TyCoVar] -> SDoc -> SDoc -> SDoc
noMoreMsg [TyCoVar]
bad_tvs SDoc
what (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
head_pred))
     | Bool -> Bool
not (Type -> Bool
isTyFamFree Type
pred) = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc (SDoc -> SDoc
nestedMsg SDoc
what)
     | Int
pred_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
head_size = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc (SDoc -> SDoc -> SDoc
smallerMsg SDoc
what (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
head_pred))
     | Bool
otherwise              = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     -- isTyFamFree: see Note [Type families in instance contexts]
     where
        what :: SDoc
what    = String -> SDoc
text "constraint" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred)
        bad_tvs :: [TyCoVar]
bad_tvs = (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (TyCoVar -> VarSet -> Bool
`elemVarSet` VarSet
foralld_tvs) (Type -> [TyCoVar]
fvType Type
pred)
                  [TyCoVar] -> [TyCoVar] -> [TyCoVar]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TyCoVar]
head_fvs

smallerMsg :: SDoc -> SDoc -> SDoc
smallerMsg :: SDoc -> SDoc -> SDoc
smallerMsg what :: SDoc
what inst_head :: SDoc
inst_head
  = [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "The" SDoc -> SDoc -> SDoc
<+> SDoc
what)
              2 ([SDoc] -> SDoc
sep [ String -> SDoc
text "is no smaller than"
                     , String -> SDoc
text "the instance head" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
inst_head ])
         , SDoc -> SDoc
parens SDoc
undecidableMsg ]

noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc
noMoreMsg :: [TyCoVar] -> SDoc -> SDoc -> SDoc
noMoreMsg tvs :: [TyCoVar]
tvs what :: SDoc
what inst_head :: SDoc
inst_head
  = [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Variable" SDoc -> SDoc -> SDoc
<> [TyCoVar] -> SDoc
forall a. [a] -> SDoc
plural [TyCoVar]
tvs1 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes ((TyCoVar -> SDoc) -> [TyCoVar] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas TyCoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCoVar]
tvs1)
                SDoc -> SDoc -> SDoc
<+> SDoc
occurs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "more often")
              2 ([SDoc] -> SDoc
sep [ String -> SDoc
text "in the" SDoc -> SDoc -> SDoc
<+> SDoc
what
                     , String -> SDoc
text "than in the instance head" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
inst_head ])
         , SDoc -> SDoc
parens SDoc
undecidableMsg ]
  where
   tvs1 :: [TyCoVar]
tvs1   = [TyCoVar] -> [TyCoVar]
forall a. Eq a => [a] -> [a]
nub [TyCoVar]
tvs
   occurs :: SDoc
occurs = if [TyCoVar] -> Bool
forall a. [a] -> Bool
isSingleton [TyCoVar]
tvs1 then String -> SDoc
text "occurs"
                               else String -> SDoc
text "occur"

undecidableMsg, constraintKindsMsg :: SDoc
undecidableMsg :: SDoc
undecidableMsg     = String -> SDoc
text "Use UndecidableInstances to permit this"
constraintKindsMsg :: SDoc
constraintKindsMsg = String -> SDoc
text "Use ConstraintKinds to permit this"

{- Note [Type families in instance contexts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Are these OK?
  type family F a
  instance F a    => C (Maybe [a]) where ...
  intance C (F a) => C [[[a]]]     where ...

No: the type family in the instance head might blow up to an
arbitrarily large type, depending on how 'a' is instantiated.
So we require UndecidableInstances if we have a type family
in the instance head.  Trac #15172.

Note [Invisible arguments and termination]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When checking the ​Paterson conditions for termination an instance
declaration, we check for the number of "constructors and variables"
in the instance head and constraints. Question: Do we look at

 * All the arguments, visible or invisible?
 * Just the visible arguments?

I think both will ensure termination, provided we are consistent.
Currently we are /not/ consistent, which is really a bug.  It's
described in Trac #15177, which contains a number of examples.
The suspicious bits are the calls to filterOutInvisibleTypes.
-}


{-
************************************************************************
*                                                                      *
        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 :: * -> *) a b.
Monad m =>
(a -> b -> m a) -> a -> [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 prev_branches :: [CoAxBranch]
prev_branches cur_branch :: CoAxBranch
cur_branch
      | CoAxBranch
cur_branch CoAxBranch -> [CoAxBranch] -> Bool
`isDominatedBy` [CoAxBranch]
prev_branches
      = do { WarnReason -> SrcSpan -> SDoc -> TcM ()
addWarnAt WarnReason
NoReason (CoAxBranch -> SrcSpan
coAxBranchSpan CoAxBranch
cur_branch) (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
             TyCon -> CoAxBranch -> SDoc
inaccessibleCoAxBranch TyCon
fam_tc CoAxBranch
cur_branch
           ; [CoAxBranch] -> IOEnv (Env TcGblEnv TcLclEnv) [CoAxBranch]
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 (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 FamInstEnv
    check_injectivity :: [CoAxBranch] -> CoAxBranch -> TcM ()
check_injectivity prev_branches :: [CoAxBranch]
prev_branches cur_branch :: CoAxBranch
cur_branch
      | Injective inj :: [Bool]
inj <- Injectivity
injectivity
      = do { let conflicts :: [CoAxBranch]
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 (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)
                                 ([], 0) [CoAxBranch]
prev_branches
           ; ((SDoc, SrcSpan) -> TcM ()) -> [(SDoc, SrcSpan)] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(err :: SDoc
err, span :: SrcSpan
span) -> SrcSpan -> TcM () -> TcM ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
span (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcM ()
addErr SDoc
err)
                   (CoAxiom Branched
-> CoAxBranch -> [Bool] -> [CoAxBranch] -> [(SDoc, SrcSpan)]
forall (br :: BranchFlag).
CoAxiom br
-> CoAxBranch -> [Bool] -> [CoAxBranch] -> [(SDoc, SrcSpan)]
makeInjectivityErrors CoAxiom Branched
ax CoAxBranch
cur_branch [Bool]
inj [CoAxBranch]
conflicts) }
      | Bool
otherwise
      = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    gather_conflicts :: [Bool]
-> [CoAxBranch]
-> CoAxBranch
-> ([CoAxBranch], Int)
-> CoAxBranch
-> ([CoAxBranch], Int)
gather_conflicts inj :: [Bool]
inj prev_branches :: [CoAxBranch]
prev_branches cur_branch :: CoAxBranch
cur_branch (acc :: [CoAxBranch]
acc, n :: Int
n) branch :: 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
          InjectivityUnified ax1 :: CoAxBranch
ax1 ax2 :: 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
+ 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
+ 1)
          InjectivityAccepted -> ([CoAxBranch]
acc, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 brs :: [CoAxBranch]
brs n :: Int
n br :: 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
+1) [CoAxBranch]
brs


-- Check that a "type instance" is well-formed (which includes decidability
-- unless -XUndecidableInstances is given).
--
checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM ()
checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM ()
checkValidCoAxBranch fam_tc :: TyCon
fam_tc
                    (CoAxBranch { cab_tvs :: CoAxBranch -> [TyCoVar]
cab_tvs = [TyCoVar]
tvs, cab_cvs :: CoAxBranch -> [TyCoVar]
cab_cvs = [TyCoVar]
cvs
                                , 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 -> [TyCoVar] -> [Type] -> Type -> TcM ()
checkValidTyFamEqn TyCon
fam_tc ([TyCoVar]
tvs[TyCoVar] -> [TyCoVar] -> [TyCoVar]
forall a. [a] -> [a] -> [a]
++[TyCoVar]
cvs) [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.
checkValidTyFamEqn :: TyCon   -- ^ of the type family
                   -> [Var]   -- ^ Bound variables in the equation
                   -> [Type]  -- ^ Type patterns
                   -> Type    -- ^ Rhs
                   -> TcM ()
checkValidTyFamEqn :: TyCon -> [TyCoVar] -> [Type] -> Type -> TcM ()
checkValidTyFamEqn fam_tc :: TyCon
fam_tc qvs :: [TyCoVar]
qvs typats :: [Type]
typats rhs :: Type
rhs
  = do { TyCon -> [TyCoVar] -> [Type] -> Type -> TcM ()
checkValidFamPats TyCon
fam_tc [TyCoVar]
qvs [Type]
typats Type
rhs

         -- 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 Trac #9357
       ; Type -> TcM ()
checkValidMonoType Type
rhs

         -- We have a decidable instance unless otherwise permitted
       ; Bool
undecidable_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UndecidableInstances
       ; String -> SDoc -> TcM ()
traceTc "checkVTFE" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs SDoc -> SDoc -> SDoc
$$ [(TyCon, [Type])] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> [(TyCon, [Type])]
tcTyFamInsts Type
rhs))
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
undecidable_ok (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
         (SDoc -> TcM ()) -> [SDoc] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SDoc -> TcM ()
addErrTc (TyCon -> [Type] -> [(TyCon, [Type])] -> [SDoc]
checkFamInstRhs TyCon
fam_tc [Type]
typats (Type -> [(TyCon, [Type])]
tcTyFamInsts Type
rhs)) }

-- Make sure that each type family application is
--   (1) strictly smaller than the lhs,
--   (2) mentions no type variable more often than the lhs, and
--   (3) does not contain any further type family instances.
--
checkFamInstRhs :: TyCon -> [Type]         -- LHS
                -> [(TyCon, [Type])]       -- type family calls in RHS
                -> [MsgDoc]
checkFamInstRhs :: TyCon -> [Type] -> [(TyCon, [Type])] -> [SDoc]
checkFamInstRhs lhs_tc :: TyCon
lhs_tc lhs_tys :: [Type]
lhs_tys famInsts :: [(TyCon, [Type])]
famInsts
  = ((TyCon, [Type]) -> Maybe SDoc) -> [(TyCon, [Type])] -> [SDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TyCon, [Type]) -> Maybe SDoc
check [(TyCon, [Type])]
famInsts
  where
   lhs_size :: Int
lhs_size  = TyCon -> [Type] -> Int
sizeTyConAppArgs TyCon
lhs_tc [Type]
lhs_tys
   inst_head :: SDoc
inst_head = Type -> SDoc
pprType (TyCon -> [Type] -> Type
TyConApp TyCon
lhs_tc [Type]
lhs_tys)
   lhs_fvs :: [TyCoVar]
lhs_fvs   = [Type] -> [TyCoVar]
fvTypes [Type]
lhs_tys
   check :: (TyCon, [Type]) -> Maybe SDoc
check (tc :: TyCon
tc, tys :: [Type]
tys)
      | Bool -> Bool
not ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyFamFree [Type]
tys) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> SDoc
nestedMsg SDoc
what)
      | Bool -> Bool
not ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
bad_tvs)        = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just ([TyCoVar] -> SDoc -> SDoc -> SDoc
noMoreMsg [TyCoVar]
bad_tvs SDoc
what SDoc
inst_head)
      | Int
lhs_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
fam_app_size  = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> SDoc -> SDoc
smallerMsg SDoc
what SDoc
inst_head)
      | Bool
otherwise                 = Maybe SDoc
forall a. Maybe a
Nothing
      where
        what :: SDoc
what = String -> SDoc
text "type family application"
               SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprType (TyCon -> [Type] -> Type
TyConApp TyCon
tc [Type]
tys))
        fam_app_size :: Int
fam_app_size = TyCon -> [Type] -> Int
sizeTyConAppArgs TyCon
tc [Type]
tys
        bad_tvs :: [TyCoVar]
bad_tvs      = [Type] -> [TyCoVar]
fvTypes [Type]
tys [TyCoVar] -> [TyCoVar] -> [TyCoVar]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TyCoVar]
lhs_fvs
                       -- The (\\) is list difference; e.g.
                       --   [a,b,a,a] \\ [a,a] = [b,a]
                       -- So we are counting repetitions

checkValidFamPats :: TyCon -> [Var]
                  -> [Type]   -- ^ patterns
                  -> Type     -- ^ RHS
                  -> TcM ()
-- Patterns in a 'type instance' or 'data instance' decl should
-- a) Shoule contain no type family applications
--    (vanilla synonyms are fine, though)
-- b) For associated types, are consistently instantiated
checkValidFamPats :: TyCon -> [TyCoVar] -> [Type] -> Type -> TcM ()
checkValidFamPats fam_tc :: TyCon
fam_tc qvs :: [TyCoVar]
qvs pats :: [Type]
pats rhs :: Type
rhs
  = do { TyCon -> [Type] -> TcM ()
checkValidTypePats TyCon
fam_tc [Type]
pats

         -- Check for things used on the right but not bound on the left
       ; TyCon -> [TyCoVar] -> [Type] -> Type -> TcM ()
checkFamPatBinders TyCon
fam_tc [TyCoVar]
qvs [Type]
pats Type
rhs

       ; String -> SDoc -> TcM ()
traceTc "checkValidFamPats" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
pats)
       }

-----------------
checkFamPatBinders :: TyCon
                   -> [TcTyVar]   -- Bound on LHS of family instance
                   -> [TcType]    -- LHS patterns
                   -> Type        -- RHS
                   -> TcM ()
-- We do these binder checks now, in tcFamTyPatsAndGen, rather
-- than later, in checkValidFamEqn, for two reasons:
--   - We have the implicitly and explicitly
--     bound type variables conveniently to hand
--   - If implicit variables are out of scope it may
--     cause a crash; notably in tcConDecl in tcDataFamInstDecl
checkFamPatBinders :: TyCon -> [TyCoVar] -> [Type] -> Type -> TcM ()
checkFamPatBinders fam_tc :: TyCon
fam_tc qtvs :: [TyCoVar]
qtvs pats :: [Type]
pats rhs :: Type
rhs
  = do { String -> SDoc -> TcM ()
traceTc "checkFamPatBinders" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
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
text "qtvs:" SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCoVar]
qtvs
              , String -> SDoc
text "rhs_tvs:" SDoc -> SDoc -> SDoc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FV -> VarSet
fvVarSet FV
rhs_fvs)
              , String -> SDoc
text "pat_tvs:" SDoc -> SDoc -> SDoc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
pat_tvs
              , String -> SDoc
text "exact_pat_tvs:" SDoc -> SDoc -> SDoc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
exact_pat_tvs ]

         -- 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 kcLHsQTyVars, and the latter right here
       ; [TyCoVar] -> SDoc -> SDoc -> TcM ()
check_tvs [TyCoVar]
bad_rhs_tvs (String -> SDoc
text "mentioned in the RHS")
                               (String -> SDoc
text "bound on the LHS of")

         -- 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]
       ; [TyCoVar] -> SDoc -> SDoc -> TcM ()
check_tvs [TyCoVar]
bad_qtvs (String -> SDoc
text "bound by a forall")
                            (String -> SDoc
text "used in")

         -- 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]
pats of
             [] -> () -> TcM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
             spec_arg :: Type
spec_arg:_ ->
               SDoc -> TcM ()
addErr (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text "Illegal oversaturated visible kind argument:"
                    SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Char -> SDoc
char '@' SDoc -> SDoc -> SDoc
<> Type -> SDoc
pprParendType Type
spec_arg) }
  where
    pat_tvs :: VarSet
pat_tvs       = [Type] -> VarSet
tyCoVarsOfTypes [Type]
pats
    exact_pat_tvs :: VarSet
exact_pat_tvs = [Type] -> VarSet
exactTyCoVarsOfTypes [Type]
pats
    rhs_fvs :: FV
rhs_fvs       = Type -> FV
tyCoFVsOfType Type
rhs
    used_tvs :: VarSet
used_tvs      = VarSet
pat_tvs VarSet -> VarSet -> VarSet
`unionVarSet` FV -> VarSet
fvVarSet FV
rhs_fvs
    bad_qtvs :: [TyCoVar]
bad_qtvs      = (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (TyCoVar -> VarSet -> Bool
`elemVarSet` VarSet
used_tvs) [TyCoVar]
qtvs
                    -- Bound but not used at all
    bad_rhs_tvs :: [TyCoVar]
bad_rhs_tvs   = (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (TyCoVar -> VarSet -> Bool
`elemVarSet` VarSet
exact_pat_tvs) (FV -> [TyCoVar]
fvVarList FV
rhs_fvs)
                    -- Used on RHS but not bound on LHS
    dodgy_tvs :: VarSet
dodgy_tvs     = VarSet
pat_tvs VarSet -> VarSet -> VarSet
`minusVarSet` VarSet
exact_pat_tvs

    check_tvs :: [TyCoVar] -> SDoc -> SDoc -> TcM ()
check_tvs tvs :: [TyCoVar]
tvs what :: SDoc
what what2 :: SDoc
what2
      = Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
tvs) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> TcM ()
addErrAt (TyCoVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan ([TyCoVar] -> TyCoVar
forall a. [a] -> a
head [TyCoVar]
tvs)) (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
        SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Type variable" SDoc -> SDoc -> SDoc
<> [TyCoVar] -> SDoc
forall a. [a] -> SDoc
plural [TyCoVar]
tvs SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TyCoVar]
tvs
              SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
forall a. [a] -> SDoc
isOrAre [TyCoVar]
tvs SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
comma)
           2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text "but not" SDoc -> SDoc -> SDoc
<+> SDoc
what2 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "the family instance"
                   , [TyCoVar] -> SDoc
forall (t :: * -> *). Foldable t => t TyCoVar -> SDoc
mk_extra [TyCoVar]
tvs ])

    -- mk_extra: Trac #7536: give a decent error message for
    --         type T a = Int
    --         type instance F (T a) = a
    mk_extra :: t TyCoVar -> SDoc
mk_extra tvs :: t TyCoVar
tvs = Bool -> SDoc -> SDoc
ppWhen ((TyCoVar -> Bool) -> t TyCoVar -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyCoVar -> VarSet -> Bool
`elemVarSet` VarSet
dodgy_tvs) t TyCoVar
tvs) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                   SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "The real LHS (expanding synonyms) is:")
                      2 (TyCon -> [Type] -> SDoc
pprTypeApp TyCon
fam_tc ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
expandTypeSynonyms [Type]
pats))


-- | Checks for occurrences of type families in class instances and type/data
-- family instances.
checkValidTypePats :: TyCon -> [Type] -> TcM ()
checkValidTypePats :: TyCon -> [Type] -> TcM ()
checkValidTypePats tc :: TyCon
tc pat_ty_args :: [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 instances occur a type pattern
  case TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVis TyCon
tc [Type]
pat_ty_args of
    [] -> () -> TcM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ((tf_is_invis_arg :: Bool
tf_is_invis_arg, tf_tc :: TyCon
tf_tc, tf_args :: [Type]
tf_args):_) -> SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
      Bool -> Type -> SDoc
ty_fam_inst_illegal_err Bool
tf_is_invis_arg (TyCon -> [Type] -> Type
mkTyConApp TyCon
tf_tc [Type]
tf_args)
  where
    inst_ty :: Type
inst_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
pat_ty_args

    ty_fam_inst_illegal_err :: Bool -> Type -> SDoc
    ty_fam_inst_illegal_err :: Bool -> Type -> SDoc
ty_fam_inst_illegal_err invis_arg :: Bool
invis_arg ty :: Type
ty
      = Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen Bool
invis_arg (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
        SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Illegal type synonym family application"
                SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "in instance" SDoc -> SDoc -> SDoc
<> SDoc
colon)
           2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
inst_ty)

-- Error messages

inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc
inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc
inaccessibleCoAxBranch fam_tc :: TyCon
fam_tc cur_branch :: CoAxBranch
cur_branch
  = String -> SDoc
text "Type family instance equation is overlapped:" SDoc -> SDoc -> SDoc
$$
    Int -> SDoc -> SDoc
nest 2 (TyCon -> CoAxBranch -> SDoc
pprCoAxBranchUser TyCon
fam_tc CoAxBranch
cur_branch)

nestedMsg :: SDoc -> SDoc
nestedMsg :: SDoc -> SDoc
nestedMsg what :: SDoc
what
  = [SDoc] -> SDoc
sep [ String -> SDoc
text "Illegal nested" SDoc -> SDoc -> SDoc
<+> SDoc
what
        , SDoc -> SDoc
parens SDoc
undecidableMsg ]

badATErr :: Name -> Name -> SDoc
badATErr :: Name -> Name -> SDoc
badATErr clas :: Name
clas op :: Name
op
  = [SDoc] -> SDoc
hsep [String -> SDoc
text "Class", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
clas),
          String -> SDoc
text "does not have an associated type", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
op)]


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

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

checkConsistentFamInst (InClsInst { ai_class :: AssocInstInfo -> Class
ai_class = Class
clas
                                  , ai_tyvars :: AssocInstInfo -> [TyCoVar]
ai_tyvars = [TyCoVar]
inst_tvs
                                  , ai_inst_env :: AssocInstInfo -> VarEnv Type
ai_inst_env = VarEnv Type
mini_env })
                       fam_tc :: TyCon
fam_tc branch :: CoAxBranch
branch
  = do { String -> SDoc -> TcM ()
traceTc "checkConsistentFamInst" ([SDoc] -> SDoc
vcat [ [TyCoVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCoVar]
inst_tvs
                                                , [(Type, Type, ArgFlag)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Type, Type, ArgFlag)]
arg_triples
                                                , VarEnv Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarEnv Type
mini_env
                                                , [TyCoVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCoVar]
ax_tvs
                                                , [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
ax_arg_tys
                                                , [(Type, Type, ArgFlag)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Type, Type, ArgFlag)]
arg_triples ])
       -- Check that the associated type indeed comes from this class
       -- See [Mismatched class methods and associated type families]
       -- in TcInstDecls.
       ; Bool -> SDoc -> 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)
                 (Name -> Name -> SDoc
badATErr (Class -> Name
className Class
clas) (TyCon -> Name
tyConName TyCon
fam_tc))

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

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

    pp_wrong_at_arg :: ArgFlag -> SDoc
pp_wrong_at_arg vis :: ArgFlag
vis
      = Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen (ArgFlag -> Bool
isInvisibleArgFlag ArgFlag
vis) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
        [SDoc] -> SDoc
vcat [ String -> SDoc
text "Type indexes must match class instance head"
             , String -> SDoc
text "Expected:" SDoc -> SDoc -> SDoc
<+> SDoc
pp_expected_ty
             , String -> SDoc
text "  Actual:" SDoc -> SDoc -> SDoc
<+> SDoc
pp_actual_ty ]

    -- 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]
    (tidy_env1 :: TidyEnv
tidy_env1, _) = TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
tidyVarBndrs TidyEnv
emptyTidyEnv [TyCoVar]
inst_tvs
    (tidy_env2 :: TidyEnv
tidy_env2, _) = TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
tidyCoAxBndrsForUser TidyEnv
tidy_env1 ([TyCoVar]
ax_tvs [TyCoVar] -> [TyCoVar] -> [TyCoVar]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TyCoVar]
inst_tvs)

    pp_expected_ty :: SDoc
pp_expected_ty = PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprIfaceTypeApp PprPrec
topPrec (TyCon -> IfaceTyCon
toIfaceTyCon TyCon
fam_tc) (IfaceAppArgs -> SDoc) -> IfaceAppArgs -> SDoc
forall a b. (a -> b) -> a -> b
$
                     TyCon -> [Type] -> IfaceAppArgs
toIfaceTcArgs TyCon
fam_tc ([Type] -> IfaceAppArgs) -> [Type] -> IfaceAppArgs
forall a b. (a -> b) -> a -> b
$
                     [ case VarEnv Type -> TyCoVar -> Maybe Type
forall a. VarEnv a -> TyCoVar -> Maybe a
lookupVarEnv VarEnv Type
mini_env TyCoVar
at_tv of
                         Just cls_arg_ty :: Type
cls_arg_ty -> TidyEnv -> Type -> Type
tidyType TidyEnv
tidy_env2 Type
cls_arg_ty
                         Nothing         -> TyCoVar -> Type
mk_wildcard TyCoVar
at_tv
                     | TyCoVar
at_tv <- TyCon -> [TyCoVar]
tyConTyVars TyCon
fam_tc ]

    pp_actual_ty :: SDoc
pp_actual_ty = PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprIfaceTypeApp PprPrec
topPrec (TyCon -> IfaceTyCon
toIfaceTyCon TyCon
fam_tc) (IfaceAppArgs -> SDoc) -> IfaceAppArgs -> SDoc
forall a b. (a -> b) -> a -> b
$
                   TyCon -> [Type] -> IfaceAppArgs
toIfaceTcArgs TyCon
fam_tc ([Type] -> IfaceAppArgs) -> [Type] -> IfaceAppArgs
forall a b. (a -> b) -> a -> b
$
                   TidyEnv -> [Type] -> [Type]
tidyTypes TidyEnv
tidy_env2 [Type]
ax_arg_tys

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

    -- For check_match, bind_me, see
    -- Note [Matching in the consistent-instantation check]
    check_match :: [(Type,Type,ArgFlag)] -> TcM ()
    check_match :: [(Type, Type, ArgFlag)] -> TcM ()
check_match triples :: [(Type, Type, ArgFlag)]
triples = TCvSubst -> TCvSubst -> [(Type, Type, ArgFlag)] -> TcM ()
go TCvSubst
emptyTCvSubst TCvSubst
emptyTCvSubst [(Type, Type, ArgFlag)]
triples

    go :: TCvSubst -> TCvSubst -> [(Type, Type, ArgFlag)] -> TcM ()
go _ _ [] = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go lr_subst :: TCvSubst
lr_subst rl_subst :: TCvSubst
rl_subst ((ty1 :: Type
ty1,ty2 :: Type
ty2,vis :: ArgFlag
vis):triples :: [(Type, Type, ArgFlag)]
triples)
      | Just lr_subst1 :: TCvSubst
lr_subst1 <- (TyCoVar -> BindFlag) -> TCvSubst -> Type -> Type -> Maybe TCvSubst
tcMatchTyX_BM TyCoVar -> BindFlag
bind_me TCvSubst
lr_subst Type
ty1 Type
ty2
      , Just rl_subst1 :: TCvSubst
rl_subst1 <- (TyCoVar -> BindFlag) -> TCvSubst -> Type -> Type -> Maybe TCvSubst
tcMatchTyX_BM TyCoVar -> BindFlag
bind_me TCvSubst
rl_subst Type
ty2 Type
ty1
      = TCvSubst -> TCvSubst -> [(Type, Type, ArgFlag)] -> TcM ()
go TCvSubst
lr_subst1 TCvSubst
rl_subst1 [(Type, Type, ArgFlag)]
triples
      | Bool
otherwise
      = SDoc -> TcM ()
addErrTc (ArgFlag -> SDoc
pp_wrong_at_arg ArgFlag
vis)

    -- 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 = [TyCoVar] -> VarSet
mkVarSet [TyCoVar]
inst_tvs
    bind_me :: TyCoVar -> BindFlag
bind_me tv :: TyCoVar
tv | TyCoVar
tv TyCoVar -> VarSet -> Bool
`elemVarSet` VarSet
no_bind_set = BindFlag
Skolem
               | Bool
otherwise                   = BindFlag
BindMe


{- Note [Matching in the consistent-instantation check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Matching the class-instance header to family-instance tyvars is
tricker than it sounds.  Consider (Trac #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 (Trac #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 Trac #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 Trac #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 Trac #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
   clase 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 aready 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 varable. At least with @x :: forall a. Int@ we can use visibile
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 TcTyClsDecls.)

   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 FamInstEnv.

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

Note [Bad 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 checkValidTelescope during kind-checking
datatype declarations. See also
Note [Required, Specified, and Inferred for types] in TcTyClsDecls.

Note [Keeping scoped variables in order: Explicit] discusses how this
check works for `forall x y z.` written in a type.

-}

-- | Check a list of binders to see if they make a valid telescope.
-- The key property we're checking for is scoping. For example:
-- > data SameKind :: k -> k -> *
-- > data X a k (b :: k) (c :: SameKind a b)
-- Kind inference says that a's kind should be k. But that's impossible,
-- because k isn't in scope when a is bound. This check has to come before
-- general validity checking, because once we kind-generalise, this sort
-- of problem is harder to spot (as we'll generalise over the unbound
-- k in a's type.)
--
-- See Note [Generalisation for type constructors] in TcTyClsDecls for
--     data type declarations
-- and Note [Keeping scoped variables in order: Explicit] in TcHsType
--     for foralls
checkValidTelescope :: TyCon -> TcM ()
checkValidTelescope :: TyCon -> TcM ()
checkValidTelescope tc :: TyCon
tc
  = Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([VarBndr TyCoVar TyConBndrVis] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VarBndr TyCoVar TyConBndrVis]
bad_tcbs) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcM ()
addErr (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "The kind of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is ill-scoped")
              2 (String -> SDoc
text "Inferred kind:" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
ppr_untidy (TyCon -> Type
tyConKind TyCon
tc))
         , SDoc
extra
         , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Perhaps try this order instead:")
              2 ([TyCoVar] -> SDoc
pprTyVars [TyCoVar]
sorted_tidied_tvs) ]
  where
    ppr_untidy :: Type -> SDoc
ppr_untidy ty :: Type
ty = IfaceType -> SDoc
pprIfaceType (Type -> IfaceType
toIfaceType Type
ty)
    tcbs :: [VarBndr TyCoVar TyConBndrVis]
tcbs = TyCon -> [VarBndr TyCoVar TyConBndrVis]
tyConBinders TyCon
tc
    tvs :: [TyCoVar]
tvs = [VarBndr TyCoVar TyConBndrVis] -> [TyCoVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TyCoVar TyConBndrVis]
tcbs
    (_, sorted_tidied_tvs :: [TyCoVar]
sorted_tidied_tvs) = TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
tidyVarBndrs TidyEnv
emptyTidyEnv ([TyCoVar] -> [TyCoVar]
scopedSort [TyCoVar]
tvs)

    (_, bad_tcbs :: [VarBndr TyCoVar TyConBndrVis]
bad_tcbs) = ((VarSet, [VarBndr TyCoVar TyConBndrVis])
 -> VarBndr TyCoVar TyConBndrVis
 -> (VarSet, [VarBndr TyCoVar TyConBndrVis]))
-> (VarSet, [VarBndr TyCoVar TyConBndrVis])
-> [VarBndr TyCoVar TyConBndrVis]
-> (VarSet, [VarBndr TyCoVar TyConBndrVis])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (VarSet, [VarBndr TyCoVar TyConBndrVis])
-> VarBndr TyCoVar TyConBndrVis
-> (VarSet, [VarBndr TyCoVar TyConBndrVis])
add_one ([TyCoVar] -> VarSet
mkVarSet [TyCoVar]
tvs, []) [VarBndr TyCoVar TyConBndrVis]
tcbs

    add_one :: (TyVarSet, [TyConBinder])
            -> TyConBinder -> (TyVarSet, [TyConBinder])
    add_one :: (VarSet, [VarBndr TyCoVar TyConBndrVis])
-> VarBndr TyCoVar TyConBndrVis
-> (VarSet, [VarBndr TyCoVar TyConBndrVis])
add_one (bad_bndrs :: VarSet
bad_bndrs, acc :: [VarBndr TyCoVar TyConBndrVis]
acc) tvb :: VarBndr TyCoVar TyConBndrVis
tvb
      | VarSet
fkvs VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
bad_bndrs = (VarSet
bad', VarBndr TyCoVar TyConBndrVis
tvb VarBndr TyCoVar TyConBndrVis
-> [VarBndr TyCoVar TyConBndrVis] -> [VarBndr TyCoVar TyConBndrVis]
forall a. a -> [a] -> [a]
: [VarBndr TyCoVar TyConBndrVis]
acc)
      | Bool
otherwise                         = (VarSet
bad', [VarBndr TyCoVar TyConBndrVis]
acc)
      where
        tv :: TyCoVar
tv = VarBndr TyCoVar TyConBndrVis -> TyCoVar
forall tv argf. VarBndr tv argf -> tv
binderVar VarBndr TyCoVar TyConBndrVis
tvb
        fkvs :: VarSet
fkvs = Type -> VarSet
tyCoVarsOfType (TyCoVar -> Type
tyVarKind TyCoVar
tv)
        bad' :: VarSet
bad' = VarSet
bad_bndrs VarSet -> TyCoVar -> VarSet
`delVarSet` TyCoVar
tv

    inferred_tvs :: [TyCoVar]
inferred_tvs  = [ VarBndr TyCoVar TyConBndrVis -> TyCoVar
forall tv argf. VarBndr tv argf -> tv
binderVar VarBndr TyCoVar TyConBndrVis
tcb
                    | VarBndr TyCoVar TyConBndrVis
tcb <- [VarBndr TyCoVar TyConBndrVis]
tcbs, ArgFlag
Inferred ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== VarBndr TyCoVar TyConBndrVis -> ArgFlag
tyConBinderArgFlag VarBndr TyCoVar TyConBndrVis
tcb ]
    specified_tvs :: [TyCoVar]
specified_tvs = [ VarBndr TyCoVar TyConBndrVis -> TyCoVar
forall tv argf. VarBndr tv argf -> tv
binderVar VarBndr TyCoVar TyConBndrVis
tcb
                    | VarBndr TyCoVar TyConBndrVis
tcb <- [VarBndr TyCoVar TyConBndrVis]
tcbs, ArgFlag
Specified ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== VarBndr TyCoVar TyConBndrVis -> ArgFlag
tyConBinderArgFlag VarBndr TyCoVar TyConBndrVis
tcb ]

    pp_inf :: SDoc
pp_inf  = SDoc -> SDoc
parens (String -> SDoc
text "namely:" SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
pprTyVars [TyCoVar]
inferred_tvs)
    pp_spec :: SDoc
pp_spec = SDoc -> SDoc
parens (String -> SDoc
text "namely:" SDoc -> SDoc -> SDoc
<+> [TyCoVar] -> SDoc
pprTyVars [TyCoVar]
specified_tvs)

    extra :: SDoc
extra
      | [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
inferred_tvs Bool -> Bool -> Bool
&& [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
specified_tvs
      = SDoc
empty
      | [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
inferred_tvs
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "NB: Specified variables")
           2 ([SDoc] -> SDoc
sep [SDoc
pp_spec, String -> SDoc
text "always come first"])
      | [TyCoVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVar]
specified_tvs
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "NB: Inferred variables")
           2 ([SDoc] -> SDoc
sep [SDoc
pp_inf, String -> SDoc
text "always come first"])
      | Bool
otherwise
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "NB: Inferred variables")
           2 ([SDoc] -> SDoc
vcat [ [SDoc] -> SDoc
sep [ SDoc
pp_inf, String -> SDoc
text "always come first"]
                   , [SDoc] -> SDoc
sep [String -> SDoc
text "then Specified variables", SDoc
pp_spec]])

{-
************************************************************************
*                                                                      *
\subsection{Auxiliary functions}
*                                                                      *
************************************************************************
-}

-- Free variables of a type, retaining repetitions, and expanding synonyms
-- This ignores coercions, as coercions aren't user-written
fvType :: Type -> [TyCoVar]
fvType :: Type -> [TyCoVar]
fvType ty :: Type
ty | Just exp_ty :: Type
exp_ty <- Type -> Maybe Type
tcView Type
ty = Type -> [TyCoVar]
fvType Type
exp_ty
fvType (TyVarTy tv :: TyCoVar
tv)          = [TyCoVar
tv]
fvType (TyConApp _ tys :: [Type]
tys)      = [Type] -> [TyCoVar]
fvTypes [Type]
tys
fvType (LitTy {})            = []
fvType (AppTy fun :: Type
fun arg :: Type
arg)       = Type -> [TyCoVar]
fvType Type
fun [TyCoVar] -> [TyCoVar] -> [TyCoVar]
forall a. [a] -> [a] -> [a]
++ Type -> [TyCoVar]
fvType Type
arg
fvType (FunTy arg :: Type
arg res :: Type
res)       = Type -> [TyCoVar]
fvType Type
arg [TyCoVar] -> [TyCoVar] -> [TyCoVar]
forall a. [a] -> [a] -> [a]
++ Type -> [TyCoVar]
fvType Type
res
fvType (ForAllTy (Bndr tv :: TyCoVar
tv _) ty :: Type
ty)
  = Type -> [TyCoVar]
fvType (TyCoVar -> Type
tyVarKind TyCoVar
tv) [TyCoVar] -> [TyCoVar] -> [TyCoVar]
forall a. [a] -> [a] -> [a]
++
    (TyCoVar -> Bool) -> [TyCoVar] -> [TyCoVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyCoVar -> TyCoVar -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCoVar
tv) (Type -> [TyCoVar]
fvType Type
ty)
fvType (CastTy ty :: Type
ty _)         = Type -> [TyCoVar]
fvType Type
ty
fvType (CoercionTy {})       = []

fvTypes :: [Type] -> [TyVar]
fvTypes :: [Type] -> [TyCoVar]
fvTypes tys :: [Type]
tys                = [[TyCoVar]] -> [TyCoVar]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Type -> [TyCoVar]) -> [Type] -> [[TyCoVar]]
forall a b. (a -> b) -> [a] -> [b]
map Type -> [TyCoVar]
fvType [Type]
tys)

sizeType :: Type -> Int
-- Size of a type: the number of variables and constructors
sizeType :: Type -> Int
sizeType ty :: Type
ty | Just exp_ty :: Type
exp_ty <- Type -> Maybe Type
tcView Type
ty = Type -> Int
sizeType Type
exp_ty
sizeType (TyVarTy {})      = 1
sizeType (TyConApp tc :: TyCon
tc tys :: [Type]
tys) = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TyCon -> [Type] -> Int
sizeTyConAppArgs TyCon
tc [Type]
tys
sizeType (LitTy {})        = 1
sizeType (AppTy fun :: Type
fun arg :: Type
arg)   = Type -> Int
sizeType Type
fun Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
sizeType Type
arg
sizeType (FunTy arg :: Type
arg res :: Type
res)   = Type -> Int
sizeType Type
arg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
sizeType Type
res Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
sizeType (ForAllTy _ ty :: Type
ty)   = Type -> Int
sizeType Type
ty
sizeType (CastTy ty :: Type
ty _)     = Type -> Int
sizeType Type
ty
sizeType (CoercionTy _)    = 0

sizeTypes :: [Type] -> Int
sizeTypes :: [Type] -> Int
sizeTypes = (Type -> Int -> Int) -> Int -> [Type] -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int) -> (Type -> Int) -> Type -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Int
sizeType) 0

sizeTyConAppArgs :: TyCon -> [Type] -> Int
sizeTyConAppArgs :: TyCon -> [Type] -> Int
sizeTyConAppArgs _tc :: TyCon
_tc tys :: [Type]
tys = [Type] -> Int
sizeTypes [Type]
tys -- (filterOutInvisibleTypes tc tys)
                           -- See Note [Invisible arguments and termination]

-- Size of a predicate
--
-- We are considering whether class constraints terminate.
-- Equality constraints and constraints for the implicit
-- parameter class always terminate so it is safe to say "size 0".
-- See Trac #4200.
sizePred :: PredType -> Int
sizePred :: Type -> Int
sizePred ty :: Type
ty = Type -> Int
goClass Type
ty
  where
    goClass :: Type -> Int
goClass p :: Type
p = PredTree -> Int
go (Type -> PredTree
classifyPredType Type
p)

    go :: PredTree -> Int
go (ClassPred cls :: Class
cls tys' :: [Type]
tys')
      | Class -> Bool
isTerminatingClass Class
cls = 0
      | Bool
otherwise = [Type] -> Int
sizeTypes (TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [Type]
tys')
                    -- The filtering looks bogus
                    -- See Note [Invisible arguments and termination]
    go (EqPred {})           = 0
    go (IrredPred ty :: Type
ty)        = Type -> Int
sizeType Type
ty
    go (ForAllPred _ _ pred :: Type
pred) = Type -> Int
goClass Type
pred

-- | When this says "True", ignore this class constraint during
-- a termination check
isTerminatingClass :: Class -> Bool
isTerminatingClass :: Class -> Bool
isTerminatingClass cls :: Class
cls
  = Class -> Bool
isIPClass Class
cls    -- Implicit parameter constraints always terminate because
                     -- there are no instances for them --- they are only solved
                     -- by "local instances" in expressions
    Bool -> Bool -> Bool
|| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
typeableClassKey
    Bool -> Bool -> Bool
|| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleTyConKey
    Bool -> Bool -> Bool
|| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey
    Bool -> Bool -> Bool
|| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey

-- | Tidy before printing a type
ppr_tidy :: TidyEnv -> Type -> SDoc
ppr_tidy :: TidyEnv -> Type -> SDoc
ppr_tidy env :: TidyEnv
env ty :: Type
ty = Type -> SDoc
pprType (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty)

allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool
-- (allDistinctTyVars tvs tys) returns True if tys are
-- a) all tyvars
-- b) all distinct
-- c) disjoint from tvs
allDistinctTyVars :: VarSet -> [Type] -> Bool
allDistinctTyVars _    [] = Bool
True
allDistinctTyVars tkvs :: VarSet
tkvs (ty :: Type
ty : tys :: [Type]
tys)
  = case Type -> Maybe TyCoVar
getTyVar_maybe Type
ty of
      Nothing -> Bool
False
      Just tv :: TyCoVar
tv | TyCoVar
tv TyCoVar -> VarSet -> Bool
`elemVarSet` VarSet
tkvs -> Bool
False
              | Bool
otherwise -> VarSet -> [Type] -> Bool
allDistinctTyVars (VarSet
tkvs VarSet -> TyCoVar -> VarSet
`extendVarSet` TyCoVar
tv) [Type]
tys