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

\section[TcType]{Types used in the typechecker}

This module provides the Type interface for front-end parts of the
compiler.  These parts

        * treat "source types" as opaque:
                newtypes, and predicates are meaningful.
        * look through usage types

The "tc" prefix is for "TypeChecker", because the type checker
is the principal client.
-}

{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-}

module TcType (
  --------------------------------
  -- Types
  TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
  TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,
  TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon,
  KnotTied,

  ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType,

  SyntaxOpType(..), synKnownType, mkSynFunTys,

  -- TcLevel
  TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,
  strictlyDeeperThan, sameDepthAs,
  tcTypeLevel, tcTyVarLevel, maxTcLevel,
  promoteSkolem, promoteSkolemX, promoteSkolemsX,
  --------------------------------
  -- MetaDetails
  UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,
  TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
  MetaDetails(Flexi, Indirect), MetaInfo(..),
  isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,
  tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,
  isFskTyVar, isFmvTyVar, isFlattenTyVar,
  isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo,
  isFlexi, isIndirect, isRuntimeUnkSkol,
  metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,
  isTouchableMetaTyVar,
  isFloatedTouchableMetaTyVar,
  findDupTyVarTvs, mkTyVarNamePairs,

  --------------------------------
  -- Builders
  mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy,
  mkNakedAppTy, mkNakedAppTys, mkNakedCastTy, nakedSubstTy,

  --------------------------------
  -- Splitters
  -- These are important because they do not look through newtypes
  getTyVar,
  tcSplitForAllTy_maybe,
  tcSplitForAllTys, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs,
  tcSplitPhiTy, tcSplitPredFunTy_maybe,
  tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,
  tcSplitFunTysN,
  tcSplitTyConApp, tcSplitTyConApp_maybe,
  tcRepSplitTyConApp, tcRepSplitTyConApp_maybe, tcRepSplitTyConApp_maybe',
  tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,
  tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe,
  tcRepGetNumAppTys,
  tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, nextRole,
  tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe,

  ---------------------------------
  -- Predicates.
  -- Again, newtypes are opaque
  eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,
  pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,
  isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
  isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
  isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,
  hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
  isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck,
  checkValidClsArgs, hasTyVarHead,
  isRigidTy,

  ---------------------------------
  -- Misc type manipulators

  deNoteType,
  orphNamesOfType, orphNamesOfCo,
  orphNamesOfTypes, orphNamesOfCoCon,
  getDFunTyKey, evVarPred,

  ---------------------------------
  -- Predicate types
  mkMinimalBySCs, transSuperClasses,
  pickQuantifiablePreds, pickCapturedPreds,
  immSuperClasses, boxEqPred,
  isImprovementPred,

  -- * Finding type instances
  tcTyFamInsts, tcTyFamInstsAndVis, tcTyConAppTyFamInstsAndVis, isTyFamFree,

  -- * Finding "exact" (non-dead) type variables
  exactTyCoVarsOfType, exactTyCoVarsOfTypes,
  anyRewritableTyVar,

  ---------------------------------
  -- Foreign import and export
  isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool
  isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
  isFFIExportResultTy, -- :: Type -> Bool
  isFFIExternalTy,     -- :: Type -> Bool
  isFFIDynTy,          -- :: Type -> Type -> Bool
  isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool
  isFFIPrimResultTy,   -- :: DynFlags -> Type -> Bool
  isFFILabelTy,        -- :: Type -> Bool
  isFFITy,             -- :: Type -> Bool
  isFunPtrTy,          -- :: Type -> Bool
  tcSplitIOType_maybe, -- :: Type -> Maybe Type

  --------------------------------
  -- Rexported from Kind
  Kind, typeKind, tcTypeKind,
  liftedTypeKind,
  constraintKind,
  isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues,

  --------------------------------
  -- Rexported from Type
  Type, PredType, ThetaType, TyCoBinder, ArgFlag(..),

  mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy,
  mkInvForAllTy, mkInvForAllTys,
  mkFunTy, mkFunTys,
  mkTyConApp, mkAppTy, mkAppTys,
  mkTyConTy, mkTyVarTy, mkTyVarTys,
  mkTyCoVarTy, mkTyCoVarTys,

  isClassPred, isEqPred, isNomEqPred, isIPPred,
  mkClassPred,
  isDictLikeTy,
  tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
  isRuntimeRepVar, isKindLevPoly,
  isVisibleBinder, isInvisibleBinder,

  -- Type substitutions
  TCvSubst(..),         -- Representation visible to a few friends
  TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst,
  zipTvSubst,
  mkTvSubstPrs, notElemTCvSubst, unionTCvSubst,
  getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope,
  extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope,
  Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,
  Type.extendTvSubst,
  isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv,
  Type.substTy, substTys, substTyWith, substTyWithCoVars,
  substTyAddInScope,
  substTyUnchecked, substTysUnchecked, substThetaUnchecked,
  substTyWithUnchecked,
  substCoUnchecked, substCoWithUnchecked,
  substTheta,

  isUnliftedType,       -- Source types are always lifted
  isUnboxedTupleType,   -- Ditto
  isPrimitiveType,

  tcView, coreView,

  tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds,
  tyCoFVsOfType, tyCoFVsOfTypes,
  tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet,
  tyCoVarsOfTypeList, tyCoVarsOfTypesList,
  noFreeVarsOfType,

  --------------------------------
  pprKind, pprParendKind, pprSigmaType,
  pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory,
  pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred,
  pprTCvBndr, pprTCvBndrs,

  TypeSize, sizeType, sizeTypes, scopedSort,

  ---------------------------------
  -- argument visibility
  tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible

  ) where

#include "HsVersions.h"

-- friends:
import GhcPrelude

import Kind
import TyCoRep
import Class
import Var
import ForeignCall
import VarSet
import Coercion
import Type
import RepType
import TyCon

-- others:
import DynFlags
import CoreFVs
import Name -- hiding (varName)
            -- We use this to make dictionaries for type literals.
            -- Perhaps there's a better way to do this?
import NameSet
import VarEnv
import PrelNames
import TysWiredIn( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey
                 , listTyCon, constraintKind )
import BasicTypes
import Util
import Maybes
import ListSetOps ( getNth, findDupsEq )
import Outputable
import FastString
import ErrUtils( Validity(..), MsgDoc, isValid )
import qualified GHC.LanguageExtensions as LangExt

import Data.List  ( mapAccumL )
import Data.Functor.Identity( Identity(..) )
import Data.IORef
import Data.List.NonEmpty( NonEmpty(..) )

{-
************************************************************************
*                                                                      *
              Types
*                                                                      *
************************************************************************

The type checker divides the generic Type world into the
following more structured beasts:

sigma ::= forall tyvars. phi
        -- A sigma type is a qualified type
        --
        -- Note that even if 'tyvars' is empty, theta
        -- may not be: e.g.   (?x::Int) => Int

        -- Note that 'sigma' is in prenex form:
        -- all the foralls are at the front.
        -- A 'phi' type has no foralls to the right of
        -- an arrow

phi :: theta => rho

rho ::= sigma -> rho
     |  tau

-- A 'tau' type has no quantification anywhere
-- Note that the args of a type constructor must be taus
tau ::= tyvar
     |  tycon tau_1 .. tau_n
     |  tau_1 tau_2
     |  tau_1 -> tau_2

-- In all cases, a (saturated) type synonym application is legal,
-- provided it expands to the required form.

Note [TcTyVars and TyVars in the typechecker]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The typechecker uses a lot of type variables with special properties,
notably being a unification variable with a mutable reference.  These
use the 'TcTyVar' variant of Var.Var.

Note, though, that a /bound/ type variable can (and probably should)
be a TyVar.  E.g
    forall a. a -> a
Here 'a' is really just a deBruijn-number; it certainly does not have
a signficant TcLevel (as every TcTyVar does).  So a forall-bound type
variable should be TyVars; and hence a TyVar can appear free in a TcType.

The type checker and constraint solver can also encounter /free/ type
variables that use the 'TyVar' variant of Var.Var, for a couple of
reasons:

  - When typechecking a class decl, say
       class C (a :: k) where
          foo :: T a -> Int
    We have first kind-check the header; fix k and (a:k) to be
    TyVars, bring 'k' and 'a' into scope, and kind check the
    signature for 'foo'.  In doing so we call solveEqualities to
    solve any kind equalities in foo's signature.  So the solver
    may see free occurrences of 'k'.

    See calls to tcExtendTyVarEnv for other places that ordinary
    TyVars are bought into scope, and hence may show up in the types
    and kinds generated by TcHsType.

  - The pattern-match overlap checker calls the constraint solver,
    long afer TcTyVars have been zonked away

It's convenient to simply treat these TyVars as skolem constants,
which of course they are.  We give them a level number of "outermost",
so they behave as global constants.  Specifically:

* Var.tcTyVarDetails succeeds on a TyVar, returning
  vanillaSkolemTv, as well as on a TcTyVar.

* tcIsTcTyVar returns True for both TyVar and TcTyVar variants
  of Var.Var.  The "tc" prefix means "a type variable that can be
  encountered by the typechecker".

This is a bit of a change from an earlier era when we remoselessly
insisted on real TcTyVars in the type checker.  But that seems
unnecessary (for skolems, TyVars are fine) and it's now very hard
to guarantee, with the advent of kind equalities.

Note [Coercion variables in free variable lists]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are several places in the GHC codebase where functions like
tyCoVarsOfType, tyCoVarsOfCt, et al. are used to compute the free type
variables of a type. The "Co" part of these functions' names shouldn't be
dismissed, as it is entirely possible that they will include coercion variables
in addition to type variables! As a result, there are some places in TcType
where we must take care to check that a variable is a _type_ variable (using
isTyVar) before calling tcTyVarDetails--a partial function that is not defined
for coercion variables--on the variable. Failing to do so led to
GHC Trac #12785.
-}

-- See Note [TcTyVars and TyVars in the typechecker]
type TcCoVar = CoVar    -- Used only during type inference
type TcType = Type      -- A TcType can have mutable type variables
type TcTyCoVar = Var    -- Either a TcTyVar or a CoVar
        -- Invariant on ForAllTy in TcTypes:
        --      forall a. T
        -- a cannot occur inside a MutTyVar in T; that is,
        -- T is "flattened" before quantifying over a

type TcTyVarBinder   = TyVarBinder
type TcTyCon         = TyCon   -- these can be the TcTyCon constructor

-- These types do not have boxy type variables in them
type TcPredType     = PredType
type TcThetaType    = ThetaType
type TcSigmaType    = TcType
type TcRhoType      = TcType  -- Note [TcRhoType]
type TcTauType      = TcType
type TcKind         = Kind
type TcTyVarSet     = TyVarSet
type TcTyCoVarSet   = TyCoVarSet
type TcDTyVarSet    = DTyVarSet
type TcDTyCoVarSet  = DTyCoVarSet

{- *********************************************************************
*                                                                      *
          ExpType: an "expected type" in the type checker
*                                                                      *
********************************************************************* -}

-- | An expected type to check against during type-checking.
-- See Note [ExpType] in TcMType, where you'll also find manipulators.
data ExpType = Check TcType
             | Infer !InferResult

data InferResult
  = IR { InferResult -> Unique
ir_uniq :: Unique  -- For debugging only
       , InferResult -> TcLevel
ir_lvl  :: TcLevel -- See Note [TcLevel of ExpType] in TcMType
       , InferResult -> Bool
ir_inst :: Bool    -- True <=> deeply instantiate before returning
                            --           i.e. return a RhoType
                            -- False <=> do not instantiate before returning
                            --           i.e. return a SigmaType
       , InferResult -> IORef (Maybe TcType)
ir_ref  :: IORef (Maybe TcType) }
         -- The type that fills in this hole should be a Type,
         -- that is, its kind should be (TYPE rr) for some rr

type ExpSigmaType = ExpType
type ExpRhoType   = ExpType

instance Outputable ExpType where
  ppr :: ExpType -> SDoc
ppr (Check ty :: TcType
ty) = String -> SDoc
text "Check" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)
  ppr (Infer ir :: InferResult
ir) = InferResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr InferResult
ir

instance Outputable InferResult where
  ppr :: InferResult -> SDoc
ppr (IR { ir_uniq :: InferResult -> Unique
ir_uniq = Unique
u, ir_lvl :: InferResult -> TcLevel
ir_lvl = TcLevel
lvl
          , ir_inst :: InferResult -> Bool
ir_inst = Bool
inst })
    = String -> SDoc
text "Infer" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
lvl SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
inst)

-- | Make an 'ExpType' suitable for checking.
mkCheckExpType :: TcType -> ExpType
mkCheckExpType :: TcType -> ExpType
mkCheckExpType = TcType -> ExpType
Check


{- *********************************************************************
*                                                                      *
          SyntaxOpType
*                                                                      *
********************************************************************* -}

-- | What to expect for an argument to a rebindable-syntax operator.
-- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp.
-- The callback called from tcSyntaxOp gets a list of types; the meaning
-- of these types is determined by a left-to-right depth-first traversal
-- of the 'SyntaxOpType' tree. So if you pass in
--
-- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny
--
-- you'll get three types back: one for the first 'SynAny', the /element/
-- type of the list, and one for the last 'SynAny'. You don't get anything
-- for the 'SynType', because you've said positively that it should be an
-- Int, and so it shall be.
--
-- This is defined here to avoid defining it in TcExpr.hs-boot.
data SyntaxOpType
  = SynAny     -- ^ Any type
  | SynRho     -- ^ A rho type, deeply skolemised or instantiated as appropriate
  | SynList    -- ^ A list type. You get back the element type of the list
  | SynFun SyntaxOpType SyntaxOpType
               -- ^ A function.
  | SynType ExpType   -- ^ A known type.
infixr 0 `SynFun`

-- | Like 'SynType' but accepts a regular TcType
synKnownType :: TcType -> SyntaxOpType
synKnownType :: TcType -> SyntaxOpType
synKnownType = ExpType -> SyntaxOpType
SynType (ExpType -> SyntaxOpType)
-> (TcType -> ExpType) -> TcType -> SyntaxOpType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> ExpType
mkCheckExpType

-- | Like 'mkFunTys' but for 'SyntaxOpType'
mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType
mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType
mkSynFunTys arg_tys :: [SyntaxOpType]
arg_tys res_ty :: ExpType
res_ty = (SyntaxOpType -> SyntaxOpType -> SyntaxOpType)
-> SyntaxOpType -> [SyntaxOpType] -> SyntaxOpType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun (ExpType -> SyntaxOpType
SynType ExpType
res_ty) [SyntaxOpType]
arg_tys


{-
Note [TcRhoType]
~~~~~~~~~~~~~~~~
A TcRhoType has no foralls or contexts at the top, or to the right of an arrow
  YES    (forall a. a->a) -> Int
  NO     forall a. a ->  Int
  NO     Eq a => a -> a
  NO     Int -> forall a. a -> Int


************************************************************************
*                                                                      *
        TyVarDetails, MetaDetails, MetaInfo
*                                                                      *
************************************************************************

TyVarDetails gives extra info about type variables, used during type
checking.  It's attached to mutable type variables only.
It's knot-tied back to Var.hs.  There is no reason in principle
why Var.hs shouldn't actually have the definition, but it "belongs" here.

Note [Signature skolems]
~~~~~~~~~~~~~~~~~~~~~~~~
A TyVarTv is a specialised variant of TauTv, with the following invarints:

    * A TyVarTv can be unified only with a TyVar,
      not with any other type

    * Its MetaDetails, if filled in, will always be another TyVarTv
      or a SkolemTv

TyVarTvs are only distinguished to improve error messages.
Consider this

  data T (a:k1) = MkT (S a)
  data S (b:k2) = MkS (T b)

When doing kind inference on {S,T} we don't want *skolems* for k1,k2,
because they end up unifying; we want those TyVarTvs again.


Note [TyVars and TcTyVars during type checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Var type has constructors TyVar and TcTyVar.  They are used
as follows:

* TcTyVar: used /only/ during type checking.  Should never appear
  afterwards.  May contain a mutable field, in the MetaTv case.

* TyVar: is never seen by the constraint solver, except locally
  inside a type like (forall a. [a] ->[a]), where 'a' is a TyVar.
  We instantiate these with TcTyVars before exposing the type
  to the constraint solver.

I have swithered about the latter invariant, excluding TyVars from the
constraint solver.  It's not strictly essential, and indeed
(historically but still there) Var.tcTyVarDetails returns
vanillaSkolemTv for a TyVar.

But ultimately I want to seeparate Type from TcType, and in that case
we would need to enforce the separation.
-}

-- A TyVarDetails is inside a TyVar
-- See Note [TyVars and TcTyVars]
data TcTyVarDetails
  = SkolemTv      -- A skolem
       TcLevel    -- Level of the implication that binds it
                  -- See TcUnify Note [Deeper level on the left] for
                  --     how this level number is used
       Bool       -- True <=> this skolem type variable can be overlapped
                  --          when looking up instances
                  -- See Note [Binding when looking up instances] in InstEnv

  | RuntimeUnk    -- Stands for an as-yet-unknown type in the GHCi
                  -- interactive context

  | MetaTv { TcTyVarDetails -> MetaInfo
mtv_info  :: MetaInfo
           , TcTyVarDetails -> IORef MetaDetails
mtv_ref   :: IORef MetaDetails
           , TcTyVarDetails -> TcLevel
mtv_tclvl :: TcLevel }  -- See Note [TcLevel and untouchable type variables]

vanillaSkolemTv, superSkolemTv :: TcTyVarDetails
-- See Note [Binding when looking up instances] in InstEnv
vanillaSkolemTv :: TcTyVarDetails
vanillaSkolemTv = TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
topTcLevel Bool
False  -- Might be instantiated
superSkolemTv :: TcTyVarDetails
superSkolemTv   = TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
topTcLevel Bool
True   -- Treat this as a completely distinct type
                  -- The choice of level number here is a bit dodgy, but
                  -- topTcLevel works in the places that vanillaSkolemTv is used

instance Outputable TcTyVarDetails where
  ppr :: TcTyVarDetails -> SDoc
ppr = TcTyVarDetails -> SDoc
pprTcTyVarDetails

pprTcTyVarDetails :: TcTyVarDetails -> SDoc
-- For debugging
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
pprTcTyVarDetails (RuntimeUnk {})      = String -> SDoc
text "rt"
pprTcTyVarDetails (SkolemTv lvl :: TcLevel
lvl True)  = String -> SDoc
text "ssk" SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
lvl
pprTcTyVarDetails (SkolemTv lvl :: TcLevel
lvl False) = String -> SDoc
text "sk"  SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
lvl
pprTcTyVarDetails (MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info, mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tclvl })
  = MetaInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaInfo
info SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl

-----------------------------
data MetaDetails
  = Flexi  -- Flexi type variables unify to become Indirects
  | Indirect TcType

data MetaInfo
   = TauTv         -- This MetaTv is an ordinary unification variable
                   -- A TauTv is always filled in with a tau-type, which
                   -- never contains any ForAlls.

   | TyVarTv       -- A variant of TauTv, except that it should not be
                   --   unified with a type, only with a type variable
                   -- See Note [Signature skolems]

   | FlatMetaTv    -- A flatten meta-tyvar
                   -- It is a meta-tyvar, but it is always untouchable, with level 0
                   -- See Note [The flattening story] in TcFlatten

   | FlatSkolTv    -- A flatten skolem tyvar
                   -- Just like FlatMetaTv, but is comletely "owned" by
                   --   its Given CFunEqCan.
                   -- It is filled in /only/ by unflattenGivens
                   -- See Note [The flattening story] in TcFlatten

instance Outputable MetaDetails where
  ppr :: MetaDetails -> SDoc
ppr Flexi         = String -> SDoc
text "Flexi"
  ppr (Indirect ty :: TcType
ty) = String -> SDoc
text "Indirect" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty

instance Outputable MetaInfo where
  ppr :: MetaInfo -> SDoc
ppr TauTv         = String -> SDoc
text "tau"
  ppr TyVarTv       = String -> SDoc
text "tyv"
  ppr FlatMetaTv    = String -> SDoc
text "fmv"
  ppr FlatSkolTv    = String -> SDoc
text "fsk"

{- *********************************************************************
*                                                                      *
          UserTypeCtxt
*                                                                      *
********************************************************************* -}

-------------------------------------
-- UserTypeCtxt describes the origin of the polymorphic type
-- in the places where we need an expression to have that type

data UserTypeCtxt
  = FunSigCtxt      -- Function type signature, when checking the type
                    -- Also used for types in SPECIALISE pragmas
       Name              -- Name of the function
       Bool              -- True <=> report redundant constraints
                            -- This is usually True, but False for
                            --   * Record selectors (not important here)
                            --   * Class and instance methods.  Here
                            --     the code may legitimately be more
                            --     polymorphic than the signature
                            --     generated from the class
                            --     declaration

  | InfSigCtxt Name     -- Inferred type for function
  | ExprSigCtxt         -- Expression type signature
  | KindSigCtxt         -- Kind signature
  | TypeAppCtxt         -- Visible type application
  | ConArgCtxt Name     -- Data constructor argument
  | TySynCtxt Name      -- RHS of a type synonym decl
  | PatSynCtxt Name     -- Type sig for a pattern synonym
  | PatSigCtxt          -- Type sig in pattern
                        --   eg  f (x::t) = ...
                        --   or  (x::t, y) = e
  | RuleSigCtxt Name    -- LHS of a RULE forall
                        --    RULE "foo" forall (x :: a -> a). f (Just x) = ...
  | ResSigCtxt          -- Result type sig
                        --      f x :: t = ....
  | ForSigCtxt Name     -- Foreign import or export signature
  | DefaultDeclCtxt     -- Types in a default declaration
  | InstDeclCtxt Bool   -- An instance declaration
                        --    True:  stand-alone deriving
                        --    False: vanilla instance declaration
  | SpecInstCtxt        -- SPECIALISE instance pragma
  | ThBrackCtxt         -- Template Haskell type brackets [t| ... |]
  | GenSigCtxt          -- Higher-rank or impredicative situations
                        -- e.g. (f e) where f has a higher-rank type
                        -- We might want to elaborate this
  | GhciCtxt Bool       -- GHCi command :kind <type>
                        -- The Bool indicates if we are checking the outermost
                        -- type application.
                        -- See Note [Unsaturated type synonyms in GHCi] in
                        -- TcValidity.

  | ClassSCCtxt Name    -- Superclasses of a class
  | SigmaCtxt           -- Theta part of a normal for-all type
                        --      f :: <S> => a -> a
  | DataTyCtxt Name     -- The "stupid theta" part of a data decl
                        --      data <S> => T a = MkT a
  | DerivClauseCtxt     -- A 'deriving' clause
  | TyVarBndrKindCtxt Name  -- The kind of a type variable being bound
  | DataKindCtxt Name   -- The kind of a data/newtype (instance)
  | TySynKindCtxt Name  -- The kind of the RHS of a type synonym
  | TyFamResKindCtxt Name   -- The result kind of a type family

{-
-- Notes re TySynCtxt
-- We allow type synonyms that aren't types; e.g.  type List = []
--
-- If the RHS mentions tyvars that aren't in scope, we'll
-- quantify over them:
--      e.g.    type T = a->a
-- will become  type T = forall a. a->a
--
-- With gla-exts that's right, but for H98 we should complain.
-}


pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt (FunSigCtxt n :: Name
n _)  = String -> SDoc
text "the type signature for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (InfSigCtxt n :: Name
n)    = String -> SDoc
text "the inferred type for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (RuleSigCtxt n :: Name
n)   = String -> SDoc
text "a RULE for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt ExprSigCtxt       = String -> SDoc
text "an expression type signature"
pprUserTypeCtxt KindSigCtxt       = String -> SDoc
text "a kind signature"
pprUserTypeCtxt TypeAppCtxt       = String -> SDoc
text "a type argument"
pprUserTypeCtxt (ConArgCtxt c :: Name
c)    = String -> SDoc
text "the type of the constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
c)
pprUserTypeCtxt (TySynCtxt c :: Name
c)     = String -> SDoc
text "the RHS of the type synonym" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
c)
pprUserTypeCtxt ThBrackCtxt       = String -> SDoc
text "a Template Haskell quotation [t|...|]"
pprUserTypeCtxt PatSigCtxt        = String -> SDoc
text "a pattern type signature"
pprUserTypeCtxt ResSigCtxt        = String -> SDoc
text "a result type signature"
pprUserTypeCtxt (ForSigCtxt n :: Name
n)    = String -> SDoc
text "the foreign declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt DefaultDeclCtxt   = String -> SDoc
text "a type in a `default' declaration"
pprUserTypeCtxt (InstDeclCtxt False) = String -> SDoc
text "an instance declaration"
pprUserTypeCtxt (InstDeclCtxt True)  = String -> SDoc
text "a stand-alone deriving instance declaration"
pprUserTypeCtxt SpecInstCtxt      = String -> SDoc
text "a SPECIALISE instance pragma"
pprUserTypeCtxt GenSigCtxt        = String -> SDoc
text "a type expected by the context"
pprUserTypeCtxt (GhciCtxt {})     = String -> SDoc
text "a type in a GHCi command"
pprUserTypeCtxt (ClassSCCtxt c :: Name
c)   = String -> SDoc
text "the super-classes of class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
c)
pprUserTypeCtxt SigmaCtxt         = String -> SDoc
text "the context of a polymorphic type"
pprUserTypeCtxt (DataTyCtxt tc :: Name
tc)   = String -> SDoc
text "the context of the data type declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc)
pprUserTypeCtxt (PatSynCtxt n :: Name
n)    = String -> SDoc
text "the signature for pattern synonym" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (UserTypeCtxt
DerivClauseCtxt) = String -> SDoc
text "a `deriving' clause"
pprUserTypeCtxt (TyVarBndrKindCtxt n :: Name
n) = String -> SDoc
text "the kind annotation on the type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (DataKindCtxt n :: Name
n)  = String -> SDoc
text "the kind annotation on the declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (TySynKindCtxt n :: Name
n) = String -> SDoc
text "the kind annotation on the declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (TyFamResKindCtxt n :: Name
n) = String -> SDoc
text "the result kind for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)

isSigMaybe :: UserTypeCtxt -> Maybe Name
isSigMaybe :: UserTypeCtxt -> Maybe Name
isSigMaybe (FunSigCtxt n :: Name
n _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe (ConArgCtxt n :: Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe (ForSigCtxt n :: Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe (PatSynCtxt n :: Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe _                = Maybe Name
forall a. Maybe a
Nothing


{- *********************************************************************
*                                                                      *
                Untoucable type variables
*                                                                      *
********************************************************************* -}

newtype TcLevel = TcLevel Int deriving( TcLevel -> TcLevel -> Bool
(TcLevel -> TcLevel -> Bool)
-> (TcLevel -> TcLevel -> Bool) -> Eq TcLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TcLevel -> TcLevel -> Bool
$c/= :: TcLevel -> TcLevel -> Bool
== :: TcLevel -> TcLevel -> Bool
$c== :: TcLevel -> TcLevel -> Bool
Eq, Eq TcLevel
Eq TcLevel =>
(TcLevel -> TcLevel -> Ordering)
-> (TcLevel -> TcLevel -> Bool)
-> (TcLevel -> TcLevel -> Bool)
-> (TcLevel -> TcLevel -> Bool)
-> (TcLevel -> TcLevel -> Bool)
-> (TcLevel -> TcLevel -> TcLevel)
-> (TcLevel -> TcLevel -> TcLevel)
-> Ord TcLevel
TcLevel -> TcLevel -> Bool
TcLevel -> TcLevel -> Ordering
TcLevel -> TcLevel -> TcLevel
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TcLevel -> TcLevel -> TcLevel
$cmin :: TcLevel -> TcLevel -> TcLevel
max :: TcLevel -> TcLevel -> TcLevel
$cmax :: TcLevel -> TcLevel -> TcLevel
>= :: TcLevel -> TcLevel -> Bool
$c>= :: TcLevel -> TcLevel -> Bool
> :: TcLevel -> TcLevel -> Bool
$c> :: TcLevel -> TcLevel -> Bool
<= :: TcLevel -> TcLevel -> Bool
$c<= :: TcLevel -> TcLevel -> Bool
< :: TcLevel -> TcLevel -> Bool
$c< :: TcLevel -> TcLevel -> Bool
compare :: TcLevel -> TcLevel -> Ordering
$ccompare :: TcLevel -> TcLevel -> Ordering
$cp1Ord :: Eq TcLevel
Ord )
  -- See Note [TcLevel and untouchable type variables] for what this Int is
  -- See also Note [TcLevel assignment]

{-
Note [TcLevel and untouchable type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Each unification variable (MetaTv)
  and each Implication
  has a level number (of type TcLevel)

* INVARIANTS.  In a tree of Implications,

    (ImplicInv) The level number (ic_tclvl) of an Implication is
                STRICTLY GREATER THAN that of its parent

    (SkolInv)   The level number of the skolems (ic_skols) of an
                Implication is equal to the level of the implication
                itself (ic_tclvl)

    (GivenInv)  The level number of a unification variable appearing
                in the 'ic_given' of an implication I should be
                STRICTLY LESS THAN the ic_tclvl of I

    (WantedInv) The level number of a unification variable appearing
                in the 'ic_wanted' of an implication I should be
                LESS THAN OR EQUAL TO the ic_tclvl of I
                See Note [WantedInv]

* A unification variable is *touchable* if its level number
  is EQUAL TO that of its immediate parent implication,
  and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv)

Note [WantedInv]
~~~~~~~~~~~~~~~~
Why is WantedInv important?  Consider this implication, where
the constraint (C alpha[3]) disobeys WantedInv:

   forall[2] a. blah => (C alpha[3])
                        (forall[3] b. alpha[3] ~ b)

We can unify alpha:=b in the inner implication, because 'alpha' is
touchable; but then 'b' has excaped its scope into the outer implication.

Note [Skolem escape prevention]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We only unify touchable unification variables.  Because of
(WantedInv), there can be no occurrences of the variable further out,
so the unification can't cause the skolems to escape. Example:
     data T = forall a. MkT a (a->Int)
     f x (MkT v f) = length [v,x]
We decide (x::alpha), and generate an implication like
      [1]forall a. (a ~ alpha[0])
But we must not unify alpha:=a, because the skolem would escape.

For the cases where we DO want to unify, we rely on floating the
equality.   Example (with same T)
     g x (MkT v f) = x && True
We decide (x::alpha), and generate an implication like
      [1]forall a. (Bool ~ alpha[0])
We do NOT unify directly, bur rather float out (if the constraint
does not mention 'a') to get
      (Bool ~ alpha[0]) /\ [1]forall a.()
and NOW we can unify alpha.

The same idea of only unifying touchables solves another problem.
Suppose we had
   (F Int ~ uf[0])  /\  [1](forall a. C a => F Int ~ beta[1])
In this example, beta is touchable inside the implication. The
first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside
the implication where a new constraint
       uf  ~  beta
emerges. If we (wrongly) spontaneously solved it to get uf := beta,
the whole implication disappears but when we pop out again we are left with
(F Int ~ uf) which will be unified by our final zonking stage and
uf will get unified *once more* to (F Int).

Note [TcLevel assignment]
~~~~~~~~~~~~~~~~~~~~~~~~~
We arrange the TcLevels like this

   0   Top level
   1   First-level implication constraints
   2   Second-level implication constraints
   ...etc...
-}

maxTcLevel :: TcLevel -> TcLevel -> TcLevel
maxTcLevel :: TcLevel -> TcLevel -> TcLevel
maxTcLevel (TcLevel a :: Int
a) (TcLevel b :: Int
b) = Int -> TcLevel
TcLevel (Int
a Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
b)

topTcLevel :: TcLevel
-- See Note [TcLevel assignment]
topTcLevel :: TcLevel
topTcLevel = Int -> TcLevel
TcLevel 0   -- 0 = outermost level

isTopTcLevel :: TcLevel -> Bool
isTopTcLevel :: TcLevel -> Bool
isTopTcLevel (TcLevel 0) = Bool
True
isTopTcLevel _           = Bool
False

pushTcLevel :: TcLevel -> TcLevel
-- See Note [TcLevel assignment]
pushTcLevel :: TcLevel -> TcLevel
pushTcLevel (TcLevel us :: Int
us) = Int -> TcLevel
TcLevel (Int
us Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)

strictlyDeeperThan :: TcLevel -> TcLevel -> Bool
strictlyDeeperThan :: TcLevel -> TcLevel -> Bool
strictlyDeeperThan (TcLevel tv_tclvl :: Int
tv_tclvl) (TcLevel ctxt_tclvl :: Int
ctxt_tclvl)
  = Int
tv_tclvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ctxt_tclvl

sameDepthAs :: TcLevel -> TcLevel -> Bool
sameDepthAs :: TcLevel -> TcLevel -> Bool
sameDepthAs (TcLevel ctxt_tclvl :: Int
ctxt_tclvl) (TcLevel tv_tclvl :: Int
tv_tclvl)
  = Int
ctxt_tclvl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tv_tclvl   -- NB: invariant ctxt_tclvl >= tv_tclvl
                             --     So <= would be equivalent

checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool
-- Checks (WantedInv) from Note [TcLevel and untouchable type variables]
checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool
checkTcLevelInvariant (TcLevel ctxt_tclvl :: Int
ctxt_tclvl) (TcLevel tv_tclvl :: Int
tv_tclvl)
  = Int
ctxt_tclvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
tv_tclvl

-- Returns topTcLevel for non-TcTyVars
tcTyVarLevel :: TcTyVar -> TcLevel
tcTyVarLevel :: TcTyVar -> TcLevel
tcTyVarLevel tv :: TcTyVar
tv
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
          MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tv_lvl } -> TcLevel
tv_lvl
          SkolemTv tv_lvl :: TcLevel
tv_lvl _             -> TcLevel
tv_lvl
          RuntimeUnk                    -> TcLevel
topTcLevel


tcTypeLevel :: TcType -> TcLevel
-- Max level of any free var of the type
tcTypeLevel :: TcType -> TcLevel
tcTypeLevel ty :: TcType
ty
  = (TcTyVar -> TcLevel -> TcLevel) -> TcLevel -> DVarSet -> TcLevel
forall a. (TcTyVar -> a -> a) -> a -> DVarSet -> a
foldDVarSet TcTyVar -> TcLevel -> TcLevel
add TcLevel
topTcLevel (TcType -> DVarSet
tyCoVarsOfTypeDSet TcType
ty)
  where
    add :: TcTyVar -> TcLevel -> TcLevel
add v :: TcTyVar
v lvl :: TcLevel
lvl
      | TcTyVar -> Bool
isTcTyVar TcTyVar
v = TcLevel
lvl TcLevel -> TcLevel -> TcLevel
`maxTcLevel` TcTyVar -> TcLevel
tcTyVarLevel TcTyVar
v
      | Bool
otherwise = TcLevel
lvl

instance Outputable TcLevel where
  ppr :: TcLevel -> SDoc
ppr (TcLevel us :: Int
us) = Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
us

promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar
promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar
promoteSkolem tclvl :: TcLevel
tclvl skol :: TcTyVar
skol
  | TcLevel
tclvl TcLevel -> TcLevel -> Bool
forall a. Ord a => a -> a -> Bool
< TcTyVar -> TcLevel
tcTyVarLevel TcTyVar
skol
  = ASSERT( isTcTyVar skol && isSkolemTyVar skol )
    TcTyVar -> TcTyVarDetails -> TcTyVar
setTcTyVarDetails TcTyVar
skol (TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
tclvl (TcTyVar -> Bool
isOverlappableTyVar TcTyVar
skol))

  | Bool
otherwise
  = TcTyVar
skol

-- | Change the TcLevel in a skolem, extending a substitution
promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
promoteSkolemX tclvl :: TcLevel
tclvl subst :: TCvSubst
subst skol :: TcTyVar
skol
  = ASSERT( isTcTyVar skol && isSkolemTyVar skol )
    (TCvSubst
new_subst, TcTyVar
new_skol)
  where
    new_skol :: TcTyVar
new_skol
      | TcLevel
tclvl TcLevel -> TcLevel -> Bool
forall a. Ord a => a -> a -> Bool
< TcTyVar -> TcLevel
tcTyVarLevel TcTyVar
skol
      = TcTyVar -> TcTyVarDetails -> TcTyVar
setTcTyVarDetails ((TcType -> TcType) -> TcTyVar -> TcTyVar
updateTyVarKind (HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
substTy TCvSubst
subst) TcTyVar
skol)
                          (TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
tclvl (TcTyVar -> Bool
isOverlappableTyVar TcTyVar
skol))
      | Bool
otherwise
      = (TcType -> TcType) -> TcTyVar -> TcTyVar
updateTyVarKind (HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
substTy TCvSubst
subst) TcTyVar
skol
    new_subst :: TCvSubst
new_subst = TCvSubst -> TcTyVar -> TcTyVar -> TCvSubst
extendTvSubstWithClone TCvSubst
subst TcTyVar
skol TcTyVar
new_skol

promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar])
promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar])
promoteSkolemsX tclvl :: TcLevel
tclvl = (TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar))
-> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
promoteSkolemX TcLevel
tclvl)

{- *********************************************************************
*                                                                      *
    Finding type family instances
*                                                                      *
************************************************************************
-}

-- | Finds outermost type-family applications occurring in a type,
-- after expanding synonyms.  In the list (F, tys) that is returned
-- we guarantee that tys matches F's arity.  For example, given
--    type family F a :: * -> *    (arity 1)
-- calling tcTyFamInsts on (Maybe (F Int Bool) will return
--     (F, [Int]), not (F, [Int,Bool])
--
-- This is important for its use in deciding termination of type
-- instances (see Trac #11581).  E.g.
--    type instance G [Int] = ...(F Int <big type>)...
-- we don't need to take <big type> into account when asking if
-- the calls on the RHS are smaller than the LHS
tcTyFamInsts :: Type -> [(TyCon, [Type])]
tcTyFamInsts :: TcType -> [(TyCon, [TcType])]
tcTyFamInsts = ((Bool, TyCon, [TcType]) -> (TyCon, [TcType]))
-> [(Bool, TyCon, [TcType])] -> [(TyCon, [TcType])]
forall a b. (a -> b) -> [a] -> [b]
map (\(_,b :: TyCon
b,c :: [TcType]
c) -> (TyCon
b,[TcType]
c)) ([(Bool, TyCon, [TcType])] -> [(TyCon, [TcType])])
-> (TcType -> [(Bool, TyCon, [TcType])])
-> TcType
-> [(TyCon, [TcType])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVis

-- | Like 'tcTyFamInsts', except that the output records whether the
-- type family and its arguments occur as an /invisible/ argument in
-- some type application. This information is useful because it helps GHC know
-- when to turn on @-fprint-explicit-kinds@ during error reporting so that
-- users can actually see the type family being mentioned.
--
-- As an example, consider:
--
-- @
-- class C a
-- data T (a :: k)
-- type family F a :: k
-- instance C (T @(F Int) (F Bool))
-- @
--
-- There are two occurrences of the type family `F` in that `C` instance, so
-- @'tcTyFamInstsAndVis' (C (T \@(F Int) (F Bool)))@ will return:
--
-- @
-- [ ('True',  F, [Int])
-- , ('False', F, [Bool]) ]
-- @
--
-- @F Int@ is paired with 'True' since it appears as an /invisible/ argument
-- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a
-- /visible/ argument to @C@.
--
-- See also @Note [Kind arguments in error messages]@ in "TcErrors".
tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVis :: TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVis = Bool -> TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVisX Bool
False

tcTyFamInstsAndVisX
  :: Bool -- ^ Is this an invisible argument to some type application?
  -> Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVisX :: Bool -> TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVisX = Bool -> TcType -> [(Bool, TyCon, [TcType])]
go
  where
    go :: Bool -> TcType -> [(Bool, TyCon, [TcType])]
go is_invis_arg :: Bool
is_invis_arg ty :: TcType
ty
      | Just exp_ty :: TcType
exp_ty <- TcType -> Maybe TcType
tcView TcType
ty       = Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
exp_ty
    go _ (TyVarTy _)                   = []
    go is_invis_arg :: Bool
is_invis_arg (TyConApp tc :: TyCon
tc tys :: [TcType]
tys)
      | TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
      = [(Bool
is_invis_arg, TyCon
tc, Int -> [TcType] -> [TcType]
forall a. Int -> [a] -> [a]
take (TyCon -> Int
tyConArity TyCon
tc) [TcType]
tys)]
      | Bool
otherwise
      = Bool -> TyCon -> [TcType] -> [(Bool, TyCon, [TcType])]
tcTyConAppTyFamInstsAndVisX Bool
is_invis_arg TyCon
tc [TcType]
tys
    go _            (LitTy {})         = []
    go is_invis_arg :: Bool
is_invis_arg (ForAllTy bndr :: TyCoVarBinder
bndr ty :: TcType
ty) = Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg (TyCoVarBinder -> TcType
forall argf. VarBndr TcTyVar argf -> TcType
binderType TyCoVarBinder
bndr)
                                         [(Bool, TyCon, [TcType])]
-> [(Bool, TyCon, [TcType])] -> [(Bool, TyCon, [TcType])]
forall a. [a] -> [a] -> [a]
++ Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
ty
    go is_invis_arg :: Bool
is_invis_arg (FunTy ty1 :: TcType
ty1 ty2 :: TcType
ty2)    = Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
ty1
                                         [(Bool, TyCon, [TcType])]
-> [(Bool, TyCon, [TcType])] -> [(Bool, TyCon, [TcType])]
forall a. [a] -> [a] -> [a]
++ Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
ty2
    go is_invis_arg :: Bool
is_invis_arg ty :: TcType
ty@(AppTy _ _)     =
      let (ty_head :: TcType
ty_head, ty_args :: [TcType]
ty_args) = TcType -> (TcType, [TcType])
splitAppTys TcType
ty
          ty_arg_flags :: [ArgFlag]
ty_arg_flags       = TcType -> [TcType] -> [ArgFlag]
appTyArgFlags TcType
ty_head [TcType]
ty_args
      in Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
ty_head
         [(Bool, TyCon, [TcType])]
-> [(Bool, TyCon, [TcType])] -> [(Bool, TyCon, [TcType])]
forall a. [a] -> [a] -> [a]
++ [[(Bool, TyCon, [TcType])]] -> [(Bool, TyCon, [TcType])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ArgFlag -> TcType -> [(Bool, TyCon, [TcType])])
-> [ArgFlag] -> [TcType] -> [[(Bool, TyCon, [TcType])]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\flag :: ArgFlag
flag -> Bool -> TcType -> [(Bool, TyCon, [TcType])]
go (ArgFlag -> Bool
isInvisibleArgFlag ArgFlag
flag))
                            [ArgFlag]
ty_arg_flags [TcType]
ty_args)
    go is_invis_arg :: Bool
is_invis_arg (CastTy ty :: TcType
ty _)      = Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
ty
    go _            (CoercionTy _)     = [] -- don't count tyfams in coercions,
                                            -- as they never get normalized,
                                            -- anyway

-- | In an application of a 'TyCon' to some arguments, find the outermost
-- occurrences of type family applications within the arguments. This function
-- will not consider the 'TyCon' itself when checking for type family
-- applications.
--
-- See 'tcTyFamInstsAndVis' for more details on how this works (as this
-- function is called inside of 'tcTyFamInstsAndVis').
tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVis :: TyCon -> [TcType] -> [(Bool, TyCon, [TcType])]
tcTyConAppTyFamInstsAndVis = Bool -> TyCon -> [TcType] -> [(Bool, TyCon, [TcType])]
tcTyConAppTyFamInstsAndVisX Bool
False

tcTyConAppTyFamInstsAndVisX
  :: Bool -- ^ Is this an invisible argument to some type application?
  -> TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVisX :: Bool -> TyCon -> [TcType] -> [(Bool, TyCon, [TcType])]
tcTyConAppTyFamInstsAndVisX is_invis_arg :: Bool
is_invis_arg tc :: TyCon
tc tys :: [TcType]
tys =
  let (invis_tys :: [TcType]
invis_tys, vis_tys :: [TcType]
vis_tys) = TyCon -> [TcType] -> ([TcType], [TcType])
partitionInvisibleTypes TyCon
tc [TcType]
tys
  in [[(Bool, TyCon, [TcType])]] -> [(Bool, TyCon, [TcType])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Bool, TyCon, [TcType])]] -> [(Bool, TyCon, [TcType])])
-> [[(Bool, TyCon, [TcType])]] -> [(Bool, TyCon, [TcType])]
forall a b. (a -> b) -> a -> b
$ (TcType -> [(Bool, TyCon, [TcType])])
-> [TcType] -> [[(Bool, TyCon, [TcType])]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVisX Bool
True)         [TcType]
invis_tys
           [[(Bool, TyCon, [TcType])]]
-> [[(Bool, TyCon, [TcType])]] -> [[(Bool, TyCon, [TcType])]]
forall a. [a] -> [a] -> [a]
++ (TcType -> [(Bool, TyCon, [TcType])])
-> [TcType] -> [[(Bool, TyCon, [TcType])]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVisX Bool
is_invis_arg) [TcType]
vis_tys

isTyFamFree :: Type -> Bool
-- ^ Check that a type does not contain any type family applications.
isTyFamFree :: TcType -> Bool
isTyFamFree = [(TyCon, [TcType])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(TyCon, [TcType])] -> Bool)
-> (TcType -> [(TyCon, [TcType])]) -> TcType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> [(TyCon, [TcType])]
tcTyFamInsts

{-
************************************************************************
*                                                                      *
          The "exact" free variables of a type
*                                                                      *
************************************************************************

Note [Silly type synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  type T a = Int
What are the free tyvars of (T x)?  Empty, of course!

exactTyCoVarsOfType is used by the type checker to figure out exactly
which type variables are mentioned in a type.  It only matters
occasionally -- see the calls to exactTyCoVarsOfType.

Historical note: years and years ago this function was used during
generalisation -- see Trac #1813.  But that code has long since died.
-}

exactTyCoVarsOfType :: Type -> TyCoVarSet
-- Find the free type variables (of any kind)
-- but *expand* type synonyms.  See Note [Silly type synonym] above.
exactTyCoVarsOfType :: TcType -> TyCoVarSet
exactTyCoVarsOfType ty :: TcType
ty
  = TcType -> TyCoVarSet
go TcType
ty
  where
    go :: TcType -> TyCoVarSet
go ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> TyCoVarSet
go TcType
ty'  -- This is the key line
    go (TyVarTy tv :: TcTyVar
tv)         = TcTyVar -> TyCoVarSet
goVar TcTyVar
tv
    go (TyConApp _ tys :: [TcType]
tys)     = [TcType] -> TyCoVarSet
exactTyCoVarsOfTypes [TcType]
tys
    go (LitTy {})           = TyCoVarSet
emptyVarSet
    go (AppTy fun :: TcType
fun arg :: TcType
arg)      = TcType -> TyCoVarSet
go TcType
fun TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go TcType
arg
    go (FunTy arg :: TcType
arg res :: TcType
res)      = TcType -> TyCoVarSet
go TcType
arg TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go TcType
res
    go (ForAllTy bndr :: TyCoVarBinder
bndr ty :: TcType
ty)   = TyCoVarSet -> TyCoVarBinder -> TyCoVarSet
delBinderVar (TcType -> TyCoVarSet
go TcType
ty) TyCoVarBinder
bndr TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go (TyCoVarBinder -> TcType
forall argf. VarBndr TcTyVar argf -> TcType
binderType TyCoVarBinder
bndr)
    go (CastTy ty :: TcType
ty co :: KindCoercion
co)       = TcType -> TyCoVarSet
go TcType
ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
co
    go (CoercionTy co :: KindCoercion
co)      = KindCoercion -> TyCoVarSet
goCo KindCoercion
co

    goMCo :: MCoercionN -> TyCoVarSet
goMCo MRefl    = TyCoVarSet
emptyVarSet
    goMCo (MCo co :: KindCoercion
co) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co

    goCo :: KindCoercion -> TyCoVarSet
goCo (Refl ty :: TcType
ty)            = TcType -> TyCoVarSet
go TcType
ty
    goCo (GRefl _ ty :: TcType
ty mco :: MCoercionN
mco)     = TcType -> TyCoVarSet
go TcType
ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` MCoercionN -> TyCoVarSet
goMCo MCoercionN
mco
    goCo (TyConAppCo _ _ args :: [KindCoercion]
args)= [KindCoercion] -> TyCoVarSet
goCos [KindCoercion]
args
    goCo (AppCo co :: KindCoercion
co arg :: KindCoercion
arg)     = KindCoercion -> TyCoVarSet
goCo KindCoercion
co TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
arg
    goCo (ForAllCo tv :: TcTyVar
tv k_co :: KindCoercion
k_co co :: KindCoercion
co)
      = KindCoercion -> TyCoVarSet
goCo KindCoercion
co TyCoVarSet -> TcTyVar -> TyCoVarSet
`delVarSet` TcTyVar
tv TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
k_co
    goCo (FunCo _ co1 :: KindCoercion
co1 co2 :: KindCoercion
co2)   = KindCoercion -> TyCoVarSet
goCo KindCoercion
co1 TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
co2
    goCo (CoVarCo v :: TcTyVar
v)         = TcTyVar -> TyCoVarSet
goVar TcTyVar
v
    goCo (HoleCo h :: CoercionHole
h)          = TcTyVar -> TyCoVarSet
goVar (CoercionHole -> TcTyVar
coHoleCoVar CoercionHole
h)
    goCo (AxiomInstCo _ _ args :: [KindCoercion]
args) = [KindCoercion] -> TyCoVarSet
goCos [KindCoercion]
args
    goCo (UnivCo p :: UnivCoProvenance
p _ t1 :: TcType
t1 t2 :: TcType
t2)  = UnivCoProvenance -> TyCoVarSet
goProv UnivCoProvenance
p TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go TcType
t1 TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go TcType
t2
    goCo (SymCo co :: KindCoercion
co)          = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
    goCo (TransCo co1 :: KindCoercion
co1 co2 :: KindCoercion
co2)   = KindCoercion -> TyCoVarSet
goCo KindCoercion
co1 TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
co2
    goCo (NthCo _ _ co :: KindCoercion
co)      = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
    goCo (LRCo _ co :: KindCoercion
co)         = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
    goCo (InstCo co :: KindCoercion
co arg :: KindCoercion
arg)     = KindCoercion -> TyCoVarSet
goCo KindCoercion
co TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
arg
    goCo (KindCo co :: KindCoercion
co)         = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
    goCo (SubCo co :: KindCoercion
co)          = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
    goCo (AxiomRuleCo _ c :: [KindCoercion]
c)   = [KindCoercion] -> TyCoVarSet
goCos [KindCoercion]
c

    goCos :: [KindCoercion] -> TyCoVarSet
goCos cos :: [KindCoercion]
cos = (KindCoercion -> TyCoVarSet -> TyCoVarSet)
-> TyCoVarSet -> [KindCoercion] -> TyCoVarSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TyCoVarSet -> TyCoVarSet -> TyCoVarSet
unionVarSet (TyCoVarSet -> TyCoVarSet -> TyCoVarSet)
-> (KindCoercion -> TyCoVarSet)
-> KindCoercion
-> TyCoVarSet
-> TyCoVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindCoercion -> TyCoVarSet
goCo) TyCoVarSet
emptyVarSet [KindCoercion]
cos

    goProv :: UnivCoProvenance -> TyCoVarSet
goProv UnsafeCoerceProv     = TyCoVarSet
emptyVarSet
    goProv (PhantomProv kco :: KindCoercion
kco)    = KindCoercion -> TyCoVarSet
goCo KindCoercion
kco
    goProv (ProofIrrelProv kco :: KindCoercion
kco) = KindCoercion -> TyCoVarSet
goCo KindCoercion
kco
    goProv (PluginProv _)       = TyCoVarSet
emptyVarSet

    goVar :: TcTyVar -> TyCoVarSet
goVar v :: TcTyVar
v = TcTyVar -> TyCoVarSet
unitVarSet TcTyVar
v TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go (TcTyVar -> TcType
varType TcTyVar
v)

exactTyCoVarsOfTypes :: [Type] -> TyVarSet
exactTyCoVarsOfTypes :: [TcType] -> TyCoVarSet
exactTyCoVarsOfTypes tys :: [TcType]
tys = (TcType -> TyCoVarSet) -> [TcType] -> TyCoVarSet
forall a. (a -> TyCoVarSet) -> [a] -> TyCoVarSet
mapUnionVarSet TcType -> TyCoVarSet
exactTyCoVarsOfType [TcType]
tys

anyRewritableTyVar :: Bool    -- Ignore casts and coercions
                   -> EqRel   -- Ambient role
                   -> (EqRel -> TcTyVar -> Bool)
                   -> TcType -> Bool
-- (anyRewritableTyVar ignore_cos pred ty) returns True
--    if the 'pred' returns True of any free TyVar in 'ty'
-- Do not look inside casts and coercions if 'ignore_cos' is True
-- See Note [anyRewritableTyVar must be role-aware]
anyRewritableTyVar :: Bool -> EqRel -> (EqRel -> TcTyVar -> Bool) -> TcType -> Bool
anyRewritableTyVar ignore_cos :: Bool
ignore_cos role :: EqRel
role pred :: EqRel -> TcTyVar -> Bool
pred ty :: TcType
ty
  = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
role TyCoVarSet
emptyVarSet TcType
ty
  where
    go_tv :: EqRel -> TyCoVarSet -> TcTyVar -> Bool
go_tv rl :: EqRel
rl bvs :: TyCoVarSet
bvs tv :: TcTyVar
tv | TcTyVar
tv TcTyVar -> TyCoVarSet -> Bool
`elemVarSet` TyCoVarSet
bvs = Bool
False
                    | Bool
otherwise           = EqRel -> TcTyVar -> Bool
pred EqRel
rl TcTyVar
tv

    go :: EqRel -> TyCoVarSet -> TcType -> Bool
go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (TyVarTy tv :: TcTyVar
tv)      = EqRel -> TyCoVarSet -> TcTyVar -> Bool
go_tv EqRel
rl TyCoVarSet
bvs TcTyVar
tv
    go _ _     (LitTy {})       = Bool
False
    go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (TyConApp tc :: TyCon
tc tys :: [TcType]
tys) = EqRel -> TyCoVarSet -> TyCon -> [TcType] -> Bool
go_tc EqRel
rl TyCoVarSet
bvs TyCon
tc [TcType]
tys
    go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (AppTy fun :: TcType
fun arg :: TcType
arg)   = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
rl TyCoVarSet
bvs TcType
fun Bool -> Bool -> Bool
|| EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
NomEq TyCoVarSet
bvs TcType
arg
    go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (FunTy arg :: TcType
arg res :: TcType
res)   = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
rl TyCoVarSet
bvs TcType
arg Bool -> Bool -> Bool
|| EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
rl TyCoVarSet
bvs TcType
res
    go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (ForAllTy tv :: TyCoVarBinder
tv ty :: TcType
ty)  = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
rl (TyCoVarSet
bvs TyCoVarSet -> TcTyVar -> TyCoVarSet
`extendVarSet` TyCoVarBinder -> TcTyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
tv) TcType
ty
    go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (CastTy ty :: TcType
ty co :: KindCoercion
co)    = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
rl TyCoVarSet
bvs TcType
ty Bool -> Bool -> Bool
|| EqRel -> TyCoVarSet -> KindCoercion -> Bool
go_co EqRel
rl TyCoVarSet
bvs KindCoercion
co
    go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (CoercionTy co :: KindCoercion
co)   = EqRel -> TyCoVarSet -> KindCoercion -> Bool
go_co EqRel
rl TyCoVarSet
bvs KindCoercion
co  -- ToDo: check

    go_tc :: EqRel -> TyCoVarSet -> TyCon -> [TcType] -> Bool
go_tc NomEq  bvs :: TyCoVarSet
bvs _  tys :: [TcType]
tys = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
NomEq TyCoVarSet
bvs) [TcType]
tys
    go_tc ReprEq bvs :: TyCoVarSet
bvs tc :: TyCon
tc tys :: [TcType]
tys = ((Role, TcType) -> Bool) -> [(Role, TcType)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyCoVarSet -> (Role, TcType) -> Bool
go_arg TyCoVarSet
bvs)
                              (TyCon -> [Role]
tyConRolesRepresentational TyCon
tc [Role] -> [TcType] -> [(Role, TcType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcType]
tys)

    go_arg :: TyCoVarSet -> (Role, TcType) -> Bool
go_arg bvs :: TyCoVarSet
bvs (Nominal,          ty :: TcType
ty) = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
NomEq  TyCoVarSet
bvs TcType
ty
    go_arg bvs :: TyCoVarSet
bvs (Representational, ty :: TcType
ty) = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
ReprEq TyCoVarSet
bvs TcType
ty
    go_arg _   (Phantom,          _)  = Bool
False  -- We never rewrite with phantoms

    go_co :: EqRel -> TyCoVarSet -> KindCoercion -> Bool
go_co rl :: EqRel
rl bvs :: TyCoVarSet
bvs co :: KindCoercion
co
      | Bool
ignore_cos = Bool
False
      | Bool
otherwise  = (TcTyVar -> Bool) -> TyCoVarSet -> Bool
anyVarSet (EqRel -> TyCoVarSet -> TcTyVar -> Bool
go_tv EqRel
rl TyCoVarSet
bvs) (KindCoercion -> TyCoVarSet
tyCoVarsOfCo KindCoercion
co)
      -- We don't have an equivalent of anyRewritableTyVar for coercions
      -- (at least not yet) so take the free vars and test them

{- Note [anyRewritableTyVar must be role-aware]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
anyRewritableTyVar is used during kick-out from the inert set,
to decide if, given a new equality (a ~ ty), we should kick out
a constraint C.  Rather than gather free variables and see if 'a'
is among them, we instead pass in a predicate; this is just efficiency.

Moreover, consider
  work item:   [G] a ~R f b
  inert item:  [G] b ~R f a
We use anyRewritableTyVar to decide whether to kick out the inert item,
on the grounds that the work item might rewrite it. Well, 'a' is certainly
free in [G] b ~R f a.  But because the role of a type variable ('f' in
this case) is nominal, the work item can't actually rewrite the inert item.
Moreover, if we were to kick out the inert item the exact same situation
would re-occur and we end up with an infinite loop in which each kicks
out the other (Trac #14363).
-}

{-
************************************************************************
*                                                                      *
                Predicates
*                                                                      *
************************************************************************
-}

tcIsTcTyVar :: TcTyVar -> Bool
-- See Note [TcTyVars and TyVars in the typechecker]
tcIsTcTyVar :: TcTyVar -> Bool
tcIsTcTyVar tv :: TcTyVar
tv = TcTyVar -> Bool
isTyVar TcTyVar
tv

isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isTouchableMetaTyVar ctxt_tclvl :: TcLevel
ctxt_tclvl tv :: TcTyVar
tv
  | TcTyVar -> Bool
isTyVar TcTyVar
tv -- See Note [Coercion variables in free variable lists]
  , MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tv_tclvl, mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } <- TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv
  , Bool -> Bool
not (MetaInfo -> Bool
isFlattenInfo MetaInfo
info)
  = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,
             ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )
    TcLevel
tv_tclvl TcLevel -> TcLevel -> Bool
`sameDepthAs` TcLevel
ctxt_tclvl

  | Bool
otherwise = Bool
False

isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isFloatedTouchableMetaTyVar ctxt_tclvl :: TcLevel
ctxt_tclvl tv :: TcTyVar
tv
  | TcTyVar -> Bool
isTyVar TcTyVar
tv -- See Note [Coercion variables in free variable lists]
  , MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tv_tclvl, mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } <- TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv
  , Bool -> Bool
not (MetaInfo -> Bool
isFlattenInfo MetaInfo
info)
  = TcLevel
tv_tclvl TcLevel -> TcLevel -> Bool
`strictlyDeeperThan` TcLevel
ctxt_tclvl

  | Bool
otherwise = Bool
False

isImmutableTyVar :: TyVar -> Bool
isImmutableTyVar :: TcTyVar -> Bool
isImmutableTyVar tv :: TcTyVar
tv = TcTyVar -> Bool
isSkolemTyVar TcTyVar
tv

isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
  isMetaTyVar, isAmbiguousTyVar,
  isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool

isTyConableTyVar :: TcTyVar -> Bool
isTyConableTyVar tv :: TcTyVar
tv
        -- True of a meta-type variable that can be filled in
        -- with a type constructor application; in particular,
        -- not a TyVarTv
  | TcTyVar -> Bool
isTyVar TcTyVar
tv -- See Note [Coercion variables in free variable lists]
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
        MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
TyVarTv } -> Bool
False
        _                             -> Bool
True
  | Bool
otherwise = Bool
True

isFmvTyVar :: TcTyVar -> Bool
isFmvTyVar tv :: TcTyVar
tv
  = ASSERT2( tcIsTcTyVar tv, ppr tv )
    case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
        MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
FlatMetaTv } -> Bool
True
        _                                -> Bool
False

isFskTyVar :: TcTyVar -> Bool
isFskTyVar tv :: TcTyVar
tv
  = ASSERT2( tcIsTcTyVar tv, ppr tv )
    case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
        MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
FlatSkolTv } -> Bool
True
        _                                -> Bool
False

-- | True of both given and wanted flatten-skolems (fmv and fsk)
isFlattenTyVar :: TcTyVar -> Bool
isFlattenTyVar tv :: TcTyVar
tv
  = ASSERT2( tcIsTcTyVar tv, ppr tv )
    case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
        MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } -> MetaInfo -> Bool
isFlattenInfo MetaInfo
info
        _                          -> Bool
False

isSkolemTyVar :: TcTyVar -> Bool
isSkolemTyVar tv :: TcTyVar
tv
  = ASSERT2( tcIsTcTyVar tv, ppr tv )
    case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
        MetaTv {} -> Bool
False
        _other :: TcTyVarDetails
_other    -> Bool
True

isOverlappableTyVar :: TcTyVar -> Bool
isOverlappableTyVar tv :: TcTyVar
tv
  | TcTyVar -> Bool
isTyVar TcTyVar
tv -- See Note [Coercion variables in free variable lists]
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
        SkolemTv _ overlappable :: Bool
overlappable -> Bool
overlappable
        _                       -> Bool
False
  | Bool
otherwise = Bool
False

isMetaTyVar :: TcTyVar -> Bool
isMetaTyVar tv :: TcTyVar
tv
  | TcTyVar -> Bool
isTyVar TcTyVar
tv -- See Note [Coercion variables in free variable lists]
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
        MetaTv {} -> Bool
True
        _         -> Bool
False
  | Bool
otherwise = Bool
False

-- isAmbiguousTyVar is used only when reporting type errors
-- It picks out variables that are unbound, namely meta
-- type variables and the RuntimUnk variables created by
-- RtClosureInspect.zonkRTTIType.  These are "ambiguous" in
-- the sense that they stand for an as-yet-unknown type
isAmbiguousTyVar :: TcTyVar -> Bool
isAmbiguousTyVar tv :: TcTyVar
tv
  | TcTyVar -> Bool
isTyVar TcTyVar
tv -- See Note [Coercion variables in free variable lists]
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
        MetaTv {}     -> Bool
True
        RuntimeUnk {} -> Bool
True
        _             -> Bool
False
  | Bool
otherwise = Bool
False

isMetaTyVarTy :: TcType -> Bool
isMetaTyVarTy :: TcType -> Bool
isMetaTyVarTy (TyVarTy tv :: TcTyVar
tv) = TcTyVar -> Bool
isMetaTyVar TcTyVar
tv
isMetaTyVarTy _            = Bool
False

metaTyVarInfo :: TcTyVar -> MetaInfo
metaTyVarInfo :: TcTyVar -> MetaInfo
metaTyVarInfo tv :: TcTyVar
tv
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
      MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } -> MetaInfo
info
      _ -> String -> SDoc -> MetaInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic "metaTyVarInfo" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv)

isFlattenInfo :: MetaInfo -> Bool
isFlattenInfo :: MetaInfo -> Bool
isFlattenInfo FlatMetaTv = Bool
True
isFlattenInfo FlatSkolTv = Bool
True
isFlattenInfo _          = Bool
False

metaTyVarTcLevel :: TcTyVar -> TcLevel
metaTyVarTcLevel :: TcTyVar -> TcLevel
metaTyVarTcLevel tv :: TcTyVar
tv
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
      MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tclvl } -> TcLevel
tclvl
      _ -> String -> SDoc -> TcLevel
forall a. HasCallStack => String -> SDoc -> a
pprPanic "metaTyVarTcLevel" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv)

metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel
metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel
metaTyVarTcLevel_maybe tv :: TcTyVar
tv
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
      MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tclvl } -> TcLevel -> Maybe TcLevel
forall a. a -> Maybe a
Just TcLevel
tclvl
      _                            -> Maybe TcLevel
forall a. Maybe a
Nothing

metaTyVarRef :: TyVar -> IORef MetaDetails
metaTyVarRef :: TcTyVar -> IORef MetaDetails
metaTyVarRef tv :: TcTyVar
tv
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
        MetaTv { mtv_ref :: TcTyVarDetails -> IORef MetaDetails
mtv_ref = IORef MetaDetails
ref } -> IORef MetaDetails
ref
        _ -> String -> SDoc -> IORef MetaDetails
forall a. HasCallStack => String -> SDoc -> a
pprPanic "metaTyVarRef" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv)

setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar
setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar
setMetaTyVarTcLevel tv :: TcTyVar
tv tclvl :: TcLevel
tclvl
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
      details :: TcTyVarDetails
details@(MetaTv {}) -> TcTyVar -> TcTyVarDetails -> TcTyVar
setTcTyVarDetails TcTyVar
tv (TcTyVarDetails
details { mtv_tclvl :: TcLevel
mtv_tclvl = TcLevel
tclvl })
      _ -> String -> SDoc -> TcTyVar
forall a. HasCallStack => String -> SDoc -> a
pprPanic "metaTyVarTcLevel" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv)

isTyVarTyVar :: Var -> Bool
isTyVarTyVar :: TcTyVar -> Bool
isTyVarTyVar tv :: TcTyVar
tv
  = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
        MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
TyVarTv } -> Bool
True
        _                             -> Bool
False

isFlexi, isIndirect :: MetaDetails -> Bool
isFlexi :: MetaDetails -> Bool
isFlexi Flexi = Bool
True
isFlexi _     = Bool
False

isIndirect :: MetaDetails -> Bool
isIndirect (Indirect _) = Bool
True
isIndirect _            = Bool
False

isRuntimeUnkSkol :: TyVar -> Bool
-- Called only in TcErrors; see Note [Runtime skolems] there
isRuntimeUnkSkol :: TcTyVar -> Bool
isRuntimeUnkSkol x :: TcTyVar
x
  | TcTyVarDetails
RuntimeUnk <- TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
x = Bool
True
  | Bool
otherwise                      = Bool
False

mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)]
-- Just pair each TyVar with its own name
mkTyVarNamePairs :: [TcTyVar] -> [(Name, TcTyVar)]
mkTyVarNamePairs tvs :: [TcTyVar]
tvs = [(TcTyVar -> Name
tyVarName TcTyVar
tv, TcTyVar
tv) | TcTyVar
tv <- [TcTyVar]
tvs]

findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)]
-- If we have [...(x1,tv)...(x2,tv)...]
-- return (x1,x2) in the result list
findDupTyVarTvs :: [(Name, TcTyVar)] -> [(Name, Name)]
findDupTyVarTvs prs :: [(Name, TcTyVar)]
prs
  = (NonEmpty (Name, TcTyVar) -> [(Name, Name)])
-> [NonEmpty (Name, TcTyVar)] -> [(Name, Name)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (Name, TcTyVar) -> [(Name, Name)]
forall b b. NonEmpty (b, b) -> [(b, b)]
mk_result_prs ([NonEmpty (Name, TcTyVar)] -> [(Name, Name)])
-> [NonEmpty (Name, TcTyVar)] -> [(Name, Name)]
forall a b. (a -> b) -> a -> b
$
    ((Name, TcTyVar) -> (Name, TcTyVar) -> Bool)
-> [(Name, TcTyVar)] -> [NonEmpty (Name, TcTyVar)]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (Name, TcTyVar) -> (Name, TcTyVar) -> Bool
forall a a a. Eq a => (a, a) -> (a, a) -> Bool
eq_snd [(Name, TcTyVar)]
prs
  where
    eq_snd :: (a, a) -> (a, a) -> Bool
eq_snd (_,tv1 :: a
tv1) (_,tv2 :: a
tv2) = a
tv1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
tv2
    mk_result_prs :: NonEmpty (b, b) -> [(b, b)]
mk_result_prs ((n1 :: b
n1,_) :| xs :: [(b, b)]
xs) = ((b, b) -> (b, b)) -> [(b, b)] -> [(b, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(n2 :: b
n2,_) -> (b
n1,b
n2)) [(b, b)]
xs

{-
************************************************************************
*                                                                      *
\subsection{Tau, sigma and rho}
*                                                                      *
************************************************************************
-}

mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type
mkSigmaTy :: [TyCoVarBinder] -> [TcType] -> TcType -> TcType
mkSigmaTy bndrs :: [TyCoVarBinder]
bndrs theta :: [TcType]
theta tau :: TcType
tau = [TyCoVarBinder] -> TcType -> TcType
mkForAllTys [TyCoVarBinder]
bndrs ([TcType] -> TcType -> TcType
mkPhiTy [TcType]
theta TcType
tau)

-- | Make a sigma ty where all type variables are 'Inferred'. That is,
-- they cannot be used with visible type application.
mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type
mkInfSigmaTy :: [TcTyVar] -> [TcType] -> TcType -> TcType
mkInfSigmaTy tyvars :: [TcTyVar]
tyvars theta :: [TcType]
theta ty :: TcType
ty = [TyCoVarBinder] -> [TcType] -> TcType -> TcType
mkSigmaTy (ArgFlag -> [TcTyVar] -> [TyCoVarBinder]
mkTyCoVarBinders ArgFlag
Inferred [TcTyVar]
tyvars) [TcType]
theta TcType
ty

-- | Make a sigma ty where all type variables are "specified". That is,
-- they can be used with visible type application
mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
mkSpecSigmaTy :: [TcTyVar] -> [TcType] -> TcType -> TcType
mkSpecSigmaTy tyvars :: [TcTyVar]
tyvars preds :: [TcType]
preds ty :: TcType
ty = [TyCoVarBinder] -> [TcType] -> TcType -> TcType
mkSigmaTy (ArgFlag -> [TcTyVar] -> [TyCoVarBinder]
mkTyCoVarBinders ArgFlag
Specified [TcTyVar]
tyvars) [TcType]
preds TcType
ty

mkPhiTy :: [PredType] -> Type -> Type
mkPhiTy :: [TcType] -> TcType -> TcType
mkPhiTy = [TcType] -> TcType -> TcType
mkFunTys

---------------
getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
                                -- construct a dictionary function name
getDFunTyKey :: TcType -> OccName
getDFunTyKey ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
coreView TcType
ty = TcType -> OccName
getDFunTyKey TcType
ty'
getDFunTyKey (TyVarTy tv :: TcTyVar
tv)            = TcTyVar -> OccName
forall a. NamedThing a => a -> OccName
getOccName TcTyVar
tv
getDFunTyKey (TyConApp tc :: TyCon
tc _)         = TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tc
getDFunTyKey (LitTy x :: TyLit
x)               = TyLit -> OccName
getDFunTyLitKey TyLit
x
getDFunTyKey (AppTy fun :: TcType
fun _)           = TcType -> OccName
getDFunTyKey TcType
fun
getDFunTyKey (FunTy _ _)             = TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
funTyCon
getDFunTyKey (ForAllTy _ t :: TcType
t)          = TcType -> OccName
getDFunTyKey TcType
t
getDFunTyKey (CastTy ty :: TcType
ty _)           = TcType -> OccName
getDFunTyKey TcType
ty
getDFunTyKey t :: TcType
t@(CoercionTy _)        = String -> SDoc -> OccName
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getDFunTyKey" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
t)

getDFunTyLitKey :: TyLit -> OccName
getDFunTyLitKey :: TyLit -> OccName
getDFunTyLitKey (NumTyLit n :: Integer
n) = NameSpace -> String -> OccName
mkOccName NameSpace
Name.varName (Integer -> String
forall a. Show a => a -> String
show Integer
n)
getDFunTyLitKey (StrTyLit n :: FastString
n) = NameSpace -> String -> OccName
mkOccName NameSpace
Name.varName (FastString -> String
forall a. Show a => a -> String
show FastString
n)  -- hm

{- *********************************************************************
*                                                                      *
           Maintaining the well-kinded type invariant
*                                                                      *
********************************************************************* -}

{- Note [The well-kinded type invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also Note [The tcType invariant] in TcHsType.

During type inference, we maintain this invariant

   (INV-TK): it is legal to call 'tcTypeKind' on any Type ty,
             /without/ zonking ty

For example, suppose
    kappa is a unification variable
    We have already unified kappa := Type
      yielding    co :: Refl (Type -> Type)
    a :: kappa
then consider the type
    (a Int)
If we call tcTypeKind on that, we'll crash, because the (un-zonked)
kind of 'a' is just kappa, not an arrow kind.  If we zonk first
we'd be fine, but that is too tiresome, so instead we maintain
(INV-TK).  So we do not form (a Int); instead we form
    (a |> co) Int
and tcTypeKind has no problem with that.

Bottom line: we want to keep that 'co' /even though it is Refl/.

Immediate consequence: during type inference we cannot use the "smart
contructors" for types, particularly
   mkAppTy, mkCastTy
because they all eliminate Refl casts.  Solution: during type
inference use the mkNakedX type formers, which do no Refl-elimination.
E.g. mkNakedCastTy uses an actual CastTy, without optimising for
Refl.  (NB: mkNakedCastTy is only called in two places: in tcInferApps
and in checkExpectedResultKind.)

Where does this show up in practice: apparently mainly in
TcHsType.tcInferApps.  Suppose we are kind-checking the type (a Int),
where (a :: kappa).  Then in tcInferApps we'll run out of binders on
a's kind, so we'll call matchExpectedFunKind, and unify
   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)
That evidence is actually Refl, but we must not discard the cast to
form the result type
   ((a::kappa) (Int::*))
because that does not satisfy the invariant, and crashes TypeKind.  This
caused Trac #14174 and #14520.

Notes:

* The Refls will be removed later, when we zonk the type.

* This /also/ applies to substitution.  We must use nakedSubstTy,
  not substTy, because the latter uses smart constructors that do
  Refl-elimination.

-}

---------------
mkNakedAppTys :: Type -> [Type] -> Type
-- See Note [The well-kinded type invariant]
mkNakedAppTys :: TcType -> [TcType] -> TcType
mkNakedAppTys ty1 :: TcType
ty1                []   = TcType
ty1
mkNakedAppTys (TyConApp tc :: TyCon
tc tys1 :: [TcType]
tys1) tys2 :: [TcType]
tys2 = TyCon -> [TcType] -> TcType
mkTyConApp TyCon
tc ([TcType]
tys1 [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
tys2)
mkNakedAppTys ty1 :: TcType
ty1                tys2 :: [TcType]
tys2 = (TcType -> TcType -> TcType) -> TcType -> [TcType] -> TcType
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TcType -> TcType -> TcType
AppTy TcType
ty1 [TcType]
tys2

mkNakedAppTy :: Type -> Type -> Type
-- See Note [The well-kinded type invariant]
mkNakedAppTy :: TcType -> TcType -> TcType
mkNakedAppTy ty1 :: TcType
ty1 ty2 :: TcType
ty2 = TcType -> [TcType] -> TcType
mkNakedAppTys TcType
ty1 [TcType
ty2]

mkNakedCastTy :: Type -> Coercion -> Type
-- Do /not/ attempt to get rid of the cast altogether,
-- even if it is Refl: see Note [The well-kinded type invariant]
-- Even doing (t |> co1) |> co2  --->  t |> (co1;co2)
-- does not seem worth the bother
--
-- NB: zonking will get rid of these casts, because it uses mkCastTy
--
-- In fact the calls to mkNakedCastTy ar pretty few and far between.
mkNakedCastTy :: TcType -> KindCoercion -> TcType
mkNakedCastTy ty :: TcType
ty co :: KindCoercion
co = TcType -> KindCoercion -> TcType
CastTy TcType
ty KindCoercion
co

nakedSubstTy :: HasCallStack => TCvSubst -> TcType  -> TcType
nakedSubstTy :: TCvSubst -> TcType -> TcType
nakedSubstTy subst :: TCvSubst
subst ty :: TcType
ty
  | TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst = TcType
ty
  | Bool
otherwise             = Identity TcType -> TcType
forall a. Identity a -> a
runIdentity                   (Identity TcType -> TcType) -> Identity TcType -> TcType
forall a b. (a -> b) -> a -> b
$
                            TCvSubst
-> [TcType] -> [KindCoercion] -> Identity TcType -> Identity TcType
forall a.
HasCallStack =>
TCvSubst -> [TcType] -> [KindCoercion] -> a -> a
checkValidSubst TCvSubst
subst [TcType
ty] [] (Identity TcType -> Identity TcType)
-> Identity TcType -> Identity TcType
forall a b. (a -> b) -> a -> b
$
                            TyCoMapper TCvSubst Identity
-> TCvSubst -> TcType -> Identity TcType
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m -> env -> TcType -> m TcType
mapType TyCoMapper TCvSubst Identity
nakedSubstMapper TCvSubst
subst TcType
ty
  -- Interesting idea: use StrictIdentity to avoid space leaks

nakedSubstMapper :: TyCoMapper TCvSubst Identity
nakedSubstMapper :: TyCoMapper TCvSubst Identity
nakedSubstMapper
  = TyCoMapper :: forall env (m :: * -> *).
Bool
-> (env -> TcTyVar -> m TcType)
-> (env -> TcTyVar -> m KindCoercion)
-> (env -> CoercionHole -> m KindCoercion)
-> (env -> TcTyVar -> ArgFlag -> m (env, TcTyVar))
-> (TyCon -> m TyCon)
-> TyCoMapper env m
TyCoMapper { tcm_smart :: Bool
tcm_smart      = Bool
False
               , tcm_tyvar :: TCvSubst -> TcTyVar -> Identity TcType
tcm_tyvar      = \subst :: TCvSubst
subst tv :: TcTyVar
tv -> TcType -> Identity TcType
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst -> TcTyVar -> TcType
substTyVar TCvSubst
subst TcTyVar
tv)
               , tcm_covar :: TCvSubst -> TcTyVar -> Identity KindCoercion
tcm_covar      = \subst :: TCvSubst
subst cv :: TcTyVar
cv -> KindCoercion -> Identity KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst -> TcTyVar -> KindCoercion
substCoVar TCvSubst
subst TcTyVar
cv)
               , tcm_hole :: TCvSubst -> CoercionHole -> Identity KindCoercion
tcm_hole       = \_ hole :: CoercionHole
hole   -> KindCoercion -> Identity KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (CoercionHole -> KindCoercion
HoleCo CoercionHole
hole)
               , tcm_tycobinder :: TCvSubst -> TcTyVar -> ArgFlag -> Identity (TCvSubst, TcTyVar)
tcm_tycobinder = \subst :: TCvSubst
subst tv :: TcTyVar
tv _ -> (TCvSubst, TcTyVar) -> Identity (TCvSubst, TcTyVar)
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
substVarBndr TCvSubst
subst TcTyVar
tv)
               , tcm_tycon :: TyCon -> Identity TyCon
tcm_tycon    = TyCon -> Identity TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return }

{-
************************************************************************
*                                                                      *
\subsection{Expanding and splitting}
*                                                                      *
************************************************************************

These tcSplit functions are like their non-Tc analogues, but
        *) they do not look through newtypes

However, they are non-monadic and do not follow through mutable type
variables.  It's up to you to make sure this doesn't matter.
-}

-- | Splits a forall type into a list of 'TyBinder's and the inner type.
-- Always succeeds, even if it returns an empty list.
tcSplitPiTys :: Type -> ([TyBinder], Type)
tcSplitPiTys :: TcType -> ([TyBinder], TcType)
tcSplitPiTys ty :: TcType
ty = ASSERT( all isTyBinder (fst sty) ) sty
  where sty :: ([TyBinder], TcType)
sty = TcType -> ([TyBinder], TcType)
splitPiTys TcType
ty

-- | Splits a type into a TyBinder and a body, if possible. Panics otherwise
tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type)
tcSplitPiTy_maybe :: TcType -> Maybe (TyBinder, TcType)
tcSplitPiTy_maybe ty :: TcType
ty = ASSERT( isMaybeTyBinder sty ) sty
  where sty :: Maybe (TyBinder, TcType)
sty = TcType -> Maybe (TyBinder, TcType)
splitPiTy_maybe TcType
ty
        isMaybeTyBinder :: Maybe (TyBinder, b) -> Bool
isMaybeTyBinder (Just (t :: TyBinder
t,_)) = TyBinder -> Bool
isTyBinder TyBinder
t
        isMaybeTyBinder _ = Bool
True

tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type)
tcSplitForAllTy_maybe :: TcType -> Maybe (TyCoVarBinder, TcType)
tcSplitForAllTy_maybe ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe (TyCoVarBinder, TcType)
tcSplitForAllTy_maybe TcType
ty'
tcSplitForAllTy_maybe (ForAllTy tv :: TyCoVarBinder
tv ty :: TcType
ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty)
tcSplitForAllTy_maybe _                = Maybe (TyCoVarBinder, TcType)
forall a. Maybe a
Nothing

-- | Like 'tcSplitPiTys', but splits off only named binders, returning
-- just the tycovars.
tcSplitForAllTys :: Type -> ([TyVar], Type)
tcSplitForAllTys :: TcType -> ([TcTyVar], TcType)
tcSplitForAllTys ty :: TcType
ty = ASSERT( all isTyVar (fst sty) ) sty
  where sty :: ([TcTyVar], TcType)
sty = TcType -> ([TcTyVar], TcType)
splitForAllTys TcType
ty

-- | Like 'tcSplitForAllTys', but splits off only named binders.
tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type)
tcSplitForAllVarBndrs :: TcType -> ([TyCoVarBinder], TcType)
tcSplitForAllVarBndrs ty :: TcType
ty = ASSERT( all isTyVarBinder (fst sty)) sty
  where sty :: ([TyCoVarBinder], TcType)
sty = TcType -> ([TyCoVarBinder], TcType)
splitForAllVarBndrs TcType
ty

-- | Is this a ForAllTy with a named binder?
tcIsForAllTy :: Type -> Bool
tcIsForAllTy :: TcType -> Bool
tcIsForAllTy ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
tcIsForAllTy TcType
ty'
tcIsForAllTy (ForAllTy {}) = Bool
True
tcIsForAllTy _             = Bool
False

tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
-- Split off the first predicate argument from a type
tcSplitPredFunTy_maybe :: TcType -> Maybe (TcType, TcType)
tcSplitPredFunTy_maybe ty :: TcType
ty
  | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe (TcType, TcType)
tcSplitPredFunTy_maybe TcType
ty'
tcSplitPredFunTy_maybe (FunTy arg :: TcType
arg res :: TcType
res)
  | TcType -> Bool
isPredTy TcType
arg = (TcType, TcType) -> Maybe (TcType, TcType)
forall a. a -> Maybe a
Just (TcType
arg, TcType
res)
tcSplitPredFunTy_maybe _
  = Maybe (TcType, TcType)
forall a. Maybe a
Nothing

tcSplitPhiTy :: Type -> (ThetaType, Type)
tcSplitPhiTy :: TcType -> ([TcType], TcType)
tcSplitPhiTy ty :: TcType
ty
  = TcType -> [TcType] -> ([TcType], TcType)
split TcType
ty []
  where
    split :: TcType -> [TcType] -> ([TcType], TcType)
split ty :: TcType
ty ts :: [TcType]
ts
      = case TcType -> Maybe (TcType, TcType)
tcSplitPredFunTy_maybe TcType
ty of
          Just (pred :: TcType
pred, ty :: TcType
ty) -> TcType -> [TcType] -> ([TcType], TcType)
split TcType
ty (TcType
predTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
ts)
          Nothing         -> ([TcType] -> [TcType]
forall a. [a] -> [a]
reverse [TcType]
ts, TcType
ty)

-- | Split a sigma type into its parts.
tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy :: TcType -> ([TcTyVar], [TcType], TcType)
tcSplitSigmaTy ty :: TcType
ty = case TcType -> ([TcTyVar], TcType)
tcSplitForAllTys TcType
ty of
                        (tvs :: [TcTyVar]
tvs, rho :: TcType
rho) -> case TcType -> ([TcType], TcType)
tcSplitPhiTy TcType
rho of
                                        (theta :: [TcType]
theta, tau :: TcType
tau) -> ([TcTyVar]
tvs, [TcType]
theta, TcType
tau)

-- | Split a sigma type into its parts, going underneath as many @ForAllTy@s
-- as possible. For example, given this type synonym:
--
-- @
-- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t
-- @
--
-- if you called @tcSplitSigmaTy@ on this type:
--
-- @
-- forall s t a b. Each s t a b => Traversal s t a b
-- @
--
-- then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But
-- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return
-- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@.
tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type)
-- NB: This is basically a pure version of deeplyInstantiate (from Inst) that
-- doesn't compute an HsWrapper.
tcSplitNestedSigmaTys :: TcType -> ([TcTyVar], [TcType], TcType)
tcSplitNestedSigmaTys ty :: TcType
ty
    -- If there's a forall, split it apart and try splitting the rho type
    -- underneath it.
  | Just (arg_tys :: [TcType]
arg_tys, tvs1 :: [TcTyVar]
tvs1, theta1 :: [TcType]
theta1, rho1 :: TcType
rho1) <- TcType -> Maybe ([TcType], [TcTyVar], [TcType], TcType)
tcDeepSplitSigmaTy_maybe TcType
ty
  = let (tvs2 :: [TcTyVar]
tvs2, theta2 :: [TcType]
theta2, rho2 :: TcType
rho2) = TcType -> ([TcTyVar], [TcType], TcType)
tcSplitNestedSigmaTys TcType
rho1
    in ([TcTyVar]
tvs1 [TcTyVar] -> [TcTyVar] -> [TcTyVar]
forall a. [a] -> [a] -> [a]
++ [TcTyVar]
tvs2, [TcType]
theta1 [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
theta2, [TcType] -> TcType -> TcType
mkFunTys [TcType]
arg_tys TcType
rho2)
    -- If there's no forall, we're done.
  | Bool
otherwise = ([], [], TcType
ty)

-----------------------
tcDeepSplitSigmaTy_maybe
  :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType)
-- Looks for a *non-trivial* quantified type, under zero or more function arrows
-- By "non-trivial" we mean either tyvars or constraints are non-empty

tcDeepSplitSigmaTy_maybe :: TcType -> Maybe ([TcType], [TcTyVar], [TcType], TcType)
tcDeepSplitSigmaTy_maybe ty :: TcType
ty
  | Just (arg_ty :: TcType
arg_ty, res_ty :: TcType
res_ty)           <- TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe TcType
ty
  , Just (arg_tys :: [TcType]
arg_tys, tvs :: [TcTyVar]
tvs, theta :: [TcType]
theta, rho :: TcType
rho) <- TcType -> Maybe ([TcType], [TcTyVar], [TcType], TcType)
tcDeepSplitSigmaTy_maybe TcType
res_ty
  = ([TcType], [TcTyVar], [TcType], TcType)
-> Maybe ([TcType], [TcTyVar], [TcType], TcType)
forall a. a -> Maybe a
Just (TcType
arg_tyTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
arg_tys, [TcTyVar]
tvs, [TcType]
theta, TcType
rho)

  | (tvs :: [TcTyVar]
tvs, theta :: [TcType]
theta, rho :: TcType
rho) <- TcType -> ([TcTyVar], [TcType], TcType)
tcSplitSigmaTy TcType
ty
  , Bool -> Bool
not ([TcTyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tvs Bool -> Bool -> Bool
&& [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcType]
theta)
  = ([TcType], [TcTyVar], [TcType], TcType)
-> Maybe ([TcType], [TcTyVar], [TcType], TcType)
forall a. a -> Maybe a
Just ([], [TcTyVar]
tvs, [TcType]
theta, TcType
rho)

  | Bool
otherwise = Maybe ([TcType], [TcTyVar], [TcType], TcType)
forall a. Maybe a
Nothing

-----------------------
tcTyConAppTyCon :: Type -> TyCon
tcTyConAppTyCon :: TcType -> TyCon
tcTyConAppTyCon ty :: TcType
ty
  = case TcType -> Maybe TyCon
tcTyConAppTyCon_maybe TcType
ty of
      Just tc :: TyCon
tc -> TyCon
tc
      Nothing -> String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcTyConAppTyCon" (TcType -> SDoc
pprType TcType
ty)

-- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'.
tcTyConAppTyCon_maybe :: Type -> Maybe TyCon
tcTyConAppTyCon_maybe :: TcType -> Maybe TyCon
tcTyConAppTyCon_maybe ty :: TcType
ty
  | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe TyCon
tcTyConAppTyCon_maybe TcType
ty'
tcTyConAppTyCon_maybe (TyConApp tc :: TyCon
tc _)
  = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc
tcTyConAppTyCon_maybe (FunTy _ _)
  = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
funTyCon
tcTyConAppTyCon_maybe _
  = Maybe TyCon
forall a. Maybe a
Nothing

tcTyConAppArgs :: Type -> [Type]
tcTyConAppArgs :: TcType -> [TcType]
tcTyConAppArgs ty :: TcType
ty = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
                        Just (_, args :: [TcType]
args) -> [TcType]
args
                        Nothing        -> String -> SDoc -> [TcType]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcTyConAppArgs" (TcType -> SDoc
pprType TcType
ty)

tcSplitTyConApp :: Type -> (TyCon, [Type])
tcSplitTyConApp :: TcType -> (TyCon, [TcType])
tcSplitTyConApp ty :: TcType
ty = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
                        Just stuff :: (TyCon, [TcType])
stuff -> (TyCon, [TcType])
stuff
                        Nothing    -> String -> SDoc -> (TyCon, [TcType])
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcSplitTyConApp" (TcType -> SDoc
pprType TcType
ty)

-- | Like 'tcRepSplitTyConApp_maybe', but returns 'Nothing' if,
--
-- 1. the type is structurally not a type constructor application, or
--
-- 2. the type is a function type (e.g. application of 'funTyCon'), but we
--    currently don't even enough information to fully determine its RuntimeRep
--    variables. For instance, @FunTy (a :: k) Int@.
--
-- By contrast 'tcRepSplitTyConApp_maybe' panics in the second case.
--
-- The behavior here is needed during canonicalization; see Note [FunTy and
-- decomposing tycon applications] in TcCanonical for details.
tcRepSplitTyConApp_maybe' :: HasCallStack => Type -> Maybe (TyCon, [Type])
tcRepSplitTyConApp_maybe' :: TcType -> Maybe (TyCon, [TcType])
tcRepSplitTyConApp_maybe' (TyConApp tc :: TyCon
tc tys :: [TcType]
tys)          = (TyCon, [TcType]) -> Maybe (TyCon, [TcType])
forall a. a -> Maybe a
Just (TyCon
tc, [TcType]
tys)
tcRepSplitTyConApp_maybe' (FunTy arg :: TcType
arg res :: TcType
res)
  | Just arg_rep :: TcType
arg_rep <- HasDebugCallStack => TcType -> Maybe TcType
TcType -> Maybe TcType
getRuntimeRep_maybe TcType
arg
  , Just res_rep :: TcType
res_rep <- HasDebugCallStack => TcType -> Maybe TcType
TcType -> Maybe TcType
getRuntimeRep_maybe TcType
res
  = (TyCon, [TcType]) -> Maybe (TyCon, [TcType])
forall a. a -> Maybe a
Just (TyCon
funTyCon, [TcType
arg_rep, TcType
res_rep, TcType
arg, TcType
res])
tcRepSplitTyConApp_maybe' _                          = Maybe (TyCon, [TcType])
forall a. Maybe a
Nothing


-----------------------
tcSplitFunTys :: Type -> ([Type], Type)
tcSplitFunTys :: TcType -> ([TcType], TcType)
tcSplitFunTys ty :: TcType
ty = case TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe TcType
ty of
                        Nothing        -> ([], TcType
ty)
                        Just (arg :: TcType
arg,res :: TcType
res) -> (TcType
argTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
args, TcType
res')
                                       where
                                          (args :: [TcType]
args,res' :: TcType
res') = TcType -> ([TcType], TcType)
tcSplitFunTys TcType
res

tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
tcSplitFunTy_maybe :: TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty         = TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe TcType
ty'
tcSplitFunTy_maybe (FunTy arg :: TcType
arg res :: TcType
res) | Bool -> Bool
not (TcType -> Bool
isPredTy TcType
arg) = (TcType, TcType) -> Maybe (TcType, TcType)
forall a. a -> Maybe a
Just (TcType
arg, TcType
res)
tcSplitFunTy_maybe _                                    = Maybe (TcType, TcType)
forall a. Maybe a
Nothing
        -- Note the tcTypeKind guard
        -- Consider     (?x::Int) => Bool
        -- We don't want to treat this as a function type!
        -- A concrete example is test tc230:
        --      f :: () -> (?p :: ()) => () -> ()
        --
        --      g = f () ()

tcSplitFunTysN :: Arity                      -- n: Number of desired args
               -> TcRhoType
               -> Either Arity               -- Number of missing arrows
                        ([TcSigmaType],      -- Arg types (always N types)
                         TcSigmaType)        -- The rest of the type
-- ^ Split off exactly the specified number argument types
-- Returns
--  (Left m) if there are 'm' missing arrows in the type
--  (Right (tys,res)) if the type looks like t1 -> ... -> tn -> res
tcSplitFunTysN :: Int -> TcType -> Either Int ([TcType], TcType)
tcSplitFunTysN n :: Int
n ty :: TcType
ty
 | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
 = ([TcType], TcType) -> Either Int ([TcType], TcType)
forall a b. b -> Either a b
Right ([], TcType
ty)
 | Just (arg :: TcType
arg,res :: TcType
res) <- TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe TcType
ty
 = case Int -> TcType -> Either Int ([TcType], TcType)
tcSplitFunTysN (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) TcType
res of
     Left m :: Int
m            -> Int -> Either Int ([TcType], TcType)
forall a b. a -> Either a b
Left Int
m
     Right (args :: [TcType]
args,body :: TcType
body) -> ([TcType], TcType) -> Either Int ([TcType], TcType)
forall a b. b -> Either a b
Right (TcType
argTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
args, TcType
body)
 | Bool
otherwise
 = Int -> Either Int ([TcType], TcType)
forall a b. a -> Either a b
Left Int
n

tcSplitFunTy :: Type -> (Type, Type)
tcSplitFunTy :: TcType -> (TcType, TcType)
tcSplitFunTy  ty :: TcType
ty = String -> Maybe (TcType, TcType) -> (TcType, TcType)
forall a. HasCallStack => String -> Maybe a -> a
expectJust "tcSplitFunTy" (TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe TcType
ty)

tcFunArgTy :: Type -> Type
tcFunArgTy :: TcType -> TcType
tcFunArgTy    ty :: TcType
ty = (TcType, TcType) -> TcType
forall a b. (a, b) -> a
fst (TcType -> (TcType, TcType)
tcSplitFunTy TcType
ty)

tcFunResultTy :: Type -> Type
tcFunResultTy :: TcType -> TcType
tcFunResultTy ty :: TcType
ty = (TcType, TcType) -> TcType
forall a b. (a, b) -> b
snd (TcType -> (TcType, TcType)
tcSplitFunTy TcType
ty)

-- | Strips off n *visible* arguments and returns the resulting type
tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type
tcFunResultTyN :: Int -> TcType -> TcType
tcFunResultTyN n :: Int
n ty :: TcType
ty
  | Right (_, res_ty :: TcType
res_ty) <- Int -> TcType -> Either Int ([TcType], TcType)
tcSplitFunTysN Int
n TcType
ty
  = TcType
res_ty
  | Bool
otherwise
  = String -> SDoc -> TcType
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcFunResultTyN" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)

-----------------------
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe :: TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty'
tcSplitAppTy_maybe ty :: TcType
ty = TcType -> Maybe (TcType, TcType)
tcRepSplitAppTy_maybe TcType
ty

tcSplitAppTy :: Type -> (Type, Type)
tcSplitAppTy :: TcType -> (TcType, TcType)
tcSplitAppTy ty :: TcType
ty = case TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty of
                    Just stuff :: (TcType, TcType)
stuff -> (TcType, TcType)
stuff
                    Nothing    -> String -> SDoc -> (TcType, TcType)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcSplitAppTy" (TcType -> SDoc
pprType TcType
ty)

tcSplitAppTys :: Type -> (Type, [Type])
tcSplitAppTys :: TcType -> (TcType, [TcType])
tcSplitAppTys ty :: TcType
ty
  = TcType -> [TcType] -> (TcType, [TcType])
go TcType
ty []
  where
    go :: TcType -> [TcType] -> (TcType, [TcType])
go ty :: TcType
ty args :: [TcType]
args = case TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty of
                   Just (ty' :: TcType
ty', arg :: TcType
arg) -> TcType -> [TcType] -> (TcType, [TcType])
go TcType
ty' (TcType
argTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
args)
                   Nothing         -> (TcType
ty,[TcType]
args)

-- | Returns the number of arguments in the given type, without
-- looking through synonyms. This is used only for error reporting.
-- We don't look through synonyms because of #11313.
tcRepGetNumAppTys :: Type -> Arity
tcRepGetNumAppTys :: TcType -> Int
tcRepGetNumAppTys = [TcType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TcType] -> Int) -> (TcType -> [TcType]) -> TcType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcType, [TcType]) -> [TcType]
forall a b. (a, b) -> b
snd ((TcType, [TcType]) -> [TcType])
-> (TcType -> (TcType, [TcType])) -> TcType -> [TcType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => TcType -> (TcType, [TcType])
TcType -> (TcType, [TcType])
repSplitAppTys

-----------------------
-- | If the type is a tyvar, possibly under a cast, returns it, along
-- with the coercion. Thus, the co is :: kind tv ~N kind type
tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)
tcGetCastedTyVar_maybe :: TcType -> Maybe (TcTyVar, KindCoercion)
tcGetCastedTyVar_maybe ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe (TcTyVar, KindCoercion)
tcGetCastedTyVar_maybe TcType
ty'
tcGetCastedTyVar_maybe (CastTy (TyVarTy tv :: TcTyVar
tv) co :: KindCoercion
co) = (TcTyVar, KindCoercion) -> Maybe (TcTyVar, KindCoercion)
forall a. a -> Maybe a
Just (TcTyVar
tv, KindCoercion
co)
tcGetCastedTyVar_maybe (TyVarTy tv :: TcTyVar
tv)             = (TcTyVar, KindCoercion) -> Maybe (TcTyVar, KindCoercion)
forall a. a -> Maybe a
Just (TcTyVar
tv, TcType -> KindCoercion
mkNomReflCo (TcTyVar -> TcType
tyVarKind TcTyVar
tv))
tcGetCastedTyVar_maybe _                        = Maybe (TcTyVar, KindCoercion)
forall a. Maybe a
Nothing

tcGetTyVar_maybe :: Type -> Maybe TyVar
tcGetTyVar_maybe :: TcType -> Maybe TcTyVar
tcGetTyVar_maybe ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe TcTyVar
tcGetTyVar_maybe TcType
ty'
tcGetTyVar_maybe (TyVarTy tv :: TcTyVar
tv)   = TcTyVar -> Maybe TcTyVar
forall a. a -> Maybe a
Just TcTyVar
tv
tcGetTyVar_maybe _              = Maybe TcTyVar
forall a. Maybe a
Nothing

tcGetTyVar :: String -> Type -> TyVar
tcGetTyVar :: String -> TcType -> TcTyVar
tcGetTyVar msg :: String
msg ty :: TcType
ty
  = case TcType -> Maybe TcTyVar
tcGetTyVar_maybe TcType
ty of
     Just tv :: TcTyVar
tv -> TcTyVar
tv
     Nothing -> String -> SDoc -> TcTyVar
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
msg (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)

tcIsTyVarTy :: Type -> Bool
tcIsTyVarTy :: TcType -> Bool
tcIsTyVarTy ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
tcIsTyVarTy TcType
ty'
tcIsTyVarTy (CastTy ty :: TcType
ty _) = TcType -> Bool
tcIsTyVarTy TcType
ty  -- look through casts, as
                                            -- this is only used for
                                            -- e.g., FlexibleContexts
tcIsTyVarTy (TyVarTy _)   = Bool
True
tcIsTyVarTy _             = Bool
False

-----------------------
tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type])
-- Split the type of a dictionary function
-- We don't use tcSplitSigmaTy,  because a DFun may (with NDP)
-- have non-Pred arguments, such as
--     df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
--
-- Also NB splitFunTys, not tcSplitFunTys;
-- the latter specifically stops at PredTy arguments,
-- and we don't want to do that here
tcSplitDFunTy :: TcType -> ([TcTyVar], [TcType], Class, [TcType])
tcSplitDFunTy ty :: TcType
ty
  = case TcType -> ([TcTyVar], TcType)
tcSplitForAllTys TcType
ty   of { (tvs :: [TcTyVar]
tvs, rho :: TcType
rho)    ->
    case TcType -> ([TcType], TcType)
splitFunTys TcType
rho       of { (theta :: [TcType]
theta, tau :: TcType
tau)  ->
    case TcType -> (Class, [TcType])
tcSplitDFunHead TcType
tau   of { (clas :: Class
clas, tys :: [TcType]
tys)   ->
    ([TcTyVar]
tvs, [TcType]
theta, Class
clas, [TcType]
tys) }}}

tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead :: TcType -> (Class, [TcType])
tcSplitDFunHead = HasDebugCallStack => TcType -> (Class, [TcType])
TcType -> (Class, [TcType])
getClassPredTys

tcSplitMethodTy :: Type -> ([TyVar], PredType, Type)
-- A class method (selector) always has a type like
--   forall as. C as => blah
-- So if the class looks like
--   class C a where
--     op :: forall b. (Eq a, Ix b) => a -> b
-- the class method type looks like
--  op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b
--
-- tcSplitMethodTy just peels off the outer forall and
-- that first predicate
tcSplitMethodTy :: TcType -> ([TcTyVar], TcType, TcType)
tcSplitMethodTy ty :: TcType
ty
  | (sel_tyvars :: [TcTyVar]
sel_tyvars,sel_rho :: TcType
sel_rho) <- TcType -> ([TcTyVar], TcType)
tcSplitForAllTys TcType
ty
  , Just (first_pred :: TcType
first_pred, local_meth_ty :: TcType
local_meth_ty) <- TcType -> Maybe (TcType, TcType)
tcSplitPredFunTy_maybe TcType
sel_rho
  = ([TcTyVar]
sel_tyvars, TcType
first_pred, TcType
local_meth_ty)
  | Bool
otherwise
  = String -> SDoc -> ([TcTyVar], TcType, TcType)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcSplitMethodTy" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)


{- *********************************************************************
*                                                                      *
            Type equalities
*                                                                      *
********************************************************************* -}

tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool
tcEqKind :: TcType -> TcType -> Bool
tcEqKind = HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
tcEqType

tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool
-- tcEqType is a proper implements the same Note [Non-trivial definitional
-- equality] (in TyCoRep) as `eqType`, but Type.eqType believes (* ==
-- Constraint), and that is NOT what we want in the type checker!
tcEqType :: TcType -> TcType -> Bool
tcEqType ty1 :: TcType
ty1 ty2 :: TcType
ty2
  = Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing ((TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type TcType -> Maybe TcType
tcView TcType
ki1 TcType
ki2) Bool -> Bool -> Bool
&&
    Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing ((TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type TcType -> Maybe TcType
tcView TcType
ty1 TcType
ty2)
  where
    ki1 :: TcType
ki1 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty1
    ki2 :: TcType
ki2 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty2

-- | Just like 'tcEqType', but will return True for types of different kinds
-- as long as their non-coercion structure is identical.
tcEqTypeNoKindCheck :: TcType -> TcType -> Bool
tcEqTypeNoKindCheck :: TcType -> TcType -> Bool
tcEqTypeNoKindCheck ty1 :: TcType
ty1 ty2 :: TcType
ty2
  = Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type TcType -> Maybe TcType
tcView TcType
ty1 TcType
ty2

-- | Like 'tcEqType', but returns information about whether the difference
-- is visible in the case of a mismatch.
-- @Nothing@    : the types are equal
-- @Just True@  : the types differ, and the point of difference is visible
-- @Just False@ : the types differ, and the point of difference is invisible
tcEqTypeVis :: TcType -> TcType -> Maybe Bool
tcEqTypeVis :: TcType -> TcType -> Maybe Bool
tcEqTypeVis ty1 :: TcType
ty1 ty2 :: TcType
ty2
  = (TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type TcType -> Maybe TcType
tcView TcType
ty1 TcType
ty2 Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Maybe Bool -> Maybe Bool
invis ((TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type TcType -> Maybe TcType
tcView TcType
ki1 TcType
ki2)
  where
    ki1 :: TcType
ki1 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty1
    ki2 :: TcType
ki2 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty2

      -- convert Just True to Just False
    invis :: Maybe Bool -> Maybe Bool
    invis :: Maybe Bool -> Maybe Bool
invis = (Bool -> Bool) -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool -> Bool
forall a b. a -> b -> a
const Bool
False)

(<!>) :: Maybe Bool -> Maybe Bool -> Maybe Bool
Nothing        <!> :: Maybe Bool -> Maybe Bool -> Maybe Bool
<!> x :: Maybe Bool
x         = Maybe Bool
x
Just True      <!> _         = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
Just _vis :: Bool
_vis      <!> Just True = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
Just vis :: Bool
vis       <!> _         = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
vis
infixr 3 <!>

-- | Real worker for 'tcEqType'. No kind check!
tc_eq_type :: (TcType -> Maybe TcType)  -- ^ @tcView@, if you want unwrapping
           -> Type -> Type -> Maybe Bool
tc_eq_type :: (TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type view_fun :: TcType -> Maybe TcType
view_fun orig_ty1 :: TcType
orig_ty1 orig_ty2 :: TcType
orig_ty2 = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
True RnEnv2
orig_env TcType
orig_ty1 TcType
orig_ty2
  where
    go :: Bool -> RnEnv2 -> Type -> Type -> Maybe Bool
    go :: Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go vis :: Bool
vis env :: RnEnv2
env t1 :: TcType
t1 t2 :: TcType
t2 | Just t1' :: TcType
t1' <- TcType -> Maybe TcType
view_fun TcType
t1 = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1' TcType
t2
    go vis :: Bool
vis env :: RnEnv2
env t1 :: TcType
t1 t2 :: TcType
t2 | Just t2' :: TcType
t2' <- TcType -> Maybe TcType
view_fun TcType
t2 = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1 TcType
t2'

    go vis :: Bool
vis env :: RnEnv2
env (TyVarTy tv1 :: TcTyVar
tv1)       (TyVarTy tv2 :: TcTyVar
tv2)
      = Bool -> Bool -> Maybe Bool
check Bool
vis (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ RnEnv2 -> TcTyVar -> TcTyVar
rnOccL RnEnv2
env TcTyVar
tv1 TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== RnEnv2 -> TcTyVar -> TcTyVar
rnOccR RnEnv2
env TcTyVar
tv2

    go vis :: Bool
vis _   (LitTy lit1 :: TyLit
lit1)        (LitTy lit2 :: TyLit
lit2)
      = Bool -> Bool -> Maybe Bool
check Bool
vis (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ TyLit
lit1 TyLit -> TyLit -> Bool
forall a. Eq a => a -> a -> Bool
== TyLit
lit2

    go vis :: Bool
vis env :: RnEnv2
env (ForAllTy (Bndr tv1 :: TcTyVar
tv1 vis1 :: ArgFlag
vis1) ty1 :: TcType
ty1)
               (ForAllTy (Bndr tv2 :: TcTyVar
tv2 vis2 :: ArgFlag
vis2) ty2 :: TcType
ty2)
      = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go (ArgFlag -> Bool
isVisibleArgFlag ArgFlag
vis1) RnEnv2
env (TcTyVar -> TcType
varType TcTyVar
tv1) (TcTyVar -> TcType
varType TcTyVar
tv2)
          Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis (RnEnv2 -> TcTyVar -> TcTyVar -> RnEnv2
rnBndr2 RnEnv2
env TcTyVar
tv1 TcTyVar
tv2) TcType
ty1 TcType
ty2
          Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> Bool -> Maybe Bool
check Bool
vis (ArgFlag
vis1 ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ArgFlag
vis2)
    -- Make sure we handle all FunTy cases since falling through to the
    -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked
    -- kind variable, which causes things to blow up.
    go vis :: Bool
vis env :: RnEnv2
env (FunTy arg1 :: TcType
arg1 res1 :: TcType
res1) (FunTy arg2 :: TcType
arg2 res2 :: TcType
res2)
      = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
arg1 TcType
arg2 Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
res1 TcType
res2
    go vis :: Bool
vis env :: RnEnv2
env ty :: TcType
ty (FunTy arg :: TcType
arg res :: TcType
res)
      = Bool -> RnEnv2 -> TcType -> TcType -> TcType -> Maybe Bool
eqFunTy Bool
vis RnEnv2
env TcType
arg TcType
res TcType
ty
    go vis :: Bool
vis env :: RnEnv2
env (FunTy arg :: TcType
arg res :: TcType
res) ty :: TcType
ty
      = Bool -> RnEnv2 -> TcType -> TcType -> TcType -> Maybe Bool
eqFunTy Bool
vis RnEnv2
env TcType
arg TcType
res TcType
ty

      -- See Note [Equality on AppTys] in Type
    go vis :: Bool
vis env :: RnEnv2
env (AppTy s1 :: TcType
s1 t1 :: TcType
t1)        ty2 :: TcType
ty2
      | Just (s2 :: TcType
s2, t2 :: TcType
t2) <- TcType -> Maybe (TcType, TcType)
tcRepSplitAppTy_maybe TcType
ty2
      = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
s1 TcType
s2 Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1 TcType
t2
    go vis :: Bool
vis env :: RnEnv2
env ty1 :: TcType
ty1                  (AppTy s2 :: TcType
s2 t2 :: TcType
t2)
      | Just (s1 :: TcType
s1, t1 :: TcType
t1) <- TcType -> Maybe (TcType, TcType)
tcRepSplitAppTy_maybe TcType
ty1
      = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
s1 TcType
s2 Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1 TcType
t2
    go vis :: Bool
vis env :: RnEnv2
env (TyConApp tc1 :: TyCon
tc1 ts1 :: [TcType]
ts1)   (TyConApp tc2 :: TyCon
tc2 ts2 :: [TcType]
ts2)
      = Bool -> Bool -> Maybe Bool
check Bool
vis (TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2) Maybe Bool -> Maybe Bool -> Maybe Bool
<!> [Bool] -> RnEnv2 -> [TcType] -> [TcType] -> Maybe Bool
gos (Bool -> TyCon -> [Bool]
tc_vis Bool
vis TyCon
tc1) RnEnv2
env [TcType]
ts1 [TcType]
ts2
    go vis :: Bool
vis env :: RnEnv2
env (CastTy t1 :: TcType
t1 _)        t2 :: TcType
t2              = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1 TcType
t2
    go vis :: Bool
vis env :: RnEnv2
env t1 :: TcType
t1                   (CastTy t2 :: TcType
t2 _)   = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1 TcType
t2
    go _   _   (CoercionTy {})      (CoercionTy {}) = Maybe Bool
forall a. Maybe a
Nothing
    go vis :: Bool
vis _   _                    _               = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
vis

    gos :: [Bool] -> RnEnv2 -> [TcType] -> [TcType] -> Maybe Bool
gos _      _   []       []       = Maybe Bool
forall a. Maybe a
Nothing
    gos (v :: Bool
v:vs :: [Bool]
vs) env :: RnEnv2
env (t1 :: TcType
t1:ts1 :: [TcType]
ts1) (t2 :: TcType
t2:ts2 :: [TcType]
ts2) = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
v RnEnv2
env TcType
t1 TcType
t2 Maybe Bool -> Maybe Bool -> Maybe Bool
<!> [Bool] -> RnEnv2 -> [TcType] -> [TcType] -> Maybe Bool
gos [Bool]
vs RnEnv2
env [TcType]
ts1 [TcType]
ts2
    gos (v :: Bool
v:_)  _   _        _        = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
v
    gos _      _   _        _        = String -> Maybe Bool
forall a. String -> a
panic "tc_eq_type"

    tc_vis :: Bool -> TyCon -> [Bool]
    tc_vis :: Bool -> TyCon -> [Bool]
tc_vis True tc :: TyCon
tc = [Bool]
viss [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True
       -- the repeat True is necessary because tycons can legitimately
       -- be oversaturated
      where
        bndrs :: [TyConBinder]
bndrs = TyCon -> [TyConBinder]
tyConBinders TyCon
tc
        viss :: [Bool]
viss  = (TyConBinder -> Bool) -> [TyConBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder [TyConBinder]
bndrs
    tc_vis False _ = Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False  -- if we're not in a visible context, our args
                                   -- aren't either

    check :: Bool -> Bool -> Maybe Bool
    check :: Bool -> Bool -> Maybe Bool
check _   True  = Maybe Bool
forall a. Maybe a
Nothing
    check vis :: Bool
vis False = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
vis

    orig_env :: RnEnv2
orig_env = InScopeSet -> RnEnv2
mkRnEnv2 (InScopeSet -> RnEnv2) -> InScopeSet -> RnEnv2
forall a b. (a -> b) -> a -> b
$ TyCoVarSet -> InScopeSet
mkInScopeSet (TyCoVarSet -> InScopeSet) -> TyCoVarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [TcType] -> TyCoVarSet
tyCoVarsOfTypes [TcType
orig_ty1, TcType
orig_ty2]

    -- @eqFunTy arg res ty@ is True when @ty@ equals @FunTy arg res@. This is
    -- sometimes hard to know directly because @ty@ might have some casts
    -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't
    -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or
    -- res is unzonked/unflattened. Thus this function, which handles this
    -- corner case.
    eqFunTy :: Bool -> RnEnv2 -> Type -> Type -> Type -> Maybe Bool
    eqFunTy :: Bool -> RnEnv2 -> TcType -> TcType -> TcType -> Maybe Bool
eqFunTy vis :: Bool
vis env :: RnEnv2
env arg :: TcType
arg res :: TcType
res (FunTy arg' :: TcType
arg' res' :: TcType
res')
      = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
arg TcType
arg' Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
res TcType
res'
    eqFunTy vis :: Bool
vis env :: RnEnv2
env arg :: TcType
arg res :: TcType
res ty :: TcType
ty@(AppTy{})
      | Just (tc :: TyCon
tc, [_, _, arg' :: TcType
arg', res' :: TcType
res']) <- TcType -> [TcType] -> Maybe (TyCon, [TcType])
get_args TcType
ty []
      , TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
funTyCon
      = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
arg TcType
arg' Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
res TcType
res'
      where
        get_args :: Type -> [Type] -> Maybe (TyCon, [Type])
        get_args :: TcType -> [TcType] -> Maybe (TyCon, [TcType])
get_args (AppTy f :: TcType
f x :: TcType
x)       args :: [TcType]
args = TcType -> [TcType] -> Maybe (TyCon, [TcType])
get_args TcType
f (TcType
xTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
args)
        get_args (CastTy t :: TcType
t _)      args :: [TcType]
args = TcType -> [TcType] -> Maybe (TyCon, [TcType])
get_args TcType
t [TcType]
args
        get_args (TyConApp tc :: TyCon
tc tys :: [TcType]
tys) args :: [TcType]
args = (TyCon, [TcType]) -> Maybe (TyCon, [TcType])
forall a. a -> Maybe a
Just (TyCon
tc, [TcType]
tys [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
args)
        get_args _                 _    = Maybe (TyCon, [TcType])
forall a. Maybe a
Nothing
    eqFunTy vis :: Bool
vis _ _ _ _
      = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
vis

-- | Like 'pickyEqTypeVis', but returns a Bool for convenience
pickyEqType :: TcType -> TcType -> Bool
-- Check when two types _look_ the same, _including_ synonyms.
-- So (pickyEqType String [Char]) returns False
-- This ignores kinds and coercions, because this is used only for printing.
pickyEqType :: TcType -> TcType -> Bool
pickyEqType ty1 :: TcType
ty1 ty2 :: TcType
ty2
  = Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    (TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type (Maybe TcType -> TcType -> Maybe TcType
forall a b. a -> b -> a
const Maybe TcType
forall a. Maybe a
Nothing) TcType
ty1 TcType
ty2

{- *********************************************************************
*                                                                      *
                       Predicate types
*                                                                      *
************************************************************************

Deconstructors and tests on predicate types

Note [Kind polymorphic type classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    class C f where...   -- C :: forall k. k -> Constraint
    g :: forall (f::*). C f => f -> f

Here the (C f) in the signature is really (C * f), and we
don't want to complain that the * isn't a type variable!
-}

isTyVarClassPred :: PredType -> Bool
isTyVarClassPred :: TcType -> Bool
isTyVarClassPred ty :: TcType
ty = case TcType -> Maybe (Class, [TcType])
getClassPredTys_maybe TcType
ty of
    Just (_, tys :: [TcType]
tys) -> (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcType -> Bool
isTyVarTy [TcType]
tys
    _             -> Bool
False

-------------------------
checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool
-- If the Bool is True (flexible contexts), return True (i.e. ok)
-- Otherwise, check that the type (not kind) args are all headed by a tyvar
--   E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected
-- This function is here rather than in TcValidity because it is
-- called from TcSimplify, which itself is imported by TcValidity
checkValidClsArgs :: Bool -> Class -> [TcType] -> Bool
checkValidClsArgs flexible_contexts :: Bool
flexible_contexts cls :: Class
cls kts :: [TcType]
kts
  | Bool
flexible_contexts = Bool
True
  | Bool
otherwise         = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcType -> Bool
hasTyVarHead [TcType]
tys
  where
    tys :: [TcType]
tys = TyCon -> [TcType] -> [TcType]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [TcType]
kts

hasTyVarHead :: Type -> Bool
-- Returns true of (a t1 .. tn), where 'a' is a type variable
hasTyVarHead :: TcType -> Bool
hasTyVarHead ty :: TcType
ty                 -- Haskell 98 allows predicates of form
  | TcType -> Bool
tcIsTyVarTy TcType
ty = Bool
True       --      C (a ty1 .. tyn)
  | Bool
otherwise                   -- where a is a type variable
  = case TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty of
       Just (ty :: TcType
ty, _) -> TcType -> Bool
hasTyVarHead TcType
ty
       Nothing      -> Bool
False

evVarPred :: EvVar -> PredType
evVarPred :: TcTyVar -> TcType
evVarPred var :: TcTyVar
var
  = ASSERT2( isEvVarType var_ty, ppr var <+> dcolon <+> ppr var_ty )
    TcType
var_ty
 where
    var_ty :: TcType
var_ty = TcTyVar -> TcType
varType TcTyVar
var

------------------
-- | When inferring types, should we quantify over a given predicate?
-- Generally true of classes; generally false of equality constraints.
-- Equality constraints that mention quantified type variables and
-- implicit variables complicate the story. See Notes
-- [Inheriting implicit parameters] and [Quantifying over equality constraints]
pickQuantifiablePreds
  :: TyVarSet           -- Quantifying over these
  -> TcThetaType        -- Proposed constraints to quantify
  -> TcThetaType        -- A subset that we can actually quantify
-- This function decides whether a particular constraint should be
-- quantified over, given the type variables that are being quantified
pickQuantifiablePreds :: TyCoVarSet -> [TcType] -> [TcType]
pickQuantifiablePreds qtvs :: TyCoVarSet
qtvs theta :: [TcType]
theta
  = let flex_ctxt :: Bool
flex_ctxt = Bool
True in  -- Quantify over non-tyvar constraints, even without
                             -- -XFlexibleContexts: see Trac #10608, #10351
         -- flex_ctxt <- xoptM Opt_FlexibleContexts
    (TcType -> Maybe TcType) -> [TcType] -> [TcType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Bool -> TcType -> Maybe TcType
pick_me Bool
flex_ctxt) [TcType]
theta
  where
    pick_me :: Bool -> TcType -> Maybe TcType
pick_me flex_ctxt :: Bool
flex_ctxt pred :: TcType
pred
      = case TcType -> PredTree
classifyPredType TcType
pred of

          ClassPred cls :: Class
cls tys :: [TcType]
tys
            | Just {} <- Class -> [TcType] -> Maybe FastString
isCallStackPred Class
cls [TcType]
tys
              -- NEVER infer a CallStack constraint.  Otherwise we let
              -- the constraints bubble up to be solved from the outer
              -- context, or be defaulted when we reach the top-level.
              -- See Note [Overview of implicit CallStacks]
            -> Maybe TcType
forall a. Maybe a
Nothing

            | Class -> Bool
isIPClass Class
cls
            -> TcType -> Maybe TcType
forall a. a -> Maybe a
Just TcType
pred -- See note [Inheriting implicit parameters]

            | Bool -> Class -> [TcType] -> Bool
pick_cls_pred Bool
flex_ctxt Class
cls [TcType]
tys
            -> TcType -> Maybe TcType
forall a. a -> Maybe a
Just TcType
pred

          EqPred eq_rel :: EqRel
eq_rel ty1 :: TcType
ty1 ty2 :: TcType
ty2
            | EqRel -> TcType -> TcType -> Bool
quantify_equality EqRel
eq_rel TcType
ty1 TcType
ty2
            , Just (cls :: Class
cls, tys :: [TcType]
tys) <- EqRel -> TcType -> TcType -> Maybe (Class, [TcType])
boxEqPred EqRel
eq_rel TcType
ty1 TcType
ty2
              -- boxEqPred: See Note [Lift equality constaints when quantifying]
            , Bool -> Class -> [TcType] -> Bool
pick_cls_pred Bool
flex_ctxt Class
cls [TcType]
tys
            -> TcType -> Maybe TcType
forall a. a -> Maybe a
Just (Class -> [TcType] -> TcType
mkClassPred Class
cls [TcType]
tys)

          IrredPred ty :: TcType
ty
            | TcType -> TyCoVarSet
tyCoVarsOfType TcType
ty TyCoVarSet -> TyCoVarSet -> Bool
`intersectsVarSet` TyCoVarSet
qtvs
            -> TcType -> Maybe TcType
forall a. a -> Maybe a
Just TcType
pred

          _ -> Maybe TcType
forall a. Maybe a
Nothing


    pick_cls_pred :: Bool -> Class -> [TcType] -> Bool
pick_cls_pred flex_ctxt :: Bool
flex_ctxt cls :: Class
cls tys :: [TcType]
tys
      = [TcType] -> TyCoVarSet
tyCoVarsOfTypes [TcType]
tys TyCoVarSet -> TyCoVarSet -> Bool
`intersectsVarSet` TyCoVarSet
qtvs
        Bool -> Bool -> Bool
&& (Bool -> Class -> [TcType] -> Bool
checkValidClsArgs Bool
flex_ctxt Class
cls [TcType]
tys)
           -- Only quantify over predicates that checkValidType
           -- will pass!  See Trac #10351.

    -- See Note [Quantifying over equality constraints]
    quantify_equality :: EqRel -> TcType -> TcType -> Bool
quantify_equality NomEq  ty1 :: TcType
ty1 ty2 :: TcType
ty2 = TcType -> Bool
quant_fun TcType
ty1 Bool -> Bool -> Bool
|| TcType -> Bool
quant_fun TcType
ty2
    quantify_equality ReprEq _   _   = Bool
True

    quant_fun :: TcType -> Bool
quant_fun ty :: TcType
ty
      = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
          Just (tc :: TyCon
tc, tys :: [TcType]
tys) | TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
                         -> [TcType] -> TyCoVarSet
tyCoVarsOfTypes [TcType]
tys TyCoVarSet -> TyCoVarSet -> Bool
`intersectsVarSet` TyCoVarSet
qtvs
          _ -> Bool
False

boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type])
-- Given (t1 ~# t2) or (t1 ~R# t2) return the boxed version
--       (t1 ~ t2)  or (t1 `Coercible` t2)
boxEqPred :: EqRel -> TcType -> TcType -> Maybe (Class, [TcType])
boxEqPred eq_rel :: EqRel
eq_rel ty1 :: TcType
ty1 ty2 :: TcType
ty2
  = case EqRel
eq_rel of
      NomEq  | Bool
homo_kind -> (Class, [TcType]) -> Maybe (Class, [TcType])
forall a. a -> Maybe a
Just (Class
eqClass,        [TcType
k1,     TcType
ty1, TcType
ty2])
             | Bool
otherwise -> (Class, [TcType]) -> Maybe (Class, [TcType])
forall a. a -> Maybe a
Just (Class
heqClass,       [TcType
k1, TcType
k2, TcType
ty1, TcType
ty2])
      ReprEq | Bool
homo_kind -> (Class, [TcType]) -> Maybe (Class, [TcType])
forall a. a -> Maybe a
Just (Class
coercibleClass, [TcType
k1,     TcType
ty1, TcType
ty2])
             | Bool
otherwise -> Maybe (Class, [TcType])
forall a. Maybe a
Nothing -- Sigh: we do not have hererogeneous Coercible
                                    --       so we can't abstract over it
                                    -- Nothing fundamental: we could add it
 where
   k1 :: TcType
k1 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty1
   k2 :: TcType
k2 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty2
   homo_kind :: Bool
homo_kind = TcType
k1 HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
`tcEqType` TcType
k2

pickCapturedPreds
  :: TyVarSet           -- Quantifying over these
  -> TcThetaType        -- Proposed constraints to quantify
  -> TcThetaType        -- A subset that we can actually quantify
-- A simpler version of pickQuantifiablePreds, used to winnow down
-- the inferred constraints of a group of bindings, into those for
-- one particular identifier
pickCapturedPreds :: TyCoVarSet -> [TcType] -> [TcType]
pickCapturedPreds qtvs :: TyCoVarSet
qtvs theta :: [TcType]
theta
  = (TcType -> Bool) -> [TcType] -> [TcType]
forall a. (a -> Bool) -> [a] -> [a]
filter TcType -> Bool
captured [TcType]
theta
  where
    captured :: TcType -> Bool
captured pred :: TcType
pred = TcType -> Bool
isIPPred TcType
pred Bool -> Bool -> Bool
|| (TcType -> TyCoVarSet
tyCoVarsOfType TcType
pred TyCoVarSet -> TyCoVarSet -> Bool
`intersectsVarSet` TyCoVarSet
qtvs)


-- Superclasses

type PredWithSCs a = (PredType, [PredType], a)

mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a]
-- Remove predicates that
--
--   - are the same as another predicate
--
--   - can be deduced from another by superclasses,
--
--   - are a reflexive equality (e.g  * ~ *)
--     (see Note [Remove redundant provided dicts] in TcPatSyn)
--
-- The result is a subset of the input.
-- The 'a' is just paired up with the PredType;
--   typically it might be a dictionary Id
mkMinimalBySCs :: (a -> TcType) -> [a] -> [a]
mkMinimalBySCs get_pred :: a -> TcType
get_pred xs :: [a]
xs = [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [PredWithSCs a]
preds_with_scs []
 where
   preds_with_scs :: [PredWithSCs a]
   preds_with_scs :: [PredWithSCs a]
preds_with_scs = [ (TcType
pred, TcType
pred TcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
: TcType -> [TcType]
transSuperClasses TcType
pred, a
x)
                    | a
x <- [a]
xs
                    , let pred :: TcType
pred = a -> TcType
get_pred a
x ]

   go :: [PredWithSCs a]   -- Work list
      -> [PredWithSCs a]   -- Accumulating result
      -> [a]
   go :: [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [] min_preds :: [PredWithSCs a]
min_preds
     = [a] -> [a]
forall a. [a] -> [a]
reverse ((PredWithSCs a -> a) -> [PredWithSCs a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map PredWithSCs a -> a
forall a b c. (a, b, c) -> c
thdOf3 [PredWithSCs a]
min_preds)
       -- The 'reverse' isn't strictly necessary, but it
       -- means that the results are returned in the same
       -- order as the input, which is generally saner
   go (work_item :: PredWithSCs a
work_item@(p :: TcType
p,_,_) : work_list :: [PredWithSCs a]
work_list) min_preds :: [PredWithSCs a]
min_preds
     | EqPred _ t1 :: TcType
t1 t2 :: TcType
t2 <- TcType -> PredTree
classifyPredType TcType
p
     , TcType
t1 HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
`tcEqType` TcType
t2   -- See TcPatSyn
                          -- Note [Remove redundant provided dicts]
     = [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [PredWithSCs a]
work_list [PredWithSCs a]
min_preds
     | TcType
p TcType -> [PredWithSCs a] -> Bool
`in_cloud` [PredWithSCs a]
work_list Bool -> Bool -> Bool
|| TcType
p TcType -> [PredWithSCs a] -> Bool
`in_cloud` [PredWithSCs a]
min_preds
     = [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [PredWithSCs a]
work_list [PredWithSCs a]
min_preds
     | Bool
otherwise
     = [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [PredWithSCs a]
work_list (PredWithSCs a
work_item PredWithSCs a -> [PredWithSCs a] -> [PredWithSCs a]
forall a. a -> [a] -> [a]
: [PredWithSCs a]
min_preds)

   in_cloud :: PredType -> [PredWithSCs a] -> Bool
   in_cloud :: TcType -> [PredWithSCs a] -> Bool
in_cloud p :: TcType
p ps :: [PredWithSCs a]
ps = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ TcType
p HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
`tcEqType` TcType
p' | (_, scs :: [TcType]
scs, _) <- [PredWithSCs a]
ps, TcType
p' <- [TcType]
scs ]

transSuperClasses :: PredType -> [PredType]
-- (transSuperClasses p) returns (p's superclasses) not including p
-- Stop if you encounter the same class again
-- See Note [Expanding superclasses]
transSuperClasses :: TcType -> [TcType]
transSuperClasses p :: TcType
p
  = NameSet -> TcType -> [TcType]
go NameSet
emptyNameSet TcType
p
  where
    go :: NameSet -> PredType -> [PredType]
    go :: NameSet -> TcType -> [TcType]
go rec_clss :: NameSet
rec_clss p :: TcType
p
       | ClassPred cls :: Class
cls tys :: [TcType]
tys <- TcType -> PredTree
classifyPredType TcType
p
       , let cls_nm :: Name
cls_nm = Class -> Name
className Class
cls
       , Bool -> Bool
not (Name
cls_nm Name -> NameSet -> Bool
`elemNameSet` NameSet
rec_clss)
       , let rec_clss' :: NameSet
rec_clss' | Class -> Bool
isCTupleClass Class
cls = NameSet
rec_clss
                       | Bool
otherwise         = NameSet
rec_clss NameSet -> Name -> NameSet
`extendNameSet` Name
cls_nm
       = [ TcType
p' | TcType
sc <- Class -> [TcType] -> [TcType]
immSuperClasses Class
cls [TcType]
tys
              , TcType
p'  <- TcType
sc TcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
: NameSet -> TcType -> [TcType]
go NameSet
rec_clss' TcType
sc ]
       | Bool
otherwise
       = []

immSuperClasses :: Class -> [Type] -> [PredType]
immSuperClasses :: Class -> [TcType] -> [TcType]
immSuperClasses cls :: Class
cls tys :: [TcType]
tys
  = HasCallStack => TCvSubst -> [TcType] -> [TcType]
TCvSubst -> [TcType] -> [TcType]
substTheta ([TcTyVar] -> [TcType] -> TCvSubst
HasDebugCallStack => [TcTyVar] -> [TcType] -> TCvSubst
zipTvSubst [TcTyVar]
tyvars [TcType]
tys) [TcType]
sc_theta
  where
    (tyvars :: [TcTyVar]
tyvars,sc_theta :: [TcType]
sc_theta,_,_) = Class -> ([TcTyVar], [TcType], [TcTyVar], [ClassOpItem])
classBigSig Class
cls

isImprovementPred :: PredType -> Bool
-- Either it's an equality, or has some functional dependency
isImprovementPred :: TcType -> Bool
isImprovementPred ty :: TcType
ty
  = case TcType -> PredTree
classifyPredType TcType
ty of
      EqPred NomEq t1 :: TcType
t1 t2 :: TcType
t2 -> Bool -> Bool
not (TcType
t1 HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
`tcEqType` TcType
t2)
      EqPred ReprEq _ _  -> Bool
False
      ClassPred cls :: Class
cls _    -> Class -> Bool
classHasFds Class
cls
      IrredPred {}       -> Bool
True -- Might have equalities after reduction?
      ForAllPred {}      -> Bool
False

-- | Is the equality
--        a ~r ...a....
-- definitely insoluble or not?
--      a ~r Maybe a      -- Definitely insoluble
--      a ~N ...(F a)...  -- Not definitely insoluble
--                        -- Perhaps (F a) reduces to Int
--      a ~R ...(N a)...  -- Not definitely insoluble
--                        -- Perhaps newtype N a = MkN Int
-- See Note [Occurs check error] in
-- TcCanonical for the motivation for this function.
isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool
isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool
isInsolubleOccursCheck eq_rel :: EqRel
eq_rel tv :: TcTyVar
tv ty :: TcType
ty
  = TcType -> Bool
go TcType
ty
  where
    go :: TcType -> Bool
go ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
go TcType
ty'
    go (TyVarTy tv' :: TcTyVar
tv') = TcTyVar
tv TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
tv' Bool -> Bool -> Bool
|| TcType -> Bool
go (TcTyVar -> TcType
tyVarKind TcTyVar
tv')
    go (LitTy {})    = Bool
False
    go (AppTy t1 :: TcType
t1 t2 :: TcType
t2) = case EqRel
eq_rel of  -- See Note [AppTy and ReprEq]
                         NomEq  -> TcType -> Bool
go TcType
t1 Bool -> Bool -> Bool
|| TcType -> Bool
go TcType
t2
                         ReprEq -> TcType -> Bool
go TcType
t1
    go (FunTy t1 :: TcType
t1 t2 :: TcType
t2) = TcType -> Bool
go TcType
t1 Bool -> Bool -> Bool
|| TcType -> Bool
go TcType
t2
    go (ForAllTy (Bndr tv' :: TcTyVar
tv' _) inner_ty :: TcType
inner_ty)
      | TcTyVar
tv' TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
tv = Bool
False
      | Bool
otherwise = TcType -> Bool
go (TcTyVar -> TcType
varType TcTyVar
tv') Bool -> Bool -> Bool
|| TcType -> Bool
go TcType
inner_ty
    go (CastTy ty :: TcType
ty _)  = TcType -> Bool
go TcType
ty   -- ToDo: what about the coercion
    go (CoercionTy _) = Bool
False   -- ToDo: what about the coercion
    go (TyConApp tc :: TyCon
tc tys :: [TcType]
tys)
      | TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
role = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcType -> Bool
go [TcType]
tys
      | Bool
otherwise                 = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcType -> Bool
go (Int -> [TcType] -> [TcType]
forall a. Int -> [a] -> [a]
drop (TyCon -> Int
tyConArity TyCon
tc) [TcType]
tys)
         -- (a ~ F b a), where F has arity 1,
         -- has an insoluble occurs check

    role :: Role
role = EqRel -> Role
eqRelRole EqRel
eq_rel

{- Note [Expanding superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we expand superclasses, we use the following algorithm:

expand( so_far, pred ) returns the transitive superclasses of pred,
                               not including pred itself
 1. If pred is not a class constraint, return empty set
       Otherwise pred = C ts
 2. If C is in so_far, return empty set (breaks loops)
 3. Find the immediate superclasses constraints of (C ts)
 4. For each such sc_pred, return (sc_pred : expand( so_far+C, D ss )

Notice that

 * With normal Haskell-98 classes, the loop-detector will never bite,
   so we'll get all the superclasses.

 * Since there is only a finite number of distinct classes, expansion
   must terminate.

 * The loop breaking is a bit conservative. Notably, a tuple class
   could contain many times without threatening termination:
      (Eq a, (Ord a, Ix a))
   And this is try of any class that we can statically guarantee
   as non-recursive (in some sense).  For now, we just make a special
   case for tuples.  Something better would be cool.

See also TcTyDecls.checkClassCycles.

Note [Lift equality constaints when quantifying]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We can't quantify over a constraint (t1 ~# t2) because that isn't a
predicate type; see Note [Types for coercions, predicates, and evidence]
in Type.hs.

So we have to 'lift' it to (t1 ~ t2).  Similarly (~R#) must be lifted
to Coercible.

This tiresome lifting is the reason that pick_me (in
pickQuantifiablePreds) returns a Maybe rather than a Bool.

Note [Quantifying over equality constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Should we quantify over an equality constraint (s ~ t)?  In general, we don't.
Doing so may simply postpone a type error from the function definition site to
its call site.  (At worst, imagine (Int ~ Bool)).

However, consider this
         forall a. (F [a] ~ Int) => blah
Should we quantify over the (F [a] ~ Int)?  Perhaps yes, because at the call
site we will know 'a', and perhaps we have instance  F [Bool] = Int.
So we *do* quantify over a type-family equality where the arguments mention
the quantified variables.

Note [Inheriting implicit parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this:

        f x = (x::Int) + ?y

where f is *not* a top-level binding.
From the RHS of f we'll get the constraint (?y::Int).
There are two types we might infer for f:

        f :: Int -> Int

(so we get ?y from the context of f's definition), or

        f :: (?y::Int) => Int -> Int

At first you might think the first was better, because then
?y behaves like a free variable of the definition, rather than
having to be passed at each call site.  But of course, the WHOLE
IDEA is that ?y should be passed at each call site (that's what
dynamic binding means) so we'd better infer the second.

BOTTOM LINE: when *inferring types* you must quantify over implicit
parameters, *even if* they don't mention the bound type variables.
Reason: because implicit parameters, uniquely, have local instance
declarations. See pickQuantifiablePreds.

Note [Quantifying over equality constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Should we quantify over an equality constraint (s ~ t)?  In general, we don't.
Doing so may simply postpone a type error from the function definition site to
its call site.  (At worst, imagine (Int ~ Bool)).

However, consider this
         forall a. (F [a] ~ Int) => blah
Should we quantify over the (F [a] ~ Int).  Perhaps yes, because at the call
site we will know 'a', and perhaps we have instance  F [Bool] = Int.
So we *do* quantify over a type-family equality where the arguments mention
the quantified variables.

************************************************************************
*                                                                      *
      Classifying types
*                                                                      *
************************************************************************
-}

isSigmaTy :: TcType -> Bool
-- isSigmaTy returns true of any qualified type.  It doesn't
-- *necessarily* have any foralls.  E.g
--        f :: (?x::Int) => Int -> Int
isSigmaTy :: TcType -> Bool
isSigmaTy ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
isSigmaTy TcType
ty'
isSigmaTy (ForAllTy {}) = Bool
True
isSigmaTy (FunTy a :: TcType
a _)   = TcType -> Bool
isPredTy TcType
a
isSigmaTy _             = Bool
False

isRhoTy :: TcType -> Bool   -- True of TcRhoTypes; see Note [TcRhoType]
isRhoTy :: TcType -> Bool
isRhoTy ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
isRhoTy TcType
ty'
isRhoTy (ForAllTy {}) = Bool
False
isRhoTy (FunTy a :: TcType
a r :: TcType
r)   = Bool -> Bool
not (TcType -> Bool
isPredTy TcType
a) Bool -> Bool -> Bool
&& TcType -> Bool
isRhoTy TcType
r
isRhoTy _             = Bool
True

-- | Like 'isRhoTy', but also says 'True' for 'Infer' types
isRhoExpTy :: ExpType -> Bool
isRhoExpTy :: ExpType -> Bool
isRhoExpTy (Check ty :: TcType
ty) = TcType -> Bool
isRhoTy TcType
ty
isRhoExpTy (Infer {}) = Bool
True

isOverloadedTy :: Type -> Bool
-- Yes for a type of a function that might require evidence-passing
-- Used only by bindLocalMethods
isOverloadedTy :: TcType -> Bool
isOverloadedTy ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
isOverloadedTy TcType
ty'
isOverloadedTy (ForAllTy _  ty :: TcType
ty) = TcType -> Bool
isOverloadedTy TcType
ty
isOverloadedTy (FunTy a :: TcType
a _)      = TcType -> Bool
isPredTy TcType
a
isOverloadedTy _                = Bool
False

isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy,
    isUnitTy, isCharTy, isAnyTy :: Type -> Bool
isFloatTy :: TcType -> Bool
isFloatTy      = Unique -> TcType -> Bool
is_tc Unique
floatTyConKey
isDoubleTy :: TcType -> Bool
isDoubleTy     = Unique -> TcType -> Bool
is_tc Unique
doubleTyConKey
isIntegerTy :: TcType -> Bool
isIntegerTy    = Unique -> TcType -> Bool
is_tc Unique
integerTyConKey
isIntTy :: TcType -> Bool
isIntTy        = Unique -> TcType -> Bool
is_tc Unique
intTyConKey
isWordTy :: TcType -> Bool
isWordTy       = Unique -> TcType -> Bool
is_tc Unique
wordTyConKey
isBoolTy :: TcType -> Bool
isBoolTy       = Unique -> TcType -> Bool
is_tc Unique
boolTyConKey
isUnitTy :: TcType -> Bool
isUnitTy       = Unique -> TcType -> Bool
is_tc Unique
unitTyConKey
isCharTy :: TcType -> Bool
isCharTy       = Unique -> TcType -> Bool
is_tc Unique
charTyConKey
isAnyTy :: TcType -> Bool
isAnyTy        = Unique -> TcType -> Bool
is_tc Unique
anyTyConKey

-- | Does a type represent a floating-point number?
isFloatingTy :: Type -> Bool
isFloatingTy :: TcType -> Bool
isFloatingTy ty :: TcType
ty = TcType -> Bool
isFloatTy TcType
ty Bool -> Bool -> Bool
|| TcType -> Bool
isDoubleTy TcType
ty

-- | Is a type 'String'?
isStringTy :: Type -> Bool
isStringTy :: TcType -> Bool
isStringTy ty :: TcType
ty
  = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
      Just (tc :: TyCon
tc, [arg_ty :: TcType
arg_ty]) -> TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
listTyCon Bool -> Bool -> Bool
&& TcType -> Bool
isCharTy TcType
arg_ty
      _                   -> Bool
False

-- | Is a type a 'CallStack'?
isCallStackTy :: Type -> Bool
isCallStackTy :: TcType -> Bool
isCallStackTy ty :: TcType
ty
  | Just tc :: TyCon
tc <- TcType -> Maybe TyCon
tyConAppTyCon_maybe TcType
ty
  = TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
callStackTyConKey
  | Bool
otherwise
  = Bool
False

-- | Is a 'PredType' a 'CallStack' implicit parameter?
--
-- If so, return the name of the parameter.
isCallStackPred :: Class -> [Type] -> Maybe FastString
isCallStackPred :: Class -> [TcType] -> Maybe FastString
isCallStackPred cls :: Class
cls tys :: [TcType]
tys
  | [ty1 :: TcType
ty1, ty2 :: TcType
ty2] <- [TcType]
tys
  , Class -> Bool
isIPClass Class
cls
  , TcType -> Bool
isCallStackTy TcType
ty2
  = TcType -> Maybe FastString
isStrLitTy TcType
ty1
  | Bool
otherwise
  = Maybe FastString
forall a. Maybe a
Nothing

hasIPPred :: PredType -> Bool
hasIPPred :: TcType -> Bool
hasIPPred pred :: TcType
pred
  = case TcType -> PredTree
classifyPredType TcType
pred of
      ClassPred cls :: Class
cls tys :: [TcType]
tys
        | Class -> Bool
isIPClass     Class
cls -> Bool
True
        | Class -> Bool
isCTupleClass Class
cls -> (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcType -> Bool
hasIPPred [TcType]
tys
      _other :: PredTree
_other -> Bool
False

is_tc :: Unique -> Type -> Bool
-- Newtypes are opaque to this
is_tc :: Unique -> TcType -> Bool
is_tc uniq :: Unique
uniq ty :: TcType
ty = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
                        Just (tc :: TyCon
tc, _) -> Unique
uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc
                        Nothing      -> Bool
False

-- | Does the given tyvar appear at the head of a chain of applications
--     (a t1 ... tn)
isTyVarHead :: TcTyVar -> TcType -> Bool
isTyVarHead :: TcTyVar -> TcType -> Bool
isTyVarHead tv :: TcTyVar
tv (TyVarTy tv' :: TcTyVar
tv')   = TcTyVar
tv TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
tv'
isTyVarHead tv :: TcTyVar
tv (AppTy fun :: TcType
fun _)   = TcTyVar -> TcType -> Bool
isTyVarHead TcTyVar
tv TcType
fun
isTyVarHead tv :: TcTyVar
tv (CastTy ty :: TcType
ty _)   = TcTyVar -> TcType -> Bool
isTyVarHead TcTyVar
tv TcType
ty
isTyVarHead _ (TyConApp {})    = Bool
False
isTyVarHead _  (LitTy {})      = Bool
False
isTyVarHead _  (ForAllTy {})   = Bool
False
isTyVarHead _  (FunTy {})      = Bool
False
isTyVarHead _  (CoercionTy {}) = Bool
False


{- Note [AppTy and ReprEq]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider   a ~R# b a
           a ~R# a b

The former is /not/ a definite error; we might instantiate 'b' with Id
   newtype Id a = MkId a
but the latter /is/ a definite error.

On the other hand, with nominal equality, both are definite errors
-}

isRigidTy :: TcType -> Bool
isRigidTy :: TcType -> Bool
isRigidTy ty :: TcType
ty
  | Just (tc :: TyCon
tc,_) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty = TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
Nominal
  | Just {} <- TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty        = Bool
True
  | TcType -> Bool
isForAllTy TcType
ty                           = Bool
True
  | Bool
otherwise                               = Bool
False


{-
************************************************************************
*                                                                      *
\subsection{Misc}
*                                                                      *
************************************************************************

Note [Visible type application]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC implements a generalisation of the algorithm described in the
"Visible Type Application" paper (available from
http://www.cis.upenn.edu/~sweirich/publications.html). A key part
of that algorithm is to distinguish user-specified variables from inferred
variables. For example, the following should typecheck:

  f :: forall a b. a -> b -> b
  f = const id

  g = const id

  x = f @Int @Bool 5 False
  y = g 5 @Bool False

The idea is that we wish to allow visible type application when we are
instantiating a specified, fixed variable. In practice, specified, fixed
variables are either written in a type signature (or
annotation), OR are imported from another module. (We could do better here,
for example by doing SCC analysis on parts of a module and considering any
type from outside one's SCC to be fully specified, but this is very confusing to
users. The simple rule above is much more straightforward and predictable.)

So, both of f's quantified variables are specified and may be instantiated.
But g has no type signature, so only id's variable is specified (because id
is imported). We write the type of g as forall {a}. a -> forall b. b -> b.
Note that the a is in braces, meaning it cannot be instantiated with
visible type application.

Tracking specified vs. inferred variables is done conveniently by a field
in TyBinder.

-}

deNoteType :: Type -> Type
-- Remove all *outermost* type synonyms and other notes
deNoteType :: TcType -> TcType
deNoteType ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
coreView TcType
ty = TcType -> TcType
deNoteType TcType
ty'
deNoteType ty :: TcType
ty = TcType
ty

{-
Find the free tycons and classes of a type.  This is used in the front
end of the compiler.
-}

{-
************************************************************************
*                                                                      *
\subsection[TysWiredIn-ext-type]{External types}
*                                                                      *
************************************************************************

The compiler's foreign function interface supports the passing of a
restricted set of types as arguments and results (the restricting factor
being the )
-}

tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
-- (tcSplitIOType_maybe t) returns Just (IO,t',co)
--              if co : t ~ IO t'
--              returns Nothing otherwise
tcSplitIOType_maybe :: TcType -> Maybe (TyCon, TcType)
tcSplitIOType_maybe ty :: TcType
ty
  = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
        Just (io_tycon :: TyCon
io_tycon, [io_res_ty :: TcType
io_res_ty])
         | TyCon
io_tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ioTyConKey ->
            (TyCon, TcType) -> Maybe (TyCon, TcType)
forall a. a -> Maybe a
Just (TyCon
io_tycon, TcType
io_res_ty)
        _ ->
            Maybe (TyCon, TcType)
forall a. Maybe a
Nothing

isFFITy :: Type -> Bool
-- True for any TyCon that can possibly be an arg or result of an FFI call
isFFITy :: TcType -> Bool
isFFITy ty :: TcType
ty = Validity -> Bool
isValid ((TyCon -> Validity) -> TcType -> Validity
checkRepTyCon TyCon -> Validity
legalFFITyCon TcType
ty)

isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity
-- Checks for valid argument type for a 'foreign import'
isFFIArgumentTy :: DynFlags -> Safety -> TcType -> Validity
isFFIArgumentTy dflags :: DynFlags
dflags safety :: Safety
safety ty :: TcType
ty
   = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon (DynFlags -> Safety -> TyCon -> Validity
legalOutgoingTyCon DynFlags
dflags Safety
safety) TcType
ty

isFFIExternalTy :: Type -> Validity
-- Types that are allowed as arguments of a 'foreign export'
isFFIExternalTy :: TcType -> Validity
isFFIExternalTy ty :: TcType
ty = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon TyCon -> Validity
legalFEArgTyCon TcType
ty

isFFIImportResultTy :: DynFlags -> Type -> Validity
isFFIImportResultTy :: DynFlags -> TcType -> Validity
isFFIImportResultTy dflags :: DynFlags
dflags ty :: TcType
ty
  = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon (DynFlags -> TyCon -> Validity
legalFIResultTyCon DynFlags
dflags) TcType
ty

isFFIExportResultTy :: Type -> Validity
isFFIExportResultTy :: TcType -> Validity
isFFIExportResultTy ty :: TcType
ty = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon TyCon -> Validity
legalFEResultTyCon TcType
ty

isFFIDynTy :: Type -> Type -> Validity
-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of
-- either, and the wrapped function type must be equal to the given type.
-- We assume that all types have been run through normaliseFfiType, so we don't
-- need to worry about expanding newtypes here.
isFFIDynTy :: TcType -> TcType -> Validity
isFFIDynTy expected :: TcType
expected ty :: TcType
ty
    -- Note [Foreign import dynamic]
    -- In the example below, expected would be 'CInt -> IO ()', while ty would
    -- be 'FunPtr (CDouble -> IO ())'.
    | Just (tc :: TyCon
tc, [ty' :: TcType
ty']) <- HasDebugCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
splitTyConApp_maybe TcType
ty
    , TyCon -> Unique
tyConUnique TyCon
tc Unique -> [Unique] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
ptrTyConKey, Unique
funPtrTyConKey]
    , TcType -> TcType -> Bool
eqType TcType
ty' TcType
expected
    = Validity
IsValid
    | Bool
otherwise
    = SDoc -> Validity
NotValid ([SDoc] -> SDoc
vcat [ String -> SDoc
text "Expected: Ptr/FunPtr" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
pprParendType TcType
expected SDoc -> SDoc -> SDoc
<> SDoc
comma
                     , String -> SDoc
text "  Actual:" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty ])

isFFILabelTy :: Type -> Validity
-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either.
isFFILabelTy :: TcType -> Validity
isFFILabelTy ty :: TcType
ty = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon TyCon -> Validity
forall a. Uniquable a => a -> Validity
ok TcType
ty
  where
    ok :: a -> Validity
ok tc :: a
tc | a
tc a -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funPtrTyConKey Bool -> Bool -> Bool
|| a
tc a -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ptrTyConKey
          = Validity
IsValid
          | Bool
otherwise
          = SDoc -> Validity
NotValid (String -> SDoc
text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)")

isFFIPrimArgumentTy :: DynFlags -> Type -> Validity
-- Checks for valid argument type for a 'foreign import prim'
-- Currently they must all be simple unlifted types, or the well-known type
-- Any, which can be used to pass the address to a Haskell object on the heap to
-- the foreign function.
isFFIPrimArgumentTy :: DynFlags -> TcType -> Validity
isFFIPrimArgumentTy dflags :: DynFlags
dflags ty :: TcType
ty
  | TcType -> Bool
isAnyTy TcType
ty = Validity
IsValid
  | Bool
otherwise  = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon (DynFlags -> TyCon -> Validity
legalFIPrimArgTyCon DynFlags
dflags) TcType
ty

isFFIPrimResultTy :: DynFlags -> Type -> Validity
-- Checks for valid result type for a 'foreign import prim' Currently
-- it must be an unlifted type, including unboxed tuples, unboxed
-- sums, or the well-known type Any.
isFFIPrimResultTy :: DynFlags -> TcType -> Validity
isFFIPrimResultTy dflags :: DynFlags
dflags ty :: TcType
ty
  | TcType -> Bool
isAnyTy TcType
ty = Validity
IsValid
  | Bool
otherwise = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon (DynFlags -> TyCon -> Validity
legalFIPrimResultTyCon DynFlags
dflags) TcType
ty

isFunPtrTy :: Type -> Bool
isFunPtrTy :: TcType -> Bool
isFunPtrTy ty :: TcType
ty
  | Just (tc :: TyCon
tc, [_]) <- HasDebugCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
splitTyConApp_maybe TcType
ty
  = TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funPtrTyConKey
  | Bool
otherwise
  = Bool
False

-- normaliseFfiType gets run before checkRepTyCon, so we don't
-- need to worry about looking through newtypes or type functions
-- here; that's already been taken care of.
checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity
checkRepTyCon :: (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon check_tc :: TyCon -> Validity
check_tc ty :: TcType
ty
  = case HasDebugCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
splitTyConApp_maybe TcType
ty of
      Just (tc :: TyCon
tc, tys :: [TcType]
tys)
        | TyCon -> Bool
isNewTyCon TyCon
tc -> SDoc -> Validity
NotValid (SDoc -> Int -> SDoc -> SDoc
hang SDoc
msg 2 (TyCon -> [TcType] -> SDoc
forall (t :: * -> *) a a.
(Foldable t, Outputable a) =>
a -> t a -> SDoc
mk_nt_reason TyCon
tc [TcType]
tys SDoc -> SDoc -> SDoc
$$ SDoc
nt_fix))
        | Bool
otherwise     -> case TyCon -> Validity
check_tc TyCon
tc of
                             IsValid        -> Validity
IsValid
                             NotValid extra :: SDoc
extra -> SDoc -> Validity
NotValid (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
extra)
      Nothing -> SDoc -> Validity
NotValid (SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not a data type")
  where
    msg :: SDoc
msg = SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "cannot be marshalled in a foreign call"
    mk_nt_reason :: a -> t a -> SDoc
mk_nt_reason tc :: a
tc tys :: t a
tys
      | t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
tys  = String -> SDoc
text "because its data constructor is not in scope"
      | Bool
otherwise = String -> SDoc
text "because the data constructor for"
                    SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not in scope"
    nt_fix :: SDoc
nt_fix = String -> SDoc
text "Possible fix: import the data constructor to bring it into scope"

{-
Note [Foreign import dynamic]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign
type.  Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'.

We use isFFIDynTy to check whether a signature is well-formed. For example,
given a (illegal) declaration like:

foreign import ccall "dynamic"
  foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO ()

isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried
result type 'CInt -> IO ()', and return False, as they are not equal.


----------------------------------------------
These chaps do the work; they are not exported
----------------------------------------------
-}

legalFEArgTyCon :: TyCon -> Validity
legalFEArgTyCon :: TyCon -> Validity
legalFEArgTyCon tc :: TyCon
tc
  -- It's illegal to make foreign exports that take unboxed
  -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
  = TyCon -> Validity
boxedMarshalableTyCon TyCon
tc

legalFIResultTyCon :: DynFlags -> TyCon -> Validity
legalFIResultTyCon :: DynFlags -> TyCon -> Validity
legalFIResultTyCon dflags :: DynFlags
dflags tc :: TyCon
tc
  | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon         = Validity
IsValid
  | Bool
otherwise               = DynFlags -> TyCon -> Validity
marshalableTyCon DynFlags
dflags TyCon
tc

legalFEResultTyCon :: TyCon -> Validity
legalFEResultTyCon :: TyCon -> Validity
legalFEResultTyCon tc :: TyCon
tc
  | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon         = Validity
IsValid
  | Bool
otherwise               = TyCon -> Validity
boxedMarshalableTyCon TyCon
tc

legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity
-- Checks validity of types going from Haskell -> external world
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity
legalOutgoingTyCon dflags :: DynFlags
dflags _ tc :: TyCon
tc
  = DynFlags -> TyCon -> Validity
marshalableTyCon DynFlags
dflags TyCon
tc

legalFFITyCon :: TyCon -> Validity
-- True for any TyCon that can possibly be an arg or result of an FFI call
legalFFITyCon :: TyCon -> Validity
legalFFITyCon tc :: TyCon
tc
  | TyCon -> Bool
isUnliftedTyCon TyCon
tc = Validity
IsValid
  | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon    = Validity
IsValid
  | Bool
otherwise          = TyCon -> Validity
boxedMarshalableTyCon TyCon
tc

marshalableTyCon :: DynFlags -> TyCon -> Validity
marshalableTyCon :: DynFlags -> TyCon -> Validity
marshalableTyCon dflags :: DynFlags
dflags tc :: TyCon
tc
  | TyCon -> Bool
isUnliftedTyCon TyCon
tc
  , Bool -> Bool
not (TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isUnboxedSumTyCon TyCon
tc)
  , Bool -> Bool
not ([PrimRep] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HasDebugCallStack => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc)) -- Note [Marshalling void]
  = DynFlags -> Validity
validIfUnliftedFFITypes DynFlags
dflags
  | Bool
otherwise
  = TyCon -> Validity
boxedMarshalableTyCon TyCon
tc

boxedMarshalableTyCon :: TyCon -> Validity
boxedMarshalableTyCon :: TyCon -> Validity
boxedMarshalableTyCon tc :: TyCon
tc
   | TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc Unique -> [Unique] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Unique
intTyConKey, Unique
int8TyConKey, Unique
int16TyConKey
                         , Unique
int32TyConKey, Unique
int64TyConKey
                         , Unique
wordTyConKey, Unique
word8TyConKey, Unique
word16TyConKey
                         , Unique
word32TyConKey, Unique
word64TyConKey
                         , Unique
floatTyConKey, Unique
doubleTyConKey
                         , Unique
ptrTyConKey, Unique
funPtrTyConKey
                         , Unique
charTyConKey
                         , Unique
stablePtrTyConKey
                         , Unique
boolTyConKey
                         ]
  = Validity
IsValid

  | Bool
otherwise = SDoc -> Validity
NotValid SDoc
empty

legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity
-- Check args of 'foreign import prim', only allow simple unlifted types.
-- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since
-- currently they're of the wrong kind to use in function args anyway.
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity
legalFIPrimArgTyCon dflags :: DynFlags
dflags tc :: TyCon
tc
  | TyCon -> Bool
isUnliftedTyCon TyCon
tc
  , Bool -> Bool
not (TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isUnboxedSumTyCon TyCon
tc)
  = DynFlags -> Validity
validIfUnliftedFFITypes DynFlags
dflags
  | Bool
otherwise
  = SDoc -> Validity
NotValid SDoc
unlifted_only

legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity
-- Check result type of 'foreign import prim'. Allow simple unlifted
-- types and also unboxed tuple and sum result types.
legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity
legalFIPrimResultTyCon dflags :: DynFlags
dflags tc :: TyCon
tc
  | TyCon -> Bool
isUnliftedTyCon TyCon
tc
  , TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isUnboxedSumTyCon TyCon
tc
     Bool -> Bool -> Bool
|| Bool -> Bool
not ([PrimRep] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HasDebugCallStack => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc))   -- Note [Marshalling void]
  = DynFlags -> Validity
validIfUnliftedFFITypes DynFlags
dflags

  | Bool
otherwise
  = SDoc -> Validity
NotValid SDoc
unlifted_only

unlifted_only :: MsgDoc
unlifted_only :: SDoc
unlifted_only = String -> SDoc
text "foreign import prim only accepts simple unlifted types"

validIfUnliftedFFITypes :: DynFlags -> Validity
validIfUnliftedFFITypes :: DynFlags -> Validity
validIfUnliftedFFITypes dflags :: DynFlags
dflags
  | Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedFFITypes DynFlags
dflags =  Validity
IsValid
  | Bool
otherwise = SDoc -> Validity
NotValid (String -> SDoc
text "To marshal unlifted types, use UnliftedFFITypes")

{-
Note [Marshalling void]
~~~~~~~~~~~~~~~~~~~~~~~
We don't treat State# (whose PrimRep is VoidRep) as marshalable.
In turn that means you can't write
        foreign import foo :: Int -> State# RealWorld

Reason: the back end falls over with panic "primRepHint:VoidRep";
        and there is no compelling reason to permit it
-}

{-
************************************************************************
*                                                                      *
        The "Paterson size" of a type
*                                                                      *
************************************************************************
-}

{-
Note [Paterson conditions on PredTypes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are considering whether *class* constraints terminate
(see Note [Paterson conditions]). Precisely, the Paterson conditions
would have us check that "the constraint has fewer constructors and variables
(taken together and counting repetitions) than the head.".

However, we can be a bit more refined by looking at which kind of constraint
this actually is. There are two main tricks:

 1. It seems like it should be OK not to count the tuple type constructor
    for a PredType like (Show a, Eq a) :: Constraint, since we don't
    count the "implicit" tuple in the ThetaType itself.

    In fact, the Paterson test just checks *each component* of the top level
    ThetaType against the size bound, one at a time. By analogy, it should be
    OK to return the size of the *largest* tuple component as the size of the
    whole tuple.

 2. Once we get into an implicit parameter or equality we
    can't get back to a class constraint, so it's safe
    to say "size 0".  See Trac #4200.

NB: we don't want to detect PredTypes in sizeType (and then call
sizePred on them), or we might get an infinite loop if that PredType
is irreducible. See Trac #5581.
-}

type TypeSize = IntWithInf

sizeType :: Type -> TypeSize
-- Size of a type: the number of variables and constructors
-- Ignore kinds altogether
sizeType :: TcType -> TypeSize
sizeType = TcType -> TypeSize
go
  where
    go :: TcType -> TypeSize
go ty :: TcType
ty | Just exp_ty :: TcType
exp_ty <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> TypeSize
go TcType
exp_ty
    go (TyVarTy {})              = 1
    go (TyConApp tc :: TyCon
tc tys :: [TcType]
tys)
      | TyCon -> Bool
isTypeFamilyTyCon TyCon
tc     = TypeSize
infinity  -- Type-family applications can
                                             -- expand to any arbitrary size
      | Bool
otherwise                = [TcType] -> TypeSize
sizeTypes (TyCon -> [TcType] -> [TcType]
filterOutInvisibleTypes TyCon
tc [TcType]
tys) TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ 1
                                   -- Why filter out invisible args?  I suppose any
                                   -- size ordering is sound, but why is this better?
                                   -- I came across this when investigating #14010.
    go (LitTy {})                = 1
    go (FunTy arg :: TcType
arg res :: TcType
res)           = TcType -> TypeSize
go TcType
arg TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ TcType -> TypeSize
go TcType
res TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ 1
    go (AppTy fun :: TcType
fun arg :: TcType
arg)           = TcType -> TypeSize
go TcType
fun TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ TcType -> TypeSize
go TcType
arg
    go (ForAllTy (Bndr tv :: TcTyVar
tv vis :: ArgFlag
vis) ty :: TcType
ty)
        | ArgFlag -> Bool
isVisibleArgFlag ArgFlag
vis   = TcType -> TypeSize
go (TcTyVar -> TcType
tyVarKind TcTyVar
tv) TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ TcType -> TypeSize
go TcType
ty TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ 1
        | Bool
otherwise              = TcType -> TypeSize
go TcType
ty TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ 1
    go (CastTy ty :: TcType
ty _)             = TcType -> TypeSize
go TcType
ty
    go (CoercionTy {})           = 0

sizeTypes :: [Type] -> TypeSize
sizeTypes :: [TcType] -> TypeSize
sizeTypes tys :: [TcType]
tys = [TypeSize] -> TypeSize
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((TcType -> TypeSize) -> [TcType] -> [TypeSize]
forall a b. (a -> b) -> [a] -> [b]
map TcType -> TypeSize
sizeType [TcType]
tys)

-----------------------------------------------------------------------------------
-----------------------------------------------------------------------------------
-----------------------
-- | For every arg a tycon can take, the returned list says True if the argument
-- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to
-- allow for oversaturation.
tcTyConVisibilities :: TyCon -> [Bool]
tcTyConVisibilities :: TyCon -> [Bool]
tcTyConVisibilities tc :: TyCon
tc = [Bool]
tc_binder_viss [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Bool]
tc_return_kind_viss [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True
  where
    tc_binder_viss :: [Bool]
tc_binder_viss      = (TyConBinder -> Bool) -> [TyConBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder (TyCon -> [TyConBinder]
tyConBinders TyCon
tc)
    tc_return_kind_viss :: [Bool]
tc_return_kind_viss = (TyBinder -> Bool) -> [TyBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TyBinder -> Bool
isVisibleBinder (([TyBinder], TcType) -> [TyBinder]
forall a b. (a, b) -> a
fst (([TyBinder], TcType) -> [TyBinder])
-> ([TyBinder], TcType) -> [TyBinder]
forall a b. (a -> b) -> a -> b
$ TcType -> ([TyBinder], TcType)
tcSplitPiTys (TyCon -> TcType
tyConResKind TyCon
tc))

-- | If the tycon is applied to the types, is the next argument visible?
isNextTyConArgVisible :: TyCon -> [Type] -> Bool
isNextTyConArgVisible :: TyCon -> [TcType] -> Bool
isNextTyConArgVisible tc :: TyCon
tc tys :: [TcType]
tys
  = TyCon -> [Bool]
tcTyConVisibilities TyCon
tc [Bool] -> Int -> Bool
forall a. Outputable a => [a] -> Int -> a
`getNth` [TcType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TcType]
tys

-- | Should this type be applied to a visible argument?
isNextArgVisible :: TcType -> Bool
isNextArgVisible :: TcType -> Bool
isNextArgVisible ty :: TcType
ty
  | Just (bndr :: TyBinder
bndr, _) <- TcType -> Maybe (TyBinder, TcType)
tcSplitPiTy_maybe TcType
ty = TyBinder -> Bool
isVisibleBinder TyBinder
bndr
  | Bool
otherwise                              = Bool
True
    -- this second case might happen if, say, we have an unzonked TauTv.
    -- But TauTvs can't range over types that take invisible arguments