{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

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

-}

-- | 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
--
module GHC.Tc.Utils.TcType (
  --------------------------------
  -- Types
  TcType, TcSigmaType, TcTypeFRR, TcSigmaTypeFRR,
  TcRhoType, TcTauType, TcPredType, TcThetaType,
  TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,
  TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder,
  TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied,

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

  SyntaxOpType(..), synKnownType, mkSynFunTys,

  --------------------------------
  -- TcLevel
  TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,
  strictlyDeeperThan, deeperThanOrSame, sameDepthAs,
  tcTypeLevel, tcTyVarLevel, maxTcLevel,

  --------------------------------
  -- MetaDetails
  TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTvUnk,
  MetaDetails(Flexi, Indirect), MetaInfo(..), skolemSkolInfo,
  isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,
  tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,
  ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar,
  isConcreteTyVarTy, isConcreteTyVarTy_maybe,
  isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo,
  isFlexi, isIndirect, isRuntimeUnkSkol,
  metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,
  isTouchableMetaTyVar, isPromotableMetaTyVar,
  findDupTyVarTvs, mkTyVarNamePairs,

  --------------------------------
  -- Builders
  mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, mkPhiTy, tcMkPhiTy,
  tcMkDFunSigmaTy, tcMkDFunPhiTy,

  --------------------------------
  -- Splitters
  getTyVar, getTyVar_maybe, getCastedTyVar_maybe,
  tcSplitForAllTyVarBinder_maybe,
  tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars,
  tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders,
  tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBinders,
  tcSplitPhiTy, tcSplitPredFunTy_maybe,
  tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,
  tcSplitFunTysN,
  tcSplitTyConApp, tcSplitTyConApp_maybe,
  tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,
  tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe,
  tcSplitSigmaTy, tcSplitNestedSigmaTys,

  ---------------------------------
  -- Predicates.
  -- Again, newtypes are opaque
  isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
  isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
  isIntegerTy, isNaturalTy,
  isBoolTy, isUnitTy, isCharTy,
  isTauTy, isTauTyCon, tcIsTyVarTy,
  isPredTy, isTyVarClassPred,
  checkValidClsArgs, hasTyVarHead,
  isRigidTy,


  -- Re-exported from GHC.Core.TyCo.Compare
  -- mainly just for back-compat reasons
  eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,
  pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,
  tcEqTyConApps, eqForAllVis, eqVarBndrs,

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

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

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

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

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

  ---------------------------------
  -- Foreign import and export
  IllegalForeignTypeReason(..),
  TypeCannotBeMarshaledReason(..),
  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
  isFunPtrTy,          -- :: Type -> Bool
  tcSplitIOType_maybe, -- :: Type -> Maybe Type

  ---------------------------------
  -- Patersons sizes
  PatersonSize(..), PatersonSizeFailure(..),
  ltPatersonSize,
  pSizeZero, pSizeOne,
  pSizeType, pSizeTypeX, pSizeTypes,
  pSizeClassPred, pSizeClassPredX,
  pSizeTyConApp,
  noMoreTyVars, allDistinctTyVars,
  TypeSize, sizeType, sizeTypes, scopedSort,
  isTerminatingClass, isStuckTypeFamily,

  --------------------------------
  -- Reexported from Kind
  Kind, liftedTypeKind, constraintKind,
  isLiftedTypeKind, isUnliftedTypeKind, isTYPEorCONSTRAINT,

  --------------------------------
  -- Reexported from Type
  Type, PredType, ThetaType, PiTyBinder,
  ForAllTyFlag(..), FunTyFlag(..),

  mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,
  mkSpecForAllTys, mkTyCoInvForAllTy,
  mkInfForAllTy, mkInfForAllTys,
  mkVisFunTy, mkVisFunTyMany, mkVisFunTysMany,
  mkScaledFunTys,
  mkInvisFunTy, mkInvisFunTys,
  mkTyConApp, mkAppTy, mkAppTys,
  mkTyConTy, mkTyVarTy, mkTyVarTys,
  mkTyCoVarTy, mkTyCoVarTys,

  isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass,
  mkClassPred,
  tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
  isRuntimeRepVar, isFixedRuntimeRepKind,
  isVisiblePiTyBinder, isInvisiblePiTyBinder,

  -- Type substitutions
  Subst(..),         -- Representation visible to a few friends
  TvSubstEnv, emptySubst, mkEmptySubst,
  zipTvSubst,
  mkTvSubstPrs, notElemSubst, unionSubst,
  getTvSubstEnv, getSubstInScope, extendSubstInScope,
  extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope,
  Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,
  Type.extendTvSubst,
  isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv,
  Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars,
  substTyAddInScope,
  substTyUnchecked, substTysUnchecked, substScaledTyUnchecked,
  substThetaUnchecked,
  substTyWithUnchecked,
  substCoUnchecked, substCoWithUnchecked,
  substTheta,

  isUnliftedType,
  isUnboxedTupleType,
  isPrimitiveType,

  coreView,

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

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

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

  ) where

-- friends:
import GHC.Prelude

import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars )
import GHC.Core.TyCo.Compare
import GHC.Core.TyCo.FVs
import GHC.Core.TyCo.Ppr
import GHC.Core.Class
import GHC.Types.Var
import GHC.Types.ForeignCall
import GHC.Types.Var.Set
import GHC.Core.Coercion
import GHC.Core.Type as Type
import GHC.Core.Predicate
import GHC.Types.RepType
import GHC.Core.TyCon

import {-# SOURCE #-} GHC.Tc.Types.Origin
  ( SkolemInfo, unkSkol
  , FixedRuntimeRepOrigin, FixedRuntimeRepContext )

-- others:
import GHC.Driver.Session
import GHC.Core.FVs
import GHC.Types.Name as Name
            -- We use this to make dictionaries for type literals.
            -- Perhaps there's a better way to do this?
import GHC.Types.Name.Set
import GHC.Builtin.Names
import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey
                         , listTyCon, constraintKind )
import GHC.Types.Basic
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Data.List.SetOps ( getNth, findDupsEq )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Error( Validity'(..) )
import qualified GHC.LanguageExtensions as LangExt

import Data.IORef
import Data.List.NonEmpty( NonEmpty(..) )
import Data.List ( partition, nub, (\\) )

import GHC.Generics ( Generic )

{-
************************************************************************
*                                                                      *
              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 significant 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 GHC.Tc.Gen.HsType.

  - The pattern-match overlap checker calls the constraint solver,
    long after 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 remorselessly
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 GHC.Tc.Utils.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 #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

-- | A type which has a syntactically fixed RuntimeRep as per
-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
type TcTypeFRR = TcType
  -- TODO: consider making this a newtype.

type TcTyVarBinder     = TyVarBinder
type TcInvisTVBinder   = InvisTVBinder
type TcReqTVBinder     = ReqTVBinder

-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]
type TcTyCon       = TyCon
type MonoTcTyCon   = TcTyCon
type PolyTcTyCon   = TcTyCon
type TcTyConBinder = TyConBinder -- With skolem TcTyVars

-- These types do not have boxy type variables in them
type TcPredType     = PredType
type TcThetaType    = ThetaType
type TcSigmaType    = TcType

-- | A 'TcSigmaTypeFRR' is a 'TcSigmaType' which has a syntactically
--  fixed 'RuntimeRep' in the sense of Note [Fixed RuntimeRep]
-- in GHC.Tc.Utils.Concrete.
--
-- In particular, this means that:
--
-- - 'GHC.Types.RepType.typePrimRep' does not panic,
-- - 'GHC.Core.typeLevity_maybe' does not return 'Nothing'.
--
-- This property is important in functions such as 'matchExpectedFunTys', where
-- we want to provide argument types which have a known runtime representation.
-- See Note [Return arguments with a fixed RuntimeRep.
type TcSigmaTypeFRR = TcSigmaType
    -- TODO: consider making this a newtype.

type TcRhoType      = TcType  -- Note [TcRhoType]
type TcTauType      = TcType
type TcKind         = Kind
type TcTyVarSet     = TyVarSet
type TcTyCoVarSet   = TyCoVarSet
type TcDTyVarSet    = DTyVarSet
type TcDTyCoVarSet  = DTyCoVarSet

{- Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Note [How TcTyCons work] in GHC.Tc.TyCl

Invariants:

* TcTyCon: a TyCon built with the TcTyCon constructor

* TcTyConBinder: a TyConBinder with a TcTyVar inside (not a TyVar)

* TcTyCons contain TcTyVars

* MonoTcTyCon:
  - Flag tcTyConIsPoly = False

  - tyConScopedTyVars is important; maps a Name to a TyVarTv unification variable
    The order is important: Specified then Required variables.   E.g. in
        data T a (b :: k) = ...
    the order will be [k, a, b].

    NB: There are no Inferred binders in tyConScopedTyVars; 'a' may
    also be poly-kinded, but that kind variable will be added by
    generaliseTcTyCon, in the passage to a PolyTcTyCon.

  - tyConBinders are irrelevant; we just use tcTyConScopedTyVars
    Well not /quite/ irrelevant: its length gives the number of Required binders,
    and so allows up to distinguish between the Specified and Required elements of
    tyConScopedTyVars.

* PolyTcTyCon:
  - Flag tcTyConIsPoly = True; this is used only to short-cut zonking

  - tyConBinders are still TcTyConBinders, but they are /skolem/ TcTyVars,
    with fixed kinds, and accurate skolem info: no unification variables here

    tyConBinders includes the Inferred binders if any

    tyConBinders uses the Names from the original, renamed program.

  - tcTyConScopedTyVars is irrelevant: just use (binderVars tyConBinders)
    All the types have been swizzled back to use the original Names
    See Note [tyConBinders and lexical scoping] in GHC.Core.TyCon

-}

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

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

data InferResult
  = IR { InferResult -> Unique
ir_uniq :: Unique
          -- ^ This 'Unique' is for debugging only

       , InferResult -> TcLevel
ir_lvl  :: TcLevel
         -- ^ See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType

       , InferResult -> Maybe FixedRuntimeRepContext
ir_frr  :: Maybe FixedRuntimeRepContext
         -- ^ See Note [FixedRuntimeRep context in ExpType] in GHC.Tc.Utils.TcMType

       , InferResult -> IORef (Maybe Type)
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 :: RuntimeRep@.
         --
         -- Additionally, if the 'ir_frr' field is @Just frr_orig@ then
         -- @rr@ must be concrete, in the sense of Note [Concrete types]
         -- in GHC.Tc.Utils.Concrete.

type ExpSigmaType    = ExpType

-- | An 'ExpType' which has a fixed RuntimeRep.
--
-- For a 'Check' 'ExpType', the stored 'TcType' must have
-- a fixed RuntimeRep. For an 'Infer' 'ExpType', the 'ir_frr'
-- field must be of the form @Just frr_orig@.
type ExpTypeFRR      = ExpType

-- | Like 'TcSigmaTypeFRR', but for an expected type.
--
-- See 'ExpTypeFRR'.
type ExpSigmaTypeFRR = ExpTypeFRR
  -- TODO: consider making this a newtype.

type ExpRhoType      = ExpType

instance Outputable ExpType where
  ppr :: ExpType -> SDoc
ppr (Check Type
ty) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Check" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
  ppr (Infer 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_frr :: InferResult -> Maybe FixedRuntimeRepContext
ir_frr = Maybe FixedRuntimeRepContext
mb_frr })
    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Infer" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
mb_frr_text SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
lvl)
    where
      mb_frr_text :: SDoc
mb_frr_text = case Maybe FixedRuntimeRepContext
mb_frr of
        Just FixedRuntimeRepContext
_  -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FRR"
        Maybe FixedRuntimeRepContext
Nothing -> SDoc
forall doc. IsOutput doc => doc
empty

-- | Make an 'ExpType' suitable for checking.
mkCheckExpType :: TcType -> ExpType
mkCheckExpType :: Type -> ExpType
mkCheckExpType = Type -> 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.
--
-- You'll also get three multiplicities back: one for each function arrow. See
-- also Note [Linear types] in Multiplicity.
--
-- This is defined here to avoid defining it in "GHC.Tc.Gen.Expr" boot file.
data SyntaxOpType
  = SynAny     -- ^ Any type
  | SynRho     -- ^ A rho type, 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 :: Type -> SyntaxOpType
synKnownType = ExpType -> SyntaxOpType
SynType (ExpType -> SyntaxOpType)
-> (Type -> ExpType) -> Type -> SyntaxOpType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ExpType
mkCheckExpType

-- | Like 'mkFunTys' but for 'SyntaxOpType'
mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType
mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType
mkSynFunTys [SyntaxOpType]
arg_tys ExpType
res_ty = (SyntaxOpType -> SyntaxOpType -> SyntaxOpType)
-> SyntaxOpType -> [SyntaxOpType] -> SyntaxOpType
forall a b. (a -> b -> b) -> b -> [a] -> b
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
  NO     forall a. a ->  Int
  NO     Eq a => a -> a
  YES    a -> a
  YES    (forall a. a->a) -> Int
  YES    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 "GHC.Types.Var".  There is no reason in principle
why "GHC.Types.Var" shouldn't actually have the definition, but it "belongs" here.

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 separate Type from TcType, and in that case
we would need to enforce the separation.

Note [Keeping SkolemInfo inside a SkolemTv]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A SkolemTv contains a SkolemInfo, which describes the binding side of that
TcTyVar.  This is very convenient to a consumer of a SkolemTv, but it is
a bit awkward for the /producer/.  Why? Because sometimes we can't produce
the SkolemInfo until we have the TcTyVars!

Example: in `GHC.Tc.Utils.Unify.tcTopSkolemise` we create SkolemTvs whose
`SkolemInfo` is `SigSkol`, whose arguments in turn mention the newly-created
SkolemTvs.  So we a RecrusiveDo idiom, like this:

  rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty
      ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }

Note that the `skol_info` can't be created until we have the `tv_prs` returned
by `skolemise`. Note also that `skolemise` had better be lazy in `skol_info`.

All uses of this idiom should be flagged with a reference to this Note.
-}

-- A TyVarDetails is inside a TyVar
-- See Note [TyVars and TcTyVars during type checking]
data TcTyVarDetails
  = SkolemTv      -- A skolem
       SkolemInfo -- See Note [Keeping SkolemInfo inside a SkolemTv]
       TcLevel    -- Level of the implication that binds it
                  -- See GHC.Tc.Utils.Unify 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 GHC.Core.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 invariants]

vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails
vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails
vanillaSkolemTvUnk = SkolemInfo -> TcLevel -> Bool -> TcTyVarDetails
SkolemTv SkolemInfo
HasCallStack => SkolemInfo
unkSkol TcLevel
topTcLevel Bool
False

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

pprTcTyVarDetails :: TcTyVarDetails -> SDoc
-- For debugging
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
pprTcTyVarDetails (RuntimeUnk {})      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rt"
pprTcTyVarDetails (SkolemTv SkolemInfo
_sk TcLevel
lvl Bool
True)  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ssk" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
lvl
pprTcTyVarDetails (SkolemTv SkolemInfo
_sk TcLevel
lvl Bool
False) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sk"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl

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

-- | What restrictions are on this metavariable around unification?
-- These are checked in GHC.Tc.Utils.Unify.startSolvingByUnification.
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 [TyVarTv] in GHC.Tc.Utils.TcMType

   | RuntimeUnkTv  -- ^ A unification variable used in the GHCi debugger.
                   -- It /is/ allowed to unify with a polytype, unlike TauTv

   | CycleBreakerTv  -- Used to fix occurs-check problems in Givens
                     -- See Note [Type equality cycles] in
                     -- GHC.Tc.Solver.Canonical

   | ConcreteTv ConcreteTvOrigin
        -- ^ A unification variable that can only be unified
        -- with a concrete type, in the sense of
        -- Note [Concrete types] in GHC.Tc.Utils.Concrete.
        -- See Note [ConcreteTv] in GHC.Tc.Utils.Concrete.
        -- See also Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete
        -- for an overview of how this works in context.

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

instance Outputable MetaInfo where
  ppr :: MetaInfo -> SDoc
ppr MetaInfo
TauTv           = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tau"
  ppr MetaInfo
TyVarTv         = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tyv"
  ppr MetaInfo
RuntimeUnkTv    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rutv"
  ppr MetaInfo
CycleBreakerTv  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cbv"
  ppr (ConcreteTv {}) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"conc"

-- | What caused us to create a 'ConcreteTv' metavariable?
-- See Note [ConcreteTv] in GHC.Tc.Utils.Concrete.
data ConcreteTvOrigin
   -- | A 'ConcreteTv' used to enforce the representation-polymorphism invariants.
   --
   -- See 'FixedRuntimeRepOrigin' for more information.
  = ConcreteFRR FixedRuntimeRepOrigin

{- *********************************************************************
*                                                                      *
                Untouchable 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
$c== :: TcLevel -> TcLevel -> Bool
== :: TcLevel -> TcLevel -> Bool
$c/= :: TcLevel -> TcLevel -> Bool
/= :: 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
$ccompare :: TcLevel -> TcLevel -> Ordering
compare :: TcLevel -> TcLevel -> Ordering
$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
>= :: TcLevel -> TcLevel -> Bool
$cmax :: TcLevel -> TcLevel -> TcLevel
max :: TcLevel -> TcLevel -> TcLevel
$cmin :: TcLevel -> TcLevel -> TcLevel
min :: TcLevel -> TcLevel -> TcLevel
Ord )
  -- See Note [TcLevel invariants] for what this Int is
  -- See also Note [TcLevel assignment]

{-
Note [TcLevel invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~
* Each unification variable (MetaTv)
  and skolem (SkolemTv)
  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
                See Note [GivenInv]

    (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]

The level of a MetaTyVar also governs its untouchability.  See
Note [Unification preconditions] in GHC.Tc.Utils.Unify.

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

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

Note [GivenInv]
~~~~~~~~~~~~~~~
Invariant (GivenInv) is not essential, but it is easy to guarantee, and
it is a useful extra piece of structure.  It ensures that the Givens of
an implication don't change because of unifications /at the same level/
caused by Wanteds.  (Wanteds can also cause unifications at an outer
level, but that will iterate the entire implication; see GHC.Tc.Solver.Monad
Note [The Unification Level Flag].)

Givens can certainly contain meta-tyvars from /outer/ levels.  E.g.
   data T a where
     MkT :: Eq a => a -> MkT a

   f x = case x of MkT y -> y && True

Then we'll infer (x :: T alpha[1]).  The Givens from the implication
arising from the pattern match will look like this:

   forall[2] . Eq alpha[1] => (alpha[1] ~ Bool)

But if we unify alpha (which in this case we will), we'll iterate
the entire implication via Note [The Unification Level Flag] in
GHC.Tc.Solver.Monad.  That isn't true of unifications at the /ambient/
level.

It would be entirely possible to weaken (GivenInv), to LESS THAN OR
EQUAL TO, but we'd need to think carefully about
  - kick-out for Givens
  - GHC.Tc.Solver.Monad.isOuterTyVar
But in fact (GivenInv) is automatically true, so we're adhering to
it for now.  See #18929.

* If a tyvar tv has level n, then the levels of all variables free
  in tv's kind are <= n. Consequence: if tv is untouchable, so are
  all variables in tv's kind.

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 escaped its scope into the outer implication.
-}

maxTcLevel :: TcLevel -> TcLevel -> TcLevel
maxTcLevel :: TcLevel -> TcLevel -> TcLevel
maxTcLevel (TcLevel Int
a) (TcLevel 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 Int
0   -- 0 = outermost level

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

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

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

deeperThanOrSame :: TcLevel -> TcLevel -> Bool
deeperThanOrSame :: TcLevel -> TcLevel -> Bool
deeperThanOrSame (TcLevel Int
tv_tclvl) (TcLevel 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 Int
ctxt_tclvl) (TcLevel 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 invariants]
checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool
checkTcLevelInvariant (TcLevel Int
ctxt_tclvl) (TcLevel 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 :: TyVar -> TcLevel
tcTyVarLevel TyVar
tv
  = case TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv of
          MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tv_lvl } -> TcLevel
tv_lvl
          SkolemTv SkolemInfo
_ TcLevel
tv_lvl Bool
_           -> TcLevel
tv_lvl
          TcTyVarDetails
RuntimeUnk                    -> TcLevel
topTcLevel


tcTypeLevel :: TcType -> TcLevel
-- Max level of any free var of the type
tcTypeLevel :: Type -> TcLevel
tcTypeLevel Type
ty
  = (TyVar -> TcLevel -> TcLevel) -> TcLevel -> DVarSet -> TcLevel
forall a. (TyVar -> a -> a) -> a -> DVarSet -> a
nonDetStrictFoldDVarSet TyVar -> TcLevel -> TcLevel
add TcLevel
topTcLevel (Type -> DVarSet
tyCoVarsOfTypeDSet Type
ty)
    -- It's safe to use a non-deterministic fold because `maxTcLevel` is
    -- commutative.
  where
    add :: TyVar -> TcLevel -> TcLevel
add TyVar
v TcLevel
lvl
      | TyVar -> Bool
isTcTyVar TyVar
v = TcLevel
lvl TcLevel -> TcLevel -> TcLevel
`maxTcLevel` TyVar -> TcLevel
tcTyVarLevel TyVar
v
      | Bool
otherwise = TcLevel
lvl

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

{- *********************************************************************
*                                                                      *
    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 #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 :: Type -> [(TyCon, [Type])]
tcTyFamInsts = ((Bool, TyCon, [Type]) -> (TyCon, [Type]))
-> [(Bool, TyCon, [Type])] -> [(TyCon, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
_,TyCon
b,[Type]
c) -> (TyCon
b,[Type]
c)) ([(Bool, TyCon, [Type])] -> [(TyCon, [Type])])
-> (Type -> [(Bool, TyCon, [Type])]) -> Type -> [(TyCon, [Type])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [(Bool, TyCon, [Type])]
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 "GHC.Tc.Errors".
tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVis = Bool -> Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVisX Bool
False

tcTyFamInstsAndVisX
  :: Bool -- ^ Is this an invisible argument to some type application?
  -> Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVisX :: Bool -> Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVisX = Bool -> Type -> [(Bool, TyCon, [Type])]
go
  where
    go :: Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty
      | Just Type
exp_ty <- Type -> Maybe Type
coreView Type
ty     = Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
exp_ty
    go Bool
_ (TyVarTy TyVar
_)                   = []
    go Bool
is_invis_arg (TyConApp TyCon
tc [Type]
tys)
      | TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
      = [(Bool
is_invis_arg, TyCon
tc, Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take (TyCon -> Int
tyConArity TyCon
tc) [Type]
tys)]
      | Bool
otherwise
      = Bool -> TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVisX Bool
is_invis_arg TyCon
tc [Type]
tys
    go Bool
_            (LitTy {})         = []
    go Bool
is_invis_arg (ForAllTy ForAllTyBinder
bndr Type
ty) = Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg (ForAllTyBinder -> Type
forall argf. VarBndr TyVar argf -> Type
binderType ForAllTyBinder
bndr)
                                         [(Bool, TyCon, [Type])]
-> [(Bool, TyCon, [Type])] -> [(Bool, TyCon, [Type])]
forall a. [a] -> [a] -> [a]
++ Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty
    go Bool
is_invis_arg (FunTy FunTyFlag
_ Type
w Type
ty1 Type
ty2)  = Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
w
                                         [(Bool, TyCon, [Type])]
-> [(Bool, TyCon, [Type])] -> [(Bool, TyCon, [Type])]
forall a. [a] -> [a] -> [a]
++ Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty1
                                         [(Bool, TyCon, [Type])]
-> [(Bool, TyCon, [Type])] -> [(Bool, TyCon, [Type])]
forall a. [a] -> [a] -> [a]
++ Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty2
    go Bool
is_invis_arg ty :: Type
ty@(AppTy Type
_ Type
_)     =
      let (Type
ty_head, [Type]
ty_args) = Type -> (Type, [Type])
splitAppTys Type
ty
          ty_arg_flags :: [ForAllTyFlag]
ty_arg_flags       = Type -> [Type] -> [ForAllTyFlag]
appTyForAllTyFlags Type
ty_head [Type]
ty_args
      in Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty_head
         [(Bool, TyCon, [Type])]
-> [(Bool, TyCon, [Type])] -> [(Bool, TyCon, [Type])]
forall a. [a] -> [a] -> [a]
++ [[(Bool, TyCon, [Type])]] -> [(Bool, TyCon, [Type])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ForAllTyFlag -> Type -> [(Bool, TyCon, [Type])])
-> [ForAllTyFlag] -> [Type] -> [[(Bool, TyCon, [Type])]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ForAllTyFlag
flag -> Bool -> Type -> [(Bool, TyCon, [Type])]
go (ForAllTyFlag -> Bool
isInvisibleForAllTyFlag ForAllTyFlag
flag))
                            [ForAllTyFlag]
ty_arg_flags [Type]
ty_args)
    go Bool
is_invis_arg (CastTy Type
ty KindCoercion
_)      = Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty
    go Bool
_            (CoercionTy KindCoercion
_)     = [] -- 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 -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVis = Bool -> TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVisX Bool
False

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

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

any_rewritable :: EqRel   -- Ambient role
               -> (EqRel -> TcTyVar -> Bool)           -- check tyvar
               -> (EqRel -> TyCon -> [TcType] -> Bool) -- check type family
               -> (TyCon -> Bool)                      -- expand type synonym?
               -> TcType -> Bool
-- Checks every tyvar and tyconapp (not including FunTys) within a type,
-- ORing the results of the predicates above together
-- Do not look inside casts and coercions
-- See Note [anyRewritableTyVar must be role-aware]
--
-- This looks like it should use foldTyCo, but that function is
-- role-agnostic, and this one must be role-aware. We could make
-- foldTyCon role-aware, but that may slow down more common usages.
--
-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function.
{-# INLINE any_rewritable #-} -- this allows specialization of predicates
any_rewritable :: EqRel
-> (EqRel -> TyVar -> Bool)
-> (EqRel -> TyCon -> [Type] -> Bool)
-> (TyCon -> Bool)
-> Type
-> Bool
any_rewritable EqRel
role EqRel -> TyVar -> Bool
tv_pred EqRel -> TyCon -> [Type] -> Bool
tc_pred TyCon -> Bool
should_expand
  = EqRel -> VarSet -> Type -> Bool
go EqRel
role VarSet
emptyVarSet
  where
    go_tv :: EqRel -> VarSet -> TyVar -> Bool
go_tv EqRel
rl VarSet
bvs TyVar
tv | TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` VarSet
bvs = Bool
False
                    | Bool
otherwise           = EqRel -> TyVar -> Bool
tv_pred EqRel
rl TyVar
tv

    go :: EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs ty :: Type
ty@(TyConApp TyCon
tc [Type]
tys)
      | TyCon -> Bool
isTypeSynonymTyCon TyCon
tc
      , TyCon -> Bool
should_expand TyCon
tc
      , Just Type
ty' <- Type -> Maybe Type
coreView Type
ty   -- should always match
      = EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs Type
ty'

      | EqRel -> TyCon -> [Type] -> Bool
tc_pred EqRel
rl TyCon
tc [Type]
tys
      = Bool
True

      | Bool
otherwise
      = EqRel -> VarSet -> TyCon -> [Type] -> Bool
go_tc EqRel
rl VarSet
bvs TyCon
tc [Type]
tys

    go EqRel
rl VarSet
bvs (TyVarTy TyVar
tv)       = EqRel -> VarSet -> TyVar -> Bool
go_tv EqRel
rl VarSet
bvs TyVar
tv
    go EqRel
_ VarSet
_     (LitTy {})        = Bool
False
    go EqRel
rl VarSet
bvs (AppTy Type
fun Type
arg)    = EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs Type
fun Bool -> Bool -> Bool
|| EqRel -> VarSet -> Type -> Bool
go EqRel
NomEq VarSet
bvs Type
arg
    go EqRel
rl VarSet
bvs (FunTy FunTyFlag
_ Type
w Type
arg Type
res)  = EqRel -> VarSet -> Type -> Bool
go EqRel
NomEq VarSet
bvs Type
arg_rep Bool -> Bool -> Bool
|| EqRel -> VarSet -> Type -> Bool
go EqRel
NomEq VarSet
bvs Type
res_rep Bool -> Bool -> Bool
||
                                     EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs Type
arg Bool -> Bool -> Bool
|| EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs Type
res Bool -> Bool -> Bool
|| EqRel -> VarSet -> Type -> Bool
go EqRel
NomEq VarSet
bvs Type
w
      where arg_rep :: Type
arg_rep = (() :: Constraint) => Type -> Type
Type -> Type
getRuntimeRep Type
arg -- forgetting these causes #17024
            res_rep :: Type
res_rep = (() :: Constraint) => Type -> Type
Type -> Type
getRuntimeRep Type
res
    go EqRel
rl VarSet
bvs (ForAllTy ForAllTyBinder
tv Type
ty)   = EqRel -> VarSet -> Type -> Bool
go EqRel
rl (VarSet
bvs VarSet -> TyVar -> VarSet
`extendVarSet` ForAllTyBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar ForAllTyBinder
tv) Type
ty
    go EqRel
rl VarSet
bvs (CastTy Type
ty KindCoercion
_)      = EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs Type
ty
    go EqRel
_  VarSet
_   (CoercionTy KindCoercion
_)     = Bool
False

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

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

anyRewritableTyVar :: EqRel    -- Ambient role
                   -> (EqRel -> TcTyVar -> Bool)  -- check tyvar
                   -> TcType -> Bool
-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function.
anyRewritableTyVar :: EqRel -> (EqRel -> TyVar -> Bool) -> Type -> Bool
anyRewritableTyVar EqRel
role EqRel -> TyVar -> Bool
pred
  = EqRel
-> (EqRel -> TyVar -> Bool)
-> (EqRel -> TyCon -> [Type] -> Bool)
-> (TyCon -> Bool)
-> Type
-> Bool
any_rewritable EqRel
role EqRel -> TyVar -> Bool
pred
      (\ EqRel
_ TyCon
_ [Type]
_ -> Bool
False) -- no special check for tyconapps
                         -- (this False is ORed with other results, so it
                         --  really means "do nothing special"; the arguments
                         --   are still inspected)
      (\ TyCon
_ -> Bool
False)     -- don't expand synonyms
    -- NB: No need to expand synonyms, because we can find
    -- all free variables of a synonym by looking at its
    -- arguments

anyRewritableTyFamApp :: EqRel   -- Ambient role
                      -> (EqRel -> TyCon -> [TcType] -> Bool) -- check tyconapp
                          -- should return True only for type family applications
                      -> TcType -> Bool
  -- always ignores casts & coercions
-- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function.
anyRewritableTyFamApp :: EqRel -> (EqRel -> TyCon -> [Type] -> Bool) -> Type -> Bool
anyRewritableTyFamApp EqRel
role EqRel -> TyCon -> [Type] -> Bool
check_tyconapp
  = EqRel
-> (EqRel -> TyVar -> Bool)
-> (EqRel -> TyCon -> [Type] -> Bool)
-> (TyCon -> Bool)
-> Type
-> Bool
any_rewritable EqRel
role (\ EqRel
_ TyVar
_ -> Bool
False) EqRel -> TyCon -> [Type] -> Bool
check_tyconapp (Bool -> Bool
not (Bool -> Bool) -> (TyCon -> Bool) -> TyCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Bool
isFamFreeTyCon)

{- 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 (#14363).

-}

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

We place this function here in GHC.Tc.Utils.TcType, not in GHC.Core.TyCo.FVs,
because we want to "see" coreView (efficiency issue only).
-}

exactTyCoVarsOfType  :: Type   -> TyCoVarSet
exactTyCoVarsOfTypes :: [Type] -> TyCoVarSet
-- Find the free type variables (of any kind)
-- but *expand* type synonyms.  See Note [Silly type synonym] above.

exactTyCoVarsOfType :: Type -> VarSet
exactTyCoVarsOfType  Type
ty  = Endo VarSet -> VarSet
runTyCoVars (Type -> Endo VarSet
exact_ty Type
ty)
exactTyCoVarsOfTypes :: [Type] -> VarSet
exactTyCoVarsOfTypes [Type]
tys = Endo VarSet -> VarSet
runTyCoVars ([Type] -> Endo VarSet
exact_tys [Type]
tys)

exact_ty  :: Type       -> Endo TyCoVarSet
exact_tys :: [Type]     -> Endo TyCoVarSet
(Type -> Endo VarSet
exact_ty, [Type] -> Endo VarSet
exact_tys, KindCoercion -> Endo VarSet
_, [KindCoercion] -> Endo VarSet
_) = TyCoFolder VarSet (Endo VarSet)
-> VarSet
-> (Type -> Endo VarSet, [Type] -> Endo VarSet,
    KindCoercion -> Endo VarSet, [KindCoercion] -> Endo VarSet)
forall a env.
Monoid a =>
TyCoFolder env a
-> env
-> (Type -> a, [Type] -> a, KindCoercion -> a, [KindCoercion] -> a)
foldTyCo TyCoFolder VarSet (Endo VarSet)
exactTcvFolder VarSet
emptyVarSet

exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)
exactTcvFolder :: TyCoFolder VarSet (Endo VarSet)
exactTcvFolder = TyCoFolder VarSet (Endo VarSet)
deepTcvFolder { tcf_view = coreView }
                 -- This is the key line

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

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

isPromotableMetaTyVar :: TcTyVar -> Bool
-- True is this is a meta-tyvar that can be
-- promoted to an outer level
isPromotableMetaTyVar :: TyVar -> Bool
isPromotableMetaTyVar TyVar
tv
  | TyVar -> Bool
isTyVar TyVar
tv -- See Note [Coercion variables in free variable lists]
  , MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } <- TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv
  = MetaInfo -> Bool
isTouchableInfo MetaInfo
info   -- Can't promote cycle breakers
  | Bool
otherwise
  = Bool
False

isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isTouchableMetaTyVar :: TcLevel -> TyVar -> Bool
isTouchableMetaTyVar TcLevel
ctxt_tclvl TyVar
tv
  | TyVar -> Bool
isTyVar TyVar
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 } <- TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv
  , MetaInfo -> Bool
isTouchableInfo MetaInfo
info
  = Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TcLevel -> TcLevel -> Bool
checkTcLevelInvariant TcLevel
ctxt_tclvl TcLevel
tv_tclvl)
              (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
tv SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tv_tclvl SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
ctxt_tclvl) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    TcLevel
tv_tclvl TcLevel -> TcLevel -> Bool
`sameDepthAs` TcLevel
ctxt_tclvl

  | Bool
otherwise = Bool
False

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

isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
  isMetaTyVar, isAmbiguousTyVar, isCycleBreakerTyVar :: TcTyVar -> Bool

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

isSkolemTyVar :: TyVar -> Bool
isSkolemTyVar TyVar
tv
  = Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyVar -> Bool
tcIsTcTyVar TyVar
tv) (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
tv) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    case TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv of
        MetaTv {} -> Bool
False
        TcTyVarDetails
_other    -> Bool
True

skolemSkolInfo :: TcTyVar -> SkolemInfo
skolemSkolInfo :: TyVar -> SkolemInfo
skolemSkolInfo TyVar
tv
  = Bool -> SkolemInfo -> SkolemInfo
forall a. HasCallStack => Bool -> a -> a
assert (TyVar -> Bool
isSkolemTyVar TyVar
tv) (SkolemInfo -> SkolemInfo) -> SkolemInfo -> SkolemInfo
forall a b. (a -> b) -> a -> b
$
    case TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv of
      SkolemTv SkolemInfo
skol_info TcLevel
_ Bool
_ -> SkolemInfo
skol_info
      TcTyVarDetails
RuntimeUnk -> String -> SkolemInfo
forall a. HasCallStack => String -> a
panic String
"RuntimeUnk"
      MetaTv {} -> String -> SkolemInfo
forall a. HasCallStack => String -> a
panic String
"skolemSkolInfo"


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

isMetaTyVar :: TyVar -> Bool
isMetaTyVar TyVar
tv
  | TyVar -> Bool
isTyVar TyVar
tv -- See Note [Coercion variables in free variable lists]
  = case TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv of
        MetaTv {} -> Bool
True
        TcTyVarDetails
_         -> 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 RuntimeUnk variables created by
-- GHC.Runtime.Heap.Inspect.zonkRTTIType.  These are "ambiguous" in
-- the sense that they stand for an as-yet-unknown type
isAmbiguousTyVar :: TyVar -> Bool
isAmbiguousTyVar TyVar
tv
  | TyVar -> Bool
isTyVar TyVar
tv -- See Note [Coercion variables in free variable lists]
  = case TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv of
        MetaTv {}     -> Bool
True
        RuntimeUnk {} -> Bool
True
        TcTyVarDetails
_             -> Bool
False
  | Bool
otherwise = Bool
False

isCycleBreakerTyVar :: TyVar -> Bool
isCycleBreakerTyVar TyVar
tv
  | TyVar -> Bool
isTyVar TyVar
tv -- See Note [Coercion variables in free variable lists]
  , MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
CycleBreakerTv } <- TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv
  = Bool
True

  | Bool
otherwise
  = Bool
False

-- | Is this type variable a concrete type variable, i.e.
-- it is a metavariable with 'ConcreteTv' 'MetaInfo'?
--
-- Returns the 'ConcreteTvOrigin' stored in the type variable
-- if so, or 'Nothing' otherwise.
isConcreteTyVar_maybe :: TcTyVar -> Maybe ConcreteTvOrigin
isConcreteTyVar_maybe :: TyVar -> Maybe ConcreteTvOrigin
isConcreteTyVar_maybe TyVar
tv
  | TyVar -> Bool
isTcTyVar TyVar
tv
  , MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = ConcreteTv ConcreteTvOrigin
conc_orig } <- TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv
  = ConcreteTvOrigin -> Maybe ConcreteTvOrigin
forall a. a -> Maybe a
Just ConcreteTvOrigin
conc_orig
  | Bool
otherwise
  = Maybe ConcreteTvOrigin
forall a. Maybe a
Nothing

-- | Is this type variable a concrete type variable, i.e.
-- it is a metavariable with 'ConcreteTv' 'MetaInfo'?
isConcreteTyVar :: TcTyVar -> Bool
isConcreteTyVar :: TyVar -> Bool
isConcreteTyVar = Maybe ConcreteTvOrigin -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ConcreteTvOrigin -> Bool)
-> (TyVar -> Maybe ConcreteTvOrigin) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Maybe ConcreteTvOrigin
isConcreteTyVar_maybe

-- | Is this type concrete type variable, i.e.
-- a metavariable with 'ConcreteTv' 'MetaInfo'?
isConcreteTyVarTy :: TcType -> Bool
isConcreteTyVarTy :: Type -> Bool
isConcreteTyVarTy = Maybe (TyVar, ConcreteTvOrigin) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (TyVar, ConcreteTvOrigin) -> Bool)
-> (Type -> Maybe (TyVar, ConcreteTvOrigin)) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (TyVar, ConcreteTvOrigin)
isConcreteTyVarTy_maybe

-- | Is this type a concrete type variable? If so, return
-- the associated 'TcTyVar' and 'ConcreteTvOrigin'.
isConcreteTyVarTy_maybe :: TcType -> Maybe (TcTyVar, ConcreteTvOrigin)
isConcreteTyVarTy_maybe :: Type -> Maybe (TyVar, ConcreteTvOrigin)
isConcreteTyVarTy_maybe (TyVarTy TyVar
tv) = (TyVar
tv, ) (ConcreteTvOrigin -> (TyVar, ConcreteTvOrigin))
-> Maybe ConcreteTvOrigin -> Maybe (TyVar, ConcreteTvOrigin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> Maybe ConcreteTvOrigin
isConcreteTyVar_maybe TyVar
tv
isConcreteTyVarTy_maybe Type
_            = Maybe (TyVar, ConcreteTvOrigin)
forall a. Maybe a
Nothing

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

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

isTouchableInfo :: MetaInfo -> Bool
isTouchableInfo :: MetaInfo -> Bool
isTouchableInfo MetaInfo
info
  | MetaInfo
CycleBreakerTv <- MetaInfo
info = Bool
False
  | Bool
otherwise              = Bool
True

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

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

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

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

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

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

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

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

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

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

-- | Returns the (kind, type) variables in a type that are
-- as-yet-unknown: metavariables and RuntimeUnks
ambigTkvsOfTy :: TcType -> ([Var],[Var])
ambigTkvsOfTy :: Type -> ([TyVar], [TyVar])
ambigTkvsOfTy Type
ty
  = (TyVar -> Bool) -> [TyVar] -> ([TyVar], [TyVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TyVar -> VarSet -> Bool
`elemVarSet` VarSet
dep_tkv_set) [TyVar]
ambig_tkvs
  where
    tkvs :: [TyVar]
tkvs        = Type -> [TyVar]
tyCoVarsOfTypeList Type
ty
    ambig_tkvs :: [TyVar]
ambig_tkvs  = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter TyVar -> Bool
isAmbiguousTyVar [TyVar]
tkvs
    dep_tkv_set :: VarSet
dep_tkv_set = [Type] -> VarSet
tyCoVarsOfTypes ((TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
tyVarKind [TyVar]
tkvs)

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

-- | Make a sigma ty where all type variables are 'Inferred'. That is,
-- they cannot be used with visible type application.
mkInfSigmaTy :: HasDebugCallStack => [TyCoVar] -> [PredType] -> Type -> Type
mkInfSigmaTy :: (() :: Constraint) => [TyVar] -> [Type] -> Type -> Type
mkInfSigmaTy [TyVar]
tyvars [Type]
theta Type
ty = [ForAllTyBinder] -> [Type] -> Type -> Type
(() :: Constraint) => [ForAllTyBinder] -> [Type] -> Type -> Type
mkSigmaTy (ForAllTyFlag -> [TyVar] -> [ForAllTyBinder]
forall vis. vis -> [TyVar] -> [VarBndr TyVar vis]
mkForAllTyBinders ForAllTyFlag
Inferred [TyVar]
tyvars) [Type]
theta Type
ty

-- | Make a sigma ty where all type variables are "specified". That is,
-- they can be used with visible type application
mkSpecSigmaTy :: HasDebugCallStack => [TyVar] -> [PredType] -> Type -> Type
mkSpecSigmaTy :: (() :: Constraint) => [TyVar] -> [Type] -> Type -> Type
mkSpecSigmaTy [TyVar]
tyvars [Type]
preds Type
ty = [ForAllTyBinder] -> [Type] -> Type -> Type
(() :: Constraint) => [ForAllTyBinder] -> [Type] -> Type -> Type
mkSigmaTy (ForAllTyFlag -> [TyVar] -> [ForAllTyBinder]
forall vis. vis -> [TyVar] -> [VarBndr TyVar vis]
mkForAllTyBinders ForAllTyFlag
Specified [TyVar]
tyvars) [Type]
preds Type
ty

mkSigmaTy :: HasDebugCallStack => [ForAllTyBinder] -> [PredType] -> Type -> Type
-- Result is TypeLike
mkSigmaTy :: (() :: Constraint) => [ForAllTyBinder] -> [Type] -> Type -> Type
mkSigmaTy [ForAllTyBinder]
bndrs [Type]
theta Type
tau = [ForAllTyBinder] -> Type -> Type
mkForAllTys [ForAllTyBinder]
bndrs ([Type] -> Type -> Type
(() :: Constraint) => [Type] -> Type -> Type
mkPhiTy [Type]
theta Type
tau)

tcMkDFunSigmaTy :: [TyVar] -> ThetaType -> Type -> Type
tcMkDFunSigmaTy :: [TyVar] -> [Type] -> Type -> Type
tcMkDFunSigmaTy [TyVar]
tvs [Type]
theta Type
res_ty
 = [ForAllTyBinder] -> Type -> Type
mkForAllTys (ForAllTyFlag -> [TyVar] -> [ForAllTyBinder]
forall vis. vis -> [TyVar] -> [VarBndr TyVar vis]
mkForAllTyBinders ForAllTyFlag
Specified [TyVar]
tvs) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
   [Type] -> Type -> Type
(() :: Constraint) => [Type] -> Type -> Type
tcMkDFunPhiTy [Type]
theta Type
res_ty

mkPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type
-- Result type is TypeLike
mkPhiTy :: (() :: Constraint) => [Type] -> Type -> Type
mkPhiTy = [Type] -> Type -> Type
(() :: Constraint) => [Type] -> Type -> Type
mkInvisFunTys

tcMkPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type
-- Like mkPhiTy, but with no assertion checks; it is called
-- by the type checker and the result kind may not be zonked yet
-- But the result kind is TypeLike
tcMkPhiTy :: (() :: Constraint) => [Type] -> Type -> Type
tcMkPhiTy [Type]
tys Type
ty = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeOrConstraint -> Type -> Type -> Type
tcMkInvisFunTy TypeOrConstraint
TypeLike) Type
ty [Type]
tys

tcMkDFunPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type
-- Just like tcMkPhiTy, but result type is ConstraintLike
tcMkDFunPhiTy :: (() :: Constraint) => [Type] -> Type -> Type
tcMkDFunPhiTy [Type]
preds Type
res = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeOrConstraint -> Type -> Type -> Type
tcMkInvisFunTy TypeOrConstraint
ConstraintLike) Type
res [Type]
preds

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

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

{-
************************************************************************
*                                                                      *
   Expanding and splitting
*                                                                      *
************************************************************************
-}

-- | Splits a forall type into a list of 'PiTyVarBinder's and the inner type.
-- Always succeeds, even if it returns an empty list.
tcSplitPiTys :: Type -> ([PiTyVarBinder], Type)
tcSplitPiTys :: Type -> ([PiTyVarBinder], Type)
tcSplitPiTys Type
ty
  = Bool -> ([PiTyVarBinder], Type) -> ([PiTyVarBinder], Type)
forall a. HasCallStack => Bool -> a -> a
assert ((PiTyVarBinder -> Bool) -> [PiTyVarBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PiTyVarBinder -> Bool
isTyBinder (([PiTyVarBinder], Type) -> [PiTyVarBinder]
forall a b. (a, b) -> a
fst ([PiTyVarBinder], Type)
sty) )   -- No CoVar binders here
    ([PiTyVarBinder], Type)
sty
  where sty :: ([PiTyVarBinder], Type)
sty = Type -> ([PiTyVarBinder], Type)
splitPiTys Type
ty

-- | Splits a type into a PiTyVarBinder and a body, if possible.
tcSplitPiTy_maybe :: Type -> Maybe (PiTyVarBinder, Type)
tcSplitPiTy_maybe :: Type -> Maybe (PiTyVarBinder, Type)
tcSplitPiTy_maybe Type
ty
  = Bool -> Maybe (PiTyVarBinder, Type) -> Maybe (PiTyVarBinder, Type)
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (PiTyVarBinder, Type) -> Bool
forall {b}. Maybe (PiTyVarBinder, b) -> Bool
isMaybeTyBinder Maybe (PiTyVarBinder, Type)
sty)  -- No CoVar binders here
    Maybe (PiTyVarBinder, Type)
sty
  where
    sty :: Maybe (PiTyVarBinder, Type)
sty = Type -> Maybe (PiTyVarBinder, Type)
splitPiTy_maybe Type
ty
    isMaybeTyBinder :: Maybe (PiTyVarBinder, b) -> Bool
isMaybeTyBinder (Just (PiTyVarBinder
t,b
_)) = PiTyVarBinder -> Bool
isTyBinder PiTyVarBinder
t
    isMaybeTyBinder Maybe (PiTyVarBinder, b)
_            = Bool
True

tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type)
tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (ForAllTyBinder, Type)
tcSplitForAllTyVarBinder_maybe Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (ForAllTyBinder, Type)
tcSplitForAllTyVarBinder_maybe Type
ty'
tcSplitForAllTyVarBinder_maybe (ForAllTy ForAllTyBinder
tv Type
ty) = Bool
-> ((ForAllTyBinder, Type) -> Maybe (ForAllTyBinder, Type))
-> (ForAllTyBinder, Type)
-> Maybe (ForAllTyBinder, Type)
forall a. HasCallStack => Bool -> a -> a
assert (ForAllTyBinder -> Bool
forall vis. VarBndr TyVar vis -> Bool
isTyVarBinder ForAllTyBinder
tv ) (ForAllTyBinder, Type) -> Maybe (ForAllTyBinder, Type)
forall a. a -> Maybe a
Just (ForAllTyBinder
tv, Type
ty)
tcSplitForAllTyVarBinder_maybe Type
_                = Maybe (ForAllTyBinder, Type)
forall a. Maybe a
Nothing

-- | Like 'tcSplitPiTys', but splits off only named binders,
-- returning just the tyvars.
tcSplitForAllTyVars :: Type -> ([TyVar], Type)
tcSplitForAllTyVars :: Type -> ([TyVar], Type)
tcSplitForAllTyVars Type
ty
  = Bool -> ([TyVar], Type) -> ([TyVar], Type)
forall a. HasCallStack => Bool -> a -> a
assert ((TyVar -> Bool) -> [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVar -> Bool
isTyVar (([TyVar], Type) -> [TyVar]
forall a b. (a, b) -> a
fst ([TyVar], Type)
sty) ) ([TyVar], Type)
sty
  where sty :: ([TyVar], Type)
sty = Type -> ([TyVar], Type)
splitForAllTyCoVars Type
ty

-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible'
-- type variable binders.
tcSplitForAllInvisTyVars :: Type -> ([TyVar], Type)
tcSplitForAllInvisTyVars :: Type -> ([TyVar], Type)
tcSplitForAllInvisTyVars Type
ty = (ForAllTyFlag -> Bool) -> Type -> ([TyVar], Type)
tcSplitSomeForAllTyVars ForAllTyFlag -> Bool
isInvisibleForAllTyFlag Type
ty

-- | Like 'tcSplitForAllTyVars', but only splits a 'ForAllTy' if @argf_pred argf@
-- is 'True', where @argf@ is the visibility of the @ForAllTy@'s binder and
-- @argf_pred@ is a predicate over visibilities provided as an argument to this
-- function.
tcSplitSomeForAllTyVars :: (ForAllTyFlag -> Bool) -> Type -> ([TyVar], Type)
tcSplitSomeForAllTyVars :: (ForAllTyFlag -> Bool) -> Type -> ([TyVar], Type)
tcSplitSomeForAllTyVars ForAllTyFlag -> Bool
argf_pred Type
ty
  = Type -> Type -> [TyVar] -> ([TyVar], Type)
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [TyVar] -> ([TyVar], Type)
split Type
_ (ForAllTy (Bndr TyVar
tv ForAllTyFlag
argf) Type
ty) [TyVar]
tvs
      | ForAllTyFlag -> Bool
argf_pred ForAllTyFlag
argf                             = Type -> Type -> [TyVar] -> ([TyVar], Type)
split Type
ty Type
ty (TyVar
tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
tvs)
    split Type
orig_ty Type
ty [TyVar]
tvs | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type -> [TyVar] -> ([TyVar], Type)
split Type
orig_ty Type
ty' [TyVar]
tvs
    split Type
orig_ty Type
_                            [TyVar]
tvs = ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
tvs, Type
orig_ty)

-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type
-- variable binders. All split tyvars are annotated with '()'.
tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)
tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)
tcSplitForAllReqTVBinders Type
ty = Bool -> ([TcReqTVBinder], Type) -> ([TcReqTVBinder], Type)
forall a. HasCallStack => Bool -> a -> a
assert ((TcReqTVBinder -> Bool) -> [TcReqTVBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcReqTVBinder -> Bool
forall vis. VarBndr TyVar vis -> Bool
isTyVarBinder (([TcReqTVBinder], Type) -> [TcReqTVBinder]
forall a b. (a, b) -> a
fst ([TcReqTVBinder], Type)
sty) ) ([TcReqTVBinder], Type)
sty
  where sty :: ([TcReqTVBinder], Type)
sty = Type -> ([TcReqTVBinder], Type)
splitForAllReqTyBinders Type
ty

-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' type
-- variable binders. All split tyvars are annotated with their 'Specificity'.
tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type)
tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type)
tcSplitForAllInvisTVBinders Type
ty = Bool -> ([TcInvisTVBinder], Type) -> ([TcInvisTVBinder], Type)
forall a. HasCallStack => Bool -> a -> a
assert ((TcInvisTVBinder -> Bool) -> [TcInvisTVBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TyVar -> Bool
isTyVar (TyVar -> Bool)
-> (TcInvisTVBinder -> TyVar) -> TcInvisTVBinder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcInvisTVBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar) (([TcInvisTVBinder], Type) -> [TcInvisTVBinder]
forall a b. (a, b) -> a
fst ([TcInvisTVBinder], Type)
sty)) ([TcInvisTVBinder], Type)
sty
  where sty :: ([TcInvisTVBinder], Type)
sty = Type -> ([TcInvisTVBinder], Type)
splitForAllInvisTyBinders Type
ty

-- | Like 'tcSplitForAllTyVars', but splits off only named binders.
tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type)
tcSplitForAllTyVarBinders :: Type -> ([ForAllTyBinder], Type)
tcSplitForAllTyVarBinders Type
ty = Bool -> ([ForAllTyBinder], Type) -> ([ForAllTyBinder], Type)
forall a. HasCallStack => Bool -> a -> a
assert ((ForAllTyBinder -> Bool) -> [ForAllTyBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ForAllTyBinder -> Bool
forall vis. VarBndr TyVar vis -> Bool
isTyVarBinder (([ForAllTyBinder], Type) -> [ForAllTyBinder]
forall a b. (a, b) -> a
fst ([ForAllTyBinder], Type)
sty)) ([ForAllTyBinder], Type)
sty
  where sty :: ([ForAllTyBinder], Type)
sty = Type -> ([ForAllTyBinder], Type)
splitForAllForAllTyBinders Type
ty

tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
-- Split off the first predicate argument from a type
tcSplitPredFunTy_maybe :: Type -> Maybe (Type, Type)
tcSplitPredFunTy_maybe Type
ty
  | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (Type, Type)
tcSplitPredFunTy_maybe Type
ty'
tcSplitPredFunTy_maybe (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af, ft_arg :: Type -> Type
ft_arg = Type
arg, ft_res :: Type -> Type
ft_res = Type
res })
  | FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af
  = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
arg, Type
res)
tcSplitPredFunTy_maybe Type
_
  = Maybe (Type, Type)
forall a. Maybe a
Nothing

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

-- | Split a sigma type into its parts. This only splits /invisible/ type
-- variable binders, as these are the only forms of binder that the typechecker
-- will implicitly instantiate.
tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy :: Type -> ([TyVar], [Type], Type)
tcSplitSigmaTy Type
ty = case Type -> ([TyVar], Type)
tcSplitForAllInvisTyVars Type
ty of
                        ([TyVar]
tvs, Type
rho) -> case Type -> ([Type], Type)
tcSplitPhiTy Type
rho of
                                        ([Type]
theta, Type
tau) -> ([TyVar]
tvs, [Type]
theta, Type
tau)

-- | Split a sigma type into its parts, going underneath as many arrows
-- and foralls as possible. See Note [tcSplitNestedSigmaTys]
tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type)
-- See Note [tcSplitNestedSigmaTys]
-- NB: This is basically a pure version of deeplyInstantiate (from Unify) that
--     doesn't compute an HsWrapper.
tcSplitNestedSigmaTys :: Type -> ([TyVar], [Type], Type)
tcSplitNestedSigmaTys Type
ty
    -- If there's a forall, split it apart and try splitting the rho type
    -- underneath it.
  | ([Scaled Type]
arg_tys, Type
body_ty)   <- Type -> ([Scaled Type], Type)
tcSplitFunTys Type
ty
  , ([TyVar]
tvs1, [Type]
theta1, Type
rho1) <- Type -> ([TyVar], [Type], Type)
tcSplitSigmaTy Type
body_ty
  , Bool -> Bool
not ([TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
tvs1 Bool -> Bool -> Bool
&& [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta1)
  = let ([TyVar]
tvs2, [Type]
theta2, Type
rho2) = Type -> ([TyVar], [Type], Type)
tcSplitNestedSigmaTys Type
rho1
    in ([TyVar]
tvs1 [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
tvs2, [Type]
theta1 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
theta2, [Scaled Type] -> Type -> Type
(() :: Constraint) => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
arg_tys Type
rho2)

    -- If there's no forall, we're done.
  | Bool
otherwise = ([], [], Type
ty)

{- Note [tcSplitNestedSigmaTys]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcSplitNestedSigmaTys splits out all the /nested/ foralls and constraints,
including under function arrows.  E.g. given this type synonym:
  type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t

then
  tcSplitNestedSigmaTys (forall s t a b. C s t a b => Int -> Traversal s t a b)

will return
  ( [s,t,a,b,f]
  , [C s t a b, Applicative f]
  , Int -> (a -> f b) -> s -> f t)@.

This function is used in these places:
* Improving error messages in GHC.Tc.Gen.Head.addFunResCtxt
* Validity checking for default methods: GHC.Tc.TyCl.checkValidClass
* A couple of calls in the GHCi debugger: GHC.Runtime.Heap.Inspect

In other words, just in validity checking and error messages; hence
no wrappers or evidence generation.

Notice that tcSplitNestedSigmaTys even looks under function arrows;
doing so is the Right Thing even with simple subsumption, not just
with deep subsumption.
-}

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

-- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'.
tcTyConAppTyCon_maybe :: Type -> Maybe TyCon
tcTyConAppTyCon_maybe :: Type -> Maybe TyCon
tcTyConAppTyCon_maybe Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe TyCon
tcTyConAppTyCon_maybe Type
ty'
tcTyConAppTyCon_maybe (TyConApp TyCon
tc [Type]
_)              = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc
tcTyConAppTyCon_maybe (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af })       = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just (FunTyFlag -> TyCon
funTyFlagTyCon FunTyFlag
af)
tcTyConAppTyCon_maybe Type
_                            = Maybe TyCon
forall a. Maybe a
Nothing

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

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

tcSplitFunTy_maybe :: Type -> Maybe (Scaled Type, Type)
-- Only splits function (->) and (-=>), not (=>) or (==>)
tcSplitFunTy_maybe :: Type -> Maybe (Scaled Type, Type)
tcSplitFunTy_maybe Type
ty
  | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (Scaled Type, Type)
tcSplitFunTy_maybe Type
ty'
tcSplitFunTy_maybe (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af, ft_mult :: Type -> Type
ft_mult = Type
w, ft_arg :: Type -> Type
ft_arg = Type
arg, ft_res :: Type -> Type
ft_res = Type
res })
  | FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af = (Scaled Type, Type) -> Maybe (Scaled Type, Type)
forall a. a -> Maybe a
Just (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
w Type
arg, Type
res)
tcSplitFunTy_maybe Type
_   = Maybe (Scaled Type, Type)
forall a. Maybe a
Nothing
        -- Note the isVisibleFunArg 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
                        ([Scaled 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 -> Type -> Either Int ([Scaled Type], Type)
tcSplitFunTysN Int
n Type
ty
 | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
 = ([Scaled Type], Type) -> Either Int ([Scaled Type], Type)
forall a b. b -> Either a b
Right ([], Type
ty)
 | Just (Scaled Type
arg,Type
res) <- Type -> Maybe (Scaled Type, Type)
tcSplitFunTy_maybe Type
ty
 = case Int -> Type -> Either Int ([Scaled Type], Type)
tcSplitFunTysN (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Type
res of
     Left Int
m            -> Int -> Either Int ([Scaled Type], Type)
forall a b. a -> Either a b
Left Int
m
     Right ([Scaled Type]
args,Type
body) -> ([Scaled Type], Type) -> Either Int ([Scaled Type], Type)
forall a b. b -> Either a b
Right (Scaled Type
argScaled Type -> [Scaled Type] -> [Scaled Type]
forall a. a -> [a] -> [a]
:[Scaled Type]
args, Type
body)
 | Bool
otherwise
 = Int -> Either Int ([Scaled Type], Type)
forall a b. a -> Either a b
Left Int
n

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

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

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

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

-----------------------
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty'
tcSplitAppTy_maybe Type
ty = Type -> Maybe (Type, Type)
tcSplitAppTyNoView_maybe Type
ty

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

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

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

-----------------------
tcSplitQuantPredTy :: Type -> ([TyVar], [Type], PredType)
-- Split up the type of a quantified predicate
--    forall tys, theta => head
-- NB splitFunTys, not tcSplitFunTys;
-- the latter specifically stops at PredTy arguments,
-- and we don't want to do that here
tcSplitQuantPredTy :: Type -> ([TyVar], [Type], Type)
tcSplitQuantPredTy Type
ty
  = case Type -> ([TyVar], Type)
tcSplitForAllInvisTyVars Type
ty of { ([TyVar]
tvs, Type
rho)    ->
    case Type -> ([Scaled Type], Type)
splitFunTys Type
rho             of { ([Scaled Type]
theta, Type
head) ->
    ([TyVar]
tvs, (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
theta, Type
head) }}

tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type])
-- Split the type of a dictionary function
tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy Type
ty
  = case Type -> ([TyVar], [Type], Type)
tcSplitQuantPredTy Type
ty of { ([TyVar]
tvs, [Type]
theta, Type
head)  ->
    case Type -> (Class, [Type])
tcSplitDFunHead Type
head  of { (Class
clas, [Type]
tys)   ->
    ([TyVar]
tvs, [Type]
theta, Class
clas, [Type]
tys) }}

tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead = (() :: Constraint) => Type -> (Class, [Type])
Type -> (Class, [Type])
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 :: Type -> ([TyVar], Type, Type)
tcSplitMethodTy Type
ty
  | ([TyVar]
sel_tyvars,Type
sel_rho) <- Type -> ([TyVar], Type)
tcSplitForAllInvisTyVars Type
ty
  , Just (Type
first_pred, Type
local_meth_ty) <- Type -> Maybe (Type, Type)
tcSplitPredFunTy_maybe Type
sel_rho
  = ([TyVar]
sel_tyvars, Type
first_pred, Type
local_meth_ty)
  | Bool
otherwise
  = String -> SDoc -> ([TyVar], Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSplitMethodTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)


{- *********************************************************************
*                                                                      *
                       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 :: Type -> Bool
isTyVarClassPred Type
ty = case Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
ty of
    Just (Class
_, [Type]
tys) -> (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVarTy [Type]
tys
    Maybe (Class, [Type])
_             -> 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 in GHC.Tc.Utils.TcType, rather than in GHC.Tc.Validity,
-- because it is called from GHC.Tc.Solver, which itself is imported by GHC.Tc.Validity
checkValidClsArgs :: Bool -> Class -> [Type] -> Bool
checkValidClsArgs Bool
flexible_contexts Class
cls [Type]
kts
  | Bool
flexible_contexts = Bool
True
  | Bool
otherwise         = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasTyVarHead [Type]
tys
  where
    tys :: [Type]
tys = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [Type]
kts

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

evVarPred :: EvVar -> PredType
evVarPred :: TyVar -> Type
evVarPred TyVar
var = TyVar -> Type
varType TyVar
var
  -- Historical note: I used to have an ASSERT here,
  -- checking (isEvVarType (varType var)).  But with something like
  --   f :: c => _ -> _
  -- we end up with (c :: kappa), and (kappa ~ Constraint).  Until
  -- we solve and zonk (which there is no particular reason to do for
  -- partial signatures, (isEvVarType kappa) will return False. But
  -- nothing is wrong.  So I just removed the ASSERT.

---------------------------
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 -> Type -> Type -> Maybe (Class, [Type])
boxEqPred EqRel
eq_rel Type
ty1 Type
ty2
  = case EqRel
eq_rel of
      EqRel
NomEq  | Bool
homo_kind -> (Class, [Type]) -> Maybe (Class, [Type])
forall a. a -> Maybe a
Just (Class
eqClass,        [Type
k1,     Type
ty1, Type
ty2])
             | Bool
otherwise -> (Class, [Type]) -> Maybe (Class, [Type])
forall a. a -> Maybe a
Just (Class
heqClass,       [Type
k1, Type
k2, Type
ty1, Type
ty2])
      EqRel
ReprEq | Bool
homo_kind -> (Class, [Type]) -> Maybe (Class, [Type])
forall a. a -> Maybe a
Just (Class
coercibleClass, [Type
k1,     Type
ty1, Type
ty2])
             | Bool
otherwise -> Maybe (Class, [Type])
forall a. Maybe a
Nothing -- Sigh: we do not have heterogeneous Coercible
                                    --       so we can't abstract over it
                                    -- Nothing fundamental: we could add it
 where
   k1 :: Type
k1 = (() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty1
   k2 :: Type
k2 = (() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty2
   homo_kind :: Bool
homo_kind = Type
k1 (() :: Constraint) => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
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 :: VarSet -> [Type] -> [Type]
pickCapturedPreds VarSet
qtvs [Type]
theta
  = (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
captured [Type]
theta
  where
    captured :: Type -> Bool
captured Type
pred = Type -> Bool
isIPLikePred Type
pred Bool -> Bool -> Bool
|| (Type -> VarSet
tyCoVarsOfType Type
pred VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
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 GHC.Tc.TyCl.PatSyn)
--
-- 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 :: forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs a -> Type
get_pred [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 = [ (Type
pred, Type -> [Type]
implicants Type
pred, a
x)
                    | a
x <- [a]
xs
                    , let pred :: Type
pred = a -> Type
get_pred a
x ]

   go :: [PredWithSCs a]   -- Work list
      -> [PredWithSCs a]   -- Accumulating result
      -> [a]
   go :: [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [] [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@(Type
p,[Type]
_,a
_) : [PredWithSCs a]
work_list) [PredWithSCs a]
min_preds
     | EqPred EqRel
_ Type
t1 Type
t2 <- Type -> Pred
classifyPredType Type
p
     , Type
t1 (() :: Constraint) => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
t2   -- See GHC.Tc.TyCl.PatSyn
                          -- Note [Remove redundant provided dicts]
     = [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [PredWithSCs a]
work_list [PredWithSCs a]
min_preds
     | Type
p Type -> [PredWithSCs a] -> Bool
`in_cloud` [PredWithSCs a]
work_list Bool -> Bool -> Bool
|| Type
p Type -> [PredWithSCs a] -> Bool
`in_cloud` [PredWithSCs a]
min_preds
       -- Why look at work-list too?  Suppose work_item is Eq a,
       -- and work-list contains Ord a
     = [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 :: Type -> [PredWithSCs a] -> Bool
in_cloud Type
p [PredWithSCs a]
ps = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Type
p (() :: Constraint) => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
p' | (Type
_, [Type]
scs, a
_) <- [PredWithSCs a]
ps, Type
p' <- [Type]
scs ]

   implicants :: Type -> [Type]
implicants Type
pred
     = Type
pred Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
eq_extras Type
pred [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Type -> [Type]
transSuperClasses Type
pred

   -- Combine (a ~ b) and (b ~ a); no need to have both in one context
   -- These can arise when dealing with partial type signatures (e.g. T14715)
   eq_extras :: Type -> [Type]
eq_extras Type
pred
     = case Type -> Pred
classifyPredType Type
pred of
         EqPred EqRel
r Type
t1 Type
t2               -> [Role -> Type -> Type -> Type
mkPrimEqPredRole (EqRel -> Role
eqRelRole EqRel
r) Type
t2 Type
t1]
         ClassPred Class
cls [Type
k1,Type
k2,Type
t1,Type
t2]
           | Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey -> [Class -> [Type] -> Type
mkClassPred Class
cls [Type
k2, Type
k1, Type
t2, Type
t1]]
         ClassPred Class
cls [Type
k,Type
t1,Type
t2]
           | Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey  -> [Class -> [Type] -> Type
mkClassPred Class
cls [Type
k, Type
t2, Type
t1]]
         Pred
_ -> []

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 :: Type -> [Type]
transSuperClasses Type
p
  = NameSet -> Type -> [Type]
go NameSet
emptyNameSet Type
p
  where
    go :: NameSet -> PredType -> [PredType]
    go :: NameSet -> Type -> [Type]
go NameSet
rec_clss Type
p
       | ClassPred Class
cls [Type]
tys <- Type -> Pred
classifyPredType Type
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
       = [ Type
p' | Type
sc <- Class -> [Type] -> [Type]
immSuperClasses Class
cls [Type]
tys
              , Type
p'  <- Type
sc Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: NameSet -> Type -> [Type]
go NameSet
rec_clss' Type
sc ]
       | Bool
otherwise
       = []

immSuperClasses :: Class -> [Type] -> [PredType]
immSuperClasses :: Class -> [Type] -> [Type]
immSuperClasses Class
cls [Type]
tys
  = (() :: Constraint) => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTheta ([TyVar] -> [Type] -> Subst
(() :: Constraint) => [TyVar] -> [Type] -> Subst
zipTvSubst [TyVar]
tyvars [Type]
tys) [Type]
sc_theta
  where
    ([TyVar]
tyvars,[Type]
sc_theta,[TyVar]
_,[ClassOpItem]
_) = Class -> ([TyVar], [Type], [TyVar], [ClassOpItem])
classBigSig Class
cls

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

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

transSuperClasses( C tys ) returns the transitive superclasses
                           of (C tys), not including C itself

For example
  class C a b => D a b
  class D b a => C a b

Then
  transSuperClasses( Ord ty )  = [Eq ty]
  transSuperClasses( C ta tb ) = [D tb ta, C tb ta]

Notice that in the recursive-superclass case we include C again at
the end of the chain.  One could exclude C in this case, but
the code is more awkward and there seems no good reason to do so.
(However C.f. GHC.Tc.Solver.Canonical.mk_strict_superclasses, which /does/
appear to do so.)

The algorithm is expand( so_far, pred ):

 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.

 * We need the loop-breaker in case we have UndecidableSuperClasses on

 * 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 GHC.Tc.TyCl.Utils.checkClassCycles.

************************************************************************
*                                                                      *
      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 :: Type -> Bool
isSigmaTy Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isSigmaTy Type
ty'
isSigmaTy (ForAllTy {})                = Bool
True
isSigmaTy (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af })       = FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af
isSigmaTy Type
_                            = Bool
False

isRhoTy :: TcType -> Bool   -- True of TcRhoTypes; see Note [TcRhoType]
isRhoTy :: Type -> Bool
isRhoTy Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isRhoTy Type
ty'
isRhoTy (ForAllTy {})                = Bool
False
isRhoTy (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af })       = FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af
isRhoTy Type
_                            = Bool
True

-- | Like 'isRhoTy', but also says 'True' for 'Infer' types
isRhoExpTy :: ExpType -> Bool
isRhoExpTy :: ExpType -> Bool
isRhoExpTy (Check Type
ty) = Type -> Bool
isRhoTy Type
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 :: Type -> Bool
isOverloadedTy Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isOverloadedTy Type
ty'
isOverloadedTy (ForAllTy ForAllTyBinder
_  Type
ty)             = Type -> Bool
isOverloadedTy Type
ty
isOverloadedTy (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af })       = FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af
isOverloadedTy Type
_                            = Bool
False

isFloatTy, isDoubleTy,
    isFloatPrimTy, isDoublePrimTy,
    isIntegerTy, isNaturalTy,
    isIntTy, isWordTy, isBoolTy,
    isUnitTy, isCharTy :: Type -> Bool
isFloatTy :: Type -> Bool
isFloatTy      = Unique -> Type -> Bool
is_tc Unique
floatTyConKey
isDoubleTy :: Type -> Bool
isDoubleTy     = Unique -> Type -> Bool
is_tc Unique
doubleTyConKey
isFloatPrimTy :: Type -> Bool
isFloatPrimTy  = Unique -> Type -> Bool
is_tc Unique
floatPrimTyConKey
isDoublePrimTy :: Type -> Bool
isDoublePrimTy = Unique -> Type -> Bool
is_tc Unique
doublePrimTyConKey
isIntegerTy :: Type -> Bool
isIntegerTy    = Unique -> Type -> Bool
is_tc Unique
integerTyConKey
isNaturalTy :: Type -> Bool
isNaturalTy    = Unique -> Type -> Bool
is_tc Unique
naturalTyConKey
isIntTy :: Type -> Bool
isIntTy        = Unique -> Type -> Bool
is_tc Unique
intTyConKey
isWordTy :: Type -> Bool
isWordTy       = Unique -> Type -> Bool
is_tc Unique
wordTyConKey
isBoolTy :: Type -> Bool
isBoolTy       = Unique -> Type -> Bool
is_tc Unique
boolTyConKey
isUnitTy :: Type -> Bool
isUnitTy       = Unique -> Type -> Bool
is_tc Unique
unitTyConKey
isCharTy :: Type -> Bool
isCharTy       = Unique -> Type -> Bool
is_tc Unique
charTyConKey

-- | Check whether the type is of the form @Any :: k@,
-- returning the kind @k@.
anyTy_maybe :: Type -> Maybe Kind
anyTy_maybe :: Type -> Maybe Type
anyTy_maybe Type
ty
  | Just (TyCon
tc, [Type
k]) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  , TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
anyTyConKey
  = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
k
  | Bool
otherwise
  = Maybe Type
forall a. Maybe a
Nothing

-- | Is the type inhabited by machine floating-point numbers?
--
-- Used to check that we don't use floating-point literal patterns
-- in Core.
--
-- See #9238 and Note [Rules for floating-point comparisons]
-- in GHC.Core.Opt.ConstantFold.
isFloatingPrimTy :: Type -> Bool
isFloatingPrimTy :: Type -> Bool
isFloatingPrimTy Type
ty = Type -> Bool
isFloatPrimTy Type
ty Bool -> Bool -> Bool
|| Type -> Bool
isDoublePrimTy Type
ty

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

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

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

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

-}

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

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

{-
************************************************************************
*                                                                      *
   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 :: Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
ty
  = case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
        Just (TyCon
io_tycon, [Type
io_res_ty])
         | TyCon
io_tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ioTyConKey ->
            (TyCon, Type) -> Maybe (TyCon, Type)
forall a. a -> Maybe a
Just (TyCon
io_tycon, Type
io_res_ty)
        Maybe (TyCon, [Type])
_ ->
            Maybe (TyCon, Type)
forall a. Maybe a
Nothing

-- | Reason why a type in an FFI signature is invalid
data IllegalForeignTypeReason
  = TypeCannotBeMarshaled !Type TypeCannotBeMarshaledReason
  | ForeignDynNotPtr
      !Type -- ^ Expected type
      !Type -- ^ Actual type
  | SafeHaskellMustBeInIO
  | IOResultExpected
  | UnexpectedNestedForall
  | LinearTypesNotAllowed
  | OneArgExpected
  | AtLeastOneArgExpected
  deriving (forall x.
 IllegalForeignTypeReason -> Rep IllegalForeignTypeReason x)
-> (forall x.
    Rep IllegalForeignTypeReason x -> IllegalForeignTypeReason)
-> Generic IllegalForeignTypeReason
forall x.
Rep IllegalForeignTypeReason x -> IllegalForeignTypeReason
forall x.
IllegalForeignTypeReason -> Rep IllegalForeignTypeReason x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
IllegalForeignTypeReason -> Rep IllegalForeignTypeReason x
from :: forall x.
IllegalForeignTypeReason -> Rep IllegalForeignTypeReason x
$cto :: forall x.
Rep IllegalForeignTypeReason x -> IllegalForeignTypeReason
to :: forall x.
Rep IllegalForeignTypeReason x -> IllegalForeignTypeReason
Generic

-- | Reason why a type cannot be marshalled through the FFI.
data TypeCannotBeMarshaledReason
  = NotADataType
  | NewtypeDataConNotInScope !(Maybe TyCon)
  | UnliftedFFITypesNeeded
  | NotABoxedMarshalableTyCon
  | ForeignLabelNotAPtr
  | NotSimpleUnliftedType
  | NotBoxedKindAny
  deriving (forall x.
 TypeCannotBeMarshaledReason -> Rep TypeCannotBeMarshaledReason x)
-> (forall x.
    Rep TypeCannotBeMarshaledReason x -> TypeCannotBeMarshaledReason)
-> Generic TypeCannotBeMarshaledReason
forall x.
Rep TypeCannotBeMarshaledReason x -> TypeCannotBeMarshaledReason
forall x.
TypeCannotBeMarshaledReason -> Rep TypeCannotBeMarshaledReason x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
TypeCannotBeMarshaledReason -> Rep TypeCannotBeMarshaledReason x
from :: forall x.
TypeCannotBeMarshaledReason -> Rep TypeCannotBeMarshaledReason x
$cto :: forall x.
Rep TypeCannotBeMarshaledReason x -> TypeCannotBeMarshaledReason
to :: forall x.
Rep TypeCannotBeMarshaledReason x -> TypeCannotBeMarshaledReason
Generic

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

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

isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy DynFlags
dflags Type
ty
  = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIResultTyCon DynFlags
dflags) Type
ty

isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEResultTyCon Type
ty

isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason
-- 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 :: Type -> Type -> Validity' IllegalForeignTypeReason
isFFIDynTy Type
expected Type
ty
    -- Note [Foreign import dynamic]
    -- In the example below, expected would be 'CInt -> IO ()', while ty would
    -- be 'FunPtr (CDouble -> IO ())'.
    | Just (TyCon
tc, [Type
ty']) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
    , TyCon -> Unique
tyConUnique TyCon
tc Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
ptrTyConKey, Unique
funPtrTyConKey]
    , Type -> Type -> Bool
eqType Type
ty' Type
expected
    = Validity' IllegalForeignTypeReason
forall a. Validity' a
IsValid
    | Bool
otherwise
    = IllegalForeignTypeReason -> Validity' IllegalForeignTypeReason
forall a. a -> Validity' a
NotValid (Type -> Type -> IllegalForeignTypeReason
ForeignDynNotPtr Type
expected Type
ty)

isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason
-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either.
isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason
isFFILabelTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
forall {a}.
Uniquable a =>
a -> Validity' TypeCannotBeMarshaledReason
ok Type
ty
  where
    ok :: a -> Validity' TypeCannotBeMarshaledReason
ok 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' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
          | Bool
otherwise
          = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
ForeignLabelNotAPtr

-- | Check validity for a type of the form @Any :: k@.
--
-- This function returns:
--
--  - @Just IsValid@ for @Any :: Type@ and @Any :: UnliftedType@,
--  - @Just (NotValid ..)@ for @Any :: k@ if @k@ is not a kind of boxed types,
--  - @Nothing@ if the type is not @Any@.
checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
  | Just Type
ki <- Type -> Maybe Type
anyTy_maybe Type
ty
  = Validity' IllegalForeignTypeReason
-> Maybe (Validity' IllegalForeignTypeReason)
forall a. a -> Maybe a
Just (Validity' IllegalForeignTypeReason
 -> Maybe (Validity' IllegalForeignTypeReason))
-> Validity' IllegalForeignTypeReason
-> Maybe (Validity' IllegalForeignTypeReason)
forall a b. (a -> b) -> a -> b
$
      if Maybe Levity -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Levity -> Bool) -> Maybe Levity -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Levity
kindBoxedRepLevity_maybe Type
ki
      then Validity' IllegalForeignTypeReason
forall a. Validity' a
IsValid
      -- NB: don't allow things like @Any :: TYPE IntRep@, as per #21305.
      else IllegalForeignTypeReason -> Validity' IllegalForeignTypeReason
forall a. a -> Validity' a
NotValid (Type -> TypeCannotBeMarshaledReason -> IllegalForeignTypeReason
TypeCannotBeMarshaled Type
ty TypeCannotBeMarshaledReason
NotBoxedKindAny)
  | Bool
otherwise
  = Maybe (Validity' IllegalForeignTypeReason)
forall a. Maybe a
Nothing

isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
-- Checks for valid argument type for a 'foreign import prim'
-- Currently they must all be simple unlifted types, or Any (at kind Type or UnliftedType),
-- which can be used to pass the address to a Haskell object on the heap to
-- the foreign function.
isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimArgumentTy DynFlags
dflags Type
ty
  | Just Validity' IllegalForeignTypeReason
validity <- Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
  = Validity' IllegalForeignTypeReason
validity
  | Bool
otherwise
  = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimArgTyCon DynFlags
dflags) Type
ty

isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
-- 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 (at kind Type or UnliftedType).
isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimResultTy DynFlags
dflags Type
ty
  | Just Validity' IllegalForeignTypeReason
validity <- Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
  = Validity' IllegalForeignTypeReason
validity
  | Bool
otherwise
  = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimResultTyCon DynFlags
dflags) Type
ty

isFunPtrTy :: Type -> Bool
isFunPtrTy :: Type -> Bool
isFunPtrTy Type
ty
  | Just (TyCon
tc, [Type
_]) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
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' TypeCannotBeMarshaledReason)
  -> Type
  -> Validity' IllegalForeignTypeReason
checkRepTyCon :: (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
check_tc Type
ty
  = (TypeCannotBeMarshaledReason -> IllegalForeignTypeReason)
-> Validity' TypeCannotBeMarshaledReason
-> Validity' IllegalForeignTypeReason
forall a b. (a -> b) -> Validity' a -> Validity' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type -> TypeCannotBeMarshaledReason -> IllegalForeignTypeReason
TypeCannotBeMarshaled Type
ty) (Validity' TypeCannotBeMarshaledReason
 -> Validity' IllegalForeignTypeReason)
-> Validity' TypeCannotBeMarshaledReason
-> Validity' IllegalForeignTypeReason
forall a b. (a -> b) -> a -> b
$ case (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
      Just (TyCon
tc, [Type]
tys)
        | TyCon -> Bool
isNewTyCon TyCon
tc -> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid (TyCon -> [Type] -> TypeCannotBeMarshaledReason
forall {t :: * -> *} {a}.
Foldable t =>
TyCon -> t a -> TypeCannotBeMarshaledReason
mk_nt_reason TyCon
tc [Type]
tys)
        | Bool
otherwise     -> TyCon -> Validity' TypeCannotBeMarshaledReason
check_tc TyCon
tc
      Maybe (TyCon, [Type])
Nothing -> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotADataType
  where
    mk_nt_reason :: TyCon -> t a -> TypeCannotBeMarshaledReason
mk_nt_reason TyCon
tc t a
tys
      | t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
tys  = Maybe TyCon -> TypeCannotBeMarshaledReason
NewtypeDataConNotInScope Maybe TyCon
forall a. Maybe a
Nothing
      | Bool
otherwise = Maybe TyCon -> TypeCannotBeMarshaledReason
NewtypeDataConNotInScope (TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc)

{-
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' TypeCannotBeMarshaledReason
legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEArgTyCon 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' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc

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

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

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

-- Check for marshalability of a primitive type.
-- We exclude lifted types such as RealWorld and TYPE.
-- They can technically appear in types, e.g.
-- f :: RealWorld -> TYPE LiftedRep -> RealWorld
-- f x _ = x
-- but there are no values of type RealWorld or TYPE LiftedRep,
-- so it doesn't make sense to use them in FFI.
marshalablePrimTyCon :: TyCon -> Bool
marshalablePrimTyCon :: TyCon -> Bool
marshalablePrimTyCon TyCon
tc = TyCon -> Bool
isPrimTyCon TyCon
tc Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isLiftedTypeKind (TyCon -> Type
tyConResKind TyCon
tc))

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

boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc
   | TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> 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' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid

  | Bool
otherwise = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotABoxedMarshalableTyCon

legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
-- Check args of 'foreign import prim', only allow simple unlifted types.
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimArgTyCon DynFlags
dflags TyCon
tc
  | TyCon -> Bool
marshalablePrimTyCon TyCon
tc
  = DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
  | Bool
otherwise
  = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotSimpleUnliftedType

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

  | TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isUnboxedSumTyCon TyCon
tc
  = DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags

  | Bool
otherwise
  = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid (TypeCannotBeMarshaledReason
 -> Validity' TypeCannotBeMarshaledReason)
-> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a b. (a -> b) -> a -> b
$ TypeCannotBeMarshaledReason
NotSimpleUnliftedType

validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
  | Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedFFITypes DynFlags
dflags =  Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
  | Bool
otherwise = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
UnliftedFFITypesNeeded

{-
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
-}

{-
************************************************************************
*                                                                      *
        Visiblities
*                                                                      *
************************************************************************
-}

-- | 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 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      = (VarBndr TyVar TyConBndrVis -> Bool)
-> [VarBndr TyVar TyConBndrVis] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map VarBndr TyVar TyConBndrVis -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder (TyCon -> [VarBndr TyVar TyConBndrVis]
tyConBinders TyCon
tc)
    tc_return_kind_viss :: [Bool]
tc_return_kind_viss = (PiTyVarBinder -> Bool) -> [PiTyVarBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map PiTyVarBinder -> Bool
isVisiblePiTyBinder (([PiTyVarBinder], Type) -> [PiTyVarBinder]
forall a b. (a, b) -> a
fst (([PiTyVarBinder], Type) -> [PiTyVarBinder])
-> ([PiTyVarBinder], Type) -> [PiTyVarBinder]
forall a b. (a -> b) -> a -> b
$ Type -> ([PiTyVarBinder], Type)
tcSplitPiTys (TyCon -> Type
tyConResKind TyCon
tc))

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

-- | Should this type be applied to a visible argument?
isNextArgVisible :: TcType -> Bool
isNextArgVisible :: Type -> Bool
isNextArgVisible Type
ty
  | Just (PiTyVarBinder
bndr, Type
_) <- Type -> Maybe (PiTyVarBinder, Type)
tcSplitPiTy_maybe Type
ty = PiTyVarBinder -> Bool
isVisiblePiTyBinder PiTyVarBinder
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

{-
************************************************************************
*                                                                      *
                     Paterson sizes
*                                                                      *
************************************************************************
-}

{- Note [The PatersonSize of a type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The PatersonSize of type is something we can compare, with `ltPatersonSize`,
to determine if the Paterson conditions are satisfied for an instance
declaration.  See Note [Paterson conditions] in GHC.Tc.Validity.

There are some wrinkles

(PS1) 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 #4200.

      We do this with isTerminatingClass

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

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

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

Note [Stuck type families]
~~~~~~~~~~~~~~~~~~~~~~~~~~
A type-family application generally has infinite size (PS_TyFam);
see (PC3) in Note [Paterson conditions] in GHC.Tc.Validity.

But a couple of built-in type families have no axioms, and can never
expand into anything else.  They are:

* (TypeError "stuff").  E.g. consider

     type family F a where
       F Int  = Bool
       F Bool = Char
       F _    = TypeError "Bad"

  We don't want to complain about possible non-termination of F, in
  GHC.Tc.Validity.checkFamInstRhs.  cf indexed-types/should_fail/T13271

* (Any @k).

For now we treat them as being size zero, but (#22696) I think we should
actually treat them as big (like any other ype family) because we don't
want to abstract over them in e.g. validDerivPred.

The type-family termination test, in GHC.Tc.Validity.checkFamInstRhs, already
has a separate call to isStuckTypeFamily, so the `F` above will still be accepted.
-}


-- | Why was the LHS 'PatersonSize' not strictly smaller than the RHS 'PatersonSize'?
--
-- See Note [Paterson conditions] in GHC.Tc.Validity.
data PatersonSizeFailure
  -- | Either side contains a type family.
  = PSF_TyFam TyCon
  -- | The size of the LHS is not strictly less than the size of the RHS.
  | PSF_Size
  -- | These type variables appear more often in the LHS than in the RHS.
  | PSF_TyVar [TyVar] -- ^  no duplicates in this list

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

-- | The Paterson size of a given type, in the sense of
-- Note [Paterson conditions] in GHC.Tc.Validity
--
--   - after expanding synonyms,
--   - ignoring coercions (as they are not user written).
data PatersonSize
  -- | The type mentions a type family, so the size could be anything.
  = PS_TyFam TyCon

  -- | The type does not mention a type family.
  | PS_Vanilla { PatersonSize -> [TyVar]
ps_tvs :: [TyVar]  -- ^ free tyvars, including repetitions;
               , PatersonSize -> Int
ps_size :: Int     -- ^ number of type constructors and variables
    }
  -- ToDo: ignore invisible arguments?  See Note [Invisible arguments and termination]

instance Outputable PatersonSize where
  ppr :: PatersonSize -> SDoc
ppr (PS_TyFam TyCon
tc) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"PS_TyFam" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
  ppr (PS_Vanilla { ps_tvs :: PatersonSize -> [TyVar]
ps_tvs = [TyVar]
tvs, ps_size :: PatersonSize -> Int
ps_size = Int
size })
    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"PS_Vanilla" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ps_tvs =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
                                       , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ps_size =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
size ])

pSizeZero, pSizeOne :: PatersonSize
pSizeZero :: PatersonSize
pSizeZero = PS_Vanilla { ps_tvs :: [TyVar]
ps_tvs = [], ps_size :: Int
ps_size = Int
0 }
pSizeOne :: PatersonSize
pSizeOne  = PS_Vanilla { ps_tvs :: [TyVar]
ps_tvs = [], ps_size :: Int
ps_size = Int
1 }

-- | @ltPatersonSize ps1 ps2@ returns:
--
--  - @Nothing@ iff @ps1@ is definitely strictly smaller than @ps2@,
--  - @Just ps_fail@ otherwise; @ps_fail@ says what went wrong.
ltPatersonSize :: PatersonSize
               -> PatersonSize
               -> Maybe PatersonSizeFailure
ltPatersonSize :: PatersonSize -> PatersonSize -> Maybe PatersonSizeFailure
ltPatersonSize (PS_Vanilla { ps_tvs :: PatersonSize -> [TyVar]
ps_tvs = [TyVar]
tvs1, ps_size :: PatersonSize -> Int
ps_size = Int
s1 })
               (PS_Vanilla { ps_tvs :: PatersonSize -> [TyVar]
ps_tvs = [TyVar]
tvs2, ps_size :: PatersonSize -> Int
ps_size = Int
s2 })
  | Int
s1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
s2                                = PatersonSizeFailure -> Maybe PatersonSizeFailure
forall a. a -> Maybe a
Just PatersonSizeFailure
PSF_Size
  | bad_tvs :: [TyVar]
bad_tvs@(TyVar
_:[TyVar]
_) <- [TyVar] -> [TyVar] -> [TyVar]
noMoreTyVars [TyVar]
tvs1 [TyVar]
tvs2 = PatersonSizeFailure -> Maybe PatersonSizeFailure
forall a. a -> Maybe a
Just ([TyVar] -> PatersonSizeFailure
PSF_TyVar [TyVar]
bad_tvs)
  | Bool
otherwise                               = Maybe PatersonSizeFailure
forall a. Maybe a
Nothing -- OK!
ltPatersonSize (PS_TyFam TyCon
tc) PatersonSize
_ = PatersonSizeFailure -> Maybe PatersonSizeFailure
forall a. a -> Maybe a
Just (TyCon -> PatersonSizeFailure
PSF_TyFam TyCon
tc)
ltPatersonSize PatersonSize
_ (PS_TyFam TyCon
tc) = PatersonSizeFailure -> Maybe PatersonSizeFailure
forall a. a -> Maybe a
Just (TyCon -> PatersonSizeFailure
PSF_TyFam TyCon
tc)
  -- NB: this last equation is never taken when checking instances, because
  -- type families are disallowed in instance heads.
  --
  -- However, this function is also used in the logic for solving superclass
  -- constraints (see Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance),
  -- in which case we might well hit this case (see e.g. T23171).

noMoreTyVars :: [TyVar]  -- Free vars (with repetitions) of the constraint C
             -> [TyVar]  -- Free vars (with repetitions) of the head H
             -> [TyVar]  -- TyVars that appear more often in C than H;
                         --   no repetitions in this list
noMoreTyVars :: [TyVar] -> [TyVar] -> [TyVar]
noMoreTyVars [TyVar]
tvs [TyVar]
head_tvs
  = [TyVar] -> [TyVar]
forall a. Eq a => [a] -> [a]
nub ([TyVar]
tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. Eq a => [a] -> [a] -> [a]
\\ [TyVar]
head_tvs)  -- The (\\) is list difference; e.g.
                           --   [a,b,a,a] \\ [a,a] = [b,a]
                           -- So we are counting repetitions

addPSize :: PatersonSize -> PatersonSize -> PatersonSize
addPSize :: PatersonSize -> PatersonSize -> PatersonSize
addPSize ps1 :: PatersonSize
ps1@(PS_TyFam {}) PatersonSize
_ = PatersonSize
ps1
addPSize PatersonSize
_ ps2 :: PatersonSize
ps2@(PS_TyFam {}) = PatersonSize
ps2
addPSize (PS_Vanilla { ps_tvs :: PatersonSize -> [TyVar]
ps_tvs = [TyVar]
tvs1, ps_size :: PatersonSize -> Int
ps_size = Int
s1 })
         (PS_Vanilla { ps_tvs :: PatersonSize -> [TyVar]
ps_tvs = [TyVar]
tvs2, ps_size :: PatersonSize -> Int
ps_size = Int
s2 })
  = PS_Vanilla { ps_tvs :: [TyVar]
ps_tvs = [TyVar]
tvs1 [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
tvs2, ps_size :: Int
ps_size = Int
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s2 }
    -- (++) is not very performant, but the types
    -- are user-written and never large

pSizeType :: Type -> PatersonSize
pSizeType :: Type -> PatersonSize
pSizeType = VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
emptyVarSet

pSizeTypes :: [Type] -> PatersonSize
pSizeTypes :: [Type] -> PatersonSize
pSizeTypes = VarSet -> PatersonSize -> [Type] -> PatersonSize
pSizeTypesX VarSet
emptyVarSet PatersonSize
pSizeZero

-- Paterson size of a type, retaining repetitions, and expanding synonyms
-- This ignores coercions, as coercions aren't user-written
pSizeTypeX :: VarSet -> Type -> PatersonSize
pSizeTypeX :: VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
bvs Type
ty | Just Type
exp_ty <- Type -> Maybe Type
coreView Type
ty = VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
bvs Type
exp_ty
pSizeTypeX VarSet
bvs (TyVarTy TyVar
tv)
  | TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` VarSet
bvs                  = PatersonSize
pSizeOne
  | Bool
otherwise                            = PS_Vanilla { ps_tvs :: [TyVar]
ps_tvs = [TyVar
tv], ps_size :: Int
ps_size = Int
1 }
pSizeTypeX VarSet
_   (LitTy {})                = PatersonSize
pSizeOne
pSizeTypeX VarSet
bvs (TyConApp TyCon
tc [Type]
tys)         = VarSet -> TyCon -> [Type] -> PatersonSize
pSizeTyConAppX VarSet
bvs TyCon
tc [Type]
tys
pSizeTypeX VarSet
bvs (AppTy Type
fun Type
arg)           = VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
bvs Type
fun PatersonSize -> PatersonSize -> PatersonSize
`addPSize` VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
bvs Type
arg
pSizeTypeX VarSet
bvs (FunTy FunTyFlag
_ Type
w Type
arg Type
res)       = VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
bvs Type
w PatersonSize -> PatersonSize -> PatersonSize
`addPSize` VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
bvs Type
arg PatersonSize -> PatersonSize -> PatersonSize
`addPSize`
                                           VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
bvs Type
res
pSizeTypeX VarSet
bvs (ForAllTy (Bndr TyVar
tv ForAllTyFlag
_) Type
ty) = VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
bvs (TyVar -> Type
tyVarKind TyVar
tv) PatersonSize -> PatersonSize -> PatersonSize
`addPSize`
                                           VarSet -> Type -> PatersonSize
pSizeTypeX (VarSet
bvs VarSet -> TyVar -> VarSet
`extendVarSet` TyVar
tv) Type
ty
pSizeTypeX VarSet
bvs (CastTy Type
ty KindCoercion
_)             = VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
bvs Type
ty
pSizeTypeX VarSet
_   (CoercionTy {})           = PatersonSize
pSizeOne

pSizeTypesX :: VarSet -> PatersonSize -> [Type] -> PatersonSize
pSizeTypesX :: VarSet -> PatersonSize -> [Type] -> PatersonSize
pSizeTypesX VarSet
bvs PatersonSize
sz [Type]
tys = (Type -> PatersonSize -> PatersonSize)
-> PatersonSize -> [Type] -> PatersonSize
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (PatersonSize -> PatersonSize -> PatersonSize
addPSize (PatersonSize -> PatersonSize -> PatersonSize)
-> (Type -> PatersonSize) -> Type -> PatersonSize -> PatersonSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarSet -> Type -> PatersonSize
pSizeTypeX VarSet
bvs) PatersonSize
sz [Type]
tys

pSizeTyConApp :: TyCon -> [Type] -> PatersonSize
pSizeTyConApp :: TyCon -> [Type] -> PatersonSize
pSizeTyConApp = VarSet -> TyCon -> [Type] -> PatersonSize
pSizeTyConAppX VarSet
emptyVarSet

pSizeTyConAppX :: VarSet -> TyCon -> [Type] -> PatersonSize
-- Open question: do we count all args, or just the visible ones?
-- See Note [Invisible arguments and termination]
pSizeTyConAppX :: VarSet -> TyCon -> [Type] -> PatersonSize
pSizeTyConAppX VarSet
bvs TyCon
tc [Type]
tys
  | TyCon -> Bool
isTypeFamilyTyCon TyCon
tc = TyCon -> PatersonSize
pSizeTyFamApp TyCon
tc
  | Bool
otherwise            = VarSet -> PatersonSize -> [Type] -> PatersonSize
pSizeTypesX VarSet
bvs PatersonSize
pSizeOne [Type]
tys

pSizeTyFamApp :: TyCon -> PatersonSize
-- See Note [Stuck type families]
pSizeTyFamApp :: TyCon -> PatersonSize
pSizeTyFamApp TyCon
tc
 | TyCon -> Bool
isStuckTypeFamily TyCon
tc = PatersonSize
pSizeZero
 | Bool
otherwise            = TyCon -> PatersonSize
PS_TyFam TyCon
tc

pSizeClassPred :: Class -> [Type] -> PatersonSize
pSizeClassPred :: Class -> [Type] -> PatersonSize
pSizeClassPred = VarSet -> Class -> [Type] -> PatersonSize
pSizeClassPredX VarSet
emptyVarSet

pSizeClassPredX :: VarSet -> Class -> [Type] -> PatersonSize
pSizeClassPredX :: VarSet -> Class -> [Type] -> PatersonSize
pSizeClassPredX VarSet
bvs Class
cls [Type]
tys
  | Class -> Bool
isTerminatingClass Class
cls -- See (PS1) in Note [The PatersonSize of a type]
  = PatersonSize
pSizeZero
  | Bool
otherwise
  = VarSet -> PatersonSize -> [Type] -> PatersonSize
pSizeTypesX VarSet
bvs PatersonSize
pSizeOne ([Type] -> PatersonSize) -> [Type] -> PatersonSize
forall a b. (a -> b) -> a -> b
$
    TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [Type]
tys
    -- filterOutInvisibleTypes Yuk!  See Note [Invisible arguments and termination]

isStuckTypeFamily :: TyCon -> Bool
-- See Note [Stuck type families]
isStuckTypeFamily :: TyCon -> Bool
isStuckTypeFamily TyCon
tc
  =  TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
errorMessageTypeErrorFamKey
  Bool -> Bool -> Bool
|| TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
anyTyConKey

-- | When this says "True", ignore this class constraint during
-- a termination check
-- See (PS1) in Note [The PatersonSize of a type]
isTerminatingClass :: Class -> Bool
isTerminatingClass :: Class -> Bool
isTerminatingClass Class
cls
  = Class -> Bool
isIPClass Class
cls    -- Implicit parameter constraints always terminate because
                     -- there are no instances for them --- they are only solved
                     -- by "local instances" in expressions
    Bool -> Bool -> Bool
|| Class -> Bool
isEqPredClass Class
cls
    Bool -> Bool -> Bool
|| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
typeableClassKey
            -- Typeable constraints are bigger than they appear due
            -- to kind polymorphism, but we can never get instance divergence this way
    Bool -> Bool -> Bool
|| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleTyConKey

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

-----------------------
type TypeSize = IntWithInf

sizeType :: Type -> TypeSize
-- Size of a type: the number of variables and constructors
sizeType :: Type -> TypeSize
sizeType Type
ty = PatersonSize -> TypeSize
toTypeSize (Type -> PatersonSize
pSizeType Type
ty)

sizeTypes :: [Type] -> TypeSize
sizeTypes :: [Type] -> TypeSize
sizeTypes [Type]
tys = PatersonSize -> TypeSize
toTypeSize ((Type -> PatersonSize -> PatersonSize)
-> PatersonSize -> [Type] -> PatersonSize
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (PatersonSize -> PatersonSize -> PatersonSize
addPSize (PatersonSize -> PatersonSize -> PatersonSize)
-> (Type -> PatersonSize) -> Type -> PatersonSize -> PatersonSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> PatersonSize
pSizeType) PatersonSize
pSizeZero [Type]
tys)

toTypeSize :: PatersonSize -> TypeSize
toTypeSize :: PatersonSize -> TypeSize
toTypeSize (PS_TyFam {})                   =  TypeSize
infinity
toTypeSize (PS_Vanilla { ps_size :: PatersonSize -> Int
ps_size = Int
size }) = Int -> TypeSize
mkIntWithInf Int
size