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

{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf, RankNTypes #-}
{-# 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,
        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,
        getRuntimeArgTys,
        mkTyConBindersPreferAnon,
        mkPiTy, mkPiTys,
        piResultTy, piResultTys,
        applyTysX, dropForAlls,
        mkFamilyTyConApp,
        buildSynTyCon,

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

        isPredTy,

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

        mkCastTy, mkCoercionTy, splitCastTy_maybe,

        ErrorMsgType,
        userTypeError_maybe, deepUserTypeError_maybe, pprUserTypeErrorTy,

        coAxNthLHS,
        stripCoercionTy,

        splitInvisPiTys, splitInvisPiTysN,
        invisibleTyBndrCount,
        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,

        -- *** 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, isDataFamilyAppType,
        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
        tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,
        tyCoVarsOfType, tyCoVarsOfTypes,
        tyCoVarsOfTypeDSet,
        coVarsOfType,
        coVarsOfTypes,

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

        -- ** Closing over kinds
        closeOverKindsDSet, closeOverKindsList,
        closeOverKinds,

        -- * Well-scoped lists of variables
        scopedSort, tyCoVarsOfTypeWellScoped,
        tyCoVarsOfTypesWellScoped,

        -- * 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, getSubstInScope, 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, substCoUnchecked, substCoWithUnchecked,
        substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,
        substVarBndr, substVarBndrs,
        substTyCoBndr, substTyVarToTyVar,
        cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,

        -- * Tidying type related things up for printing
        tidyType,      tidyTypes,
        tidyOpenType,  tidyOpenTypes,
        tidyOpenTypeX, tidyOpenTypesX,
        tidyVarBndr, tidyVarBndrs,
        tidyFreeTyCoVars,
        tidyFreeTyCoVarX, tidyFreeTyCoVarsX,
        tidyTyCoVarOcc,
        tidyTopType,
        tidyForAllTyBinder, tidyForAllTyBinders,

        -- * 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.Tidy
import GHC.Core.TyCo.FVs

-- friends:
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Unique.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, mkAxiomInstCo, 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.FV
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString

import GHC.Data.Maybe   ( orElse, isJust, firstJust )

-- $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
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
shallowTyCoVarsOfTypes ([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 (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 -> MCoercionN -> MCoercionN
go_mco Subst
_     MCoercionN
MRefl    = MCoercionN
MRefl
    go_mco Subst
subst (MCo KindCoercion
co) = KindCoercion -> MCoercionN
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 MCoercionN
mco)
      = Role -> Type -> MCoercionN -> KindCoercion
mkGReflCo Role
r (Subst -> Type -> Type
go Subst
subst Type
ty) (Subst -> MCoercionN -> MCoercionN
go_mco Subst
subst MCoercionN
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
tv, fco_visL :: KindCoercion -> ForAllTyFlag
fco_visL = ForAllTyFlag
visL, fco_visR :: KindCoercion -> ForAllTyFlag
fco_visR = ForAllTyFlag
visR
                          , fco_kind :: KindCoercion -> KindCoercion
fco_kind = KindCoercion
kind_co, fco_body :: KindCoercion -> KindCoercion
fco_body = KindCoercion
co })
      = let (Subst
subst', TyVar
tv', KindCoercion
kind_co') = Subst -> TyVar -> KindCoercion -> (Subst, TyVar, KindCoercion)
go_cobndr Subst
subst TyVar
tv KindCoercion
kind_co in
        HasDebugCallStack =>
TyVar
-> ForAllTyFlag
-> ForAllTyFlag
-> KindCoercion
-> KindCoercion
-> KindCoercion
TyVar
-> ForAllTyFlag
-> ForAllTyFlag
-> KindCoercion
-> KindCoercion
-> KindCoercion
mkForAllCo TyVar
tv' ForAllTyFlag
visL ForAllTyFlag
visR KindCoercion
kind_co' (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst' KindCoercion
co)
    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 (AxiomInstCo CoAxiom Branched
ax Arity
ind [KindCoercion]
args)
      = CoAxiom Branched -> Arity -> [KindCoercion] -> KindCoercion
mkAxiomInstCo CoAxiom Branched
ax Arity
ind ((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 (UnivCo UnivCoProvenance
p Role
r Type
t1 Type
t2)
      = UnivCoProvenance -> Role -> Type -> Type -> KindCoercion
mkUnivCo (Subst -> UnivCoProvenance -> UnivCoProvenance
go_prov Subst
subst UnivCoProvenance
p) Role
r (Subst -> Type -> Type
go Subst
subst Type
t1) (Subst -> Type -> Type
go Subst
subst Type
t2)
    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)
      = 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
subst (AxiomRuleCo CoAxiomRule
ax [KindCoercion]
cs)
      = CoAxiomRule -> [KindCoercion] -> KindCoercion
AxiomRuleCo 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
_ (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)

    go_prov :: Subst -> UnivCoProvenance -> UnivCoProvenance
go_prov Subst
subst (PhantomProv KindCoercion
co)    = KindCoercion -> UnivCoProvenance
PhantomProv (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co)
    go_prov Subst
subst (ProofIrrelProv KindCoercion
co) = KindCoercion -> UnivCoProvenance
ProofIrrelProv (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst KindCoercion
co)
    go_prov Subst
_     p :: UnivCoProvenance
p@(PluginProv String
_ DCoVarSet
_)  = UnivCoProvenance
p

      -- the "False" and "const" are to accommodate the type of
      -- substForAllCoBndrUsing, which is general enough to
      -- handle coercion optimization (which sometimes swaps the
      -- order of a coercion)
    go_cobndr :: Subst -> TyVar -> KindCoercion -> (Subst, TyVar, KindCoercion)
go_cobndr Subst
subst = Bool
-> (KindCoercion -> KindCoercion)
-> Subst
-> TyVar
-> KindCoercion
-> (Subst, TyVar, KindCoercion)
substForAllCoBndrUsing Bool
False (Subst -> KindCoercion -> KindCoercion
go_co Subst
subst) Subst
subst

{- 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
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 -> MCoercionN -> m MCoercionN
go_mco !env
_   MCoercionN
MRefl    = MCoercionN -> m MCoercionN
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return MCoercionN
MRefl
    go_mco !env
env (MCo KindCoercion
co) = KindCoercion -> MCoercionN
MCo (KindCoercion -> MCoercionN) -> m KindCoercion -> m MCoercionN
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
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 MCoercionN
mco)           = Role -> Type -> MCoercionN -> KindCoercion
mkGReflCo Role
r (Type -> MCoercionN -> KindCoercion)
-> m Type -> m (MCoercionN -> KindCoercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Type -> m Type
go_ty env
env Type
ty m (MCoercionN -> KindCoercion) -> m MCoercionN -> 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 -> MCoercionN -> m MCoercionN
go_mco env
env MCoercionN
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 UnivCoProvenance
p Role
r Type
t1 Type
t2)         = UnivCoProvenance -> Role -> Type -> Type -> KindCoercion
mkUnivCo (UnivCoProvenance -> Role -> Type -> Type -> KindCoercion)
-> m UnivCoProvenance -> m (Role -> Type -> Type -> KindCoercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> UnivCoProvenance -> m UnivCoProvenance
go_prov env
env UnivCoProvenance
p 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)            = 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 (AxiomRuleCo CoAxiomRule
r [KindCoercion]
cos)        = CoAxiomRule -> [KindCoercion] -> KindCoercion
AxiomRuleCo 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 (AxiomInstCo CoAxiom Branched
ax Arity
i [KindCoercion]
cos)     = CoAxiom Branched -> Arity -> [KindCoercion] -> KindCoercion
mkAxiomInstCo CoAxiom Branched
ax Arity
i ([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 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 -> KindCoercion
fco_kind = KindCoercion
kind_co, fco_body :: KindCoercion -> KindCoercion
fco_body = KindCoercion
co })
      = do { kind_co' <- env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
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]

    go_prov :: env -> UnivCoProvenance -> m UnivCoProvenance
go_prov !env
env (PhantomProv KindCoercion
co)    = KindCoercion -> UnivCoProvenance
PhantomProv (KindCoercion -> UnivCoProvenance)
-> m KindCoercion -> m UnivCoProvenance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co
    go_prov !env
env (ProofIrrelProv KindCoercion
co) = KindCoercion -> UnivCoProvenance
ProofIrrelProv (KindCoercion -> UnivCoProvenance)
-> m KindCoercion -> m UnivCoProvenance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> KindCoercion -> m KindCoercion
go_co env
env KindCoercion
co
    go_prov !env
env (PluginProv String
s DCoVarSet
cvs)  = String -> DCoVarSet -> UnivCoProvenance
PluginProv String
s (DCoVarSet -> UnivCoProvenance)
-> m DCoVarSet -> m UnivCoProvenance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> [TyVar] -> m DCoVarSet
go_fcvs env
env (DCoVarSet -> [TyVar]
dVarSetElems DCoVarSet
cvs)

    -- See Note [Use explicit recursion in mapTyCo]
    go_fcvs :: env -> [CoVar] -> m DTyCoVarSet
    go_fcvs :: env -> [TyVar] -> m DCoVarSet
go_fcvs env
_   []       = DCoVarSet -> m DCoVarSet
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return DCoVarSet
emptyDVarSet
    go_fcvs env
env (TyVar
cv:[TyVar]
cvs) = do { co   <- env -> TyVar -> m KindCoercion
covar env
env TyVar
cv
                              ; cvs' <- go_fcvs env cvs
                              ; return (tyCoVarsOfCoDSet co `unionDVarSet` cvs') }

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

-- | Is this type a custom user error?
-- If so, give us the error message.
userTypeError_maybe :: Type -> Maybe ErrorMsgType
userTypeError_maybe :: Type -> Maybe Type
userTypeError_maybe Type
ty
  | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe Type
userTypeError_maybe Type
ty'
userTypeError_maybe (TyConApp TyCon
tc (Type
_kind : Type
msg : [Type]
_))
  | TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
errorMessageTypeErrorFamName
          -- There may be more than 2 arguments, if the type error is
          -- used as a type constructor (e.g. at kind `Type -> Type`).
  = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
msg
userTypeError_maybe Type
_
  = Maybe Type
forall a. Maybe a
Nothing

deepUserTypeError_maybe :: Type -> Maybe ErrorMsgType
-- Look for custom user error, deeply inside the type
deepUserTypeError_maybe :: Type -> Maybe Type
deepUserTypeError_maybe Type
ty
  | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe Type
userTypeError_maybe Type
ty'
deepUserTypeError_maybe (TyConApp TyCon
tc [Type]
tys)
  | TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
errorMessageTypeErrorFamName
  , Type
_kind : Type
msg : [Type]
_ <- [Type]
tys
          -- There may be more than 2 arguments, if the type error is
          -- used as a type constructor (e.g. at kind `Type -> Type`).
  = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
msg

  | TyCon -> Bool
tyConMustBeSaturated TyCon
tc  -- Don't go looking for user type errors
                             -- inside type family arguments (see #20241).
  = (Type -> Maybe Type -> Maybe Type)
-> Maybe Type -> [Type] -> Maybe Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe Type -> Maybe Type -> Maybe Type
forall a. Maybe a -> Maybe a -> Maybe a
firstJust (Maybe Type -> Maybe Type -> Maybe Type)
-> (Type -> Maybe Type) -> Type -> Maybe Type -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Type
deepUserTypeError_maybe) Maybe Type
forall a. Maybe a
Nothing (Arity -> [Type] -> [Type]
forall a. Arity -> [a] -> [a]
drop (TyCon -> Arity
tyConArity TyCon
tc) [Type]
tys)
  | Bool
otherwise
  = (Type -> Maybe Type -> Maybe Type)
-> Maybe Type -> [Type] -> Maybe Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe Type -> Maybe Type -> Maybe Type
forall a. Maybe a -> Maybe a -> Maybe a
firstJust (Maybe Type -> Maybe Type -> Maybe Type)
-> (Type -> Maybe Type) -> Type -> Maybe Type -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Type
deepUserTypeError_maybe) Maybe Type
forall a. Maybe a
Nothing [Type]
tys
deepUserTypeError_maybe (ForAllTy VarBndr TyVar ForAllTyFlag
_ Type
ty) = Type -> Maybe Type
deepUserTypeError_maybe Type
ty
deepUserTypeError_maybe (FunTy { ft_arg :: Type -> Type
ft_arg = Type
arg, ft_res :: Type -> Type
ft_res = Type
res })
  = Type -> Maybe Type
deepUserTypeError_maybe Type
arg Maybe Type -> Maybe Type -> Maybe Type
forall a. Maybe a -> Maybe a -> Maybe a
`firstJust` Type -> Maybe Type
deepUserTypeError_maybe Type
res
deepUserTypeError_maybe (AppTy Type
t1 Type
t2)
  = Type -> Maybe Type
deepUserTypeError_maybe Type
t1 Maybe Type -> Maybe Type -> Maybe Type
forall a. Maybe a -> Maybe a -> Maybe a
`firstJust` Type -> Maybe Type
deepUserTypeError_maybe Type
t2
deepUserTypeError_maybe (CastTy Type
ty KindCoercion
_)
  = Type -> Maybe Type
deepUserTypeError_maybe Type
ty
deepUserTypeError_maybe Type
_   -- TyVarTy, CoercionTy, LitTy
  = Maybe Type
forall a. Maybe a
Nothing

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

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
-- We don't need a 'tc' version, because
-- this function behaves the same for Type and Constraint
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 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
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
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
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 a function or forall?
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 a function?
-- Note: `forall {b}. Show b => b -> IO b` will not be considered a function by this function.
--       It would merely be a forall wrapping a function type.
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)

-- | 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
      = []

invisibleTyBndrCount :: 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
invisibleTyBndrCount :: Type -> Arity
invisibleTyBndrCount 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)
      |