-- (c) The University of Glasgow 2006
-- (c) The GRASP/AQUA Project, Glasgow University, 1998
--
-- Type - public interface

{-# LANGUAGE PatternSynonyms, ViewPatterns, MultiWayIf #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Main functions for manipulating types and type-related things
module GHC.Core.Type (
        -- Note some of this is just re-exports from TyCon..

        -- * Main data types representing Types
        -- $type_classification

        -- $representation_types
        Type, ForAllTyFlag(..), FunTyFlag(..),
        Specificity(..),
        KindOrType, PredType, ThetaType, FRRType,
        Var, TyVar, isTyVar, TyCoVar, PiTyBinder, ForAllTyBinder, TyVarBinder,
        Mult, Scaled,
        KnotTied, RuntimeRepType,

        -- ** Constructing and deconstructing types
        mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe,
        getCastedTyVar_maybe, tyVarKind, varType,

        mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTysNoView,
        splitAppTy_maybe, splitAppTyNoView_maybe, tcSplitAppTyNoView_maybe,

        mkFunTy, mkVisFunTy,
        mkVisFunTyMany, mkVisFunTysMany,
        mkScaledFunTys,
        mkInvisFunTy, mkInvisFunTys,
        tcMkVisFunTy, tcMkScaledFunTys, tcMkInvisFunTy,
        splitFunTy, splitFunTy_maybe, splitVisibleFunTy_maybe,
        splitFunTys, funResultTy, funArgTy,
        funTyConAppTy_maybe, funTyFlagTyCon,
        tyConAppFunTy_maybe, tyConAppFunCo_maybe,
        mkFunctionType, mkScaledFunctionTys, chooseFunTyFlag,

        mkTyConApp, mkTyConTy,
        tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,
        tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,

        splitTyConApp_maybe, splitTyConAppNoView_maybe, splitTyConApp,
        tcSplitTyConApp, tcSplitTyConApp_maybe,

        mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,
        mkSpecForAllTy, mkSpecForAllTys,
        mkVisForAllTys, mkTyCoForAllTy, mkTyCoForAllTys, mkTyCoInvForAllTy,
        mkInfForAllTy, mkInfForAllTys,
        splitForAllTyCoVars, splitForAllTyVars,
        splitForAllReqTyBinders, splitForAllInvisTyBinders,
        splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe,
        splitForAllTyCoVar_maybe, splitForAllTyCoVar,
        splitForAllTyVar_maybe, splitForAllCoVar_maybe,
        splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders,
        getRuntimeArgTys,
        mkTyConBindersPreferAnon,
        mkPiTy, mkPiTys,
        piResultTy, piResultTys,
        applyTysX, dropForAlls,
        mkFamilyTyConApp,
        buildSynTyCon,

        mkNumLitTy, isNumLitTy,
        mkStrLitTy, isStrLitTy,
        mkCharLitTy, isCharLitTy,
        isLitTy,

        getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep,
        getLevity, levityType_maybe,

        mkCastTy, mkCoercionTy, splitCastTy_maybe,

        ErrorMsgType, pprUserTypeErrorTy,

        coAxNthLHS,
        stripCoercionTy,

        splitInvisPiTys, splitInvisPiTysN, invisibleBndrCount,
        filterOutInvisibleTypes, filterOutInferredTypes,
        partitionInvisibleTypes, partitionInvisibles,
        tyConForAllTyFlags, appTyForAllTyFlags,

        -- ** Analyzing types
        TyCoMapper(..), mapTyCo, mapTyCoX,
        TyCoFolder(..), foldTyCo, noView,

        -- (Newtypes)
        newTyConInstRhs,

        -- ** Binders
        mkForAllTyBinder, mkForAllTyBinders,
        mkTyVarBinder, mkTyVarBinders,
        tyVarSpecToBinders,
        isAnonPiTyBinder,
        binderVar, binderVars, binderType, binderFlag, binderFlags,
        piTyBinderType, namedPiTyBinder_maybe,
        anonPiTyBinderType_maybe,
        isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isVisiblePiTyBinder,
        isInvisiblePiTyBinder, isNamedPiTyBinder,
        tyConBindersPiTyBinders,

        -- ** Predicates on types
        isTyVarTy, isFunTy, isCoercionTy,
        isCoercionTy_maybe, isForAllTy,
        isForAllTy_ty, isForAllTy_co,
        isForAllTy_invis_ty,
        isPiTy, isTauTy, isFamFreeTy,
        isAtomicTy,

        isValidJoinPointType,
        tyConAppNeedsKindSig,

        -- * Space-saving construction
        mkTYPEapp, mkTYPEapp_maybe,
        mkCONSTRAINTapp, mkCONSTRAINTapp_maybe,
        mkBoxedRepApp_maybe, mkTupleRepApp_maybe,
        typeOrConstraintKind, liftedTypeOrConstraintKind,

        -- *** Levity and boxity
        sORTKind_maybe, typeTypeOrConstraint,
        typeLevity, typeLevity_maybe, tyConIsTYPEorCONSTRAINT,
        isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind,
        isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe,
        isBoxedRuntimeRep,
        isLiftedLevity, isUnliftedLevity,
        isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,
        kindBoxedRepLevity_maybe,
        mightBeLiftedType, mightBeUnliftedType,
        definitelyLiftedType, definitelyUnliftedType,
        isAlgType, isDataFamilyApp, isSatTyFamApp,
        isPrimitiveType, isStrictType, isTerminatingType,
        isLevityTy, isLevityVar,
        isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,
        dropRuntimeRepArgs,

        -- * Multiplicity

        isMultiplicityTy, isMultiplicityVar,
        unrestricted, linear, tymult,
        mkScaled, irrelevantMult, scaledSet,
        pattern OneTy, pattern ManyTy,
        isOneTy, isManyTy,
        isLinearType,

        -- * Main data types representing Kinds
        Kind,

        -- ** Finding the kind of a type
        typeKind, typeHasFixedRuntimeRep,
        tcIsLiftedTypeKind,
        isConstraintKind, isConstraintLikeKind, returnsConstraintKind,
        tcIsBoxedTypeKind, isTypeLikeKind,

        -- ** Common Kind
        liftedTypeKind, unliftedTypeKind,

        -- * Type free variables
        tyCoVarsOfType, tyCoVarsOfTypes, tyCoVarsOfTypeDSet,
        coVarsOfType, coVarsOfTypes,

        anyFreeVarsOfType, anyFreeVarsOfTypes,
        noFreeVarsOfType,
        expandTypeSynonyms, expandSynTyConApp_maybe,
        typeSize, occCheckExpand,

        -- ** Closing over kinds
        closeOverKindsDSet,
        closeOverKinds,

        -- * Forcing evaluation of types
        seqType, seqTypes,

        -- * Other views onto Types
        coreView, coreFullView, rewriterView,

        tyConsOfType,

        -- * Main type substitution data types
        TvSubstEnv,     -- Representation widely visible
        IdSubstEnv,
        Subst(..),    -- Representation visible to a few friends

        -- ** Manipulating type substitutions
        emptyTvSubstEnv, emptySubst, mkEmptySubst,

        mkTCvSubst, zipTvSubst, mkTvSubstPrs,
        zipTCvSubst,
        notElemSubst,
        getTvSubstEnv,
        zapSubst, substInScopeSet, setInScope, getSubstRangeTyCoFVs,
        extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,
        extendTCvSubst, extendCvSubst,
        extendTvSubst, extendTvSubstList, extendTvSubstAndInScope,
        extendTCvSubstList,
        extendTvSubstWithClone,
        extendTCvSubstWithClone,
        isInScope, composeTCvSubst, zipTyEnv, zipCoEnv,
        isEmptySubst, unionSubst, isEmptyTCvSubst,

        -- ** Performing substitution on types and kinds
        substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta,
        substTyAddInScope,
        substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked,
        substThetaUnchecked, substTyWithUnchecked,
        substCo, substCoWithInScope,
        substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,
        substVarBndr, substVarBndrs,
        substTyCoBndr, substTyVarToTyVar,
        cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,

        -- * Kinds
        isTYPEorCONSTRAINT,
        isConcreteType,
        isFixedRuntimeRepKind
    ) where

import GHC.Prelude

import GHC.Types.Basic

-- We import the representation and primitive functions from GHC.Core.TyCo.Rep.
-- Many things are reexported, but not the representation!

import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Subst
import GHC.Core.TyCo.FVs

-- friends:
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set

import GHC.Core.TyCon
import GHC.Builtin.Types.Prim

import {-# SOURCE #-} GHC.Builtin.Types
   ( charTy, naturalTy
   , typeSymbolKind, liftedTypeKind, unliftedTypeKind
   , constraintKind, zeroBitTypeKind
   , manyDataConTy, oneDataConTy
   , liftedRepTy, unliftedRepTy, zeroBitRepTy )

import GHC.Types.Name( Name )
import GHC.Builtin.Names
import GHC.Core.Coercion.Axiom

import {-# SOURCE #-} GHC.Core.Coercion
   ( mkNomReflCo, mkGReflCo, mkReflCo
   , mkTyConAppCo, mkAppCo
   , mkForAllCo, mkFunCo2, mkAxiomCo, mkUnivCo
   , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo
   , mkKindCo, mkSubCo, mkFunCo, funRole
   , decomposePiCos, coercionKind
   , coercionRKind, coercionType
   , isReflexiveCo, seqCo
   , topNormaliseNewType_maybe
   )
import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar )

-- others
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString

import GHC.Data.Maybe   ( orElse, isJust )
import GHC.List (build)

-- $type_classification
-- #type_classification#
--
-- Types are any, but at least one, of:
--
-- [Boxed]              Iff its representation is a pointer to an object on the
--                      GC'd heap. Operationally, heap objects can be entered as
--                      a means of evaluation.
--
-- [Lifted]             Iff it has bottom as an element: An instance of a
--                      lifted type might diverge when evaluated.
--                      GHC Haskell's unboxed types are unlifted.
--                      An unboxed, but lifted type is not very useful.
--                      (Example: A byte-represented type, where evaluating 0xff
--                      computes the 12345678th collatz number modulo 0xff.)
--                      Only lifted types may be unified with a type variable.
--
-- [Algebraic]          Iff it is a type with one or more constructors, whether
--                      declared with @data@ or @newtype@.
--                      An algebraic type is one that can be deconstructed
--                      with a case expression. There are algebraic types that
--                      are not lifted types, like unlifted data types or
--                      unboxed tuples.
--
-- [Data]               Iff it is a type declared with @data@, or a boxed tuple.
--                      There are also /unlifted/ data types.
--
-- [Primitive]          Iff it is a built-in type that can't be expressed in Haskell.
--
-- [Unlifted]           Anything that isn't lifted is considered unlifted.
--
-- Currently, all primitive types are unlifted, but that's not necessarily
-- the case: for example, @Int@ could be primitive.
--
-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed
-- but unlifted (such as @ByteArray#@).  The only primitive types that we
-- classify as algebraic are the unboxed tuples.
--
-- Some examples of type classifications that may make this a bit clearer are:
--
-- @
-- Type          primitive       boxed           lifted          algebraic
-- -----------------------------------------------------------------------------
-- Int#          Yes             No              No              No
-- ByteArray#    Yes             Yes             No              No
-- (\# a, b \#)  Yes             No              No              Yes
-- (\# a | b \#) Yes             No              No              Yes
-- (  a, b  )    No              Yes             Yes             Yes
-- [a]           No              Yes             Yes             Yes
-- @

-- $representation_types
-- A /source type/ is a type that is a separate type as far as the type checker is
-- concerned, but which has a more low-level representation as far as Core-to-Core
-- passes and the rest of the back end is concerned.
--
-- You don't normally have to worry about this, as the utility functions in
-- this module will automatically convert a source into a representation type
-- if they are spotted, to the best of its abilities. If you don't want this
-- to happen, use the equivalent functions from the "TcType" module.

{-
************************************************************************
*                                                                      *
                Type representation
*                                                                      *
************************************************************************
-}

rewriterView :: Type -> Maybe Type
-- Unwrap a type synonym only when either:
--   The type synonym is forgetful, or
--   the type synonym mentions a type family in its expansion
-- See Note [Rewriting synonyms]
{-# INLINE rewriterView #-}
rewriterView :: Type -> Maybe Type
rewriterView (TyConApp TyCon
tc [Type]
tys)
  | TyCon -> Bool
isTypeSynonymTyCon TyCon
tc
  , TyCon -> Bool
isForgetfulSynTyCon TyCon
tc Bool -> Bool -> Bool
|| Bool -> Bool
not (TyCon -> Bool
isFamFreeTyCon TyCon
tc)
  = TyCon -> [Type] -> Maybe Type
expandSynTyConApp_maybe TyCon
tc [Type]
tys
rewriterView Type
_other
  = Maybe Type
forall a. Maybe a
Nothing

coreView :: Type -> Maybe Type
-- ^ This function strips off the /top layer only/ of a type synonym
-- application (if any) its underlying representation type.
-- Returns 'Nothing' if there is nothing to look through.
--
-- This function does not look through type family applications.
--
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
coreView :: Type -> Maybe Type
coreView (TyConApp TyCon
tc [Type]
tys) = TyCon -> [Type] -> Maybe Type
expandSynTyConApp_maybe TyCon
tc [Type]
tys
coreView Type
_                 = Maybe Type
forall a. Maybe a
Nothing
-- See Note [Inlining coreView].
{-# INLINE coreView #-}

coreFullView, core_full_view :: Type -> Type
-- ^ Iterates 'coreView' until there is no more to synonym to expand.
-- NB: coreFullView is non-recursive and can be inlined;
--     core_full_view is the recursive one
-- See Note [Inlining coreView].
coreFullView :: Type -> Type
coreFullView ty :: Type
ty@(TyConApp TyCon
tc [Type]
_)
  | TyCon -> Bool
isTypeSynonymTyCon TyCon
tc = Type -> Type
core_full_view Type
ty
coreFullView Type
ty = Type
ty
{-# INLINE coreFullView #-}

core_full_view :: Type -> Type
core_full_view Type
ty
  | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type
core_full_view Type
ty'
  | Bool
otherwise               = Type
ty

-----------------------------------------------
-- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@
-- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a
-- synonym.
expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type
{-# INLINE expandSynTyConApp_maybe #-}
-- This INLINE will inline the call to expandSynTyConApp_maybe in coreView,
-- which will eliminate the allocation Just/Nothing in the result
-- Don't be tempted to make `expand_syn` (which is NOINLINE) return the
-- Just/Nothing, else you'll increase allocation
expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type
expandSynTyConApp_maybe TyCon
tc [Type]
arg_tys
  | Just ([TyVar]
tvs, Type
rhs) <- TyCon -> Maybe ([TyVar], Type)
synTyConDefn_maybe TyCon
tc
  , [Type]
arg_tys [Type] -> Arity -> Bool
`saturates` TyCon -> Arity
tyConArity TyCon
tc
  = Type -> Maybe Type
Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$! ([TyVar] -> Type -> [Type] -> Type
expand_syn [TyVar]
tvs Type
rhs [Type]
arg_tys)
    -- Why strict application? Because every client of this function will evaluat
    -- that (expand_syn ...) thunk, so it's more efficient not to build a thunk.
    -- Mind you, this function is always INLINEd, so the client context is probably
    -- enough to avoid thunk construction and so the $! is just belt-and-braces.
  | Bool
otherwise
  = Maybe Type
forall a. Maybe a
Nothing

saturates :: [Type] -> Arity -> Bool
saturates :: [Type] -> Arity -> Bool
saturates [Type]
_       Arity
0 = Bool
True
saturates []      Arity
_ = Bool
False
saturates (Type
_:[Type]
tys) Arity
n = Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert( Arity
n Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
>= Arity
0 ) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Type] -> Arity -> Bool
saturates [Type]
tys (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1)
                       -- Arities are always positive; the assertion just checks
                       -- that, to avoid an infinite loop in the bad case

-- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path
-- into call-sites.
--
-- Precondition: the call is saturated or over-saturated;
--               i.e. length tvs <= length arg_tys
expand_syn :: [TyVar]  -- ^ the variables bound by the synonym
           -> Type     -- ^ the RHS of the synonym
           -> [Type]   -- ^ the type arguments the synonym is instantiated at.
           -> Type
{-# NOINLINE expand_syn #-} -- We never want to inline this cold-path.

expand_syn :: [TyVar] -> Type -> [Type] -> Type
expand_syn [TyVar]
tvs Type
rhs [Type]
arg_tys
  -- No substitution necessary if either tvs or tys is empty
  -- This is both more efficient, and steers clear of an infinite
  -- loop; see Note [Care using synonyms to compress types]
  | [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
arg_tys  = Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert ([TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
tvs) Type
rhs
  | [TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
tvs      = Type -> [Type] -> Type
mkAppTys Type
rhs [Type]
arg_tys
  | Bool
otherwise     = Subst -> [TyVar] -> [Type] -> Type
go Subst
empty_subst [TyVar]
tvs [Type]
arg_tys
  where
    empty_subst :: Subst
empty_subst = InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
    in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [Type] -> VarSet
tyCoVarsOfTypes ([Type] -> VarSet) -> [Type] -> VarSet
forall a b. (a -> b) -> a -> b
$ [Type]
arg_tys
      -- The free vars of 'rhs' should all be bound by 'tenv',
      -- so we only need the free vars of tys
      -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.

    go :: Subst -> [TyVar] -> [Type] -> Type
go Subst
subst [] [Type]
tys
      | [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys  = Type
rhs'  -- Exactly Saturated
      | Bool
otherwise = Type -> [Type] -> Type
mkAppTys Type
rhs' [Type]
tys
          -- Its important to use mkAppTys, rather than (foldl AppTy),
          -- because the function part might well return a
          -- partially-applied type constructor; indeed, usually will!
      where
        rhs' :: Type
rhs' = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
rhs

    go Subst
subst (TyVar
tv:[TyVar]
tvs) (Type
ty:[Type]
tys) = Subst -> [TyVar] -> [Type] -> Type
go (HasDebugCallStack => Subst -> TyVar -> Type -> Subst
Subst -> TyVar -> Type -> Subst
extendTvSubst Subst
subst TyVar
tv Type
ty) [TyVar]
tvs [Type]
tys

    go Subst
_ (TyVar
_:[TyVar]
_) [] = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"expand_syn" ([TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
arg_tys)
                   -- Under-saturated, precondition failed

{- Note [Inlining coreView]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
It is very common to have a function

  f :: Type -> ...
  f ty | Just ty' <- coreView ty = f ty'
  f (TyVarTy ...) = ...
  f ...           = ...

If f is not otherwise recursive, the initial call to coreView
causes f to become recursive, which kills the possibility of
inlining. Instead, for non-recursive functions, we prefer to
use coreFullView, which guarantees to unwrap top-level type
synonyms. It can be inlined and is efficient and non-allocating
in its fast path. For this to really be fast, all calls made
on its fast path must also be inlined, linked back to this Note.
-}


{- *********************************************************************
*                                                                      *
                expandTypeSynonyms
*                                                                      *
********************************************************************* -}

expandTypeSynonyms :: Type -> Type
-- ^ Expand out all type synonyms.  Actually, it'd suffice to expand out
-- just the ones that discard type variables (e.g.  type Funny a = Int)
-- But we don't know which those are currently, so we just expand all.
--
-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type,
-- not in the kinds of any TyCon or TyVar mentioned in the type.
--
-- Keep this synchronized with 'synonymTyConsOfType'
expandTypeSynonyms :: Type -> Type
expandTypeSynonyms Type
ty
  = Subst -> Type -> Type
go (InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope) Type
ty
  where
    in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (Type -> VarSet
tyCoVarsOfType Type
ty)

    go :: Subst -> Type -> Type
go Subst
subst (TyConApp TyCon
tc [Type]
tys)
      | ExpandsSyn [(TyVar, Type)]
tenv Type
rhs [Type]
tys' <- TyCon -> [Type] -> ExpandSynResult Type
forall tyco. TyCon -> [tyco] -> ExpandSynResult tyco
expandSynTyCon_maybe TyCon
tc [Type]
expanded_tys
      = let subst' :: Subst
subst' = InScopeSet -> TvSubstEnv -> Subst
mkTvSubst InScopeSet
in_scope ([(TyVar, Type)] -> TvSubstEnv
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv [(TyVar, Type)]
tenv)
            -- Make a fresh substitution; rhs has nothing to
            -- do with anything that has happened so far
            -- NB: if you make changes here, be sure to build an
            --     /idempotent/ substitution, even in the nested case
            --        type T a b = a -> b
            --        type S x y = T y x
            -- (#11665)
        in  Type -> [Type] -> Type
mkAppTys (Subst -> Type -> Type
go Subst
subst' Type
rhs) [Type]
tys'
      | Bool
otherwise
      = TyCon -> [Type] -> Type
TyConApp TyCon
tc [Type]
expanded_tys
      where
        expanded_tys :: [Type]
expanded_tys = ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> Type -> Type
go Subst
subst) [Type]
tys)

    go Subst
_     (LitTy TyLit
l)     = TyLit -> Type
LitTy TyLit
l
    go Subst
subst (TyVarTy TyVar
tv)  = Subst -> TyVar -> Type
substTyVar Subst
subst TyVar
tv
    go Subst
subst (AppTy Type
t1 Type
t2) = Type -> Type -> Type
mkAppTy (Subst -> Type -> Type
go Subst
subst Type
t1) (Subst -> Type -> Type
go Subst
subst Type
t2)
    go Subst
subst ty :: Type
ty@(FunTy FunTyFlag
_ Type
mult Type
arg Type
res)
      = Type
ty { ft_mult = go subst mult, ft_arg = go subst arg, ft_res = go subst res }
    go Subst
subst (ForAllTy (Bndr TyVar
tv ForAllTyFlag
vis) Type
t)
      = let (Subst
subst', TyVar
tv') = (Subst -> Type -> Type) -> Subst -> TyVar -> (Subst, TyVar)
substVarBndrUsing Subst -> Type -> Type
go Subst
subst TyVar
tv in
        VarBndr TyVar ForAllTyFlag -> Type -> Type
ForAllTy (TyVar -> ForAllTyFlag -> VarBndr TyVar ForAllTyFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' ForAllTyFlag
vis) (Subst -> Type -> Type
go Subst
subst' Type
t)
    go Subst
subst (CastTy Type
ty KindCoercion
co)  = Type -> KindCoercion -> Type
mkCastTy (Subst -> Type -> Type
go Subst
subst Type
ty) (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co)
    go Subst
subst (CoercionTy KindCoercion
co) = KindCoercion -> Type
mkCoercionTy (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co)

    go_mco :: Subst -> KindMCoercion -> KindMCoercion
go_mco Subst
_     KindMCoercion
MRefl    = KindMCoercion
MRefl
    go_mco Subst
subst (MCo KindCoercion
co) = KindCoercion -> KindMCoercion
MCo (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co)

    go_co :: Subst -> KindCoercion -> KindCoercion
go_co Subst
subst (Refl Type
ty)
      = Type -> KindCoercion
mkNomReflCo (Subst -> Type -> Type
go Subst
subst Type
ty)
    go_co Subst
subst (GRefl Role
r Type
ty KindMCoercion
mco)
      = Role -> Type -> KindMCoercion -> KindCoercion
mkGReflCo Role
r (Subst -> Type -> Type
go Subst
subst Type
ty) (Subst -> KindMCoercion -> KindMCoercion
go_mco Subst
subst KindMCoercion
mco)
       -- NB: coercions are always expanded upon creation
    go_co Subst
subst (TyConAppCo Role
r TyCon
tc [KindCoercion]
args)
      = HasDebugCallStack =>
Role -> TyCon -> [KindCoercion] -> KindCoercion
Role -> TyCon -> [KindCoercion] -> KindCoercion
mkTyConAppCo Role
r TyCon
tc ((KindCoercion -> KindCoercion) -> [KindCoercion] -> [KindCoercion]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst) [KindCoercion]
args)
    go_co Subst
subst (AppCo KindCoercion
co KindCoercion
arg)
      = KindCoercion -> KindCoercion -> KindCoercion
mkAppCo (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co) (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
arg)
    go_co Subst
subst (ForAllCo { fco_tcv :: KindCoercion -> TyVar
fco_tcv = TyVar
tcv, fco_visL :: KindCoercion -> ForAllTyFlag
fco_visL = ForAllTyFlag
visL, fco_visR :: KindCoercion -> ForAllTyFlag
fco_visR = ForAllTyFlag
visR
                          , fco_kind :: KindCoercion -> KindMCoercion
fco_kind = KindMCoercion
kind_co, fco_body :: KindCoercion -> KindCoercion
fco_body = KindCoercion
co })
      = HasDebugCallStack =>
TyVar
-> ForAllTyFlag
-> ForAllTyFlag
-> KindMCoercion
-> KindCoercion
-> KindCoercion
TyVar
-> ForAllTyFlag
-> ForAllTyFlag
-> KindMCoercion
-> KindCoercion
-> KindCoercion
mkForAllCo TyVar
tcv' ForAllTyFlag
visL ForAllTyFlag
visR
                   (Subst -> KindMCoercion -> KindMCoercion
go_mco Subst
subst KindMCoercion
kind_co)
                   (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst' KindCoercion
co)
      where
        (Subst
subst', TyVar
tcv') = HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar)
Subst -> TyVar -> (Subst, TyVar)
substVarBndr Subst
subst TyVar
tcv
    go_co Subst
subst (FunCo Role
r FunTyFlag
afl FunTyFlag
afr KindCoercion
w KindCoercion
co1 KindCoercion
co2)
      = Role
-> FunTyFlag
-> FunTyFlag
-> KindCoercion
-> KindCoercion
-> KindCoercion
-> KindCoercion
mkFunCo2 Role
r FunTyFlag
afl FunTyFlag
afr (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
w) (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co1) (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co2)
    go_co Subst
subst (CoVarCo TyVar
cv)
      = Subst -> TyVar -> KindCoercion
substCoVar Subst
subst TyVar
cv
    go_co Subst
subst (AxiomCo CoAxiomRule
ax [KindCoercion]
cs)
      = CoAxiomRule -> [KindCoercion] -> KindCoercion
mkAxiomCo CoAxiomRule
ax ((KindCoercion -> KindCoercion) -> [KindCoercion] -> [KindCoercion]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst) [KindCoercion]
cs)
    go_co Subst
subst co :: KindCoercion
co@(UnivCo { uco_lty :: KindCoercion -> Type
uco_lty = Type
lty, uco_rty :: KindCoercion -> Type
uco_rty = Type
rty })
      = KindCoercion
co { uco_lty = go subst lty, uco_rty = go subst rty }
    go_co Subst
subst (SymCo KindCoercion
co)
      = KindCoercion -> KindCoercion
mkSymCo (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co)
    go_co Subst
subst (TransCo KindCoercion
co1 KindCoercion
co2)
      = HasDebugCallStack => KindCoercion -> KindCoercion -> KindCoercion
KindCoercion -> KindCoercion -> KindCoercion
mkTransCo (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co1) (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co2)
    go_co Subst
subst (SelCo CoSel
n KindCoercion
co)
      = HasDebugCallStack => CoSel -> KindCoercion -> KindCoercion
CoSel -> KindCoercion -> KindCoercion
mkSelCo CoSel
n (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co)
    go_co Subst
subst (LRCo LeftOrRight
lr KindCoercion
co)
      = LeftOrRight -> KindCoercion -> KindCoercion
mkLRCo LeftOrRight
lr (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co)
    go_co Subst
subst (InstCo KindCoercion
co KindCoercion
arg)
      = KindCoercion -> KindCoercion -> KindCoercion
mkInstCo (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co) (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
arg)
    go_co Subst
subst (KindCo KindCoercion
co)
      = KindCoercion -> KindCoercion
mkKindCo (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co)
    go_co Subst
subst (SubCo KindCoercion
co)
      = HasDebugCallStack => KindCoercion -> KindCoercion
KindCoercion -> KindCoercion
mkSubCo (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co)
    go_co Subst
_ (HoleCo CoercionHole
h)
      = String -> SDoc -> KindCoercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"expandTypeSynonyms hit a hole" (CoercionHole -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionHole
h)

{- Notes on type synonyms
~~~~~~~~~~~~~~~~~~~~~~~~~
The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
to return type synonyms wherever possible. Thus

        type Foo a = a -> a

we want
        splitFunTys (a -> Foo a) = ([a], Foo a)
not                                ([a], a -> a)

The reason is that we then get better (shorter) type signatures in
interfaces.  Notably this plays a role in tcTySigs in GHC.Tc.Gen.Bind.
-}

{- *********************************************************************
*                                                                      *
                Random functions (todo: organise)
*                                                                      *
********************************************************************* -}

-- | An INLINE helper for function such as 'kindRep_maybe' below.
--
-- @isTyConKeyApp_maybe key ty@ returns @Just tys@ iff
-- the type @ty = T tys@, where T's unique = key
-- key must not be `fUNTyConKey`; to test for functions, use `splitFunTy_maybe`.
-- Thanks to this fact, we don't have to pattern match on `FunTy` here.
isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type]
isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type]
isTyConKeyApp_maybe Unique
key Type
ty
  | TyConApp TyCon
tc [Type]
args <- Type -> Type
coreFullView Type
ty
  , TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
key
  = [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type]
args
  | Bool
otherwise
  = Maybe [Type]
forall a. Maybe a
Nothing
{-# INLINE isTyConKeyApp_maybe #-}

-- | Extract the RuntimeRep classifier of a type from its kind. For example,
-- @kindRep * = LiftedRep@; Panics if this is not possible.
-- Treats * and Constraint as the same
kindRep :: HasDebugCallStack => Kind -> RuntimeRepType
kindRep :: HasDebugCallStack => Type -> Type
kindRep Type
k = case HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
k of
              Just Type
r  -> Type
r
              Maybe Type
Nothing -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"kindRep" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k)

-- | Given a kind (TYPE rr) or (CONSTRAINT rr), extract its RuntimeRep classifier rr.
-- For example, @kindRep_maybe * = Just LiftedRep@
-- Returns 'Nothing' if the kind is not of form (TYPE rr)
kindRep_maybe :: HasDebugCallStack => Kind -> Maybe RuntimeRepType
kindRep_maybe :: HasDebugCallStack => Type -> Maybe Type
kindRep_maybe Type
kind
  | Just (TypeOrConstraint
_, Type
rep) <- Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
kind = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
rep
  | Bool
otherwise                            = Maybe Type
forall a. Maybe a
Nothing

-- | Returns True if the argument is (lifted) Type or Constraint
-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim
isLiftedTypeKind :: Kind -> Bool
isLiftedTypeKind :: Type -> Bool
isLiftedTypeKind Type
kind
  = case HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
kind of
      Just Type
rep -> Type -> Bool
isLiftedRuntimeRep Type
rep
      Maybe Type
Nothing  -> Bool
False

-- | Returns True if the kind classifies unlifted types (like 'Int#') and False
-- otherwise. Note that this returns False for representation-polymorphic
-- kinds, which may be specialized to a kind that classifies unlifted types.
isUnliftedTypeKind :: Kind -> Bool
isUnliftedTypeKind :: Type -> Bool
isUnliftedTypeKind Type
kind
  = case HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
kind of
      Just Type
rep -> Type -> Bool
isUnliftedRuntimeRep Type
rep
      Maybe Type
Nothing  -> Bool
False

pickyIsLiftedTypeKind :: Kind -> Bool
-- Checks whether the kind is literally
--      TYPE LiftedRep
-- or   TYPE ('BoxedRep 'Lifted)
-- or   Type
-- without expanding type synonyms or anything
-- Used only when deciding whether to suppress the ":: *" in
-- (a :: *) when printing kinded type variables
-- See Note [Suppressing * kinds] in GHC.Core.TyCo.Ppr
pickyIsLiftedTypeKind :: Type -> Bool
pickyIsLiftedTypeKind Type
kind
  | TyConApp TyCon
tc [Type
arg] <- Type
kind
  , TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tYPETyConKey
  , TyConApp TyCon
rr_tc [Type]
rr_args <- Type
arg = case [Type]
rr_args of
      [] -> TyCon
rr_tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
liftedRepTyConKey
      [Type
rr_arg]
        | TyCon
rr_tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boxedRepDataConKey
        , TyConApp TyCon
lev [] <- Type
rr_arg
        , TyCon
lev TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
liftedDataConKey -> Bool
True
      [Type]
_ -> Bool
False
  | TyConApp TyCon
tc [] <- Type
kind
  , TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
liftedTypeKindTyConKey = Bool
True
  | Bool
otherwise                          = Bool
False

-- | Check whether a kind is of the form `TYPE (BoxedRep Lifted)`
-- or `TYPE (BoxedRep Unlifted)`.
--
-- Returns:
--
--  - `Just Lifted` for `TYPE (BoxedRep Lifted)` and `Type`,
--  - `Just Unlifted` for `TYPE (BoxedRep Unlifted)` and `UnliftedType`,
--  - `Nothing` for anything else, e.g. `TYPE IntRep`, `TYPE (BoxedRep l)`, etc.
kindBoxedRepLevity_maybe :: Type -> Maybe Levity
kindBoxedRepLevity_maybe :: Type -> Maybe Levity
kindBoxedRepLevity_maybe Type
ty
  | Just Type
rep <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
ty
  , Type -> Bool
isBoxedRuntimeRep Type
rep
  = Type -> Maybe Levity
runtimeRepLevity_maybe Type
rep
  | Bool
otherwise
  = Maybe Levity
forall a. Maybe a
Nothing

-- | Check whether a type of kind 'RuntimeRep' is lifted.
--
-- 'isLiftedRuntimeRep' is:
--
--  * True of @LiftedRep :: RuntimeRep@
--  * False of type variables, type family applications,
--    and of other reps such as @IntRep :: RuntimeRep@.
isLiftedRuntimeRep :: RuntimeRepType -> Bool
isLiftedRuntimeRep :: Type -> Bool
isLiftedRuntimeRep Type
rep
  = Type -> Maybe Levity
runtimeRepLevity_maybe Type
rep Maybe Levity -> Maybe Levity -> Bool
forall a. Eq a => a -> a -> Bool
== Levity -> Maybe Levity
forall a. a -> Maybe a
Just Levity
Lifted

-- | Check whether a type of kind 'RuntimeRep' is unlifted.
--
--  * True of definitely unlifted 'RuntimeRep's such as
--    'UnliftedRep', 'IntRep', 'FloatRep', ...
--  * False of 'LiftedRep',
--  * False for type variables and type family applications.
isUnliftedRuntimeRep :: RuntimeRepType -> Bool
isUnliftedRuntimeRep :: Type -> Bool
isUnliftedRuntimeRep Type
rep =
  Type -> Maybe Levity
runtimeRepLevity_maybe Type
rep Maybe Levity -> Maybe Levity -> Bool
forall a. Eq a => a -> a -> Bool
== Levity -> Maybe Levity
forall a. a -> Maybe a
Just Levity
Unlifted

-- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'.
--
-- Checks whether the type is a nullary 'TyCon' application,
-- for a 'TyCon' with the given 'Unique'.
isNullaryTyConKeyApp :: Unique -> Type -> Bool
isNullaryTyConKeyApp :: Unique -> Type -> Bool
isNullaryTyConKeyApp Unique
key Type
ty
  | Just [Type]
args <- Unique -> Type -> Maybe [Type]
isTyConKeyApp_maybe Unique
key Type
ty
  = Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args) Bool
True
  | Bool
otherwise
  = Bool
False
{-# INLINE isNullaryTyConKeyApp #-}

isLiftedLevity :: Type -> Bool
isLiftedLevity :: Type -> Bool
isLiftedLevity = Unique -> Type -> Bool
isNullaryTyConKeyApp Unique
liftedDataConKey

isUnliftedLevity :: Type -> Bool
isUnliftedLevity :: Type -> Bool
isUnliftedLevity = Unique -> Type -> Bool
isNullaryTyConKeyApp Unique
unliftedDataConKey

-- | Is this the type 'Levity'?
isLevityTy :: Type -> Bool
isLevityTy :: Type -> Bool
isLevityTy = Unique -> Type -> Bool
isNullaryTyConKeyApp Unique
levityTyConKey

-- | Is this the type 'RuntimeRep'?
isRuntimeRepTy :: Type -> Bool
isRuntimeRepTy :: Type -> Bool
isRuntimeRepTy = Unique -> Type -> Bool
isNullaryTyConKeyApp Unique
runtimeRepTyConKey

-- | Is a tyvar of type 'RuntimeRep'?
isRuntimeRepVar :: TyVar -> Bool
isRuntimeRepVar :: TyVar -> Bool
isRuntimeRepVar = Type -> Bool
isRuntimeRepTy (Type -> Bool) -> (TyVar -> Type) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Type
tyVarKind

-- | Is a tyvar of type 'Levity'?
isLevityVar :: TyVar -> Bool
isLevityVar :: TyVar -> Bool
isLevityVar = Type -> Bool
isLevityTy (Type -> Bool) -> (TyVar -> Type) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Type
tyVarKind

-- | Is this the type 'Multiplicity'?
isMultiplicityTy :: Type -> Bool
isMultiplicityTy :: Type -> Bool
isMultiplicityTy  = Unique -> Type -> Bool
isNullaryTyConKeyApp Unique
multiplicityTyConKey

-- | Is a tyvar of type 'Multiplicity'?
isMultiplicityVar :: TyVar -> Bool
isMultiplicityVar :: TyVar -> Bool
isMultiplicityVar = Type -> Bool
isMultiplicityTy (Type -> Bool) -> (TyVar -> Type) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Type
tyVarKind

--------------------------------------------
--  Splitting RuntimeRep
--------------------------------------------

-- | (splitRuntimeRep_maybe rr) takes a Type rr :: RuntimeRep, and
--   returns the (TyCon,[Type]) for the RuntimeRep, if possible, where
--   the TyCon is one of the promoted DataCons of RuntimeRep.
-- Remember: the unique on TyCon that is a a promoted DataCon is the
--           same as the unique on the DataCon
--           See Note [Promoted data constructors] in GHC.Core.TyCon
-- May not be possible if `rr` is a type variable or type
--   family application
splitRuntimeRep_maybe :: RuntimeRepType -> Maybe (TyCon, [Type])
splitRuntimeRep_maybe :: Type -> Maybe (TyCon, [Type])
splitRuntimeRep_maybe Type
rep
  | TyConApp TyCon
rr_tc [Type]
args <- Type -> Type
coreFullView Type
rep
  , TyCon -> Bool
isPromotedDataCon TyCon
rr_tc
    -- isPromotedDataCon: be careful of type families (F tys) :: RuntimeRep,
  = (TyCon, [Type]) -> Maybe (TyCon, [Type])
forall a. a -> Maybe a
Just (TyCon
rr_tc, [Type]
args)
  | Bool
otherwise
  = Maybe (TyCon, [Type])
forall a. Maybe a
Nothing

-- | See 'isBoxedRuntimeRep_maybe'.
isBoxedRuntimeRep :: RuntimeRepType -> Bool
isBoxedRuntimeRep :: Type -> Bool
isBoxedRuntimeRep Type
rep = Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe Type
isBoxedRuntimeRep_maybe Type
rep)

-- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep`
-- expands to `Boxed lev` and returns `Nothing` otherwise.
--
-- Types with this runtime rep are represented by pointers on the GC'd heap.
isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe LevityType
isBoxedRuntimeRep_maybe :: Type -> Maybe Type
isBoxedRuntimeRep_maybe Type
rep
  | Just (TyCon
rr_tc, [Type]
args) <- Type -> Maybe (TyCon, [Type])
splitRuntimeRep_maybe Type
rep
  , TyCon
rr_tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boxedRepDataConKey
  , [Type
lev] <- [Type]
args
  = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
lev
  | Bool
otherwise
  = Maybe Type
forall a. Maybe a
Nothing

-- | Check whether a type (usually of kind 'RuntimeRep') is lifted, unlifted,
--   or unknown.  Returns Nothing if the type isn't of kind 'RuntimeRep'.
--
-- `runtimeRepLevity_maybe rr` returns:
--
--   * `Just Lifted` if `rr` is `LiftedRep :: RuntimeRep`
--   * `Just Unlifted` if `rr` is definitely unlifted, e.g. `IntRep`
--   * `Nothing` if not known (e.g. it's a type variable or a type family application).
runtimeRepLevity_maybe :: RuntimeRepType -> Maybe Levity
runtimeRepLevity_maybe :: Type -> Maybe Levity
runtimeRepLevity_maybe Type
rep
  | Just (TyCon
rr_tc, [Type]
args) <- Type -> Maybe (TyCon, [Type])
splitRuntimeRep_maybe Type
rep
  =       -- NB: args might be non-empty e.g. TupleRep [r1, .., rn]
    if (TyCon
rr_tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boxedRepDataConKey)
    then case [Type]
args of
            [Type
lev] -> Type -> Maybe Levity
levityType_maybe Type
lev
            [Type]
_     -> Maybe Levity
forall a. Maybe a
Nothing  -- Type isn't of kind RuntimeRep
                     -- The latter case happens via the call to isLiftedRuntimeRep
                     -- in GHC.Tc.Errors.Ppr.pprMismatchMsg (#22742)
    else Levity -> Maybe Levity
forall a. a -> Maybe a
Just Levity
Unlifted
        -- Avoid searching all the unlifted RuntimeRep type cons
        -- In the RuntimeRep data type, only LiftedRep is lifted
  | Bool
otherwise
  = Maybe Levity
forall a. Maybe a
Nothing

--------------------------------------------
--  Splitting Levity
--------------------------------------------

-- | `levityType_maybe` takes a Type of kind Levity, and returns its levity
-- May not be possible for a type variable or type family application
levityType_maybe :: LevityType -> Maybe Levity
levityType_maybe :: Type -> Maybe Levity
levityType_maybe Type
lev
  | TyConApp TyCon
lev_tc [Type]
args <- Type -> Type
coreFullView Type
lev
  = if | TyCon
lev_tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
liftedDataConKey   -> Bool -> Maybe Levity -> Maybe Levity
forall a. HasCallStack => Bool -> a -> a
assert( [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args) (Maybe Levity -> Maybe Levity) -> Maybe Levity -> Maybe Levity
forall a b. (a -> b) -> a -> b
$ Levity -> Maybe Levity
forall a. a -> Maybe a
Just Levity
Lifted
       | TyCon
lev_tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unliftedDataConKey -> Bool -> Maybe Levity -> Maybe Levity
forall a. HasCallStack => Bool -> a -> a
assert( [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args) (Maybe Levity -> Maybe Levity) -> Maybe Levity -> Maybe Levity
forall a b. (a -> b) -> a -> b
$ Levity -> Maybe Levity
forall a. a -> Maybe a
Just Levity
Unlifted
       | Bool
otherwise                          -> Maybe Levity
forall a. Maybe a
Nothing
  | Bool
otherwise
  = Maybe Levity
forall a. Maybe a
Nothing


{- *********************************************************************
*                                                                      *
               mapType
*                                                                      *
************************************************************************

These functions do a map-like operation over types, performing some operation
on all variables and binding sites. Primarily used for zonking.

Note [Efficiency for ForAllCo case of mapTyCoX]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As noted in Note [ForAllCo] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant.
It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches
the left-hand kind of the coercion. This is convenient lots of the time, but
not when mapping a function over a coercion.

The problem is that tcm_tybinder will affect the TyCoVar's kind and
mapCoercion will affect the Coercion, and we hope that the results will be
the same. Even if they are the same (which should generally happen with
correct algorithms), then there is an efficiency issue. In particular,
this problem seems to make what should be a linear algorithm into a potentially
exponential one. But it's only going to be bad in the case where there's
lots of foralls in the kinds of other foralls. Like this:

  forall a : (forall b : (forall c : ...). ...). ...

This construction seems unlikely. So we'll do the inefficient, easy way
for now.

Note [Specialising mappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used
to implement zonking, and it's vital that they get specialised to the TcM
monad and the particular mapper in use.

Even specialising to the monad alone made a 20% allocation difference
in perf/compiler/T5030.

See Note [Specialising foldType] in "GHC.Core.TyCo.Rep" for more details of this
idiom.
-}

-- | This describes how a "map" operation over a type/coercion should behave
data TyCoMapper env m
  = TyCoMapper
      { forall env (m :: * -> *).
TyCoMapper env m -> env -> TyVar -> m Type
tcm_tyvar :: env -> TyVar -> m Type
      , forall env (m :: * -> *).
TyCoMapper env m -> env -> TyVar -> m KindCoercion
tcm_covar :: env -> CoVar -> m Coercion
      , forall env (m :: * -> *).
TyCoMapper env m -> env -> CoercionHole -> m KindCoercion
tcm_hole  :: env -> CoercionHole -> m Coercion
          -- ^ What to do with coercion holes.
          -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep".

      , forall env (m :: * -> *).
TyCoMapper env m
-> forall r.
   env -> TyVar -> ForAllTyFlag -> (env -> TyVar -> m r) -> m r
tcm_tycobinder :: forall r. env -> TyCoVar -> ForAllTyFlag
                       -> (env -> TyCoVar -> m r) -> m r
          -- ^ The returned env is used in the extended scope

      , forall env (m :: * -> *). TyCoMapper env m -> TyCon -> m TyCon
tcm_tycon :: TyCon -> m TyCon
          -- ^ This is used only for TcTyCons
          -- a) To zonk TcTyCons
          -- b) To turn TcTyCons into TyCons.
          --    See Note [Type checking recursive type and class declarations]
          --    in "GHC.Tc.TyCl"
      }

{-# INLINE mapTyCo #-}  -- See Note [Specialising mappers]
mapTyCo :: Monad m => TyCoMapper () m
        -> ( Type       -> m  Type
           , [Type]     -> m  [Type]
           , Coercion   -> m  Coercion
           , [Coercion] -> m [Coercion] )
mapTyCo :: forall (m :: * -> *).
Monad m =>
TyCoMapper () m
-> (Type -> m Type, [Type] -> m [Type],
    KindCoercion -> m KindCoercion, [KindCoercion] -> m [KindCoercion])
mapTyCo TyCoMapper () m
mapper
  = case TyCoMapper () m
-> (() -> Type -> m Type, () -> [Type] -> m [Type],
    () -> KindCoercion -> m KindCoercion,
    () -> [KindCoercion] -> m [KindCoercion])
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m
-> (env -> Type -> m Type, env -> [Type] -> m [Type],
    env -> KindCoercion -> m KindCoercion,
    env -> [KindCoercion] -> m [KindCoercion])
mapTyCoX TyCoMapper () m
mapper of
     (() -> Type -> m Type
go_ty, () -> [Type] -> m [Type]
go_tys, () -> KindCoercion -> m KindCoercion
go_co, () -> [KindCoercion] -> m [KindCoercion]
go_cos)
        -> (() -> Type -> m Type
go_ty (), () -> [Type] -> m [Type]
go_tys (), () -> KindCoercion -> m KindCoercion
go_co (), () -> [KindCoercion] -> m [KindCoercion]
go_cos ())

{-# INLINE mapTyCoX #-}  -- See Note [Specialising mappers]
mapTyCoX :: forall m env. Monad m
         => TyCoMapper env m
         -> ( env -> Type       -> m Type
            , env -> [Type]     -> m [Type]
            , env -> Coercion   -> m Coercion
            , env -> [Coercion] -> m [Coercion] )
mapTyCoX :: forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m
-> (env -> Type -> m Type, env -> [Type] -> m [Type],
    env -> KindCoercion -> m KindCoercion,
    env -> [KindCoercion] -> m [KindCoercion])
mapTyCoX (TyCoMapper { tcm_tyvar :: forall env (m :: * -> *).
TyCoMapper env m -> env -> TyVar -> m Type
tcm_tyvar = env -> TyVar -> m Type
tyvar
                     , tcm_tycobinder :: forall env (m :: * -> *).
TyCoMapper env m
-> forall r.
   env -> TyVar -> ForAllTyFlag -> (env -> TyVar -> m r) -> m r
tcm_tycobinder = forall r.
env -> TyVar -> ForAllTyFlag -> (env -> TyVar -> m r) -> m r
tycobinder
                     , tcm_tycon :: forall env (m :: * -> *). TyCoMapper env m -> TyCon -> m TyCon
tcm_tycon = TyCon -> m TyCon
tycon
                     , tcm_covar :: forall env (m :: * -> *).
TyCoMapper env m -> env -> TyVar -> m KindCoercion
tcm_covar = env -> TyVar -> m KindCoercion
covar
                     , tcm_hole :: forall env (m :: * -> *).
TyCoMapper env m -> env -> CoercionHole -> m KindCoercion
tcm_hole = env -> CoercionHole -> m KindCoercion
cohole })
  = (env -> Type -> m Type
go_ty, env -> [Type] -> m [Type]
go_tys, env -> KindCoercion -> m KindCoercion
go_co, env -> [KindCoercion] -> m [KindCoercion]
go_cos)
  where
    -- See Note [Use explicit recursion in mapTyCo]
    go_tys :: env -> [Type] -> m [Type]
go_tys !env
_   []       = [Type] -> m [Type]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go_tys !env
env (Type
ty:[Type]
tys) = (:) (Type -> [Type] -> [Type]) -> m Type -> m ([Type] -> [Type])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Type -> m Type
go_ty env
env Type
ty m ([Type] -> [Type]) -> m [Type] -> m [Type]
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> [Type] -> m [Type]
go_tys env
env [Type]
tys

    go_ty :: env -> Type -> m Type
go_ty !env
env (TyVarTy TyVar
tv)    = env -> TyVar -> m Type
tyvar env
env TyVar
tv
    go_ty !env
env (AppTy Type
t1 Type
t2)   = Type -> Type -> Type
mkAppTy (Type -> Type -> Type) -> m Type -> m (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Type -> m Type
go_ty env
env Type
t1 m (Type -> Type) -> m Type -> m Type
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> Type -> m Type
go_ty env
env Type
t2
    go_ty !env
_   ty :: Type
ty@(LitTy {})   = Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    go_ty !env
env (CastTy Type
ty KindCoercion
co)  = Type -> KindCoercion -> Type
mkCastTy (Type -> KindCoercion -> Type)
-> m Type -> m (KindCoercion -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Type -> m Type
go_ty env
env Type
ty m (KindCoercion -> Type) -> m KindCoercion -> m Type
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co
    go_ty !env
env (CoercionTy KindCoercion
co) = KindCoercion -> Type
KindCoercion -> Type
CoercionTy (KindCoercion -> Type) -> m KindCoercion -> m Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co

    go_ty !env
env ty :: Type
ty@(FunTy FunTyFlag
_ Type
w Type
arg Type
res)
      = do { w' <- env -> Type -> m Type
go_ty env
env Type
w; arg' <- go_ty env arg; res' <- go_ty env res
           ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) }

    go_ty !env
env ty :: Type
ty@(TyConApp TyCon
tc [Type]
tys)
      | TyCon -> Bool
isTcTyCon TyCon
tc
      = do { tc' <- TyCon -> m TyCon
tycon TyCon
tc
           ; mkTyConApp tc' <$> go_tys env tys }

      -- Not a TcTyCon
      | [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys    -- Avoid allocation in this very
      = Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty   -- common case (E.g. Int, LiftedRep etc)

      | Bool
otherwise
      = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Type] -> Type) -> m [Type] -> m Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> [Type] -> m [Type]
go_tys env
env [Type]
tys

    go_ty !env
env (ForAllTy (Bndr TyVar
tv ForAllTyFlag
vis) Type
inner)
      = do { env -> TyVar -> ForAllTyFlag -> (env -> TyVar -> m Type) -> m Type
forall r.
env -> TyVar -> ForAllTyFlag -> (env -> TyVar -> m r) -> m r
tycobinder env
env TyVar
tv ForAllTyFlag
vis ((env -> TyVar -> m Type) -> m Type)
-> (env -> TyVar -> m Type) -> m Type
forall a b. (a -> b) -> a -> b
$ \env
env' TyVar
tv' -> do
           ; inner' <- env -> Type -> m Type
go_ty env
env' Type
inner
           ; return $ ForAllTy (Bndr tv' vis) inner' }

    -- See Note [Use explicit recursion in mapTyCo]
    go_cos :: env -> [KindCoercion] -> m [KindCoercion]
go_cos !env
_   []       = [KindCoercion] -> m [KindCoercion]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go_cos !env
env (KindCoercion
co:[KindCoercion]
cos) = (:) (KindCoercion -> [KindCoercion] -> [KindCoercion])
-> m KindCoercion -> m ([KindCoercion] -> [KindCoercion])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co m ([KindCoercion] -> [KindCoercion])
-> m [KindCoercion] -> m [KindCoercion]
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> [KindCoercion] -> m [KindCoercion]
go_cos env
env [KindCoercion]
cos

    go_mco :: env -> KindMCoercion -> m KindMCoercion
go_mco !env
_   KindMCoercion
MRefl    = KindMCoercion -> m KindMCoercion
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return KindMCoercion
MRefl
    go_mco !env
env (MCo KindCoercion
co) = KindCoercion -> KindMCoercion
KindCoercion -> KindMCoercion
MCo (KindCoercion -> KindMCoercion)
-> m KindCoercion -> m KindMCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co)

    go_co :: env -> Coercion -> m Coercion
    go_co :: env -> KindCoercion -> m KindCoercion
go_co !env
env (Refl Type
ty)                  = Type -> KindCoercion
Type -> KindCoercion
Refl (Type -> KindCoercion) -> m Type -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Type -> m Type
go_ty env
env Type
ty
    go_co !env
env (GRefl Role
r Type
ty KindMCoercion
mco)           = Role -> Type -> KindMCoercion -> KindCoercion
mkGReflCo Role
r (Type -> KindMCoercion -> KindCoercion)
-> m Type -> m (KindMCoercion -> KindCoercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Type -> m Type
go_ty env
env Type
ty m (KindMCoercion -> KindCoercion)
-> m KindMCoercion -> m KindCoercion
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> KindMCoercion -> m KindMCoercion
go_mco env
env KindMCoercion
mco
    go_co !env
env (AppCo KindCoercion
c1 KindCoercion
c2)              = KindCoercion -> KindCoercion -> KindCoercion
mkAppCo (KindCoercion -> KindCoercion -> KindCoercion)
-> m KindCoercion -> m (KindCoercion -> KindCoercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
c1 m (KindCoercion -> KindCoercion)
-> m KindCoercion -> m KindCoercion
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
c2
    go_co !env
env (FunCo Role
r FunTyFlag
afl FunTyFlag
afr KindCoercion
cw KindCoercion
c1 KindCoercion
c2) = Role
-> FunTyFlag
-> FunTyFlag
-> KindCoercion
-> KindCoercion
-> KindCoercion
-> KindCoercion
mkFunCo2 Role
r FunTyFlag
afl FunTyFlag
afr (KindCoercion -> KindCoercion -> KindCoercion -> KindCoercion)
-> m KindCoercion
-> m (KindCoercion -> KindCoercion -> KindCoercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
cw
                                           m (KindCoercion -> KindCoercion -> KindCoercion)
-> m KindCoercion -> m (KindCoercion -> KindCoercion)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
c1 m (KindCoercion -> KindCoercion)
-> m KindCoercion -> m KindCoercion
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
c2
    go_co !env
env (CoVarCo TyVar
cv)               = env -> TyVar -> m KindCoercion
covar env
env TyVar
cv
    go_co !env
env (HoleCo CoercionHole
hole)              = env -> CoercionHole -> m KindCoercion
cohole env
env CoercionHole
hole
    go_co !env
env (UnivCo { uco_prov :: KindCoercion -> UnivCoProvenance
uco_prov = UnivCoProvenance
p, uco_role :: KindCoercion -> Role
uco_role = Role
r
                       , uco_lty :: KindCoercion -> Type
uco_lty = Type
t1, uco_rty :: KindCoercion -> Type
uco_rty = Type
t2, uco_deps :: KindCoercion -> [KindCoercion]
uco_deps = [KindCoercion]
deps })
                                          = UnivCoProvenance
-> [KindCoercion] -> Role -> Type -> Type -> KindCoercion
mkUnivCo (UnivCoProvenance
 -> [KindCoercion] -> Role -> Type -> Type -> KindCoercion)
-> m UnivCoProvenance
-> m ([KindCoercion] -> Role -> Type -> Type -> KindCoercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnivCoProvenance -> m UnivCoProvenance
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnivCoProvenance
p
                                                     m ([KindCoercion] -> Role -> Type -> Type -> KindCoercion)
-> m [KindCoercion] -> m (Role -> Type -> Type -> KindCoercion)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> [KindCoercion] -> m [KindCoercion]
go_cos env
env [KindCoercion]
deps
                                                     m (Role -> Type -> Type -> KindCoercion)
-> m Role -> m (Type -> Type -> KindCoercion)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Role -> m Role
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Role
r
                                                     m (Type -> Type -> KindCoercion)
-> m Type -> m (Type -> KindCoercion)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> Type -> m Type
go_ty env
env Type
t1 m (Type -> KindCoercion) -> m Type -> m KindCoercion
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> Type -> m Type
go_ty env
env Type
t2
    go_co !env
env (SymCo KindCoercion
co)                 = KindCoercion -> KindCoercion
mkSymCo (KindCoercion -> KindCoercion) -> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co
    go_co !env
env (TransCo KindCoercion
c1 KindCoercion
c2)            = HasDebugCallStack => KindCoercion -> KindCoercion -> KindCoercion
KindCoercion -> KindCoercion -> KindCoercion
mkTransCo (KindCoercion -> KindCoercion -> KindCoercion)
-> m KindCoercion -> m (KindCoercion -> KindCoercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
c1 m (KindCoercion -> KindCoercion)
-> m KindCoercion -> m KindCoercion
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
c2
    go_co !env
env (AxiomCo CoAxiomRule
r [KindCoercion]
cos)            = CoAxiomRule -> [KindCoercion] -> KindCoercion
mkAxiomCo CoAxiomRule
r ([KindCoercion] -> KindCoercion)
-> m [KindCoercion] -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> [KindCoercion] -> m [KindCoercion]
go_cos env
env [KindCoercion]
cos
    go_co !env
env (SelCo CoSel
i KindCoercion
co)               = HasDebugCallStack => CoSel -> KindCoercion -> KindCoercion
CoSel -> KindCoercion -> KindCoercion
mkSelCo CoSel
i (KindCoercion -> KindCoercion) -> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co
    go_co !env
env (LRCo LeftOrRight
lr KindCoercion
co)               = LeftOrRight -> KindCoercion -> KindCoercion
mkLRCo LeftOrRight
lr (KindCoercion -> KindCoercion) -> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co
    go_co !env
env (InstCo KindCoercion
co KindCoercion
arg)            = KindCoercion -> KindCoercion -> KindCoercion
mkInstCo (KindCoercion -> KindCoercion -> KindCoercion)
-> m KindCoercion -> m (KindCoercion -> KindCoercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co m (KindCoercion -> KindCoercion)
-> m KindCoercion -> m KindCoercion
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
arg
    go_co !env
env (KindCo KindCoercion
co)                = KindCoercion -> KindCoercion
mkKindCo (KindCoercion -> KindCoercion) -> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co
    go_co !env
env (SubCo KindCoercion
co)                 = HasDebugCallStack => KindCoercion -> KindCoercion
KindCoercion -> KindCoercion
mkSubCo (KindCoercion -> KindCoercion) -> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co
    go_co !env
env co :: KindCoercion
co@(TyConAppCo Role
r TyCon
tc [KindCoercion]
cos)
      | TyCon -> Bool
isTcTyCon TyCon
tc
      = do { tc' <- TyCon -> m TyCon
tycon TyCon
tc
           ; mkTyConAppCo r tc' <$> go_cos env cos }

      -- Not a TcTyCon
      | [KindCoercion] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KindCoercion]
cos    -- Avoid allocation in this very
      = KindCoercion -> m KindCoercion
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return KindCoercion
co   -- common case (E.g. Int, LiftedRep etc)

      | Bool
otherwise
      = HasDebugCallStack =>
Role -> TyCon -> [KindCoercion] -> KindCoercion
Role -> TyCon -> [KindCoercion] -> KindCoercion
mkTyConAppCo Role
r TyCon
tc ([KindCoercion] -> KindCoercion)
-> m [KindCoercion] -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> [KindCoercion] -> m [KindCoercion]
go_cos env
env [KindCoercion]
cos
    go_co !env
env (ForAllCo { fco_tcv :: KindCoercion -> TyVar
fco_tcv = TyVar
tv, fco_visL :: KindCoercion -> ForAllTyFlag
fco_visL = ForAllTyFlag
visL, fco_visR :: KindCoercion -> ForAllTyFlag
fco_visR = ForAllTyFlag
visR
                         , fco_kind :: KindCoercion -> KindMCoercion
fco_kind = KindMCoercion
kind_co, fco_body :: KindCoercion -> KindCoercion
fco_body = KindCoercion
co })
      = do { kind_co' <- env -> KindMCoercion -> m KindMCoercion
go_mco env
env KindMCoercion
kind_co
           ; tycobinder env tv visL $ \env
env' TyVar
tv' ->  do
           ; co' <- env -> KindCoercion -> m KindCoercion
go_co env
env' KindCoercion
co
           ; return $ mkForAllCo tv' visL visR kind_co' co' }
        -- See Note [Efficiency for ForAllCo case of mapTyCoX]


{- Note [Use explicit recursion in mapTyCo]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use explicit recursion in `mapTyCo`, rather than calling, say, `strictFoldDVarSet`,
for exactly the same reason as in Note [Use explicit recursion in foldTyCo] in
GHC.Core.TyCo.Rep. We are in a monadic context, and using too-clever higher order
functions makes the strictness analyser produce worse results.

We could probably use `foldr`, since it is inlined bodily, fairly early; but
I'm doing the simple thing and inlining it by hand.

See !12037 for performance glitches caused by using `strictFoldDVarSet` (which is
definitely not inlined bodily).
-}

{- *********************************************************************
*                                                                      *
                      TyVarTy
*                                                                      *
********************************************************************* -}

-- | Attempts to obtain the type variable underlying a 'Type', and panics with the
-- given message if this is not a type variable type. See also 'getTyVar_maybe'
getTyVar :: HasDebugCallStack => Type -> TyVar
getTyVar :: HasDebugCallStack => Type -> TyVar
getTyVar Type
ty = case Type -> Maybe TyVar
getTyVar_maybe Type
ty of
                    Just TyVar
tv -> TyVar
tv
                    Maybe TyVar
Nothing -> String -> SDoc -> TyVar
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getTyVar" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

-- | Attempts to obtain the type variable underlying a 'Type'
getTyVar_maybe :: Type -> Maybe TyVar
getTyVar_maybe :: Type -> Maybe TyVar
getTyVar_maybe = Type -> Maybe TyVar
repGetTyVar_maybe (Type -> Maybe TyVar) -> (Type -> Type) -> Type -> Maybe TyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
coreFullView

-- | Attempts to obtain the type variable underlying a 'Type', without
-- any expansion
repGetTyVar_maybe :: Type -> Maybe TyVar
repGetTyVar_maybe :: Type -> Maybe TyVar
repGetTyVar_maybe (TyVarTy TyVar
tv) = TyVar -> Maybe TyVar
forall a. a -> Maybe a
Just TyVar
tv
repGetTyVar_maybe Type
_            = Maybe TyVar
forall a. Maybe a
Nothing

isTyVarTy :: Type -> Bool
isTyVarTy :: Type -> Bool
isTyVarTy Type
ty = Maybe TyVar -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe TyVar
getTyVar_maybe Type
ty)

-- | If the type is a tyvar, possibly under a cast, returns it, along
-- with the coercion. Thus, the co is :: kind tv ~N kind ty
getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)
getCastedTyVar_maybe :: Type -> Maybe (TyVar, KindCoercion)
getCastedTyVar_maybe Type
ty = case Type -> Type
coreFullView Type
ty of
  CastTy (TyVarTy TyVar
tv) KindCoercion
co -> (TyVar, KindCoercion) -> Maybe (TyVar, KindCoercion)
forall a. a -> Maybe a
Just (TyVar
tv, KindCoercion
co)
  TyVarTy TyVar
tv             -> (TyVar, KindCoercion) -> Maybe (TyVar, KindCoercion)
forall a. a -> Maybe a
Just (TyVar
tv, Role -> Type -> KindCoercion
mkReflCo Role
Nominal (TyVar -> Type
tyVarKind TyVar
tv))
  Type
_                      -> Maybe (TyVar, KindCoercion)
forall a. Maybe a
Nothing


{- *********************************************************************
*                                                                      *
                      AppTy
*                                                                      *
********************************************************************* -}

{- We need to be pretty careful with AppTy to make sure we obey the
invariant that a TyConApp is always visibly so.  mkAppTy maintains the
invariant: use it.

Note [Decomposing fat arrow c=>t]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Can we unify (a b) with (Eq a => ty)?   If we do so, we end up with
a partial application like ((=>) (Eq a)) which doesn't make sense in
source Haskell.  In contrast, we *can* unify (a b) with (t1 -> t2).
Here's an example (#9858) of how you might do it:
   i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep
   i p = typeRep p

   j = i (Proxy :: Proxy (Eq Int => Int))
The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes,
but suppose we want that.  But then in the call to 'i', we end
up decomposing (Eq Int => Int), and we definitely don't want that.

We are willing to split (t1 -=> t2) because the argument is still of
kind Type, not Constraint.  So the criterion is isVisibleFunArg.

In Core there is no real reason to avoid such decomposition.  But for now I've
put the test in splitAppTyNoView_maybe, which applies throughout, because the
other calls to splitAppTy are in GHC.Core.Unify, which is also used by the
type checker (e.g. when matching type-function equations).
-}

-- | Applies a type to another, as in e.g. @k a@
mkAppTy :: Type -> Type -> Type
  -- See Note [Respecting definitional equality], invariant (EQ1).
mkAppTy :: Type -> Type -> Type
mkAppTy (CastTy Type
fun_ty KindCoercion
co) Type
arg_ty
  | ([KindCoercion
arg_co], KindCoercion
res_co) <- HasDebugCallStack =>
KindCoercion
-> Pair Type -> [Type] -> ([KindCoercion], KindCoercion)
KindCoercion
-> Pair Type -> [Type] -> ([KindCoercion], KindCoercion)
decomposePiCos KindCoercion
co (HasDebugCallStack => KindCoercion -> Pair Type
KindCoercion -> Pair Type
coercionKind KindCoercion
co) [Type
arg_ty]
  = (Type
fun_ty Type -> Type -> Type
`mkAppTy` (Type
arg_ty Type -> KindCoercion -> Type
`mkCastTy` KindCoercion
arg_co)) Type -> KindCoercion -> Type
`mkCastTy` KindCoercion
res_co

mkAppTy (TyConApp TyCon
tc [Type]
tys) Type
ty2 = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Type]
tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
ty2])
mkAppTy Type
ty1               Type
ty2 = Type -> Type -> Type
AppTy Type
ty1 Type
ty2
        -- Note that the TyConApp could be an
        -- under-saturated type synonym.  GHC allows that; e.g.
        --      type Foo k = k a -> k a
        --      type Id x = x
        --      foo :: Foo Id -> Foo Id
        --
        -- Here Id is partially applied in the type sig for Foo,
        -- but once the type synonyms are expanded all is well
        --
        -- Moreover in GHC.Tc.Types.tcInferTyApps we build up a type
        --   (T t1 t2 t3) one argument at a type, thus forming
        --   (T t1), (T t1 t2), etc

mkAppTys :: Type -> [Type] -> Type
mkAppTys :: Type -> [Type] -> Type
mkAppTys Type
ty1                []   = Type
ty1
mkAppTys (CastTy Type
fun_ty KindCoercion
co) [Type]
arg_tys  -- much more efficient then nested mkAppTy
                                     -- Why do this? See (EQ1) of
                                     -- Note [Respecting definitional equality]
                                     -- in GHC.Core.TyCo.Rep
  = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
Type -> Type -> Type
AppTy ((Type -> [Type] -> Type
mkAppTys Type
fun_ty [Type]
casted_arg_tys) Type -> KindCoercion -> Type
`mkCastTy` KindCoercion
res_co) [Type]
leftovers
  where
    ([KindCoercion]
arg_cos, KindCoercion
res_co) = HasDebugCallStack =>
KindCoercion
-> Pair Type -> [Type] -> ([KindCoercion], KindCoercion)
KindCoercion
-> Pair Type -> [Type] -> ([KindCoercion], KindCoercion)
decomposePiCos KindCoercion
co (HasDebugCallStack => KindCoercion -> Pair Type
KindCoercion -> Pair Type
coercionKind KindCoercion
co) [Type]
arg_tys
    ([Type]
args_to_cast, [Type]
leftovers) = [KindCoercion] -> [Type] -> ([Type], [Type])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [KindCoercion]
arg_cos [Type]
arg_tys
    casted_arg_tys :: [Type]
casted_arg_tys = (Type -> KindCoercion -> Type)
-> [Type] -> [KindCoercion] -> [Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> KindCoercion -> Type
mkCastTy [Type]
args_to_cast [KindCoercion]
arg_cos
mkAppTys (TyConApp TyCon
tc [Type]
tys1) [Type]
tys2 = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Type]
tys1 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
tys2)
mkAppTys Type
ty1                [Type]
tys2 = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
Type -> Type -> Type
AppTy Type
ty1 [Type]
tys2

-------------
splitAppTy_maybe :: Type -> Maybe (Type, Type)
-- ^ Attempt to take a type application apart, whether it is a
-- function, type constructor, or plain type application. Note
-- that type family applications are NEVER unsaturated by this!
splitAppTy_maybe :: Type -> Maybe (Type, Type)
splitAppTy_maybe = HasDebugCallStack => Type -> Maybe (Type, Type)
Type -> Maybe (Type, Type)
splitAppTyNoView_maybe (Type -> Maybe (Type, Type))
-> (Type -> Type) -> Type -> Maybe (Type, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
coreFullView

splitAppTy :: Type -> (Type, Type)
-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe',
-- and panics if this is not possible
splitAppTy :: Type -> (Type, Type)
splitAppTy Type
ty = Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ty Maybe (Type, Type) -> (Type, Type) -> (Type, Type)
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> (Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"splitAppTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

-------------
splitAppTyNoView_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type)
-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that
-- any 'coreView' stuff is already done.
splitAppTyNoView_maybe :: HasDebugCallStack => Type -> Maybe (Type, Type)
splitAppTyNoView_maybe (AppTy Type
ty1 Type
ty2)
  = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
ty1, Type
ty2)

splitAppTyNoView_maybe (FunTy FunTyFlag
af Type
w Type
ty1 Type
ty2)
  | Just (TyCon
tc, [Type]
tys)   <- FunTyFlag -> Type -> Type -> Type -> Maybe (TyCon, [Type])
funTyConAppTy_maybe FunTyFlag
af Type
w Type
ty1 Type
ty2
  , Just ([Type]
tys', Type
ty') <- [Type] -> Maybe ([Type], Type)
forall a. [a] -> Maybe ([a], a)
snocView [Type]
tys
  = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (TyCon -> [Type] -> Type
TyConApp TyCon
tc [Type]
tys', Type
ty')

splitAppTyNoView_maybe (TyConApp TyCon
tc [Type]
tys)
  | Bool -> Bool
not (TyCon -> Bool
tyConMustBeSaturated TyCon
tc) Bool -> Bool -> Bool
|| [Type]
tys [Type] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthExceeds` TyCon -> Arity
tyConArity TyCon
tc
  , Just ([Type]
tys', Type
ty') <- [Type] -> Maybe ([Type], Type)
forall a. [a] -> Maybe ([a], a)
snocView [Type]
tys
  = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (TyCon -> [Type] -> Type
TyConApp TyCon
tc [Type]
tys', Type
ty')    -- Never create unsaturated type family apps!

splitAppTyNoView_maybe Type
_other = Maybe (Type, Type)
forall a. Maybe a
Nothing

tcSplitAppTyNoView_maybe :: Type -> Maybe (Type,Type)
-- ^ Just like 'splitAppTyNoView_maybe', but does not split @(c => t)@.
--
-- See Note [Decomposing fat arrow c=>t]
tcSplitAppTyNoView_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTyNoView_maybe Type
ty
  | FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af } <- Type
ty
  , Bool -> Bool
not (FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af)  -- See Note [Decomposing fat arrow c=>t]
  = Maybe (Type, Type)
forall a. Maybe a
Nothing
  | Bool
otherwise
  = HasDebugCallStack => Type -> Maybe (Type, Type)
Type -> Maybe (Type, Type)
splitAppTyNoView_maybe Type
ty

-------------
splitAppTys :: HasDebugCallStack => Type -> (Type, [Type])
-- ^ Recursively splits a type as far as is possible, leaving a residual
-- type being applied to and the type arguments applied to it. Never fails,
-- even if that means returning an empty list of type applications.
splitAppTys :: HasDebugCallStack => Type -> (Type, [Type])
splitAppTys Type
ty = Type -> Type -> [Type] -> (Type, [Type])
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [Type] -> (Type, [Type])
split Type
orig_ty Type
ty [Type]
args | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type -> [Type] -> (Type, [Type])
split Type
orig_ty Type
ty' [Type]
args
    split Type
_       (AppTy Type
ty Type
arg)        [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
split Type
ty Type
ty (Type
argType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args)
    split Type
_       (TyConApp TyCon
tc [Type]
tc_args) [Type]
args
      = let -- keep type families saturated
            n :: Arity
n | TyCon -> Bool
tyConMustBeSaturated TyCon
tc = TyCon -> Arity
tyConArity TyCon
tc
              | Bool
otherwise               = Arity
0
            ([Type]
tc_args1, [Type]
tc_args2) = Arity -> [Type] -> ([Type], [Type])
forall a. Arity -> [a] -> ([a], [a])
splitAt Arity
n [Type]
tc_args
        in
        (TyCon -> [Type] -> Type
TyConApp TyCon
tc [Type]
tc_args1, [Type]
tc_args2 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
args)
    split Type
_   (FunTy FunTyFlag
af Type
w Type
ty1 Type
ty2) [Type]
args
      | Just (TyCon
tc,[Type]
tys) <- FunTyFlag -> Type -> Type -> Type -> Maybe (TyCon, [Type])
funTyConAppTy_maybe FunTyFlag
af Type
w Type
ty1 Type
ty2
      = Bool -> (Type, [Type]) -> (Type, [Type])
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args )
        (TyCon -> [Type] -> Type
TyConApp TyCon
tc [], [Type]
tys)

    split Type
orig_ty Type
_ [Type]
args  = (Type
orig_ty, [Type]
args)

-- | Like 'splitAppTys', but doesn't look through type synonyms
splitAppTysNoView :: HasDebugCallStack => Type -> (Type, [Type])
splitAppTysNoView :: HasDebugCallStack => Type -> (Type, [Type])
splitAppTysNoView Type
ty = Type -> [Type] -> (Type, [Type])
split Type
ty []
  where
    split :: Type -> [Type] -> (Type, [Type])
split (AppTy Type
ty Type
arg) [Type]
args = Type -> [Type] -> (Type, [Type])
split Type
ty (Type
argType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args)
    split (TyConApp TyCon
tc [Type]
tc_args) [Type]
args
      = let n :: Arity
n | TyCon -> Bool
tyConMustBeSaturated TyCon
tc = TyCon -> Arity
tyConArity TyCon
tc
              | Bool
otherwise               = Arity
0
            ([Type]
tc_args1, [Type]
tc_args2) = Arity -> [Type] -> ([Type], [Type])
forall a. Arity -> [a] -> ([a], [a])
splitAt Arity
n [Type]
tc_args
        in
        (TyCon -> [Type] -> Type
TyConApp TyCon
tc [Type]
tc_args1, [Type]
tc_args2 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
args)
    split (FunTy FunTyFlag
af Type
w Type
ty1 Type
ty2) [Type]
args
      | Just (TyCon
tc, [Type]
tys) <- FunTyFlag -> Type -> Type -> Type -> Maybe (TyCon, [Type])
funTyConAppTy_maybe FunTyFlag
af Type
w Type
ty1 Type
ty2
      = Bool -> (Type, [Type]) -> (Type, [Type])
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args )
        (TyCon -> [Type] -> Type
TyConApp TyCon
tc [], [Type]
tys)

    split Type
ty [Type]
args = (Type
ty, [Type]
args)


{- *********************************************************************
*                                                                      *
                      LitTy
*                                                                      *
********************************************************************* -}

mkNumLitTy :: Integer -> Type
mkNumLitTy :: Integer -> Type
mkNumLitTy Integer
n = TyLit -> Type
LitTy (Integer -> TyLit
NumTyLit Integer
n)

-- | Is this a numeric literal. We also look through type synonyms.
isNumLitTy :: Type -> Maybe Integer
isNumLitTy :: Type -> Maybe Integer
isNumLitTy Type
ty
  | LitTy (NumTyLit Integer
n) <- Type -> Type
coreFullView Type
ty = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n
  | Bool
otherwise                             = Maybe Integer
forall a. Maybe a
Nothing

mkStrLitTy :: FastString -> Type
mkStrLitTy :: FastString -> Type
mkStrLitTy FastString
s = TyLit -> Type
LitTy (FastString -> TyLit
StrTyLit FastString
s)

-- | Is this a symbol literal. We also look through type synonyms.
isStrLitTy :: Type -> Maybe FastString
isStrLitTy :: Type -> Maybe FastString
isStrLitTy Type
ty
  | LitTy (StrTyLit FastString
s) <- Type -> Type
coreFullView Type
ty = FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
s
  | Bool
otherwise                             = Maybe FastString
forall a. Maybe a
Nothing

mkCharLitTy :: Char -> Type
mkCharLitTy :: Char -> Type
mkCharLitTy Char
c = TyLit -> Type
LitTy (Char -> TyLit
CharTyLit Char
c)

-- | Is this a char literal? We also look through type synonyms.
isCharLitTy :: Type -> Maybe Char
isCharLitTy :: Type -> Maybe Char
isCharLitTy Type
ty
  | LitTy (CharTyLit Char
s) <- Type -> Type
coreFullView Type
ty = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
s
  | Bool
otherwise                              = Maybe Char
forall a. Maybe a
Nothing


-- | Is this a type literal (symbol, numeric, or char)?
isLitTy :: Type -> Maybe TyLit
isLitTy :: Type -> Maybe TyLit
isLitTy Type
ty
  | LitTy TyLit
l <- Type -> Type
coreFullView Type
ty = TyLit -> Maybe TyLit
forall a. a -> Maybe a
Just TyLit
l
  | Bool
otherwise                  = Maybe TyLit
forall a. Maybe a
Nothing

-- | A type of kind 'ErrorMessage' (from the 'GHC.TypeError' module).
type ErrorMsgType = Type

-- | Render a type corresponding to a user type error into a SDoc.
pprUserTypeErrorTy :: ErrorMsgType -> SDoc
pprUserTypeErrorTy :: Type -> SDoc
pprUserTypeErrorTy Type
ty =
  case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of

    -- Text "Something"
    Just (TyCon
tc,[Type
txt])
      | TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeErrorTextDataConName
      , Just FastString
str <- Type -> Maybe FastString
isStrLitTy Type
txt -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
str

    -- ShowType t
    Just (TyCon
tc,[Type
_k,Type
t])
      | TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeErrorShowTypeDataConName -> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t

    -- t1 :<>: t2
    Just (TyCon
tc,[Type
t1,Type
t2])
      | TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeErrorAppendDataConName ->
        Type -> SDoc
pprUserTypeErrorTy Type
t1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
pprUserTypeErrorTy Type
t2

    -- t1 :$$: t2
    Just (TyCon
tc,[Type
t1,Type
t2])
      | TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeErrorVAppendDataConName ->
        Type -> SDoc
pprUserTypeErrorTy Type
t1 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
pprUserTypeErrorTy Type
t2

    -- An unevaluated type function
    Maybe (TyCon, [Type])
_ -> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty

{- *********************************************************************
*                                                                      *
                      FunTy
*                                                                      *
********************************************************************* -}

{- Note [Representation of function types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Functions (e.g. Int -> Char) can be thought of as being applications
of funTyCon (known in Haskell surface syntax as (->)), (note that
`RuntimeRep' quantifiers are left inferred)

    (->) :: forall {r1 :: RuntimeRep} {r2 :: RuntimeRep}
                   (a :: TYPE r1) (b :: TYPE r2).
            a -> b -> Type

However, for efficiency's sake we represent saturated applications of (->)
with FunTy. For instance, the type,

    (->) r1 r2 a b

is equivalent to,

    FunTy (Anon a) b

Note how the RuntimeReps are implied in the FunTy representation. For this
reason we must be careful when reconstructing the TyConApp representation (see,
for instance, splitTyConApp_maybe).

In the compiler we maintain the invariant that all saturated applications of
(->) are represented with FunTy.

See #11714.
-}

-----------------------------------------------
funTyConAppTy_maybe :: FunTyFlag -> Type -> Type -> Type
                    -> Maybe (TyCon, [Type])
-- ^ Given the components of a FunTy
-- figure out the corresponding TyConApp.
funTyConAppTy_maybe :: FunTyFlag -> Type -> Type -> Type -> Maybe (TyCon, [Type])
funTyConAppTy_maybe FunTyFlag
af Type
mult Type
arg Type
res
  | Just Type
arg_rep <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
getRuntimeRep_maybe Type
arg
  , Just Type
res_rep <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
getRuntimeRep_maybe Type
res
  -- If you're changing the lines below, you'll probably want to adapt the
  -- `fUNTyCon` case of GHC.Core.Unify.unify_ty correspondingly.
  , let args :: [Type]
args | FunTyFlag -> Bool
isFUNArg FunTyFlag
af = [Type
mult, Type
arg_rep, Type
res_rep, Type
arg, Type
res]
             | Bool
otherwise   = [      Type
arg_rep, Type
res_rep, Type
arg, Type
res]
  = (TyCon, [Type]) -> Maybe (TyCon, [Type])
(TyCon, [Type]) -> Maybe (TyCon, [Type])
forall a. a -> Maybe a
Just ((TyCon, [Type]) -> Maybe (TyCon, [Type]))
-> (TyCon, [Type]) -> Maybe (TyCon, [Type])
forall a b. (a -> b) -> a -> b
$ (FunTyFlag -> TyCon
funTyFlagTyCon FunTyFlag
af, [Type]
args)
  | Bool
otherwise
  = Maybe (TyCon, [Type])
forall a. Maybe a
Nothing

tyConAppFunTy_maybe :: HasDebugCallStack => TyCon -> [Type] -> Maybe Type
-- ^ Return Just if this TyConApp should be represented as a FunTy
tyConAppFunTy_maybe :: HasDebugCallStack => TyCon -> [Type] -> Maybe Type
tyConAppFunTy_maybe TyCon
tc [Type]
tys
  | Just (FunTyFlag
af, Type
mult, Type
arg, Type
res) <- Type -> TyCon -> [Type] -> Maybe (FunTyFlag, Type, Type, Type)
forall a.
(HasDebugCallStack, Outputable a) =>
a -> TyCon -> [a] -> Maybe (FunTyFlag, a, a, a)
ty_con_app_fun_maybe Type
manyDataConTy TyCon
tc [Type]
tys
            = Type -> Maybe Type
forall a. a -> Maybe a
Just (FunTy { ft_af :: FunTyFlag
ft_af = FunTyFlag
af, ft_mult :: Type
ft_mult = Type
mult, ft_arg :: Type
ft_arg = Type
arg, ft_res :: Type
ft_res = Type
res })
  | Bool
otherwise = Maybe Type
forall a. Maybe a
Nothing

tyConAppFunCo_maybe :: HasDebugCallStack => Role -> TyCon -> [Coercion]
                    -> Maybe Coercion
-- ^ Return Just if this TyConAppCo should be represented as a FunCo
tyConAppFunCo_maybe :: HasDebugCallStack =>
Role -> TyCon -> [KindCoercion] -> Maybe KindCoercion
tyConAppFunCo_maybe Role
r TyCon
tc [KindCoercion]
cos
  | Just (FunTyFlag
af, KindCoercion
mult, KindCoercion
arg, KindCoercion
res) <- KindCoercion
-> TyCon
-> [KindCoercion]
-> Maybe (FunTyFlag, KindCoercion, KindCoercion, KindCoercion)
forall a.
(HasDebugCallStack, Outputable a) =>
a -> TyCon -> [a] -> Maybe (FunTyFlag, a, a, a)
ty_con_app_fun_maybe KindCoercion
mult_refl TyCon
tc [KindCoercion]
cos
  = KindCoercion -> Maybe KindCoercion
forall a. a -> Maybe a
Just (Role
-> FunTyFlag
-> KindCoercion
-> KindCoercion
-> KindCoercion
-> KindCoercion
mkFunCo Role
r FunTyFlag
af KindCoercion
mult KindCoercion
arg KindCoercion
res)
  | Bool
otherwise
  = Maybe KindCoercion
forall a. Maybe a
Nothing
  where
    mult_refl :: KindCoercion
mult_refl = Role -> Type -> KindCoercion
mkReflCo (Role -> FunSel -> Role
funRole Role
r FunSel
SelMult) Type
manyDataConTy

ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a]
                     -> Maybe (FunTyFlag, a, a, a)
{-# INLINE ty_con_app_fun_maybe #-}
-- Specialise this function for its two call sites
ty_con_app_fun_maybe :: forall a.
(HasDebugCallStack, Outputable a) =>
a -> TyCon -> [a] -> Maybe (FunTyFlag, a, a, a)
ty_con_app_fun_maybe a
many_ty_co TyCon
tc [a]
args
  | Unique
tc_uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
fUNTyConKey     = Maybe (FunTyFlag, a, a, a)
fUN_case
  | Unique
tc_uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
tcArrowTyConKey = FunTyFlag -> Maybe (FunTyFlag, a, a, a)
non_FUN_case FunTyFlag
FTF_T_C
  | Unique
tc_uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
ctArrowTyConKey = FunTyFlag -> Maybe (FunTyFlag, a, a, a)
non_FUN_case FunTyFlag
FTF_C_T
  | Unique
tc_uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
ccArrowTyConKey = FunTyFlag -> Maybe (FunTyFlag, a, a, a)
non_FUN_case FunTyFlag
FTF_C_C
  | Bool
otherwise                  = Maybe (FunTyFlag, a, a, a)
forall a. Maybe a
Nothing
  where
    tc_uniq :: Unique
tc_uniq = TyCon -> Unique
tyConUnique TyCon
tc

    fUN_case :: Maybe (FunTyFlag, a, a, a)
fUN_case
      | (a
w:a
_r1:a
_r2:a
a1:a
a2:[a]
rest) <- [a]
args
      = Bool
-> SDoc -> Maybe (FunTyFlag, a, a, a) -> Maybe (FunTyFlag, a, a, a)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
rest) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [a] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [a]
args) (Maybe (FunTyFlag, a, a, a) -> Maybe (FunTyFlag, a, a, a))
-> Maybe (FunTyFlag, a, a, a) -> Maybe (FunTyFlag, a, a, a)
forall a b. (a -> b) -> a -> b
$
        (FunTyFlag, a, a, a) -> Maybe (FunTyFlag, a, a, a)
forall a. a -> Maybe a
Just (FunTyFlag
FTF_T_T, a
w, a
a1, a
a2)
      | Bool
otherwise = Maybe (FunTyFlag, a, a, a)
forall a. Maybe a
Nothing

    non_FUN_case :: FunTyFlag -> Maybe (FunTyFlag, a, a, a)
non_FUN_case FunTyFlag
ftf
      | (a
_r1:a
_r2:a
a1:a
a2:[a]
rest) <- [a]
args
      = Bool
-> SDoc -> Maybe (FunTyFlag, a, a, a) -> Maybe (FunTyFlag, a, a, a)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
rest) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [a] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [a]
args) (Maybe (FunTyFlag, a, a, a) -> Maybe (FunTyFlag, a, a, a))
-> Maybe (FunTyFlag, a, a, a) -> Maybe (FunTyFlag, a, a, a)
forall a b. (a -> b) -> a -> b
$
        (FunTyFlag, a, a, a) -> Maybe (FunTyFlag, a, a, a)
forall a. a -> Maybe a
Just (FunTyFlag
ftf, a
many_ty_co, a
a1, a
a2)
      | Bool
otherwise
      = Maybe (FunTyFlag, a, a, a)
forall a. Maybe a
Nothing

mkFunctionType :: HasDebugCallStack => Mult -> Type -> Type -> Type
-- ^ This one works out the FunTyFlag from the argument type
-- See GHC.Types.Var Note [FunTyFlag]
mkFunctionType :: HasDebugCallStack => Type -> Type -> Type -> Type
mkFunctionType Type
mult Type
arg_ty Type
res_ty
 = FunTy { ft_af :: FunTyFlag
ft_af = FunTyFlag
af, ft_arg :: Type
ft_arg = Type
arg_ty, ft_res :: Type
ft_res = Type
res_ty
         , ft_mult :: Type
ft_mult = Bool -> SDoc -> Type -> Type
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
mult_ok ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type
mult, Type
arg_ty, Type
res_ty]) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                     Type
mult }
  where
    af :: FunTyFlag
af = HasDebugCallStack => Type -> Type -> FunTyFlag
Type -> Type -> FunTyFlag
chooseFunTyFlag Type
arg_ty Type
res_ty
    mult_ok :: Bool
mult_ok = FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af Bool -> Bool -> Bool
|| Type -> Bool
isManyTy Type
mult

mkScaledFunctionTys :: [Scaled Type] -> Type -> Type
-- ^ Like mkFunctionType, compute the FunTyFlag from the arguments
mkScaledFunctionTys :: [Scaled Type] -> Type -> Type
mkScaledFunctionTys [Scaled Type]
arg_tys Type
res_ty
  = (Scaled Type -> Type -> Type) -> Type -> [Scaled 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 Scaled Type -> Type -> Type
mk Type
res_ty [Scaled Type]
arg_tys
  where
    mk :: Scaled Type -> Type -> Type
mk (Scaled Type
mult Type
arg_ty) Type
res_ty
      = HasDebugCallStack => FunTyFlag -> Type -> Type -> Type -> Type
FunTyFlag -> Type -> Type -> Type -> Type
mkFunTy (HasDebugCallStack => Type -> Type -> FunTyFlag
Type -> Type -> FunTyFlag
chooseFunTyFlag Type
arg_ty Type
res_ty)
                Type
mult Type
arg_ty Type
res_ty

chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag
-- ^ See GHC.Types.Var Note [FunTyFlag]
chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag
chooseFunTyFlag Type
arg_ty Type
res_ty
  = TypeOrConstraint -> TypeOrConstraint -> FunTyFlag
mkFunTyFlag (HasDebugCallStack => Type -> TypeOrConstraint
Type -> TypeOrConstraint
typeTypeOrConstraint Type
arg_ty) (HasDebugCallStack => Type -> TypeOrConstraint
Type -> TypeOrConstraint
typeTypeOrConstraint Type
res_ty)

splitFunTy :: Type -> (Mult, Type, Type)
-- ^ Attempts to extract the multiplicity, argument and result types from a type,
-- and panics if that is not possible. See also 'splitFunTy_maybe'
splitFunTy :: Type -> (Type, Type, Type)
splitFunTy Type
ty = case Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
ty of
                   Just (FunTyFlag
_af, Type
mult, Type
arg, Type
res) -> (Type
mult,Type
arg,Type
res)
                   Maybe (FunTyFlag, Type, Type, Type)
Nothing                    -> String -> SDoc -> (Type, Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"splitFunTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

{-# INLINE splitFunTy_maybe #-}
splitFunTy_maybe :: Type -> Maybe (FunTyFlag, Mult, Type, Type)
-- ^ Attempts to extract the multiplicity, argument and result types from a type
splitFunTy_maybe :: Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
ty
  | FunTy FunTyFlag
af Type
w Type
arg Type
res <- Type -> Type
coreFullView Type
ty = (FunTyFlag, Type, Type, Type)
-> Maybe (FunTyFlag, Type, Type, Type)
forall a. a -> Maybe a
Just (FunTyFlag
af, Type
w, Type
arg, Type
res)
  | Bool
otherwise                             = Maybe (FunTyFlag, Type, Type, Type)
forall a. Maybe a
Nothing

{-# INLINE splitVisibleFunTy_maybe #-}
splitVisibleFunTy_maybe :: Type -> Maybe (Type, Type)
-- ^ Works on visible function types only (t1 -> t2), and
--   returns t1 and t2, but not the multiplicity
splitVisibleFunTy_maybe :: Type -> Maybe (Type, Type)
splitVisibleFunTy_maybe Type
ty
  | FunTy FunTyFlag
af Type
_ Type
arg Type
res <- Type -> Type
coreFullView Type
ty
  , FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
arg, Type
res)
  | Bool
otherwise          = Maybe (Type, Type)
forall a. Maybe a
Nothing

splitFunTys :: Type -> ([Scaled Type], Type)
splitFunTys :: Type -> ([Scaled Type], Type)
splitFunTys Type
ty = [Scaled Type] -> Type -> Type -> ([Scaled Type], Type)
split [] Type
ty Type
ty
  where
      -- common case first
    split :: [Scaled Type] -> Type -> Type -> ([Scaled Type], Type)
split [Scaled Type]
args Type
_       (FunTy FunTyFlag
_ Type
w Type
arg Type
res) = [Scaled Type] -> Type -> Type -> ([Scaled Type], Type)
split (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
w Type
arg Scaled Type -> [Scaled Type] -> [Scaled Type]
forall a. a -> [a] -> [a]
: [Scaled Type]
args) Type
res Type
res
    split [Scaled Type]
args Type
orig_ty Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = [Scaled Type] -> Type -> Type -> ([Scaled Type], Type)
split [Scaled Type]
args Type
orig_ty Type
ty'
    split [Scaled Type]
args Type
orig_ty Type
_                   = ([Scaled Type] -> [Scaled Type]
forall a. [a] -> [a]
reverse [Scaled Type]
args, Type
orig_ty)

funResultTy :: HasDebugCallStack => Type -> Type
-- ^ Extract the function result type and panic if that is not possible
funResultTy :: HasDebugCallStack => Type -> Type
funResultTy Type
ty
  | FunTy { ft_res :: Type -> Type
ft_res = Type
res } <- Type -> Type
coreFullView Type
ty = Type
res
  | Bool
otherwise                                 = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"funResultTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

funArgTy :: HasDebugCallStack => Type -> Type
-- ^ Extract the function argument type and panic if that is not possible
funArgTy :: HasDebugCallStack => Type -> Type
funArgTy Type
ty
  | FunTy { ft_arg :: Type -> Type
ft_arg = Type
arg } <- Type -> Type
coreFullView Type
ty = Type
arg
  | Bool
otherwise                                 = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"funArgTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

-- ^ Just like 'piResultTys' but for a single argument
-- Try not to iterate 'piResultTy', because it's inefficient to substitute
-- one variable at a time; instead use 'piResultTys"
piResultTy :: HasDebugCallStack => Type -> Type ->  Type
piResultTy :: HasDebugCallStack => Type -> Type -> Type
piResultTy Type
ty Type
arg = case Type -> Type -> Maybe Type
piResultTy_maybe Type
ty Type
arg of
                      Just Type
res -> Type
res
                      Maybe Type
Nothing  -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"piResultTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg)

piResultTy_maybe :: Type -> Type -> Maybe Type
piResultTy_maybe :: Type -> Type -> Maybe Type
piResultTy_maybe Type
ty Type
arg = case Type -> Type
coreFullView Type
ty of
  FunTy { ft_res :: Type -> Type
ft_res = Type
res } -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
res

  ForAllTy (Bndr TyVar
tv ForAllTyFlag
_) Type
res
    -> let empty_subst :: Subst
empty_subst = InScopeSet -> Subst
mkEmptySubst (InScopeSet -> Subst) -> InScopeSet -> Subst
forall a b. (a -> b) -> a -> b
$ VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$
                         [Type] -> VarSet
tyCoVarsOfTypes [Type
arg,Type
res]
       in Type -> Maybe Type
forall a. a -> Maybe a
Just (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy (Subst -> TyVar -> Type -> Subst
extendTCvSubst Subst
empty_subst TyVar
tv Type
arg) Type
res)

  Type
_ -> Maybe Type
forall a. Maybe a
Nothing

-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn)
--   where f :: f_ty
-- 'piResultTys' is interesting because:
--      1. 'f_ty' may have more for-alls than there are args
--      2. Less obviously, it may have fewer for-alls
-- For case 2. think of:
--   piResultTys (forall a.a) [forall b.b, Int]
-- This really can happen, but only (I think) in situations involving
-- undefined.  For example:
--       undefined :: forall a. a
-- Term: undefined @(forall b. b->b) @Int
-- This term should have type (Int -> Int), but notice that
-- there are more type args than foralls in 'undefined's type.

-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism] in GHC.Core.Lint

-- This is a heavily used function (e.g. from typeKind),
-- so we pay attention to efficiency, especially in the special case
-- where there are no for-alls so we are just dropping arrows from
-- a function type/kind.
piResultTys :: HasDebugCallStack => Type -> [Type] -> Type
piResultTys :: HasDebugCallStack => Type -> [Type] -> Type
piResultTys Type
ty [] = Type
ty
piResultTys Type
ty orig_args :: [Type]
orig_args@(Type
arg:[Type]
args)
  | FunTy { ft_res :: Type -> Type
ft_res = Type
res } <- Type
ty
  = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys Type
res [Type]
args

  | ForAllTy (Bndr TyVar
tcv ForAllTyFlag
_) Type
res <- Type
ty
  = -- Both type and coercion variables
    Subst -> Type -> [Type] -> Type
go (Subst -> TyVar -> Type -> Subst
extendTCvSubst Subst
init_subst TyVar
tcv Type
arg) Type
res [Type]
args

  | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
  = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys Type
ty' [Type]
orig_args

  | Bool
otherwise
  = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"piResultTys1" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
orig_args)
  where
    init_subst :: Subst
init_subst = InScopeSet -> Subst
mkEmptySubst (InScopeSet -> Subst) -> InScopeSet -> Subst
forall a b. (a -> b) -> a -> b
$ VarSet -> InScopeSet
mkInScopeSet ([Type] -> VarSet
tyCoVarsOfTypes (Type
tyType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
orig_args))

    go :: Subst -> Type -> [Type] -> Type
    go :: Subst -> Type -> [Type] -> Type
go Subst
subst Type
ty [] = Subst -> Type -> Type
substTyUnchecked Subst
subst Type
ty

    go Subst
subst Type
ty all_args :: [Type]
all_args@(Type
arg:[Type]
args)
      | FunTy { ft_res :: Type -> Type
ft_res = Type
res } <- Type
ty
      = Subst -> Type -> [Type] -> Type
go Subst
subst Type
res [Type]
args

      | ForAllTy (Bndr TyVar
tv ForAllTyFlag
_) Type
res <- Type
ty
      = Subst -> Type -> [Type] -> Type
go (Subst -> TyVar -> Type -> Subst
extendTCvSubst Subst
subst TyVar
tv Type
arg) Type
res [Type]
args

      | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
      = Subst -> Type -> [Type] -> Type
go Subst
subst Type
ty' [Type]
all_args

      | Bool -> Bool
not (Subst -> Bool
isEmptyTCvSubst Subst
subst)  -- See Note [Care with kind instantiation]
      = Subst -> Type -> [Type] -> Type
go Subst
init_subst
          (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
ty)
          [Type]
all_args

      | Bool
otherwise
      = -- We have not run out of arguments, but the function doesn't
        -- have the right kind to apply to them; so panic.
        -- Without the explicit isEmptyVarEnv test, an ill-kinded type
        -- would give an infinite loop, which is very unhelpful
        -- c.f. #15473
        String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"piResultTys2" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
orig_args SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
all_args)

applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type
-- applyTysX beta-reduces (/\tvs. body_ty) arg_tys
-- Assumes that (/\tvs. body_ty) is closed
applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type
applyTysX [TyVar]
tvs Type
body_ty [Type]
arg_tys
  = Bool -> SDoc -> Type -> Type
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([TyVar]
tvs [TyVar] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
`leLength` [Type]
arg_tys) SDoc
pp_stuff (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
    Bool -> SDoc -> Type -> Type
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Type -> VarSet
tyCoVarsOfType Type
body_ty VarSet -> VarSet -> Bool
`subVarSet` [TyVar] -> VarSet
mkVarSet [TyVar]
tvs) SDoc
pp_stuff (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
    Type -> [Type] -> Type
mkAppTys ([TyVar] -> [Type] -> Type -> Type
HasDebugCallStack => [TyVar] -> [Type] -> Type -> Type
substTyWith [TyVar]
tvs [Type]
arg_tys_prefix Type
body_ty)
             [Type]
arg_tys_rest
  where
    pp_stuff :: SDoc
pp_stuff = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [[TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_ty, [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
arg_tys]
    ([Type]
arg_tys_prefix, [Type]
arg_tys_rest) = [TyVar] -> [Type] -> ([Type], [Type])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [TyVar]
tvs [Type]
arg_tys


{- Note [Care with kind instantiation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
  T :: forall k. k
and we are finding the kind of
  T (forall b. b -> b) * Int
Then
  T (forall b. b->b) :: k[ k :-> forall b. b->b]
                     :: forall b. b -> b
So
  T (forall b. b->b) * :: (b -> b)[ b :-> *]
                       :: * -> *

In other words we must instantiate the forall!

Similarly (#15428)
   S :: forall k f. k -> f k
and we are finding the kind of
   S * (* ->) Int Bool
We have
   S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)]
              :: * -> * -> *
So again we must instantiate.

The same thing happens in GHC.CoreToIface.toIfaceAppArgsX.
-}


{- *********************************************************************
*                                                                      *
                      TyConApp
*                                                                      *
********************************************************************* -}

-- splitTyConApp "looks through" synonyms, because they don't
-- mean a distinct type, but all other type-constructor applications
-- including functions are returned as Just ..

-- | Retrieve the tycon heading this type, if there is one. Does /not/
-- look through synonyms.
tyConAppTyConPicky_maybe :: Type -> Maybe TyCon
tyConAppTyConPicky_maybe :: Type -> Maybe TyCon
tyConAppTyConPicky_maybe (TyConApp TyCon
tc [Type]
_)        = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc
tyConAppTyConPicky_maybe (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af }) = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just (FunTyFlag -> TyCon
funTyFlagTyCon FunTyFlag
af)
tyConAppTyConPicky_maybe Type
_                      = Maybe TyCon
forall a. Maybe a
Nothing


-- | The same as @fst . splitTyConApp@
-- We can short-cut the FunTy case
{-# INLINE tyConAppTyCon_maybe #-}
tyConAppTyCon_maybe :: Type -> Maybe TyCon
tyConAppTyCon_maybe :: Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty = case Type -> Type
coreFullView Type
ty of
  TyConApp TyCon
tc [Type]
_        -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc
  FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af } -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just (FunTyFlag -> TyCon
funTyFlagTyCon FunTyFlag
af)
  Type
_                    -> Maybe TyCon
forall a. Maybe a
Nothing

tyConAppTyCon :: HasDebugCallStack => Type -> TyCon
tyConAppTyCon :: HasDebugCallStack => Type -> TyCon
tyConAppTyCon Type
ty = Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty Maybe TyCon -> TyCon -> TyCon
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tyConAppTyCon" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

-- | The same as @snd . splitTyConApp@
tyConAppArgs_maybe :: Type -> Maybe [Type]
tyConAppArgs_maybe :: Type -> Maybe [Type]
tyConAppArgs_maybe Type
ty = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
                          Just (TyCon
_, [Type]
tys) -> [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type]
tys
                          Maybe (TyCon, [Type])
Nothing       -> Maybe [Type]
forall a. Maybe a
Nothing

tyConAppArgs :: HasDebugCallStack => Type -> [Type]
tyConAppArgs :: HasDebugCallStack => Type -> [Type]
tyConAppArgs Type
ty = Type -> Maybe [Type]
tyConAppArgs_maybe Type
ty Maybe [Type] -> [Type] -> [Type]
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> [Type]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tyConAppArgs" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

-- | Attempts to tease a type apart into a type constructor and the application
-- of a number of arguments to that constructor. Panics if that is not possible.
-- See also 'splitTyConApp_maybe'
splitTyConApp :: Type -> (TyCon, [Type])
splitTyConApp :: Type -> (TyCon, [Type])
splitTyConApp Type
ty = HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty Maybe (TyCon, [Type]) -> (TyCon, [Type]) -> (TyCon, [Type])
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> (TyCon, [Type])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"splitTyConApp" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

-- | Attempts to tease a type apart into a type constructor and the application
-- of a number of arguments to that constructor
splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty = HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConAppNoView_maybe (Type -> Type
coreFullView Type
ty)

splitTyConAppNoView_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
-- Same as splitTyConApp_maybe but without looking through synonyms
splitTyConAppNoView_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConAppNoView_maybe Type
ty
  = case Type
ty of
      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 -> Type -> Type -> Type -> Maybe (TyCon, [Type])
funTyConAppTy_maybe FunTyFlag
af Type
w Type
arg Type
res
      TyConApp TyCon
tc [Type]
tys -> (TyCon, [Type]) -> Maybe (TyCon, [Type])
forall a. a -> Maybe a
Just (TyCon
tc, [Type]
tys)
      Type
_               -> Maybe (TyCon, [Type])
forall a. Maybe a
Nothing

-- | tcSplitTyConApp_maybe splits a type constructor application into
-- its type constructor and applied types.
--
-- Differs from splitTyConApp_maybe in that it does *not* split types
-- headed with (=>), as that's not a TyCon in the type-checker.
--
-- Note that this may fail (in funTyConAppTy_maybe) in the case
-- of a 'FunTy' with an argument of unknown kind 'FunTy'
-- (e.g. `FunTy (a :: k) Int`, since the kind of @a@ isn't of
-- the form `TYPE rep`.  This isn't usually a problem but may
-- be temporarily the case during canonicalization:
--     see Note [Decomposing FunTy] in GHC.Tc.Solver.Equality
--     and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType,
--         Wrinkle around FunTy
--
-- Consequently, you may need to zonk your type before
-- using this function.
tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
-- Defined here to avoid module loops between Unify and TcType.
tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
  = case Type -> Type
coreFullView Type
ty of
      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    -- Visible args only
                        -- See Note [Decomposing fat arrow c=>t]
                      -> FunTyFlag -> Type -> Type -> Type -> Maybe (TyCon, [Type])
funTyConAppTy_maybe FunTyFlag
af Type
w Type
arg Type
res
      TyConApp TyCon
tc [Type]
tys -> (TyCon, [Type]) -> Maybe (TyCon, [Type])
forall a. a -> Maybe a
Just (TyCon
tc, [Type]
tys)
      Type
_               -> Maybe (TyCon, [Type])
forall a. Maybe a
Nothing

tcSplitTyConApp :: Type -> (TyCon, [Type])
tcSplitTyConApp :: Type -> (TyCon, [Type])
tcSplitTyConApp Type
ty
  = HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty Maybe (TyCon, [Type]) -> (TyCon, [Type]) -> (TyCon, [Type])
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> (TyCon, [Type])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSplitTyConApp" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

---------------------------
newTyConInstRhs :: TyCon -> [Type] -> Type
-- ^ Unwrap one 'layer' of newtype on a type constructor and its
-- arguments, using an eta-reduced version of the @newtype@ if possible.
-- This requires tys to have at least @newTyConInstArity tycon@ elements.
newTyConInstRhs :: TyCon -> [Type] -> Type
newTyConInstRhs TyCon
tycon [Type]
tys
    = Bool -> SDoc -> Type -> Type
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([TyVar]
tvs [TyVar] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
`leLength` [Type]
tys) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
      [TyVar] -> Type -> [Type] -> Type
HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type
applyTysX [TyVar]
tvs Type
rhs [Type]
tys
  where
    ([TyVar]
tvs, Type
rhs) = TyCon -> ([TyVar], Type)
newTyConEtadRhs TyCon
tycon


{- *********************************************************************
*                                                                      *
                      CastTy
*                                                                      *
********************************************************************* -}

splitCastTy_maybe :: Type -> Maybe (Type, Coercion)
splitCastTy_maybe :: Type -> Maybe (Type, KindCoercion)
splitCastTy_maybe Type
ty
  | CastTy Type
ty' KindCoercion
co <- Type -> Type
coreFullView Type
ty = (Type, KindCoercion) -> Maybe (Type, KindCoercion)
forall a. a -> Maybe a
Just (Type
ty', KindCoercion
co)
  | Bool
otherwise                        = Maybe (Type, KindCoercion)
forall a. Maybe a
Nothing

-- | Make a 'CastTy'. The Coercion must be nominal. Checks the
-- Coercion for reflexivity, dropping it if it's reflexive.
-- See @Note [Respecting definitional equality]@ in "GHC.Core.TyCo.Rep"
mkCastTy :: Type -> Coercion -> Type
mkCastTy :: Type -> KindCoercion -> Type
mkCastTy Type
orig_ty KindCoercion
co | KindCoercion -> Bool
isReflexiveCo KindCoercion
co = Type
orig_ty  -- (EQ2) from the Note
-- NB: Do the slow check here. This is important to keep the splitXXX
-- functions working properly. Otherwise, we may end up with something
-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz)
-- fails under splitFunTy_maybe. This happened with the cheaper check
-- in test dependent/should_compile/dynamic-paper.
mkCastTy Type
orig_ty KindCoercion
co = Type -> KindCoercion -> Type
mk_cast_ty Type
orig_ty KindCoercion
co

-- | Like 'mkCastTy', but avoids checking the coercion for reflexivity,
-- as that can be expensive.
mk_cast_ty :: Type -> Coercion -> Type
mk_cast_ty :: Type -> KindCoercion -> Type
mk_cast_ty Type
orig_ty KindCoercion
co = Type -> Type
go Type
orig_ty
  where
    go :: Type -> Type
    -- See Note [Using coreView in mk_cast_ty]
    go :: Type -> Type
go Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type
go Type
ty'

    go (CastTy Type
ty KindCoercion
co1)
      -- (EQ3) from the Note
      = Type -> KindCoercion -> Type
mkCastTy Type
ty (KindCoercion
co1 HasDebugCallStack => KindCoercion -> KindCoercion -> KindCoercion
KindCoercion -> KindCoercion -> KindCoercion
`mkTransCo` KindCoercion
co)
          -- call mkCastTy again for the reflexivity check

    go (ForAllTy (Bndr TyVar
tv ForAllTyFlag
vis) Type
inner_ty)
      -- (EQ4) from the Note
      -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep.
      | TyVar -> Bool
isTyVar TyVar
tv
      , let fvs :: VarSet
fvs = KindCoercion -> VarSet
tyCoVarsOfCo KindCoercion
co
      = -- have to make sure that pushing the co in doesn't capture the bound var!
        if TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` VarSet
fvs
        then let empty_subst :: Subst
empty_subst = InScopeSet -> Subst
mkEmptySubst (VarSet -> InScopeSet
mkInScopeSet VarSet
fvs)
                 (Subst
subst, TyVar
tv') = HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar)
Subst -> TyVar -> (Subst, TyVar)
substVarBndr Subst
empty_subst TyVar
tv
             in VarBndr TyVar ForAllTyFlag -> Type -> Type
ForAllTy (TyVar -> ForAllTyFlag -> VarBndr TyVar ForAllTyFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' ForAllTyFlag
vis) (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
inner_ty Type -> KindCoercion -> Type
`mk_cast_ty` KindCoercion
co)
        else VarBndr TyVar ForAllTyFlag -> Type -> Type
ForAllTy (TyVar -> ForAllTyFlag -> VarBndr TyVar ForAllTyFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ForAllTyFlag
vis) (Type
inner_ty Type -> KindCoercion -> Type
`mk_cast_ty` KindCoercion
co)

    go Type
_ = Type -> KindCoercion -> Type
CastTy Type
orig_ty KindCoercion
co -- NB: orig_ty: preserve synonyms if possible

{-
Note [Using coreView in mk_cast_ty]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Invariants (EQ3) and (EQ4) of Note [Respecting definitional equality] in
GHC.Core.TyCo.Rep must apply regardless of type synonyms. For instance,
consider this example (#19742):

   type EqSameNat = () |> co
   useNatEq :: EqSameNat |> sym co

(Those casts aren't visible in the user-source code, of course; see #19742 for
what the user might write.)

The type `EqSameNat |> sym co` looks as if it satisfies (EQ3), as it has no
nested casts, but if we expand EqSameNat, we see that it doesn't.
And then Bad Things happen.

The solution is easy: just use `coreView` when establishing (EQ3) and (EQ4) in
`mk_cast_ty`.
-}

{- *********************************************************************
*                                                                      *
                     CoercionTy
  CoercionTy allows us to inject coercions into types. A CoercionTy
  should appear only in the right-hand side of an application.
*                                                                      *
********************************************************************* -}

mkCoercionTy :: Coercion -> Type
mkCoercionTy :: KindCoercion -> Type
mkCoercionTy = KindCoercion -> Type
KindCoercion -> Type
CoercionTy

isCoercionTy :: Type -> Bool
isCoercionTy :: Type -> Bool
isCoercionTy (CoercionTy KindCoercion
_) = Bool
True
isCoercionTy Type
_              = Bool
False

isCoercionTy_maybe :: Type -> Maybe Coercion
isCoercionTy_maybe :: Type -> Maybe KindCoercion
isCoercionTy_maybe (CoercionTy KindCoercion
co) = KindCoercion -> Maybe KindCoercion
forall a. a -> Maybe a
Just KindCoercion
co
isCoercionTy_maybe Type
_               = Maybe KindCoercion
forall a. Maybe a
Nothing

stripCoercionTy :: Type -> Coercion
stripCoercionTy :: Type -> KindCoercion
stripCoercionTy (CoercionTy KindCoercion
co) = KindCoercion
co
stripCoercionTy Type
ty              = String -> SDoc -> KindCoercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"stripCoercionTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)


{- *********************************************************************
*                                                                      *
                      ForAllTy
*                                                                      *
********************************************************************* -}

tyConBindersPiTyBinders :: [TyConBinder] -> [PiTyBinder]
-- Return the tyConBinders in PiTyBinder form
tyConBindersPiTyBinders :: [TyConBinder] -> [PiTyBinder]
tyConBindersPiTyBinders = (TyConBinder -> PiTyBinder) -> [TyConBinder] -> [PiTyBinder]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> PiTyBinder
to_tyb
  where
    to_tyb :: TyConBinder -> PiTyBinder
to_tyb (Bndr TyVar
tv (NamedTCB ForAllTyFlag
vis)) = VarBndr TyVar ForAllTyFlag -> PiTyBinder
Named (TyVar -> ForAllTyFlag -> VarBndr TyVar ForAllTyFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ForAllTyFlag
vis)
    to_tyb (Bndr TyVar
tv TyConBndrVis
AnonTCB)        = Scaled Type -> FunTyFlag -> PiTyBinder
Anon (Type -> Scaled Type
forall a. a -> Scaled a
tymult (TyVar -> Type
varType TyVar
tv)) FunTyFlag
FTF_T_T

-- | Make a dependent forall over a TyCoVar
mkTyCoForAllTy :: TyCoVar -> ForAllTyFlag -> Type -> Type
mkTyCoForAllTy :: TyVar -> ForAllTyFlag -> Type -> Type
mkTyCoForAllTy TyVar
tv ForAllTyFlag
vis Type
ty
  | TyVar -> Bool
isCoVar TyVar
tv
  , Bool -> Bool
not (TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
ty)
   -- Maintain ForAllTy's invariants
    -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep
  = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany (TyVar -> Type
varType TyVar
tv) Type
ty
  | Bool
otherwise
  = VarBndr TyVar ForAllTyFlag -> Type -> Type
ForAllTy (ForAllTyFlag -> TyVar -> VarBndr TyVar ForAllTyFlag
forall vis. vis -> TyVar -> VarBndr TyVar vis
mkForAllTyBinder ForAllTyFlag
vis TyVar
tv) Type
ty

-- | Make a dependent forall over a TyCoVar
mkTyCoForAllTys :: [ForAllTyBinder] -> Type -> Type
mkTyCoForAllTys :: [VarBndr TyVar ForAllTyFlag] -> Type -> Type
mkTyCoForAllTys [VarBndr TyVar ForAllTyFlag]
bndrs Type
ty
  = (VarBndr TyVar ForAllTyFlag -> Type -> Type)
-> Type -> [VarBndr TyVar ForAllTyFlag] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Bndr TyVar
var ForAllTyFlag
vis) -> TyVar -> ForAllTyFlag -> Type -> Type
mkTyCoForAllTy TyVar
var ForAllTyFlag
vis) Type
ty [VarBndr TyVar ForAllTyFlag]
bndrs

-- | Make a dependent forall over an 'Inferred' variable
mkTyCoInvForAllTy :: TyCoVar -> Type -> Type
mkTyCoInvForAllTy :: TyVar -> Type -> Type
mkTyCoInvForAllTy TyVar
tv Type
ty = TyVar -> ForAllTyFlag -> Type -> Type
mkTyCoForAllTy TyVar
tv ForAllTyFlag
Inferred Type
ty

-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar
mkInfForAllTy :: TyVar -> Type -> Type
mkInfForAllTy :: TyVar -> Type -> Type
mkInfForAllTy TyVar
tv Type
ty = Bool
-> (VarBndr TyVar ForAllTyFlag -> Type -> Type)
-> VarBndr TyVar ForAllTyFlag
-> Type
-> Type
forall a. HasCallStack => Bool -> a -> a
assert (TyVar -> Bool
isTyVar TyVar
tv )
                      VarBndr TyVar ForAllTyFlag -> Type -> Type
VarBndr TyVar ForAllTyFlag -> Type -> Type
ForAllTy (TyVar -> ForAllTyFlag -> VarBndr TyVar ForAllTyFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ForAllTyFlag
Inferred) Type
ty

-- | Like 'mkForAllTys', but assumes all variables are dependent and
-- 'Inferred', a common case
mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type
mkTyCoInvForAllTys :: [TyVar] -> Type -> Type
mkTyCoInvForAllTys [TyVar]
tvs Type
ty = (TyVar -> Type -> Type) -> Type -> [TyVar] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyVar -> Type -> Type
mkTyCoInvForAllTy Type
ty [TyVar]
tvs

-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar
mkInfForAllTys :: [TyVar] -> Type -> Type
mkInfForAllTys :: [TyVar] -> Type -> Type
mkInfForAllTys [TyVar]
tvs Type
ty = (TyVar -> Type -> Type) -> Type -> [TyVar] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyVar -> Type -> Type
mkInfForAllTy Type
ty [TyVar]
tvs

-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified',
-- a common case
mkSpecForAllTy :: TyVar -> Type -> Type
mkSpecForAllTy :: TyVar -> Type -> Type
mkSpecForAllTy TyVar
tv Type
ty = Bool
-> (VarBndr TyVar ForAllTyFlag -> Type -> Type)
-> VarBndr TyVar ForAllTyFlag
-> Type
-> Type
forall a. HasCallStack => Bool -> a -> a
assert (TyVar -> Bool
isTyVar TyVar
tv )
                       -- covar is always Inferred, so input should be tyvar
                       VarBndr TyVar ForAllTyFlag -> Type -> Type
VarBndr TyVar ForAllTyFlag -> Type -> Type
ForAllTy (TyVar -> ForAllTyFlag -> VarBndr TyVar ForAllTyFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ForAllTyFlag
Specified) Type
ty

-- | Like 'mkForAllTys', but assumes all variables are dependent and
-- 'Specified', a common case
mkSpecForAllTys :: [TyVar] -> Type -> Type
mkSpecForAllTys :: [TyVar] -> Type -> Type
mkSpecForAllTys [TyVar]
tvs Type
ty = (TyVar -> Type -> Type) -> Type -> [TyVar] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyVar -> Type -> Type
mkSpecForAllTy Type
ty [TyVar]
tvs

-- | Like mkForAllTys, but assumes all variables are dependent and visible
mkVisForAllTys :: [TyVar] -> Type -> Type
mkVisForAllTys :: [TyVar] -> Type -> Type
mkVisForAllTys [TyVar]
tvs = Bool
-> ([VarBndr TyVar ForAllTyFlag] -> Type -> Type)
-> [VarBndr TyVar ForAllTyFlag]
-> Type
-> 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]
tvs )
                     -- covar is always Inferred, so all inputs should be tyvar
                     [VarBndr TyVar ForAllTyFlag] -> Type -> Type
mkForAllTys [ TyVar -> ForAllTyFlag -> VarBndr TyVar ForAllTyFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ForAllTyFlag
Required | TyVar
tv <- [TyVar]
tvs ]

-- | Given a list of type-level vars and the free vars of a result kind,
-- makes PiTyBinders, preferring anonymous binders
-- if the variable is, in fact, not dependent.
-- e.g.    mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k)
-- We want (k:*) Named, (b:k) Anon, (c:k) Anon
--
-- All non-coercion binders are /visible/.
mkTyConBindersPreferAnon :: [TyVar]      -- ^ binders
                         -> TyCoVarSet   -- ^ free variables of result
                         -> [TyConBinder]
mkTyConBindersPreferAnon :: [TyVar] -> VarSet -> [TyConBinder]
mkTyConBindersPreferAnon [TyVar]
vars VarSet
inner_tkvs = Bool
-> (([TyConBinder], VarSet) -> [TyConBinder])
-> ([TyConBinder], VarSet)
-> [TyConBinder]
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]
vars)
                                           ([TyConBinder], VarSet) -> [TyConBinder]
forall a b. (a, b) -> a
fst ([TyVar] -> ([TyConBinder], VarSet)
go [TyVar]
vars)
  where
    go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars
    go :: [TyVar] -> ([TyConBinder], VarSet)
go [] = ([], VarSet
inner_tkvs)
    go (TyVar
v:[TyVar]
vs) | TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` VarSet
fvs
              = ( TyVar -> TyConBndrVis -> TyConBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
v (ForAllTyFlag -> TyConBndrVis
NamedTCB ForAllTyFlag
Required) TyConBinder -> [TyConBinder] -> [TyConBinder]
forall a. a -> [a] -> [a]
: [TyConBinder]
binders
                , VarSet
fvs VarSet -> TyVar -> VarSet
`delVarSet` TyVar
v VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
kind_vars )
              | Bool
otherwise
              = ( TyVar -> TyConBndrVis -> TyConBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
v TyConBndrVis
AnonTCB TyConBinder -> [TyConBinder] -> [TyConBinder]
forall a. a -> [a] -> [a]
: [TyConBinder]
binders
                , VarSet
fvs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
kind_vars )
      where
        ([TyConBinder]
binders, VarSet
fvs) = [TyVar] -> ([TyConBinder], VarSet)
go [TyVar]
vs
        kind_vars :: VarSet
kind_vars      = Type -> VarSet
tyCoVarsOfType (Type -> VarSet) -> Type -> VarSet
forall a b. (a -> b) -> a -> b
$ TyVar -> Type
tyVarKind TyVar
v

-- | Take a ForAllTy apart, returning the binders and result type
splitForAllForAllTyBinders :: Type -> ([ForAllTyBinder], Type)
splitForAllForAllTyBinders :: Type -> ([VarBndr TyVar ForAllTyFlag], Type)
splitForAllForAllTyBinders Type
ty = Type
-> Type
-> [VarBndr TyVar ForAllTyFlag]
-> ([VarBndr TyVar ForAllTyFlag], Type)
split Type
ty Type
ty []
  where
    split :: Type
-> Type
-> [VarBndr TyVar ForAllTyFlag]
-> ([VarBndr TyVar ForAllTyFlag], Type)
split Type
_ (ForAllTy VarBndr TyVar ForAllTyFlag
b Type
res) [VarBndr TyVar ForAllTyFlag]
bs                   = Type
-> Type
-> [VarBndr TyVar ForAllTyFlag]
-> ([VarBndr TyVar ForAllTyFlag], Type)
split Type
res Type
res (VarBndr TyVar ForAllTyFlag
bVarBndr TyVar ForAllTyFlag
-> [VarBndr TyVar ForAllTyFlag] -> [VarBndr TyVar ForAllTyFlag]
forall a. a -> [a] -> [a]
:[VarBndr TyVar ForAllTyFlag]
bs)
    split Type
orig_ty Type
ty [VarBndr TyVar ForAllTyFlag]
bs | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type
-> Type
-> [VarBndr TyVar ForAllTyFlag]
-> ([VarBndr TyVar ForAllTyFlag], Type)
split Type
orig_ty Type
ty' [VarBndr TyVar ForAllTyFlag]
bs
    split Type
orig_ty Type
_                [VarBndr TyVar ForAllTyFlag]
bs             = ([VarBndr TyVar ForAllTyFlag] -> [VarBndr TyVar ForAllTyFlag]
forall a. [a] -> [a]
reverse [VarBndr TyVar ForAllTyFlag]
bs, Type
orig_ty)
{-# INLINE splitForAllForAllTyBinders #-}

-- | Take a ForAllTy apart, returning the list of tycovars and the result type.
-- This always succeeds, even if it returns only an empty list. Note that the
-- result type returned may have free variables that were bound by a forall.
splitForAllTyCoVars :: Type -> ([TyCoVar], Type)
splitForAllTyCoVars :: Type -> ([TyVar], Type)
splitForAllTyCoVars 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
_) Type
ty)    [TyVar]
tvs = 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 'splitForAllTyCoVars', but split only for tyvars.
-- This always succeeds, even if it returns only an empty list. Note that the
-- result type returned may have free variables that were bound by a forall.
splitForAllTyVars :: Type -> ([TyVar], Type)
splitForAllTyVars :: Type -> ([TyVar], Type)
splitForAllTyVars 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
_) Type
ty) [TyVar]
tvs | TyVar -> Bool
isTyVar TyVar
tv = 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 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Required' type
-- variable binders. Furthermore, each returned tyvar is annotated with '()'.
splitForAllReqTyBinders :: Type -> ([ReqTyBinder], Type)
splitForAllReqTyBinders :: Type -> ([ReqTyBinder], Type)
splitForAllReqTyBinders Type
ty = Type -> Type -> [ReqTyBinder] -> ([ReqTyBinder], Type)
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [ReqTyBinder] -> ([ReqTyBinder], Type)
split Type
_ (ForAllTy (Bndr TyVar
tv ForAllTyFlag
Required) Type
ty) [ReqTyBinder]
tvs   = Type -> Type -> [ReqTyBinder] -> ([ReqTyBinder], Type)
split Type
ty Type
ty (TyVar -> () -> ReqTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ()ReqTyBinder -> [ReqTyBinder] -> [ReqTyBinder]
forall a. a -> [a] -> [a]
:[ReqTyBinder]
tvs)
    split Type
orig_ty Type
ty [ReqTyBinder]
tvs | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type -> [ReqTyBinder] -> ([ReqTyBinder], Type)
split Type
orig_ty Type
ty' [ReqTyBinder]
tvs
    split Type
orig_ty Type
_                   [ReqTyBinder]
tvs          = ([ReqTyBinder] -> [ReqTyBinder]
forall a. [a] -> [a]
reverse [ReqTyBinder]
tvs, Type
orig_ty)

-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Invisible' type
-- variable binders. Furthermore, each returned tyvar is annotated with its
-- 'Specificity'.
splitForAllInvisTyBinders :: Type -> ([InvisTyBinder], Type)
splitForAllInvisTyBinders :: Type -> ([InvisTyBinder], Type)
splitForAllInvisTyBinders Type
ty = Type -> Type -> [InvisTyBinder] -> ([InvisTyBinder], Type)
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [InvisTyBinder] -> ([InvisTyBinder], Type)
split Type
_ (ForAllTy (Bndr TyVar
tv (Invisible Specificity
spec)) Type
ty) [InvisTyBinder]
tvs = Type -> Type -> [InvisTyBinder] -> ([InvisTyBinder], Type)
split Type
ty Type
ty (TyVar -> Specificity -> InvisTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv Specificity
specInvisTyBinder -> [InvisTyBinder] -> [InvisTyBinder]
forall a. a -> [a] -> [a]
:[InvisTyBinder]
tvs)
    split Type
orig_ty Type
ty [InvisTyBinder]
tvs | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty       = Type -> Type -> [InvisTyBinder] -> ([InvisTyBinder], Type)
split Type
orig_ty Type
ty' [InvisTyBinder]
tvs
    split Type
orig_ty Type
_                   [InvisTyBinder]
tvs                = ([InvisTyBinder] -> [InvisTyBinder]
forall a. [a] -> [a]
reverse [InvisTyBinder]
tvs, Type
orig_ty)

-- | Checks whether this is a proper forall (with a named binder)
isForAllTy :: Type -> Bool
isForAllTy :: Type -> Bool
isForAllTy Type
ty
  | ForAllTy {} <- Type -> Type
coreFullView Type
ty = Bool
True
  | Bool
otherwise                      = Bool
False

-- | Like `isForAllTy`, but returns True only if it is a tyvar binder
isForAllTy_ty :: Type -> Bool
isForAllTy_ty :: Type -> Bool
isForAllTy_ty Type
ty
  | ForAllTy (Bndr TyVar
tv ForAllTyFlag
_) Type
_ <- Type -> Type
coreFullView Type
ty
  , TyVar -> Bool
isTyVar TyVar
tv
  = Bool
True

  | Bool
otherwise = Bool
False

-- | Like `isForAllTy`, but returns True only if it is an inferred tyvar binder
isForAllTy_invis_ty :: Type -> Bool
isForAllTy_invis_ty :: Type -> Bool
isForAllTy_invis_ty  Type
ty
  | ForAllTy (Bndr TyVar
tv (Invisible Specificity
InferredSpec)) Type
_ <- Type -> Type
coreFullView Type
ty
  , TyVar -> Bool
isTyVar TyVar
tv
  = Bool
True

  | Bool
otherwise = Bool
False

-- | Like `isForAllTy`, but returns True only if it is a covar binder
isForAllTy_co :: Type -> Bool
isForAllTy_co :: Type -> Bool
isForAllTy_co Type
ty
  | ForAllTy (Bndr TyVar
tv ForAllTyFlag
_) Type
_ <- Type -> Type
coreFullView Type
ty
  , TyVar -> Bool
isCoVar TyVar
tv
  = Bool
True

  | Bool
otherwise = Bool
False

-- | Is this type a @FunTy@ or a @ForAllTy@, after expanding type synonyms?
--
-- Does not look through newtypes nor reduce type family applications.
isPiTy :: Type -> Bool
isPiTy :: Type -> Bool
isPiTy Type
ty = case Type -> Type
coreFullView Type
ty of
  ForAllTy {} -> Bool
True
  FunTy {}    -> Bool
True
  Type
_           -> Bool
False

-- | Is this type a function type (e.g. @X -> Y@ or @X => Y@),
-- after expanding type synonyms?
--
-- Note:
--
--  - Does not look through newtypes, so 'isFunTy' is 'False' for @IO ()@,
--    despite the latter being operationally a function (after expanding newtypes).
--  - Does not reduce type family applications, so 'isFunTy' is 'False' for
--    @Id (Int -> Bool)@ (where 'Id' is the identity type family).
--  - Does not consider @ForAllTy@ to be a function type (even when the argument
--    is a required argument), nor does it look through foralls.
--    Hence both 'isFunTy' is 'False' for both @forall b. Show b => b -> b@
--    and for @forall a -> Int@.
--
-- See also 'mightBeFunTy', when you want to know whether something could
-- be a function (taking a value argument) at runtime.
isFunTy :: Type -> Bool
isFunTy :: Type -> Bool
isFunTy Type
ty
  | FunTy {} <- Type -> Type
coreFullView Type
ty = Bool
True
  | Bool
otherwise                   = Bool
False

-- | Take a forall type apart, or panics if that is not possible.
splitForAllTyCoVar :: Type -> (TyCoVar, Type)
splitForAllTyCoVar :: Type -> (TyVar, Type)
splitForAllTyCoVar Type
ty
  | Just (TyVar, Type)
answer <- Type -> Maybe (TyVar, Type)
splitForAllTyCoVar_maybe Type
ty = (TyVar, Type)
answer
  | Bool
otherwise                                  = String -> SDoc -> (TyVar, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"splitForAllTyCoVar" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

-- | Drops all ForAllTys
dropForAlls :: Type -> Type
dropForAlls :: Type -> Type
dropForAlls Type
ty = Type -> Type
go Type
ty
  where
    go :: Type -> Type
go (ForAllTy VarBndr TyVar ForAllTyFlag
_ Type
res)            = Type -> Type
go Type
res
    go Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type
go Type
ty'
    go Type
res                         = Type
res

-- | Attempts to take a ForAllTy apart, returning the full ForAllTyBinder
splitForAllForAllTyBinder_maybe :: Type -> Maybe (ForAllTyBinder, Type)
splitForAllForAllTyBinder_maybe :: Type -> Maybe (VarBndr TyVar ForAllTyFlag, Type)
splitForAllForAllTyBinder_maybe Type
ty
  | ForAllTy VarBndr TyVar ForAllTyFlag
bndr Type
inner_ty <- Type -> Type
coreFullView Type
ty = (VarBndr TyVar ForAllTyFlag, Type)
-> Maybe (VarBndr TyVar ForAllTyFlag, Type)
forall a. a -> Maybe a
Just (VarBndr TyVar ForAllTyFlag
bndr, Type
inner_ty)
  | Bool
otherwise                                 = Maybe (VarBndr TyVar ForAllTyFlag, Type)
forall a. Maybe a
Nothing


-- | Attempts to take a ForAllTy apart, returning the Var
splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type)
splitForAllTyCoVar_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTyCoVar_maybe Type
ty
  | ForAllTy (Bndr TyVar
tv ForAllTyFlag
_) Type
inner_ty <- Type -> Type
coreFullView Type
ty = (TyVar, Type) -> Maybe (TyVar, Type)
forall a. a -> Maybe a
Just (TyVar
tv, Type
inner_ty)
  | Bool
otherwise                                        = Maybe (TyVar, Type)
forall a. Maybe a
Nothing

-- | Attempts to take a ForAllTy apart, but only if the binder is a TyVar
splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTyVar_maybe Type
ty
  | ForAllTy (Bndr TyVar
tv ForAllTyFlag
_) Type
inner_ty <- Type -> Type
coreFullView Type
ty
  , TyVar -> Bool
isTyVar TyVar
tv
  = (TyVar, Type) -> Maybe (TyVar, Type)
forall a. a -> Maybe a
Just (TyVar
tv, Type
inner_ty)

  | Bool
otherwise = Maybe (TyVar, Type)
forall a. Maybe a
Nothing

-- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a covar binder.
splitForAllCoVar_maybe :: Type -> Maybe (CoVar, Type)
splitForAllCoVar_maybe :: Type -> Maybe (TyVar, Type)
splitForAllCoVar_maybe Type
ty
  | ForAllTy (Bndr TyVar
tv ForAllTyFlag
_) Type
inner_ty <- Type -> Type
coreFullView Type
ty
  , TyVar -> Bool
isCoVar TyVar
tv
  = (TyVar, Type) -> Maybe (TyVar, Type)
forall a. a -> Maybe a
Just (TyVar
tv, Type
inner_ty)

  | Bool
otherwise = Maybe (TyVar, Type)
forall a. Maybe a
Nothing

-- | Attempts to take a forall type apart; works with proper foralls and
-- functions
{-# INLINE splitPiTy_maybe #-}  -- callers will immediately deconstruct
splitPiTy_maybe :: Type -> Maybe (PiTyBinder, Type)
splitPiTy_maybe :: Type -> Maybe (PiTyBinder, Type)
splitPiTy_maybe Type
ty = case Type -> Type
coreFullView Type
ty of
  ForAllTy VarBndr TyVar ForAllTyFlag
bndr Type
ty -> (PiTyBinder, Type) -> Maybe (PiTyBinder, Type)
forall a. a -> Maybe a
Just (VarBndr TyVar ForAllTyFlag -> PiTyBinder
Named VarBndr TyVar ForAllTyFlag
bndr, Type
ty)
  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}
                   -> (PiTyBinder, Type) -> Maybe (PiTyBinder, Type)
forall a. a -> Maybe a
Just (Scaled Type -> FunTyFlag -> PiTyBinder
Anon (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
mkScaled Type
w Type
arg) FunTyFlag
af, Type
res)
  Type
_                -> Maybe (PiTyBinder, Type)
forall a. Maybe a
Nothing

-- | Takes a forall type apart, or panics
splitPiTy :: Type -> (PiTyBinder, Type)
splitPiTy :: Type -> (PiTyBinder, Type)
splitPiTy Type
ty
  | Just (PiTyBinder, Type)
answer <- Type -> Maybe (PiTyBinder, Type)
splitPiTy_maybe Type
ty = (PiTyBinder, Type)
answer
  | Bool
otherwise                         = String -> SDoc -> (PiTyBinder, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"splitPiTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

-- | Split off all PiTyBinders to a type, splitting both proper foralls
-- and functions
splitPiTys :: Type -> ([PiTyBinder], Type)
splitPiTys :: Type -> ([PiTyBinder], Type)
splitPiTys Type
ty = Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Type
_       (ForAllTy VarBndr TyVar ForAllTyFlag
b Type
res) [PiTyBinder]
bs = Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Type
res Type
res (VarBndr TyVar ForAllTyFlag -> PiTyBinder
Named VarBndr TyVar ForAllTyFlag
b  PiTyBinder -> [PiTyBinder] -> [PiTyBinder]
forall a. a -> [a] -> [a]
: [PiTyBinder]
bs)
    split Type
_       (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 }) [PiTyBinder]
bs
                                      = Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Type
res Type
res (Scaled Type -> FunTyFlag -> PiTyBinder
Anon (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
w Type
arg) FunTyFlag
af PiTyBinder -> [PiTyBinder] -> [PiTyBinder]
forall a. a -> [a] -> [a]
: [PiTyBinder]
bs)
    split Type
orig_ty Type
ty [PiTyBinder]
bs | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Type
orig_ty Type
ty' [PiTyBinder]
bs
    split Type
orig_ty Type
_                [PiTyBinder]
bs = ([PiTyBinder] -> [PiTyBinder]
forall a. [a] -> [a]
reverse [PiTyBinder]
bs, Type
orig_ty)

collectPiTyBinders :: Type -> [PiTyBinder]
collectPiTyBinders :: Type -> [PiTyBinder]
collectPiTyBinders Type
ty = (forall b. (PiTyBinder -> b -> b) -> b -> b) -> [PiTyBinder]
forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
build ((forall b. (PiTyBinder -> b -> b) -> b -> b) -> [PiTyBinder])
-> (forall b. (PiTyBinder -> b -> b) -> b -> b) -> [PiTyBinder]
forall a b. (a -> b) -> a -> b
$ \PiTyBinder -> b -> b
c b
n ->
  let
    split :: Type -> b
split (ForAllTy VarBndr TyVar ForAllTyFlag
b Type
res) = VarBndr TyVar ForAllTyFlag -> PiTyBinder
Named VarBndr TyVar ForAllTyFlag
b PiTyBinder -> b -> b
`c` Type -> b
split Type
res
    split (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 })
                           = Scaled Type -> FunTyFlag -> PiTyBinder
Anon (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
w Type
arg) FunTyFlag
af PiTyBinder -> b -> b
`c` Type -> b
split Type
res
    split Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> b
split Type
ty'
    split Type
_                = b
n
  in
    Type -> b
split Type
ty
{-# INLINE collectPiTyBinders #-}

-- | Extracts a list of run-time arguments from a function type,
-- looking through newtypes to the right of arrows.
--
-- Examples:
--
-- @
--    newtype Identity a = I a
--
--    getRuntimeArgTys (Int -> Bool -> Double) == [(Int, FTF_T_T), (Bool, FTF_T_T)]
--    getRuntimeArgTys (Identity Int -> Bool -> Double) == [(Identity Int, FTF_T_T), (Bool, FTF_T_T)]
--    getRuntimeArgTys (Int -> Identity (Bool -> Identity Double)) == [(Int, FTF_T_T), (Bool, FTF_T_T)]
--    getRuntimeArgTys (forall a. Show a => Identity a -> a -> Int -> Bool)
--             == [(Show a, FTF_C_T), (Identity a, FTF_T_T),(a, FTF_T_T),(Int, FTF_T_T)]
-- @
--
-- Note that, in the last case, the returned types might mention an out-of-scope
-- type variable. This function is used only when we really care about the /kinds/
-- of the returned types, so this is OK.
--
-- **Warning**: this function can return an infinite list. For example:
--
-- @
--   newtype N a = MkN (a -> N a)
--   getRuntimeArgTys (N a) == repeat (a, FTF_T_T)
-- @
getRuntimeArgTys :: Type -> [(Scaled Type, FunTyFlag)]
getRuntimeArgTys :: Type -> [(Scaled Type, FunTyFlag)]
getRuntimeArgTys = Type -> [(Scaled Type, FunTyFlag)]
go
  where
    go :: Type -> [(Scaled Type, FunTyFlag)]
    go :: Type -> [(Scaled Type, FunTyFlag)]
go (ForAllTy VarBndr TyVar ForAllTyFlag
_ Type
res)
      = Type -> [(Scaled Type, FunTyFlag)]
go Type
res
    go (FunTy { ft_mult :: Type -> Type
ft_mult = Type
w, ft_arg :: Type -> Type
ft_arg = Type
arg, ft_res :: Type -> Type
ft_res = Type
res, ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af })
      = (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
w Type
arg, FunTyFlag
af) (Scaled Type, FunTyFlag)
-> [(Scaled Type, FunTyFlag)] -> [(Scaled Type, FunTyFlag)]
forall a. a -> [a] -> [a]
: Type -> [(Scaled Type, FunTyFlag)]
go Type
res
    go Type
ty
      | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
      = Type -> [(Scaled Type, FunTyFlag)]
go Type
ty'
      | Just (KindCoercion
_,Type
ty') <- Type -> Maybe (KindCoercion, Type)
topNormaliseNewType_maybe Type
ty
      = Type -> [(Scaled Type, FunTyFlag)]
go Type
ty'
      | Bool
otherwise
      = []

invisibleBndrCount :: Type -> Int
-- Returns the number of leading invisible forall'd binders in the type
-- Includes invisible predicate arguments; e.g. for
--    e.g.  forall {k}. (k ~ *) => k -> k
-- returns 2 not 1
invisibleBndrCount :: Type -> Arity
invisibleBndrCount Type
ty = [PiTyBinder] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length (([PiTyBinder], Type) -> [PiTyBinder]
forall a b. (a, b) -> a
fst (Type -> ([PiTyBinder], Type)
splitInvisPiTys Type
ty))

-- | Like 'splitPiTys', but returns only *invisible* binders, including constraints.
-- Stops at the first visible binder.
splitInvisPiTys :: Type -> ([PiTyBinder], Type)
splitInvisPiTys :: Type -> ([PiTyBinder], Type)
splitInvisPiTys Type
ty = Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Type
ty Type
ty []
   where
    split :: Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Type
_ (ForAllTy VarBndr TyVar ForAllTyFlag
b Type
res) [PiTyBinder]
bs
      | Bndr TyVar
_ ForAllTyFlag
vis <- VarBndr TyVar ForAllTyFlag
b
      , ForAllTyFlag -> Bool
isInvisibleForAllTyFlag ForAllTyFlag
vis   = Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Type
res Type
res (VarBndr TyVar ForAllTyFlag -> PiTyBinder
Named VarBndr TyVar ForAllTyFlag
b  PiTyBinder -> [PiTyBinder] -> [PiTyBinder]
forall a. a -> [a] -> [a]
: [PiTyBinder]
bs)
    split Type
_ (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af, ft_mult :: Type -> Type
ft_mult = Type
mult, ft_arg :: Type -> Type
ft_arg = Type
arg, ft_res :: Type -> Type
ft_res = Type
res })  [PiTyBinder]
bs
      | FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af     = Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Type
res Type
res (Scaled Type -> FunTyFlag -> PiTyBinder
Anon (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
mkScaled Type
mult Type
arg) FunTyFlag
af PiTyBinder -> [PiTyBinder] -> [PiTyBinder]
forall a. a -> [a] -> [a]
: [PiTyBinder]
bs)
    split Type
orig_ty Type
ty [PiTyBinder]
bs
      | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty  = Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Type
orig_ty Type
ty' [PiTyBinder]
bs
    split Type
orig_ty Type
_          [PiTyBinder]
bs  = ([PiTyBinder] -> [PiTyBinder]
forall a. [a] -> [a]
reverse [PiTyBinder]
bs, Type
orig_ty)

splitInvisPiTysN :: Int -> Type -> ([PiTyBinder], Type)
-- ^ Same as 'splitInvisPiTys', but stop when
--   - you have found @n@ 'PiTyBinder's,
--   - or you run out of invisible binders
splitInvisPiTysN :: Arity -> Type -> ([PiTyBinder], Type)
splitInvisPiTysN Arity
n Type
ty = Arity -> Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
forall {t}.
(Eq t, Num t) =>
t -> Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split Arity
n Type
ty Type
ty []
   where
    split :: t -> Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split t
n Type
orig_ty Type
ty [PiTyBinder]
bs
      | t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0                  = ([PiTyBinder] -> [PiTyBinder]
forall a. [a] -> [a]
reverse [PiTyBinder]
bs, Type
orig_ty)
      | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = t -> Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split t
n Type
orig_ty Type
ty' [PiTyBinder]
bs
      | ForAllTy VarBndr TyVar ForAllTyFlag
b Type
res <- Type
ty
      , Bndr TyVar
_ ForAllTyFlag
vis <- VarBndr TyVar ForAllTyFlag
b
      , ForAllTyFlag -> Bool
isInvisibleForAllTyFlag ForAllTyFlag
vis  = t -> Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) Type
res Type
res (VarBndr TyVar ForAllTyFlag -> PiTyBinder
Named VarBndr TyVar ForAllTyFlag
b  PiTyBinder -> [PiTyBinder] -> [PiTyBinder]
forall a. a -> [a] -> [a]
: [PiTyBinder]
bs)
      | FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af, ft_mult :: Type -> Type
ft_mult = Type
mult, ft_arg :: Type -> Type
ft_arg = Type
arg, ft_res :: Type -> Type
ft_res = Type
res } <- Type
ty
      , FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af   = t -> Type -> Type -> [PiTyBinder] -> ([PiTyBinder], Type)
split (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) Type
res Type
res (Scaled Type -> FunTyFlag -> PiTyBinder
Anon (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult Type
arg) FunTyFlag
af PiTyBinder -> [PiTyBinder] -> [PiTyBinder]
forall a. a -> [a] -> [a]
: [PiTyBinder]
bs)
      | Bool
otherwise              = ([PiTyBinder] -> [PiTyBinder]
forall a. [a] -> [a]
reverse [PiTyBinder]
bs, Type
orig_ty)

-- | Given a 'TyCon' and a list of argument types, filter out any invisible
-- (i.e., 'Inferred' or 'Specified') arguments.
filterOutInvisibleTypes :: TyCon -> [Type] -> [Type]
filterOutInvisibleTypes :: TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
tc [Type]
tys = ([Type], [Type]) -> [Type]
forall a b. (a, b) -> b
snd (([Type], [Type]) -> [Type]) -> ([Type], [Type]) -> [Type]
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> ([Type], [Type])
partitionInvisibleTypes TyCon
tc [Type]
tys

-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred'
-- arguments.
filterOutInferredTypes :: TyCon -> [Type] -> [Type]
filterOutInferredTypes :: TyCon -> [Type] -> [Type]
filterOutInferredTypes TyCon
tc [Type]
tys =
  [Bool] -> [Type] -> [Type]
forall a. [Bool] -> [a] -> [a]
filterByList ((ForAllTyFlag -> Bool) -> [ForAllTyFlag] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (ForAllTyFlag -> ForAllTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
/= ForAllTyFlag
Inferred) ([ForAllTyFlag] -> [Bool]) -> [ForAllTyFlag] -> [Bool]
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> [ForAllTyFlag]
tyConForAllTyFlags TyCon
tc [Type]
tys) [Type]
tys

-- | Given a 'TyCon' and a list of argument types, partition the arguments
-- into:
--
-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and
--
-- 2. 'Required' (i.e., visible) arguments
partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])
partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])
partitionInvisibleTypes TyCon
tc [Type]
tys =
  [Bool] -> [Type] -> ([Type], [Type])
forall a. [Bool] -> [a] -> ([a], [a])
partitionByList ((ForAllTyFlag -> Bool) -> [ForAllTyFlag] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ForAllTyFlag -> Bool
isInvisibleForAllTyFlag ([ForAllTyFlag] -> [Bool]) -> [ForAllTyFlag] -> [Bool]
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> [ForAllTyFlag]
tyConForAllTyFlags TyCon
tc [Type]
tys) [Type]
tys

-- | Given a list of things paired with their visibilities, partition the
-- things into (invisible things, visible things).
partitionInvisibles :: [(a, ForAllTyFlag)] -> ([a], [a])
partitionInvisibles :: forall a. [(a, ForAllTyFlag)] -> ([a], [a])
partitionInvisibles = ((a, ForAllTyFlag) -> Either a a)
-> [(a, ForAllTyFlag)] -> ([a], [a])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (a, ForAllTyFlag) -> Either a a
forall a. (a, ForAllTyFlag) -> Either a a
pick_invis
  where
    pick_invis :: (a, ForAllTyFlag) -> Either a a
    pick_invis :: forall a. (a, ForAllTyFlag) -> Either a a
pick_invis (a
thing, ForAllTyFlag
vis) | ForAllTyFlag -> Bool
isInvisibleForAllTyFlag ForAllTyFlag
vis = a -> Either a a
forall a b. a -> Either a b
Left a
thing
                            | Bool
otherwise              = a -> Either a a
forall a b. b -> Either a b
Right a
thing

-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is
-- applied, determine each argument's visibility
-- ('Inferred', 'Specified', or 'Required').
--
-- Wrinkle: consider the following scenario:
--
-- > T :: forall k. k -> k
-- > tyConForAllTyFlags T [forall m. m -> m -> m, S, R, Q]
--
-- After substituting, we get
--
-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n
--
-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again,
-- and @Q@ is visible.
tyConForAllTyFlags :: TyCon -> [Type] -> [ForAllTyFlag]
tyConForAllTyFlags :: TyCon -> [Type] -> [ForAllTyFlag]
tyConForAllTyFlags TyCon
tc = Type -> [Type] -> [ForAllTyFlag]
fun_kind_arg_flags (TyCon -> Type
tyConKind TyCon
tc)

-- | Given a 'Type' and a list of argument types to which the 'Type' is
-- applied, determine each argument's visibility
-- ('Inferred', 'Specified', or 'Required').
--
-- Most of the time, the arguments will be 'Required', but not always. Consider
-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is
-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely
-- this sort of higher-rank situation in which 'appTyForAllTyFlags' comes in handy,
-- since @f Type Bool@ would be represented in Core using 'AppTy's.
-- (See also #15792).
appTyForAllTyFlags :: Type -> [Type] -> [ForAllTyFlag]
appTyForAllTyFlags :: Type -> [Type] -> [ForAllTyFlag]
appTyForAllTyFlags Type
ty = Type -> [Type] -> [ForAllTyFlag]
fun_kind_arg_flags (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)

-- | Given a function kind and a list of argument types (where each argument's
-- kind aligns with the corresponding position in the argument kind), determine
-- each argument's visibility ('Inferred', 'Specified', or 'Required').
fun_kind_arg_flags :: Kind -> [Type] -> [ForAllTyFlag]
fun_kind_arg_flags :: Type -> [Type] -> [ForAllTyFlag]
fun_kind_arg_flags = Subst -> Type -> [Type] -> [ForAllTyFlag]
go Subst
emptySubst
  where
    go :: Subst -> Type -> [Type] -> [ForAllTyFlag]
go Subst
subst Type
ki [Type]
arg_tys
      | Just Type
ki' <- Type -> Maybe Type
coreView Type
ki = Subst -> Type -> [Type] -> [ForAllTyFlag]
go Subst
subst Type
ki' [Type]
arg_tys
    go Subst
_ Type
_ [] = []
    go Subst
subst (ForAllTy (Bndr TyVar
tv ForAllTyFlag
argf) Type
res_ki) (Type
arg_ty:[Type]
arg_tys)
      = ForAllTyFlag
argf ForAllTyFlag -> [ForAllTyFlag] -> [ForAllTyFlag]
forall a. a -> [a] -> [a]
: Subst -> Type -> [Type] -> [ForAllTyFlag]
go Subst
subst' Type
res_ki [Type]
arg_tys
      where
        subst' :: Subst
subst' = HasDebugCallStack => Subst -> TyVar -> Type -> Subst
Subst -> TyVar -> Type -> Subst
extendTvSubst Subst
subst TyVar
tv Type
arg_ty
    go Subst
subst (TyVarTy TyVar
tv) [Type]
arg_tys
      | Just Type
ki <- Subst -> TyVar -> Maybe Type
lookupTyVar Subst
subst TyVar
tv = Subst -> Type -> [Type] -> [ForAllTyFlag]
go Subst
subst Type
ki [Type]
arg_tys
    -- This FunTy case is important to handle kinds with nested foralls, such
    -- as this kind (inspired by #16518):
    --
    --   forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type
    --
    -- Here, we want to get the following ForAllTyFlags:
    --
    -- [Inferred,   Specified, Required, Required, Specified, Required]
    -- forall {k1}. forall k2. k1 ->     k2 ->     forall k3. k3 ->     Type
    go Subst
subst (FunTy{ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af, ft_res :: Type -> Type
ft_res = Type
res_ki}) (Type
_:[Type]
arg_tys)
      = ForAllTyFlag
argf ForAllTyFlag -> [ForAllTyFlag] -> [ForAllTyFlag]
forall a. a -> [a] -> [a]
: Subst -> Type -> [Type] -> [ForAllTyFlag]
go Subst
subst Type
res_ki [Type]
arg_tys
      where
        argf :: ForAllTyFlag
argf | FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af = ForAllTyFlag
Required
             | Bool
otherwise          = ForAllTyFlag
Inferred
    go Subst
_ Type
_ [Type]
arg_tys = (Type -> ForAllTyFlag) -> [Type] -> [ForAllTyFlag]
forall a b. (a -> b) -> [a] -> [b]
map (ForAllTyFlag -> Type -> ForAllTyFlag
forall a b. a -> b -> a
const ForAllTyFlag
Required) [Type]
arg_tys
                        -- something is ill-kinded. But this can happen
                        -- when printing errors. Assume everything is Required.

-- @isTauTy@ tests if a type has no foralls or (=>)
isTauTy :: Type -> Bool
isTauTy :: Type -> Bool
isTauTy Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isTauTy Type
ty'
isTauTy (TyVarTy TyVar
_)       = Bool
True
isTauTy (LitTy {})        = Bool
True
isTauTy (TyConApp TyCon
tc [Type]
tys) = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTauTy [Type]
tys Bool -> Bool -> Bool
&& TyCon -> Bool
isTauTyCon TyCon
tc
isTauTy (AppTy Type
a Type
b)       = Type -> Bool
isTauTy Type
a Bool -> Bool -> Bool
&& Type -> Bool
isTauTy Type
b
isTauTy (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af, ft_mult :: Type -> Type
ft_mult = Type
w, ft_arg :: Type -> Type
ft_arg = Type
a, ft_res :: Type -> Type
ft_res = Type
b })
 | FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af   = Bool
False                               -- e.g., Eq a => b
 | Bool
otherwise              = Type -> Bool
isTauTy Type
w Bool -> Bool -> Bool
&& Type -> Bool
isTauTy Type
a Bool -> Bool -> Bool
&& Type -> Bool
isTauTy Type
b -- e.g., a -> b
isTauTy (ForAllTy {})     = Bool
False
isTauTy (CastTy Type
ty KindCoercion
_)     = Type -> Bool
isTauTy Type
ty
isTauTy (CoercionTy KindCoercion
_)    = Bool
False  -- Not sure about this

isAtomicTy :: Type -> Bool
-- True if the type is just a single token, and can be printed compactly
-- Used when deciding how to lay out type error messages; see the
-- call in GHC.Tc.Errors
isAtomicTy :: Type -> Bool
isAtomicTy (TyVarTy {})    = Bool
True
isAtomicTy (LitTy {})      = Bool
True
isAtomicTy (TyConApp TyCon
_ []) = Bool
True

isAtomicTy Type
ty | Type -> Bool
isLiftedTypeKind Type
ty = Bool
True
   -- 'Type' prints compactly as *
   -- See GHC.Iface.Type.ppr_kind_type

isAtomicTy Type
_ = Bool
False

{-
************************************************************************
*                                                                      *
\subsection{Type families}
*                                                                      *
************************************************************************
-}

mkFamilyTyConApp :: TyCon -> [Type] -> Type
-- ^ Given a family instance TyCon and its arg types, return the
-- corresponding family type.  E.g:
--
-- > data family T a
-- > data instance T (Maybe b) = MkT b
--
-- Where the instance tycon is :RTL, so:
--
-- > mkFamilyTyConApp :RTL Int  =  T (Maybe Int)
mkFamilyTyConApp :: TyCon -> [Type] -> Type
mkFamilyTyConApp TyCon
tc [Type]
tys
  | Just (TyCon
fam_tc, [Type]
fam_tys) <- TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tc
  , let tvs :: [TyVar]
tvs = TyCon -> [TyVar]
tyConTyVars TyCon
tc
        fam_subst :: Subst
fam_subst = Bool -> SDoc -> Subst -> Subst
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([TyVar]
tvs [TyVar] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Type]
tys) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys) (Subst -> Subst) -> Subst -> Subst
forall a b. (a -> b) -> a -> b
$
                    [TyVar] -> [Type] -> Subst
HasDebugCallStack => [TyVar] -> [Type] -> Subst
zipTvSubst [TyVar]
tvs [Type]
tys
  = TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc (HasDebugCallStack => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTys Subst
fam_subst [Type]
fam_tys)
  | Bool
otherwise
  = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tys

-- | Get the type on the LHS of a coercion induced by a type/data
-- family instance.
coAxNthLHS :: CoAxiom br -> Int -> Type
coAxNthLHS :: forall (br :: BranchFlag). CoAxiom br -> Arity -> Type
coAxNthLHS CoAxiom br
ax Arity
ind =
  TyCon -> [Type] -> Type
mkTyConApp (CoAxiom br -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom br
ax) (CoAxBranch -> [Type]
coAxBranchLHS (CoAxiom br -> Arity -> CoAxBranch
forall (br :: BranchFlag). CoAxiom br -> Arity -> CoAxBranch
coAxiomNthBranch CoAxiom br
ax Arity
ind))

isFamFreeTy :: Type -> Bool
isFamFreeTy :: Type -> Bool
isFamFreeTy Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isFamFreeTy Type
ty'
isFamFreeTy (TyVarTy TyVar
_)       = Bool
True
isFamFreeTy (LitTy {})        = Bool
True
isFamFreeTy (TyConApp TyCon
tc [Type]
tys) = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isFamFreeTy [Type]
tys Bool -> Bool -> Bool
&& TyCon -> Bool
isFamFreeTyCon TyCon
tc
isFamFreeTy (AppTy Type
a Type
b)       = Type -> Bool
isFamFreeTy Type
a Bool -> Bool -> Bool
&& Type -> Bool
isFamFreeTy Type
b
isFamFreeTy (FunTy FunTyFlag
_ Type
w Type
a Type
b)   = Type -> Bool
isFamFreeTy Type
w Bool -> Bool -> Bool
&& Type -> Bool
isFamFreeTy Type
a Bool -> Bool -> Bool
&& Type -> Bool
isFamFreeTy Type
b
isFamFreeTy (ForAllTy VarBndr TyVar ForAllTyFlag
_ Type
ty)   = Type -> Bool
isFamFreeTy Type
ty
isFamFreeTy (CastTy Type
ty KindCoercion
_)     = Type -> Bool
isFamFreeTy Type
ty
isFamFreeTy (CoercionTy KindCoercion
_)    = Bool
False  -- Not sure about this

-- | Check whether a type is a data family type
isDataFamilyApp :: Type -> Bool
isDataFamilyApp :: Type -> Bool
isDataFamilyApp Type
ty = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
                           Just TyCon
tc -> TyCon -> Bool
isDataFamilyTyCon TyCon
tc
                           Maybe TyCon
_       -> Bool
False

isSatTyFamApp :: Type -> Maybe (TyCon, [Type])
-- Return the argument if we have a saturated type family application
-- Why saturated?  See (ATF4) in Note [Apartness and type families]
isSatTyFamApp :: Type -> Maybe (TyCon, [Type])
isSatTyFamApp (TyConApp TyCon
tc [Type]
tys)
  |  TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
  Bool -> Bool -> Bool
&& Bool -> Bool
not ([Type]
tys [Type] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthExceeds` TyCon -> Arity
tyConArity TyCon
tc)  -- Not over-saturated
  = (TyCon, [Type]) -> Maybe (TyCon, [Type])
forall a. a -> Maybe a
Just (TyCon
tc, [Type]
tys)
isSatTyFamApp Type
_ = Maybe (TyCon, [Type])
forall a. Maybe a
Nothing

buildSynTyCon :: Name
              -> KnotTied Kind
              -> [KnotTied TyConBinder]
              -> Kind   -- ^ /result/ kind
              -> [Role] -> KnotTied Type -> TyCon
-- This function is here because here is where we have
--   isFamFree and isTauTy
buildSynTyCon :: Name -> Type -> [TyConBinder] -> Type -> [Role] -> Type -> TyCon
buildSynTyCon Name
name Type
kind [TyConBinder]
binders Type
res_kind [Role]
roles Type
rhs
  = Name
-> Type
-> [TyConBinder]
-> Type
-> [Role]
-> Type
-> Bool
-> Bool
-> Bool
-> Bool
-> TyCon
mkSynonymTyCon Name
name Type
kind [TyConBinder]
binders Type
res_kind [Role]
roles Type
rhs
                   Bool
is_tau Bool
is_fam_free Bool
is_forgetful Bool
is_concrete
  where
    qtvs :: VarSet
qtvs         = [TyVar] -> VarSet
mkVarSet ((TyConBinder -> TyVar) -> [TyConBinder] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar [TyConBinder]
binders)
    is_tau :: Bool
is_tau       = Type -> Bool
isTauTy Type
rhs
    is_fam_free :: Bool
is_fam_free  = Type -> Bool
isFamFreeTy Type
rhs
    is_concrete :: Bool
is_concrete  = VarSet -> Type -> Bool
isConcreteTypeWith VarSet
qtvs Type
rhs
    is_forgetful :: Bool
is_forgetful = Bool -> Bool
not (VarSet
qtvs VarSet -> VarSet -> Bool
`subVarSet` VarSet
expanded_rhs_tyvars)

    expanded_rhs_tyvars :: VarSet
expanded_rhs_tyvars = Type -> VarSet
tyCoVarsOfType (Type -> Type
expandTypeSynonyms Type
rhs)
       -- See Note [Forgetful type synonyms] in GHC.Core.TyCon
       -- To find out if this TyCon is forgetful, expand the synonyms in its RHS
       -- and check that all of the binders are free in the expanded type.
       -- We really only need to expand the /forgetful/ synonyms on the RHS,
       -- but we don't currently have a function to do that.
       -- Failing to expand the RHS led to #25094, e.g.
       --    type Bucket a b c = Key (a,b,c)
       --    type Key x = Any
       -- Here Bucket is definitely forgetful!

{-
************************************************************************
*                                                                      *
\subsection{Liftedness}
*                                                                      *
************************************************************************
-}

-- | Tries to compute the 'Levity' of the given type. Returns either
-- a definite 'Levity', or 'Nothing' if we aren't sure (e.g. the
-- type is representation-polymorphic).
--
-- Panics if the kind does not have the shape @TYPE r@.
typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity
typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity
typeLevity_maybe Type
ty = Type -> Maybe Levity
runtimeRepLevity_maybe (HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty)

typeLevity :: HasDebugCallStack => Type -> Levity
typeLevity :: HasDebugCallStack => Type -> Levity
typeLevity Type
ty = case HasDebugCallStack => Type -> Maybe Levity
Type -> Maybe Levity
typeLevity_maybe Type
ty of
                   Just Levity
lev -> Levity
lev
                   Maybe Levity
Nothing  -> String -> SDoc -> Levity
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typeLevity" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

-- | Is the given type definitely unlifted?
-- See "Type#type_classification" for what an unlifted type is.
--
-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for
-- a more approximate predicate that behaves better in the presence of
-- representation polymorphism.
isUnliftedType :: HasDebugCallStack => Type -> Bool
        -- isUnliftedType returns True for forall'd unlifted types:
        --      x :: forall a. Int#
        -- I found bindings like these were getting floated to the top level.
isUnliftedType :: HasDebugCallStack => Type -> Bool
isUnliftedType Type
ty =
  case HasDebugCallStack => Type -> Maybe Levity
Type -> Maybe Levity
typeLevity_maybe Type
ty of
    Just Levity
Lifted   -> Bool
False
    Just Levity
Unlifted -> Bool
True
    Maybe Levity
Nothing       -> String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isUnliftedType" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty))

-- | Returns:
--
-- * 'False' if the type is /guaranteed/ unlifted or
-- * 'True' if it lifted, OR we aren't sure
--    (e.g. in a representation-polymorphic case)
mightBeLiftedType :: Type -> Bool
mightBeLiftedType :: Type -> Bool
mightBeLiftedType = Maybe Levity -> Bool
mightBeLifted (Maybe Levity -> Bool) -> (Type -> Maybe Levity) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Maybe Levity
Type -> Maybe Levity
typeLevity_maybe

definitelyLiftedType :: Type -> Bool
definitelyLiftedType :: Type -> Bool
definitelyLiftedType = Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
mightBeUnliftedType

-- | Returns:
--
-- * 'False' if the type is /guaranteed/ lifted or
-- * 'True' if it is unlifted, OR we aren't sure
--    (e.g. in a representation-polymorphic case)
mightBeUnliftedType :: Type -> Bool
mightBeUnliftedType :: Type -> Bool
mightBeUnliftedType = Maybe Levity -> Bool
mightBeUnlifted (Maybe Levity -> Bool) -> (Type -> Maybe Levity) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Maybe Levity
Type -> Maybe Levity
typeLevity_maybe

definitelyUnliftedType :: Type -> Bool
definitelyUnliftedType :: Type -> Bool
definitelyUnliftedType = Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
mightBeLiftedType

-- | See "Type#type_classification" for what a boxed type is.
-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for
-- a more approximate predicate that behaves better in the presence of
-- representation polymorphism.
isBoxedType :: Type -> Bool
isBoxedType :: Type -> Bool
isBoxedType Type
ty = Type -> Bool
isBoxedRuntimeRep (HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty)

-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep)
isRuntimeRepKindedTy :: Type -> Bool
isRuntimeRepKindedTy :: Type -> Bool
isRuntimeRepKindedTy = Type -> Bool
isRuntimeRepTy (Type -> Bool) -> (Type -> Type) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Type
Type -> Type
typeKind

-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g.
-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications:
--
--   dropRuntimeRepArgs [ 'LiftedRep, 'IntRep
--                      , String, Int# ] == [String, Int#]
--
dropRuntimeRepArgs :: [Type] -> [Type]
dropRuntimeRepArgs :: [Type] -> [Type]
dropRuntimeRepArgs = (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Type -> Bool
isRuntimeRepKindedTy

-- | Extract the RuntimeRep classifier of a type. For instance,
-- @getRuntimeRep_maybe Int = Just LiftedRep@. Returns 'Nothing' if this is not
-- possible.
getRuntimeRep_maybe :: HasDebugCallStack
                    => Type -> Maybe RuntimeRepType
getRuntimeRep_maybe :: HasDebugCallStack => Type -> Maybe Type
getRuntimeRep_maybe = HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe (Type -> Maybe Type) -> (Type -> Type) -> Type -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Type
Type -> Type
typeKind

-- | Extract the RuntimeRep classifier of a type. For instance,
-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible.
getRuntimeRep :: HasDebugCallStack => Type -> RuntimeRepType
getRuntimeRep :: HasDebugCallStack => Type -> Type
getRuntimeRep Type
ty
  = case HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
getRuntimeRep_maybe Type
ty of
      Just Type
r  -> Type
r
      Maybe Type
Nothing -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRuntimeRep" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty))

-- | Extract the 'Levity' of a type. For example, @getLevity_maybe Int = Just Lifted@,
-- @getLevity (Array# Int) = Just Unlifted@, @getLevity Float# = Nothing@.
--
-- Returns 'Nothing' if this is not possible. Does not look through type family applications.
getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type
getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type
getLevity_maybe Type
ty
  | Just Type
rep <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
getRuntimeRep_maybe Type
ty
  -- Directly matching on TyConApp after expanding type synonyms
  -- saves allocations compared to `splitTyConApp_maybe`. See #22254.
  -- Given that this is a pretty hot function we make use of the fact
  -- and use isTyConKeyApp_maybe instead.
  , Just [Type
lev] <- Unique -> Type -> Maybe [Type]
isTyConKeyApp_maybe Unique
boxedRepDataConKey Type
rep
  = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
lev
  | Bool
otherwise
  = Maybe Type
forall a. Maybe a
Nothing

-- | Extract the 'Levity' of a type. For example, @getLevity Int = Lifted@,
-- or @getLevity (Array# Int) = Unlifted@.
--
-- Panics if this is not possible. Does not look through type family applications.
getLevity :: HasDebugCallStack => Type -> Type
getLevity :: HasDebugCallStack => Type -> Type
getLevity Type
ty
  | Just Type
lev <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
getLevity_maybe Type
ty
  = Type
lev
  | Bool
otherwise
  = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getLevity" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty))

isUnboxedTupleType :: Type -> Bool
isUnboxedTupleType :: Type -> Bool
isUnboxedTupleType Type
ty
  = HasDebugCallStack => Type -> TyCon
Type -> TyCon
tyConAppTyCon (HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty) TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tupleRepDataConKey
  -- NB: Do not use typePrimRep, as that can't tell the difference between
  -- unboxed tuples and unboxed sums


isUnboxedSumType :: Type -> Bool
isUnboxedSumType :: Type -> Bool
isUnboxedSumType Type
ty
  = HasDebugCallStack => Type -> TyCon
Type -> TyCon
tyConAppTyCon (HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty) TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
sumRepDataConKey

-- | See "Type#type_classification" for what an algebraic type is.
-- Should only be applied to /types/, as opposed to e.g. partially
-- saturated type constructors
isAlgType :: Type -> Bool
isAlgType :: Type -> Bool
isAlgType Type
ty
  = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
      Just (TyCon
tc, [Type]
ty_args) -> Bool -> (TyCon -> Bool) -> TyCon -> Bool
forall a. HasCallStack => Bool -> a -> a
assert ([Type]
ty_args [Type] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthIs` TyCon -> Arity
tyConArity TyCon
tc )
                            TyCon -> Bool
isAlgTyCon TyCon
tc
      Maybe (TyCon, [Type])
_other             -> Bool
False

-- | Computes whether an argument (or let right hand side) should
-- be computed strictly or lazily, based only on its type.
-- Currently, it's just 'isUnliftedType'.
-- Panics on representation-polymorphic types.
isStrictType :: HasDebugCallStack => Type -> Bool
isStrictType :: HasDebugCallStack => Type -> Bool
isStrictType = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType

isTerminatingType :: HasDebugCallStack => Type -> Bool
-- ^ True <=> a term of this type cannot be bottom
-- This identifies the types described by
--    Note [NON-BOTTOM-DICTS invariant] in GHC.Core
-- NB: unlifted types are not terminating types!
--     e.g. you can write a term (loop 1)::Int# that diverges.
isTerminatingType :: HasDebugCallStack => Type -> Bool
isTerminatingType Type
ty = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
    Just TyCon
tc -> TyCon -> Bool
isTerminatingTyCon TyCon
tc
    Maybe TyCon
_       -> Bool
False

isPrimitiveType :: Type -> Bool
-- ^ Returns true of types that are opaque to Haskell.
isPrimitiveType :: Type -> Bool
isPrimitiveType Type
ty = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
                        Just (TyCon
tc, [Type]
ty_args) -> Bool -> (TyCon -> Bool) -> TyCon -> Bool
forall a. HasCallStack => Bool -> a -> a
assert ([Type]
ty_args [Type] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthIs` TyCon -> Arity
tyConArity TyCon
tc )
                                              TyCon -> Bool
isPrimTyCon TyCon
tc
                        Maybe (TyCon, [Type])
_                  -> Bool
False

{-
************************************************************************
*                                                                      *
\subsection{Join points}
*                                                                      *
************************************************************************
-}

-- | Determine whether a type could be the type of a join point of given total
-- arity, according to the polymorphism rule. A join point cannot be polymorphic
-- in its return type, since given
--   join j @a @b x y z = e1 in e2,
-- the types of e1 and e2 must be the same, and a and b are not in scope for e2.
-- (See Note [The polymorphism rule of join points] in "GHC.Core".) Returns False
-- also if the type simply doesn't have enough arguments.
--
-- Note that we need to know how many arguments (type *and* value) the putative
-- join point takes; for instance, if
--   j :: forall a. a -> Int
-- then j could be a binary join point returning an Int, but it could *not* be a
-- unary join point returning a -> Int.
--
-- TODO: See Note [Excess polymorphism and join points]
isValidJoinPointType :: JoinArity -> Type -> Bool
isValidJoinPointType :: Arity -> Type -> Bool
isValidJoinPointType Arity
arity Type
ty
  = VarSet -> Arity -> Type -> Bool
forall {t}. (Eq t, Num t) => VarSet -> t -> Type -> Bool
valid_under VarSet
emptyVarSet Arity
arity Type
ty
  where
    valid_under :: VarSet -> t -> Type -> Bool
valid_under VarSet
tvs t
arity Type
ty
      | t
arity t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0
      = VarSet
tvs VarSet -> VarSet -> Bool
`disjointVarSet` Type -> VarSet
tyCoVarsOfType Type
ty
      | Just (TyVar
t, Type
ty') <- Type -> Maybe (TyVar, Type)
splitForAllTyCoVar_maybe Type
ty
      = VarSet -> t -> Type -> Bool
valid_under (VarSet
tvs VarSet -> TyVar -> VarSet
`extendVarSet` TyVar
t) (t
arityt -> t -> t
forall a. Num a => a -> a -> a
-t
1) Type
ty'
      | Just (FunTyFlag
_, Type
_, Type
_, Type
res_ty) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
ty
      = VarSet -> t -> Type -> Bool
valid_under VarSet
tvs (t
arityt -> t -> t
forall a. Num a => a -> a -> a
-t
1) Type
res_ty
      | Bool
otherwise
      = Bool
False

{- Note [Excess polymorphism and join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In principle, if a function would be a join point except that it fails
the polymorphism rule (see Note [The polymorphism rule of join points] in
GHC.Core), it can still be made a join point with some effort. This is because
all tail calls must return the same type (they return to the same context!), and
thus if the return type depends on an argument, that argument must always be the
same.

For instance, consider:

  let f :: forall a. a -> Char -> [a]
      f @a x c = ... f @a y 'a' ...
  in ... f @Int 1 'b' ... f @Int 2 'c' ...

(where the calls are tail calls). `f` fails the polymorphism rule because its
return type is [a], where [a] is bound. But since the type argument is always
'Int', we can rewrite it as:

  let f' :: Int -> Char -> [Int]
      f' x c = ... f' y 'a' ...
  in ... f' 1 'b' ... f 2 'c' ...

and now we can make f' a join point:

  join f' :: Int -> Char -> [Int]
       f' x c = ... jump f' y 'a' ...
  in ... jump f' 1 'b' ... jump f' 2 'c' ...

It's not clear that this comes up often, however. TODO: Measure how often and
add this analysis if necessary.  See #14620.


************************************************************************
*                                                                      *
\subsection{Sequencing on types}
*                                                                      *
************************************************************************
-}

seqType :: Type -> ()
seqType :: Type -> ()
seqType (LitTy TyLit
n)                   = TyLit
n TyLit -> () -> ()
forall a b. a -> b -> b
`seq` ()
seqType (TyVarTy TyVar
tv)                = TyVar
tv TyVar -> () -> ()
forall a b. a -> b -> b
`seq` ()
seqType (AppTy Type
t1 Type
t2)               = Type -> ()
seqType Type
t1 () -> () -> ()
forall a b. a -> b -> b
`seq` Type -> ()
seqType Type
t2
seqType (FunTy FunTyFlag
_ Type
w Type
t1 Type
t2)           = Type -> ()
seqType Type
w () -> () -> ()
forall a b. a -> b -> b
`seq` Type -> ()
seqType Type
t1 () -> () -> ()
forall a b. a -> b -> b
`seq` Type -> ()
seqType Type
t2
seqType (TyConApp TyCon
tc [Type]
tys)           = TyCon
tc TyCon -> () -> ()
forall a b. a -> b -> b
`seq` [Type] -> ()
seqTypes [Type]
tys
seqType (ForAllTy (Bndr TyVar
tv ForAllTyFlag
_) Type
ty)   = Type -> ()
seqType (TyVar -> Type
varType TyVar
tv) () -> () -> ()
forall a b. a -> b -> b
`seq` Type -> ()
seqType Type
ty
seqType (CastTy Type
ty KindCoercion
co)              = Type -> ()
seqType Type
ty () -> () -> ()
forall a b. a -> b -> b
`seq` KindCoercion -> ()
seqCo KindCoercion
co
seqType (CoercionTy KindCoercion
co)             = KindCoercion -> ()
seqCo KindCoercion
co

seqTypes :: [Type] -> ()
seqTypes :: [Type] -> ()
seqTypes []       = ()
seqTypes (Type
ty:[Type]
tys) = Type -> ()
seqType Type
ty () -> () -> ()
forall a b. a -> b -> b
`seq` [Type] -> ()
seqTypes [Type]
tys

{-
************************************************************************
*                                                                      *
        The kind of a type
*                                                                      *
************************************************************************

Note [Kinding rules for types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here are the key kinding rules for types

          torc1 is TYPE or CONSTRAINT
          torc2 is TYPE or CONSTRAINT
          t1 : torc1 rep1
          t2 : torc2 rep2
   (FUN)  ----------------
          t1 -> t2 : torc2 LiftedRep
          -- In fact the arrow varies with torc1/torc2
          -- See Note [Function type constructors and FunTy]
          -- in GHC.Builtin.Types.Prim

          torc is TYPE or CONSTRAINT
          ty : body_torc rep
          ki : Type
          `a` is a type variable
          `a` is not free in rep
(FORALL1) -----------------------
          forall (a::ki). ty : body_torc rep

          torc is TYPE or CONSTRAINT
          ty : body_torc rep
          `c` is a coercion variable
          `c` is not free in rep
          `c` is free in ty       -- Surprise 1!
(FORALL2) -------------------------
          forall (cv::k1 ~#{N,R} k2). ty : body_torc LiftedRep
                                           -- Surprise 2!

Note that:
* (FORALL1) rejects (forall (a::Maybe). blah)

* (FORALL2) Surprise 1:
  See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]

* (FORALL2) Surprise 2: coercion abstractions are not erased, so
  this must be LiftedRep, just like (FUN).  (FORALL2) is just a
  dependent form of (FUN).


Note [Phantom type variables in kinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider

  type K (r :: RuntimeRep) = Type   -- Note 'r' is unused
  data T r :: K r                   -- T :: forall r -> K r
  foo :: forall r. T r

The body of the forall in foo's type has kind (K r), and
normally it would make no sense to have
   forall r. (ty :: K r)
because the kind of the forall would escape the binding
of 'r'.  But in this case it's fine because (K r) expands
to Type, so we explicitly /permit/ the type
   forall r. T r

To accommodate such a type, in typeKind (forall a.ty) we use
occCheckExpand to expand any type synonyms in the kind of 'ty'
to eliminate 'a'.  See kinding rule (FORALL) in
Note [Kinding rules for types]


See also
 * GHC.Core.Type.occCheckExpand
 * GHC.Core.Utils.coreAltsType
 * GHC.Tc.Validity.checkEscapingKind
all of which grapple with the same problem.

See #14939.
-}

-----------------------------
typeKind :: HasDebugCallStack => Type -> Kind
-- No need to expand synonyms
typeKind :: HasDebugCallStack => Type -> Type
typeKind (TyConApp TyCon
tc [Type]
tys)      = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys (TyCon -> Type
tyConKind TyCon
tc) [Type]
tys
typeKind (LitTy TyLit
l)              = TyLit -> Type
typeLiteralKind TyLit
l
typeKind (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af }) = TypeOrConstraint -> Type
liftedTypeOrConstraintKind (FunTyFlag -> TypeOrConstraint
funTyFlagResultTypeOrConstraint FunTyFlag
af)
typeKind (TyVarTy TyVar
tyvar)        = TyVar -> Type
tyVarKind TyVar
tyvar
typeKind (CastTy Type
_ty KindCoercion
co)        = HasDebugCallStack => KindCoercion -> Type
KindCoercion -> Type
coercionRKind KindCoercion
co
typeKind (CoercionTy KindCoercion
co)        = KindCoercion -> Type
coercionType KindCoercion
co

typeKind (AppTy Type
fun Type
arg)
  = Type -> [Type] -> Type
go Type
fun [Type
arg]
  where
    -- Accumulate the type arguments, so we can call piResultTys,
    -- rather than a succession of calls to piResultTy (which is
    -- asymptotically costly as the number of arguments increases)
    go :: Type -> [Type] -> Type
go (AppTy Type
fun Type
arg) [Type]
args = Type -> [Type] -> Type
go Type
fun (Type
argType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args)
    go Type
fun             [Type]
args = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
fun) [Type]
args

typeKind ty :: Type
ty@(ForAllTy {})
  = Bool -> SDoc -> Type -> Type
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not ([TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
tcvs)) (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
       -- If tcvs is empty somehow we'll get an infinite loop!
    case [TyVar] -> Type -> Maybe Type
occCheckExpand [TyVar]
tcvs Type
body_kind of
      -- We must make sure tvs do not occur in kind,
      -- as they would be out of scope!
      -- See Note [Phantom type variables in kinds]
      Maybe Type
Nothing -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typeKind"
                  (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tcvs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_kind)

      Just Type
k' | (TyVar -> Bool) -> [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyVar -> Bool
isTyVar [TyVar]
tcvs -> Type
k'                     -- Rule (FORALL1)
              | Bool
otherwise        -> Type
lifted_kind_from_body  -- Rule (FORALL2)
  where
    ([TyVar]
tcvs, Type
body) = Type -> ([TyVar], Type)
splitForAllTyCoVars Type
ty  -- Important: splits both TyVar and CoVar binders
    body_kind :: Type
body_kind    = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
body

    lifted_kind_from_body :: Type
lifted_kind_from_body  -- Implements (FORALL2)
      = case Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
body_kind of
          Just (TypeOrConstraint
torc, Type
_) -> TypeOrConstraint -> Type
liftedTypeOrConstraintKind TypeOrConstraint
torc
          Maybe (TypeOrConstraint, Type)
Nothing        -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typeKind" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_kind)


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

sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, Type)
-- Sees if the argument is of form (TYPE rep) or (CONSTRAINT rep)
-- and if so returns which, and the runtime rep
--
-- This is a "hot" function.  Do not call splitTyConApp_maybe here,
-- to avoid the faff with FunTy
sORTKind_maybe :: Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe (TyConApp TyCon
tc [Type]
tys)
  -- First, short-cuts for Type and Constraint that do no allocation
  | Unique
tc_uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
liftedTypeKindTyConKey = Bool
-> Maybe (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type)
forall a. HasCallStack => Bool -> a -> a
assert( [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys ) (Maybe (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type))
-> Maybe (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type)
forall a b. (a -> b) -> a -> b
$ (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type)
forall a. a -> Maybe a
Just (TypeOrConstraint
TypeLike,       Type
liftedRepTy)
  | Unique
tc_uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
constraintKindTyConKey = Bool
-> Maybe (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type)
forall a. HasCallStack => Bool -> a -> a
assert( [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys ) (Maybe (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type))
-> Maybe (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type)
forall a b. (a -> b) -> a -> b
$ (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type)
forall a. a -> Maybe a
Just (TypeOrConstraint
ConstraintLike, Type
liftedRepTy)
  | Unique
tc_uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
tYPETyConKey           = TypeOrConstraint -> Maybe (TypeOrConstraint, Type)
get_rep TypeOrConstraint
TypeLike
  | Unique
tc_uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
cONSTRAINTTyConKey     = TypeOrConstraint -> Maybe (TypeOrConstraint, Type)
get_rep TypeOrConstraint
ConstraintLike
  | Just Type
ty' <- TyCon -> [Type] -> Maybe Type
expandSynTyConApp_maybe TyCon
tc [Type]
tys = Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
ty'
  where
    !tc_uniq :: Unique
tc_uniq = TyCon -> Unique
tyConUnique TyCon
tc
     -- This bang on tc_uniq is important.  It means that sORTKind_maybe starts
     -- by evaluating tc_uniq, and then ends up with a single case with a 4-way branch

    get_rep :: TypeOrConstraint -> Maybe (TypeOrConstraint, Type)
get_rep TypeOrConstraint
torc = case [Type]
tys of
                     (Type
rep:[Type]
_reps) -> Bool
-> Maybe (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type)
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
_reps) (Maybe (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type))
-> Maybe (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type)
forall a b. (a -> b) -> a -> b
$ (TypeOrConstraint, Type) -> Maybe (TypeOrConstraint, Type)
forall a. a -> Maybe a
Just (TypeOrConstraint
torc, Type
rep)
                     []          -> Maybe (TypeOrConstraint, Type)
forall a. Maybe a
Nothing

sORTKind_maybe Type
_ = Maybe (TypeOrConstraint, Type)
forall a. Maybe a
Nothing

typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint
-- Precondition: expects a type that classifies values.
-- Returns whether it is TypeLike or ConstraintLike.
-- Equivalent to calling sORTKind_maybe, but faster in the FunTy case
typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint
typeTypeOrConstraint Type
ty
   = case Type -> Type
coreFullView Type
ty of
       FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af } -> FunTyFlag -> TypeOrConstraint
funTyFlagResultTypeOrConstraint FunTyFlag
af
       Type
ty' | Just (TypeOrConstraint
torc, Type
_) <- Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty')
          -> TypeOrConstraint
torc
          | Bool
otherwise
          -> String -> SDoc -> TypeOrConstraint
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typeOrConstraint" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty))

-- | Does this classify a type allowed to have values? Responds True to things
-- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint.
isTYPEorCONSTRAINT :: Kind -> Bool
-- ^ True of a kind `TYPE _` or `CONSTRAINT _`
isTYPEorCONSTRAINT :: Type -> Bool
isTYPEorCONSTRAINT Type
k = Maybe (TypeOrConstraint, Type) -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
k)

tyConIsTYPEorCONSTRAINT :: TyCon -> Bool
tyConIsTYPEorCONSTRAINT :: TyCon -> Bool
tyConIsTYPEorCONSTRAINT TyCon
tc
  = Unique
tc_uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
tYPETyConKey Bool -> Bool -> Bool
|| Unique
tc_uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
cONSTRAINTTyConKey
  where
    !tc_uniq :: Unique
tc_uniq = TyCon -> Unique
tyConUnique TyCon
tc

isConstraintLikeKind :: Kind -> Bool
-- True of (CONSTRAINT _)
isConstraintLikeKind :: Type -> Bool
isConstraintLikeKind Type
kind
  = case Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
kind of
      Just (TypeOrConstraint
ConstraintLike, Type
_) -> Bool
True
      Maybe (TypeOrConstraint, Type)
_                        -> Bool
False

isConstraintKind :: Kind -> Bool
-- True of (CONSTRAINT LiftedRep)
isConstraintKind :: Type -> Bool
isConstraintKind Type
kind
  = case Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
kind of
      Just (TypeOrConstraint
ConstraintLike, Type
rep) -> Type -> Bool
isLiftedRuntimeRep Type
rep
      Maybe (TypeOrConstraint, Type)
_                          -> Bool
False

tcIsLiftedTypeKind :: Kind -> Bool
-- ^ Is this kind equivalent to 'Type' i.e. TYPE LiftedRep?
tcIsLiftedTypeKind :: Type -> Bool
tcIsLiftedTypeKind Type
kind
  | Just (TypeOrConstraint
TypeLike, Type
rep) <- Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
kind
  = Type -> Bool
isLiftedRuntimeRep Type
rep
  | Bool
otherwise
  = Bool
False

tcIsBoxedTypeKind :: Kind -> Bool
-- ^ Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@?
tcIsBoxedTypeKind :: Type -> Bool
tcIsBoxedTypeKind Type
kind
  | Just (TypeOrConstraint
TypeLike, Type
rep) <- Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
kind
  = Type -> Bool
isBoxedRuntimeRep Type
rep
  | Bool
otherwise
  = Bool
False

-- | Is this kind equivalent to @TYPE r@ (for some unknown r)?
--
-- This considers 'Constraint' to be distinct from @*@.
isTypeLikeKind :: Kind -> Bool
isTypeLikeKind :: Type -> Bool
isTypeLikeKind Type
kind
  = case Type -> Maybe (TypeOrConstraint, Type)
sORTKind_maybe Type
kind of
      Just (TypeOrConstraint
TypeLike, Type
_) -> Bool
True
      Maybe (TypeOrConstraint, Type)
_                  -> Bool
False

returnsConstraintKind :: Kind -> Bool
-- True <=> the Kind ultimately returns a Constraint
--   E.g.  * -> Constraint
--         forall k. k -> Constraint
returnsConstraintKind :: Type -> Bool
returnsConstraintKind Type
kind
  | Just Type
kind' <- Type -> Maybe Type
coreView Type
kind = Type -> Bool
returnsConstraintKind Type
kind'
returnsConstraintKind (ForAllTy VarBndr TyVar ForAllTyFlag
_ Type
ty)         = Type -> Bool
returnsConstraintKind Type
ty
returnsConstraintKind (FunTy { ft_res :: Type -> Type
ft_res = Type
ty }) = Type -> Bool
returnsConstraintKind Type
ty
returnsConstraintKind Type
kind                    = Type -> Bool
isConstraintLikeKind Type
kind

--------------------------
typeLiteralKind :: TyLit -> Kind
typeLiteralKind :: TyLit -> Type
typeLiteralKind (NumTyLit {}) = Type
naturalTy
typeLiteralKind (StrTyLit {}) = Type
typeSymbolKind
typeLiteralKind (CharTyLit {}) = Type
charTy

-- | Returns True if a type has a syntactically fixed runtime rep,
-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
--
-- This function is equivalent to `isFixedRuntimeRepKind . typeKind`
-- but much faster.
--
-- __Precondition:__ The type has kind @('TYPE' blah)@
typeHasFixedRuntimeRep :: HasDebugCallStack => Type -> Bool
typeHasFixedRuntimeRep :: HasDebugCallStack => Type -> Bool
typeHasFixedRuntimeRep = Type -> Bool
go
  where
    go :: Type -> Bool
go (TyConApp TyCon
tc [Type]
_)
      | TyCon -> Bool
tcHasFixedRuntimeRep TyCon
tc = Bool
True
    go (FunTy {})               = Bool
True
    go (LitTy {})               = Bool
True
    go (ForAllTy VarBndr TyVar ForAllTyFlag
_ Type
ty)          = Type -> Bool
go Type
ty
    go Type
ty                       = HasDebugCallStack => Type -> Bool
Type -> Bool
isFixedRuntimeRepKind (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)

-- | Checks that a kind of the form 'Type', 'Constraint'
-- or @'TYPE r@ is concrete. See 'isConcreteType'.
--
-- __Precondition:__ The type has kind `TYPE blah` or `CONSTRAINT blah`
isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool
isFixedRuntimeRepKind :: HasDebugCallStack => Type -> Bool
isFixedRuntimeRepKind Type
k
  = Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Type -> Bool
isTYPEorCONSTRAINT Type
k) (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    -- the isLiftedTypeKind check is necessary b/c of Constraint
    Type -> Bool
isConcreteType Type
k

-- | Tests whether the given type is concrete, i.e. it
-- whether it consists only of concrete type constructors,
-- concrete type variables, and applications.
--
-- See Note [Concrete types] in GHC.Tc.Utils.Concrete.
isConcreteType :: Type -> Bool
isConcreteType :: Type -> Bool
isConcreteType = VarSet -> Type -> Bool
isConcreteTypeWith VarSet
emptyVarSet

-- | Like 'isConcreteType', but allows passing in a set of 'TyVar's that
-- should be considered concrete.
--
-- See Note [Concrete types] in GHC.Tc.Utils.Concrete.
isConcreteTypeWith :: TyVarSet -> Type -> Bool
-- This version, with a 'TyVarSet' argument, supports 'mkSynonymTyCon',
-- which needs to test the RHS for concreteness, under the assumption that
-- the binders are instantiated to concrete types
isConcreteTypeWith :: VarSet -> Type -> Bool
isConcreteTypeWith VarSet
conc_tvs = Type -> Bool
go
  where
    go :: Type -> Bool
go (TyVarTy TyVar
tv)        = TyVar -> Bool
isConcreteTyVar TyVar
tv Bool -> Bool -> Bool
|| TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` VarSet
conc_tvs
    go (AppTy Type
ty1 Type
ty2)     = Type -> Bool
go Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
go Type
ty2
    go (TyConApp TyCon
tc [Type]
tys)   = TyCon -> [Type] -> Bool
go_tc TyCon
tc [Type]
tys
    go ForAllTy{}          = Bool
False
    go (FunTy FunTyFlag
_ Type
w Type
t1 Type
t2)   =  Type -> Bool
go Type
w
                           Bool -> Bool -> Bool
&& Type -> Bool
go (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
t1) Bool -> Bool -> Bool
&& Type -> Bool
go Type
t1
                           Bool -> Bool -> Bool
&& Type -> Bool
go (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
t2) Bool -> Bool -> Bool
&& Type -> Bool
go Type
t2
    go LitTy{}             = Bool
True
    go CastTy{}            = Bool
False
    go CoercionTy{}        = Bool
False

    go_tc :: TyCon -> [Type] -> Bool
    go_tc :: TyCon -> [Type] -> Bool
go_tc TyCon
tc [Type]
tys
      | TyCon -> Bool
isForgetfulSynTyCon TyCon
tc  -- E.g. type S a = Int
                                -- Then (S x) is concrete even if x isn't
      , Just Type
ty' <- TyCon -> [Type] -> Maybe Type
expandSynTyConApp_maybe TyCon
tc [Type]
tys
      = Type -> Bool
go Type
ty'

      -- Apart from forgetful synonyms, isConcreteTyCon
      -- is enough; no need to expand.  This is good for e.g
      --      type LiftedRep = BoxedRep Lifted
      | TyCon -> Bool
isConcreteTyCon TyCon
tc
      = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
go [Type]
tys

      | Bool
otherwise  -- E.g. type families
      = Bool
False

{-
%************************************************************************
%*                                                                      *
         Pretty-printing
%*                                                                      *
%************************************************************************

Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type.

-}

-- | Does a 'TyCon' (that is applied to some number of arguments) need to be
-- ascribed with an explicit kind signature to resolve ambiguity if rendered as
-- a source-syntax type?
-- (See @Note [When does a tycon application need an explicit kind signature?]@
-- for a full explanation of what this function checks for.)
tyConAppNeedsKindSig
  :: Bool  -- ^ Should specified binders count towards injective positions in
           --   the kind of the TyCon? (If you're using visible kind
           --   applications, then you want True here.)
  -> TyCon
  -> Int   -- ^ The number of args the 'TyCon' is applied to.
  -> Bool  -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the
           --   number of arguments)
tyConAppNeedsKindSig :: Bool -> TyCon -> Arity -> Bool
tyConAppNeedsKindSig Bool
spec_inj_pos TyCon
tc Arity
n_args
  | Ordering
LT <- [TyConBinder] -> Arity -> Ordering
forall a. [a] -> Arity -> Ordering
listLengthCmp [TyConBinder]
tc_binders Arity
n_args
  = Bool
False
  | Bool
otherwise
  = let ([TyConBinder]
dropped_binders, [TyConBinder]
remaining_binders)
          = Arity -> [TyConBinder] -> ([TyConBinder], [TyConBinder])
forall a. Arity -> [a] -> ([a], [a])
splitAt Arity
n_args [TyConBinder]
tc_binders
        result_kind :: Type
result_kind  = [TyConBinder] -> Type -> Type
mkTyConKind [TyConBinder]
remaining_binders Type
tc_res_kind
        result_vars :: VarSet
result_vars  = Type -> VarSet
tyCoVarsOfType Type
result_kind
        dropped_vars :: VarSet
dropped_vars = (TyConBinder -> VarSet) -> [TyConBinder] -> VarSet
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet TyConBinder -> VarSet
injective_vars_of_binder [TyConBinder]
dropped_binders

    in Bool -> Bool
not (VarSet -> VarSet -> Bool
subVarSet VarSet
result_vars VarSet
dropped_vars)
  where
    tc_binders :: [TyConBinder]
tc_binders  = TyCon -> [TyConBinder]
tyConBinders TyCon
tc
    tc_res_kind :: Type
tc_res_kind = TyCon -> Type
tyConResKind TyCon
tc

    -- Returns the variables that would be fixed by knowing a TyConBinder. See
    -- Note [When does a tycon application need an explicit kind signature?]
    -- for a more detailed explanation of what this function does.
    injective_vars_of_binder :: TyConBinder -> VarSet
    injective_vars_of_binder :: TyConBinder -> VarSet
injective_vars_of_binder (Bndr TyVar
tv TyConBndrVis
vis) =
      case TyConBndrVis
vis of
        TyConBndrVis
AnonTCB        -> Bool -> Type -> VarSet
injectiveVarsOfType Bool
False -- conservative choice
                                              (TyVar -> Type
varType TyVar
tv)
        NamedTCB ForAllTyFlag
argf  | ForAllTyFlag -> Bool
source_of_injectivity ForAllTyFlag
argf
                       -> TyVar -> VarSet
unitVarSet TyVar
tv VarSet -> VarSet -> VarSet
`unionVarSet`
                          Bool -> Type -> VarSet
injectiveVarsOfType Bool
False (TyVar -> Type
varType TyVar
tv)
        TyConBndrVis
_              -> VarSet
emptyVarSet

    source_of_injectivity :: ForAllTyFlag -> Bool
source_of_injectivity ForAllTyFlag
Required  = Bool
True
    source_of_injectivity ForAllTyFlag
Specified = Bool
spec_inj_pos
    source_of_injectivity ForAllTyFlag
Inferred  = Bool
False

{-
Note [When does a tycon application need an explicit kind signature?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are a couple of places in GHC where we convert Core Types into forms that
more closely resemble user-written syntax. These include:

1. Template Haskell Type reification (see, for instance, GHC.Tc.Gen.Splice.reify_tc_app)
2. Converting Types to LHsTypes (such as in Haddock.Convert in haddock)

This conversion presents a challenge: how do we ensure that the resulting type
has enough kind information so as not to be ambiguous? To better motivate this
question, consider the following Core type:

  -- Foo :: Type -> Type
  type Foo = Proxy Type

There is nothing ambiguous about the RHS of Foo in Core. But if we were to,
say, reify it into a TH Type, then it's tempting to just drop the invisible
Type argument and simply return `Proxy`. But now we've lost crucial kind
information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool`
or `Proxy Int` or something else! We've inadvertently introduced ambiguity.

Unlike in other situations in GHC, we can't just turn on
-fprint-explicit-kinds, as we need to produce something which has the same
structure as a source-syntax type. Moreover, we can't rely on visible kind
application, since the first kind argument to Proxy is inferred, not specified.
Our solution is to annotate certain tycons with their kinds whenever they
appear in applied form in order to resolve the ambiguity. For instance, we
would reify the RHS of Foo like so:

  type Foo = (Proxy :: Type -> Type)

We need to devise an algorithm that determines precisely which tycons need
these explicit kind signatures. We certainly don't want to annotate _every_
tycon with a kind signature, or else we might end up with horribly bloated
types like the following:

  (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type)

We only want to annotate tycons that absolutely require kind signatures in
order to resolve some sort of ambiguity, and nothing more.

Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type
require a kind signature? It might require it when we need to fill in any of
T's omitted arguments. By "omitted argument", we mean one that is dropped when
reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and
specified arguments (e.g., TH reification in GHC.Tc.Gen.Splice), and sometimes the
omitted arguments are only the inferred ones (e.g., in situations where
specified arguments are reified through visible kind application).
Regardless, the key idea is that _some_ arguments are going to be omitted after
reification, and the only mechanism we have at our disposal for filling them in
is through explicit kind signatures.

What do we mean by "fill in"? Let's consider this small example:

  T :: forall {k}. Type -> (k -> Type) -> k

Moreover, we have this application of T:

  T @{j} Int aty

When we reify this type, we omit the inferred argument @{j}. Is it fixed by the
other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then
we'll generate an equality constraint (kappa -> Type) and, assuming we can
solve it, that will fix `kappa`. (Here, `kappa` is the unification variable
that we instantiate `k` with.)

Therefore, for any application of a tycon T to some arguments, the Question We
Must Answer is:

* Given the first n arguments of T, do the kinds of the non-omitted arguments
  fill in the omitted arguments?

(This is still a bit hand-wavy, but we'll refine this question incrementally
as we explain more of the machinery underlying this process.)

Answering this question is precisely the role that the `injectiveVarsOfType`
and `injective_vars_of_binder` functions exist to serve. If an omitted argument
`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing
`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a
bit.)

More formally, if
`a` is in `injectiveVarsOfType ty`
and  S1(ty) ~ S2(ty),
then S1(a)  ~ S2(a),
where S1 and S2 are arbitrary substitutions.

For example, is `F` is a non-injective type family, then

  injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c}

Now that we know what this function does, here is a second attempt at the
Question We Must Answer:

* Given the first n arguments of T (ty_1 ... ty_n), consider the binders
  of T that are instantiated by non-omitted arguments. Do the injective
  variables of these binders fill in the remainder of T's kind?

Alright, we're getting closer. Next, we need to clarify what the injective
variables of a tycon binder are. This the role that the
`injective_vars_of_binder` function serves. Here is what this function does for
each form of tycon binder:

* Anonymous binders are injective positions. For example, in the promoted data
  constructor '(:):

    '(:) :: forall a. a -> [a] -> [a]

  The second and third tyvar binders (of kinds `a` and `[a]`) are both
  anonymous, so if we had '(:) 'True '[], then the kinds of 'True and
  '[] would contribute to the kind of '(:) 'True '[]. Therefore,
  injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}.
  (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.)
* Named binders:
  - Inferred binders are never injective positions. For example, in this data
    type:

      data Proxy a
      Proxy :: forall {k}. k -> Type

    If we had Proxy 'True, then the kind of 'True would not contribute to the
    kind of Proxy 'True. Therefore,
    injective_vars_of_binder(forall {k}. ...) = {}.
  - Required binders are injective positions. For example, in this data type:

      data Wurble k (a :: k) :: k
      Wurble :: forall k -> k -> k

  The first tyvar binder (of kind `forall k`) has required visibility, so if
  we had Wurble (Maybe a) Nothing, then the kind of Maybe a would
  contribute to the kind of Wurble (Maybe a) Nothing. Hence,
  injective_vars_of_binder(forall a -> ...) = {a}.
  - Specified binders /might/ be injective positions, depending on how you
    approach things. Continuing the '(:) example:

      '(:) :: forall a. a -> [a] -> [a]

    Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind
    of '(:) 'True '[], since it's not explicitly instantiated by the user. But
    if visible kind application is enabled, then this is possible, since the
    user can write '(:) @Bool 'True '[]. (In that case,
    injective_vars_of_binder(forall a. ...) = {a}.)

    There are some situations where using visible kind application is appropriate
    and others where it is not (e.g., TH
    reification), so the `injective_vars_of_binder` function is parameterized by
    a Bool which decides if specified binders should be counted towards
    injective positions or not.

Now that we've defined injective_vars_of_binder, we can refine the Question We
Must Answer once more:

* Given the first n arguments of T (ty_1 ... ty_n), consider the binders
  of T that are instantiated by non-omitted arguments. For each such binder
  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a
  superset of the free variables of the remainder of T's kind?

If the answer to this question is "no", then (T ty_1 ... ty_n) needs an
explicit kind signature, since T's kind has kind variables leftover that
aren't fixed by the non-omitted arguments.

One last sticking point: what does "the remainder of T's kind" mean? You might
be tempted to think that it corresponds to all of the arguments in the kind of
T that would normally be instantiated by omitted arguments. But this isn't
quite right, strictly speaking. Consider the following (silly) example:

  S :: forall {k}. Type -> Type

And suppose we have this application of S:

  S Int Bool

The Int argument would be omitted, and
injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which
might suggest that (S Bool) needs an explicit kind signature. But
(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature
only affects the /result/ of the application, not all of the individual
arguments. So adding a kind signature here won't make a difference. Therefore,
the fourth (and final) iteration of the Question We Must Answer is:

* Given the first n arguments of T (ty_1 ... ty_n), consider the binders
  of T that are instantiated by non-omitted arguments. For each such binder
  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a
  superset of the free variables of the kind of (T ty_1 ... ty_n)?

Phew, that was a lot of work!

How can be sure that this is correct? That is, how can we be sure that in the
event that we leave off a kind annotation, that one could infer the kind of the
tycon application from its arguments? It's essentially a proof by induction: if
we can infer the kinds of every subtree of a type, then the whole tycon
application will have an inferrable kind--unless, of course, the remainder of
the tycon application's kind has uninstantiated kind variables.

What happens if T is oversaturated? That is, if T's kind has fewer than n
arguments, in the case that the concrete application instantiates a result
kind variable with an arrow kind? If we run out of arguments, we do not attach
a kind annotation. This should be a rare case, indeed. Here is an example:

   data T1 :: k1 -> k2 -> *
   data T2 :: k1 -> k2 -> *

   type family G (a :: k) :: k
   type instance G T1 = T2

   type instance F Char = (G T1 Bool :: (* -> *) -> *)   -- F from above

Here G's kind is (forall k. k -> k), and the desugared RHS of that last
instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
the algorithm above, there are 3 arguments to G so we should peel off 3
arguments in G's kind. But G's kind has only two arguments. This is the
rare special case, and we choose not to annotate the application of G with
a kind signature. After all, we needn't do this, since that instance would
be reified as:

   type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool

So the kind of G isn't ambiguous anymore due to the explicit kind annotation
on its argument. See #8953 and test th/T8953.
-}

{-
************************************************************************
*                                                                      *
        Multiplicities
*                                                                      *
************************************************************************

These functions would prefer to be in GHC.Core.Multiplicity, but
they some are used elsewhere in this module, and wanted to bring
their friends here with them.
-}

unrestricted, linear, tymult :: a -> Scaled a

-- | Scale a payload by Many
unrestricted :: forall a. a -> Scaled a
unrestricted = Type -> a -> Scaled a
forall a. Type -> a -> Scaled a
Scaled Type
ManyTy

-- | Scale a payload by One
linear :: forall a. a -> Scaled a
linear = Type -> a -> Scaled a
forall a. Type -> a -> Scaled a
Scaled Type
OneTy

-- | Scale a payload by Many; used for type arguments in core
tymult :: forall a. a -> Scaled a
tymult = Type -> a -> Scaled a
forall a. Type -> a -> Scaled a
Scaled Type
ManyTy

irrelevantMult :: Scaled a -> a
irrelevantMult :: forall a. Scaled a -> a
irrelevantMult = Scaled a -> a
forall a. Scaled a -> a
scaledThing

mkScaled :: Mult -> a -> Scaled a
mkScaled :: forall a. Type -> a -> Scaled a
mkScaled = Type -> a -> Scaled a
Type -> a -> Scaled a
forall a. Type -> a -> Scaled a
Scaled

scaledSet :: Scaled a -> b -> Scaled b
scaledSet :: forall a b. Scaled a -> b -> Scaled b
scaledSet (Scaled Type
m a
_) b
b = Type -> b -> Scaled b
forall a. Type -> a -> Scaled a
Scaled Type
m b
b

pattern OneTy :: Mult
pattern $mOneTy :: forall {r}. Type -> ((# #) -> r) -> ((# #) -> r) -> r
$bOneTy :: Type
OneTy <- (isOneTy -> True)
  where OneTy = Type
oneDataConTy

pattern ManyTy :: Mult
pattern $mManyTy :: forall {r}. Type -> ((# #) -> r) -> ((# #) -> r) -> r
$bManyTy :: Type
ManyTy <- (isManyTy -> True)
  where ManyTy = Type
manyDataConTy

isManyTy :: Mult -> Bool
isManyTy :: Type -> Bool
isManyTy Type
ty
  | Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty
  = TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
manyDataConKey
isManyTy Type
_ = Bool
False

isOneTy :: Mult -> Bool
isOneTy :: Type -> Bool
isOneTy Type
ty
  | Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty
  = TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
oneDataConKey
isOneTy Type
_ = Bool
False

isLinearType :: Type -> Bool
-- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function
-- where at least one argument is linear (or otherwise non-unrestricted). We use
-- this function to check whether it is safe to eta reduce an Id in CorePrep. It
-- is always safe to return 'True', because 'True' deactivates the optimisation.
isLinearType :: Type -> Bool
isLinearType Type
ty = case Type
ty of
                      FunTy FunTyFlag
_ Type
ManyTy Type
_ Type
res -> Type -> Bool
isLinearType Type
res
                      FunTy FunTyFlag
_ Type
_ Type
_ Type
_        -> Bool
True
                      ForAllTy VarBndr TyVar ForAllTyFlag
_ Type
res       -> Type -> Bool
isLinearType Type
res
                      Type
_ -> Bool
False

{- *********************************************************************
*                                                                      *
                    Space-saving construction
*                                                                      *
********************************************************************* -}

{- Note [Using synonyms to compress types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Was: [Prefer Type over TYPE (BoxedRep Lifted)]

The Core of nearly any program will have numerous occurrences of the Types

   TyConApp BoxedRep [TyConApp Lifted []]    -- Synonym LiftedRep
   TyConApp BoxedRep [TyConApp Unlifted []]  -- Synonym UnliftedREp
   TyConApp TYPE [TyConApp LiftedRep []]     -- Synonym Type
   TyConApp TYPE [TyConApp UnliftedRep []]   -- Synonym UnliftedType

While investigating #17292 we found that these constituted a majority
of all TyConApp constructors on the heap:

    (From a sample of 100000 TyConApp closures)
    0x45f3523    - 28732 - `Type`
    0x420b840702 - 9629  - generic type constructors
    0x42055b7e46 - 9596
    0x420559b582 - 9511
    0x420bb15a1e - 9509
    0x420b86c6ba - 9501
    0x42055bac1e - 9496
    0x45e68fd    - 538   - `TYPE ...`

Consequently, we try hard to ensure that operations on such types are
efficient. Specifically, we strive to

 a. Avoid heap allocation of such types; use a single static TyConApp
 b. Use a small (shallow in the tree-depth sense) representation
    for such types

Goal (b) is particularly useful as it makes traversals (e.g. free variable
traversal, substitution, and comparison) more efficient.
Comparison in particular takes special advantage of nullary type synonym
applications (e.g. things like @TyConApp typeTyCon []@). See
* Note [Comparing type synonyms] in "GHC.Core.TyCo.Compare"
* Note [Unifying type synonyms] in "GHC.Core.Unify"

To accomplish these we use a number of tricks, implemented by mkTyConApp.

 1. Instead of (TyConApp BoxedRep [TyConApp Lifted []]),
    we prefer a statically-allocated (TyConApp LiftedRep [])
    where `LiftedRep` is a type synonym:
       type LiftedRep = BoxedRep Lifted
    Similarly for UnliftedRep

 2. Instead of (TyConApp TYPE [TyConApp LiftedRep []])
    we prefer the statically-allocated (TyConApp Type [])
    where `Type` is a type synonym
       type Type = TYPE LiftedRep
    Similarly for UnliftedType

These serve goal (b) since there are no applied type arguments to traverse,
e.g., during comparison.

 3. We have a single, statically allocated top-level binding to
    represent `TyConApp GHC.Types.Type []` (namely
    'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't
    need to allocate such types (goal (a)).  See functions
    mkTYPEapp and mkBoxedRepApp

 4. We use the sharing mechanism described in Note [Sharing nullary TyConApps]
    in GHC.Core.TyCon to ensure that we never need to allocate such
    nullary applications (goal (a)).

See #17958, #20541
-}

-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to
-- its arguments.  Applies its arguments to the constructor from left to right.
mkTyConApp :: TyCon -> [Type] -> Type
mkTyConApp :: TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon []
  = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon
    TyCon -> Type
mkTyConTy TyCon
tycon

mkTyConApp TyCon
tycon tys :: [Type]
tys@(Type
ty1:[Type]
rest)
  | Just Type
fun_ty <- HasDebugCallStack => TyCon -> [Type] -> Maybe Type
TyCon -> [Type] -> Maybe Type
tyConAppFunTy_maybe TyCon
tycon [Type]
tys
  = Type
fun_ty

  -- See Note [Using synonyms to compress types]
  | Unique
key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
tYPETyConKey
  , Just Type
ty <- Type -> Maybe Type
mkTYPEapp_maybe Type
ty1
  = Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
rest) Type
ty

  | Unique
key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
cONSTRAINTTyConKey
  , Just Type
ty <- Type -> Maybe Type
mkCONSTRAINTapp_maybe Type
ty1
  = Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
rest) Type
ty

  -- See Note [Using synonyms to compress types]
  | Unique
key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
boxedRepDataConTyConKey
  , Just Type
ty <- Type -> Maybe Type
mkBoxedRepApp_maybe Type
ty1
  = Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
rest) Type
ty

  | Unique
key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
tupleRepDataConTyConKey
  , Just Type
ty <- Type -> Maybe Type
mkTupleRepApp_maybe Type
ty1
  = Bool -> Type -> Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
rest) Type
ty

  -- The catch-all case
  | Bool
otherwise
  = TyCon -> [Type] -> Type
TyConApp TyCon
tycon [Type]
tys
  where
    key :: Unique
key = TyCon -> Unique
tyConUnique TyCon
tycon


{- Note [Care using synonyms to compress types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Using a synonym to compress a types has a tricky wrinkle. Consider
coreView applied to (TyConApp LiftedRep [])

* coreView expands the LiftedRep synonym:
     type LiftedRep = BoxedRep Lifted

* Danger: we might apply the empty substitution to the RHS of the
  synonym.  And substTy calls mkTyConApp BoxedRep [Lifted]. And
  mkTyConApp compresses that back to LiftedRep.  Loop!

* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary
  type synonyms.  That's more efficient anyway.
-}


mkTYPEapp :: RuntimeRepType -> Type
mkTYPEapp :: Type -> Type
mkTYPEapp Type
rr
  = case Type -> Maybe Type
mkTYPEapp_maybe Type
rr of
       Just Type
ty -> Type
ty
       Maybe Type
Nothing -> TyCon -> [Type] -> Type
TyConApp TyCon
tYPETyCon [Type
rr]

mkTYPEapp_maybe :: RuntimeRepType -> Maybe Type
-- ^ Given a @RuntimeRep@, applies @TYPE@ to it.
-- On the fly it rewrites
--      TYPE LiftedRep      -->   liftedTypeKind    (a synonym)
--      TYPE UnliftedRep    -->   unliftedTypeKind  (ditto)
--      TYPE ZeroBitRep     -->   zeroBitTypeKind   (ditto)
-- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted)
--     because those inner types should already have been rewritten
--     to LiftedRep and UnliftedRep respectively, by mkTyConApp
--
-- see Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim.
-- See Note [Using synonyms to compress types] in GHC.Core.Type
{-# NOINLINE mkTYPEapp_maybe #-}
mkTYPEapp_maybe :: Type -> Maybe Type
mkTYPEapp_maybe (TyConApp TyCon
tc [Type]
args)
  | Unique
key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
liftedRepTyConKey    = Bool -> Maybe Type -> Maybe Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args) (Maybe Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
forall a. a -> Maybe a
Just Type
liftedTypeKind   -- TYPE LiftedRep
  | Unique
key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
unliftedRepTyConKey  = Bool -> Maybe Type -> Maybe Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args) (Maybe Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
forall a. a -> Maybe a
Just Type
unliftedTypeKind -- TYPE UnliftedRep
  | Unique
key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
zeroBitRepTyConKey   = Bool -> Maybe Type -> Maybe Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args) (Maybe Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
forall a. a -> Maybe a
Just Type
zeroBitTypeKind  -- TYPE ZeroBitRep
  where
    key :: Unique
key = TyCon -> Unique
tyConUnique TyCon
tc
mkTYPEapp_maybe Type
_ = Maybe Type
forall a. Maybe a
Nothing

------------------
mkCONSTRAINTapp :: RuntimeRepType -> Type
-- ^ Just like mkTYPEapp
mkCONSTRAINTapp :: Type -> Type
mkCONSTRAINTapp Type
rr
  = case Type -> Maybe Type
mkCONSTRAINTapp_maybe Type
rr of
       Just Type
ty -> Type
ty
       Maybe Type
Nothing -> TyCon -> [Type] -> Type
TyConApp TyCon
cONSTRAINTTyCon [Type
rr]

mkCONSTRAINTapp_maybe :: RuntimeRepType -> Maybe Type
-- ^ Just like mkTYPEapp_maybe
{-# NOINLINE mkCONSTRAINTapp_maybe #-}
mkCONSTRAINTapp_maybe :: Type -> Maybe Type
mkCONSTRAINTapp_maybe (TyConApp TyCon
tc [Type]
args)
  | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
liftedRepTyConKey = Bool -> Maybe Type -> Maybe Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args) (Maybe Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$
                                    Type -> Maybe Type
forall a. a -> Maybe a
Just Type
constraintKind   -- CONSTRAINT LiftedRep
mkCONSTRAINTapp_maybe Type
_ = Maybe Type
forall a. Maybe a
Nothing

------------------
mkBoxedRepApp_maybe :: LevityType -> Maybe Type
-- ^ Given a `Levity`, apply `BoxedRep` to it
-- On the fly, rewrite
--      BoxedRep Lifted     -->   liftedRepTy    (a synonym)
--      BoxedRep Unlifted   -->   unliftedRepTy  (ditto)
-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim.
-- See Note [Using synonyms to compress types] in GHC.Core.Type
{-# NOINLINE mkBoxedRepApp_maybe #-}
mkBoxedRepApp_maybe :: Type -> Maybe Type
mkBoxedRepApp_maybe (TyConApp TyCon
tc [Type]
args)
  | Unique
key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
liftedDataConKey   = Bool -> Maybe Type -> Maybe Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args) (Maybe Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
forall a. a -> Maybe a
Just Type
liftedRepTy    -- BoxedRep Lifted
  | Unique
key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
unliftedDataConKey = Bool -> Maybe Type -> Maybe Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args) (Maybe Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
forall a. a -> Maybe a
Just Type
unliftedRepTy  -- BoxedRep Unlifted
  where
    key :: Unique
key = TyCon -> Unique
tyConUnique TyCon
tc
mkBoxedRepApp_maybe Type
_ = Maybe Type
forall a. Maybe a
Nothing

mkTupleRepApp_maybe :: Type -> Maybe Type
-- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it
-- On the fly, rewrite
--      TupleRep [] -> zeroBitRepTy   (a synonym)
-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim.
-- See Note [Using synonyms to compress types] in GHC.Core.Type
{-# NOINLINE mkTupleRepApp_maybe #-}
mkTupleRepApp_maybe :: Type -> Maybe Type
mkTupleRepApp_maybe (TyConApp TyCon
tc [Type]
args)
  | Unique
key Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
nilDataConKey = Bool -> Maybe Type -> Maybe Type
forall a. HasCallStack => Bool -> a -> a
assert ([Type] -> Bool
forall a. [a] -> Bool
isSingleton [Type]
args) (Maybe Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
forall a. a -> Maybe a
Just Type
zeroBitRepTy  -- ZeroBitRep
  where
    key :: Unique
key = TyCon -> Unique
tyConUnique TyCon
tc
mkTupleRepApp_maybe Type
_ = Maybe Type
forall a. Maybe a
Nothing

typeOrConstraintKind :: TypeOrConstraint -> RuntimeRepType -> Kind
typeOrConstraintKind :: TypeOrConstraint -> Type -> Type
typeOrConstraintKind TypeOrConstraint
TypeLike       Type
rep = Type -> Type
mkTYPEapp       Type
rep
typeOrConstraintKind TypeOrConstraint
ConstraintLike Type
rep = Type -> Type
mkCONSTRAINTapp Type
rep

liftedTypeOrConstraintKind :: TypeOrConstraint -> Kind
liftedTypeOrConstraintKind :: TypeOrConstraint -> Type
liftedTypeOrConstraintKind TypeOrConstraint
TypeLike       = Type
liftedTypeKind
liftedTypeOrConstraintKind TypeOrConstraint
ConstraintLike = Type
constraintKind