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

{-# LANGUAGE CPP, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

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

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

        -- $representation_types
        TyThing(..), Type, ArgFlag(..), KindOrType, PredType, ThetaType,
        Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,
        KnotTied,

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

        mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys,
        splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe,

        mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe,
        splitFunTys, funResultTy, funArgTy,

        mkTyConApp, mkTyConTy,
        tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,
        tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,
        splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole,
        tcRepSplitTyConApp_maybe, tcRepSplitTyConApp, tcSplitTyConApp_maybe,
        splitListTyConApp_maybe,
        repSplitTyConApp_maybe,

        mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys,
        mkVisForAllTys, mkTyCoInvForAllTy,
        mkInvForAllTy, mkInvForAllTys,
        splitForAllTys, splitForAllVarBndrs,
        splitForAllTy_maybe, splitForAllTy,
        splitForAllTy_ty_maybe, splitForAllTy_co_maybe,
        splitPiTy_maybe, splitPiTy, splitPiTys,
        mkTyCoPiTy, mkTyCoPiTys, mkTyConBindersPreferAnon,
        mkPiTys,
        mkLamType, mkLamTypes,
        piResultTy, piResultTys,
        applyTysX, dropForAlls,

        mkNumLitTy, isNumLitTy,
        mkStrLitTy, isStrLitTy,
        isLitTy,

        getRuntimeRep_maybe, kindRep_maybe, kindRep,

        mkCastTy, mkCoercionTy, splitCastTy_maybe,

        userTypeError_maybe, pprUserTypeErrorTy,

        coAxNthLHS,
        stripCoercionTy, splitCoercionType_maybe,

        splitPiTysInvisible, splitPiTysInvisibleN,
        invisibleTyBndrCount,
        filterOutInvisibleTypes, filterOutInferredTypes,
        partitionInvisibleTypes, partitionInvisibles,
        tyConArgFlags, appTyArgFlags,
        synTyConResKind,

        modifyJoinResTy, setJoinResTy,

        -- Analyzing types
        TyCoMapper(..), mapType, mapCoercion,

        -- (Newtypes)
        newTyConInstRhs,

        -- Pred types
        mkFamilyTyConApp,
        isDictLikeTy,
        mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,
        equalityTyCon,
        mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,
        mkClassPred,
        isClassPred, isEqPred, isNomEqPred,
        isIPPred, isIPPred_maybe, isIPTyCon, isIPClass,
        isCTupleClass,

        -- Deconstructing predicate types
        PredTree(..), EqRel(..), eqRelRole, classifyPredType,
        getClassPredTys, getClassPredTys_maybe,
        getEqPredTys, getEqPredTys_maybe, getEqPredRole,
        predTypeEqRel,

        -- ** Binders
        sameVis,
        mkTyCoVarBinder, mkTyCoVarBinders,
        mkTyVarBinders,
        mkAnonBinder,
        isAnonTyCoBinder,
        binderVar, binderVars, binderType, binderArgFlag,
        tyCoBinderType, tyCoBinderVar_maybe,
        tyBinderType,
        binderRelevantType_maybe, caseBinder,
        isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder,
        isInvisibleBinder, isNamedBinder,
        tyConBindersTyCoBinders,

        -- ** Common type constructors
        funTyCon,

        -- ** Predicates on types
        isTyVarTy, isFunTy, isDictTy, isPredTy, isCoercionTy,
        isCoercionTy_maybe, isForAllTy,
        isForAllTy_ty, isForAllTy_co,
        isPiTy, isTauTy, isFamFreeTy,
        isCoVarType, isEvVarType,

        isValidJoinPointType,

        -- (Lifting and boxity)
        isLiftedType_maybe, isUnliftedType, isUnboxedTupleType, isUnboxedSumType,
        isAlgType, isDataFamilyAppType,
        isPrimitiveType, isStrictType,
        isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,
        dropRuntimeRepArgs,
        getRuntimeRep,

        -- * Main data types representing Kinds
        Kind,

        -- ** Finding the kind of a type
        typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly,
        tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,

        -- ** Common Kind
        liftedTypeKind,

        -- * Type free variables
        tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,
        tyCoVarsOfType, tyCoVarsOfTypes,
        tyCoVarsOfTypeDSet,
        coVarsOfType,
        coVarsOfTypes,
        closeOverKindsDSet, closeOverKindsFV, closeOverKindsList,
        closeOverKinds,

        noFreeVarsOfType,
        splitVisVarsOfType, splitVisVarsOfTypes,
        expandTypeSynonyms,
        typeSize, occCheckExpand,

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

        -- * Type comparison
        eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX,
        nonDetCmpTypesX, nonDetCmpTc,
        eqVarBndrs,

        -- * Forcing evaluation of types
        seqType, seqTypes,

        -- * Other views onto Types
        coreView, tcView,

        tyConsOfType,

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

        -- ** Manipulating type substitutions
        emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst,

        mkTCvSubst, zipTvSubst, mkTvSubstPrs,
        zipTCvSubst,
        notElemTCvSubst,
        getTvSubstEnv, setTvSubstEnv,
        zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs,
        extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,
        extendTCvSubst, extendCvSubst,
        extendTvSubst, extendTvSubstBinderAndInScope,
        extendTvSubstList, extendTvSubstAndInScope,
        extendTCvSubstList,
        extendTvSubstWithClone,
        extendTCvSubstWithClone,
        isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv,
        isEmptyTCvSubst, unionTCvSubst,

        -- ** Performing substitution on types and kinds
        substTy, substTys, substTyWith, substTysWith, substTheta,
        substTyAddInScope,
        substTyUnchecked, substTysUnchecked, substThetaUnchecked,
        substTyWithUnchecked,
        substCoUnchecked, substCoWithUnchecked,
        substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,
        substVarBndr, substVarBndrs,
        cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,

        -- * Pretty-printing
        pprType, pprParendType, pprPrecType,
        pprTypeApp, pprTyThingCategory, pprShortTyThing,
        pprTCvBndr, pprTCvBndrs, pprForAll, pprUserForAll,
        pprSigmaType, pprWithExplicitKindsWhen,
        pprTheta, pprThetaArrowTy, pprClassPred,
        pprKind, pprParendKind, pprSourceTyCon,
        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
        pprTyVar, pprTyVars,
        pprWithTYPE,

        -- * Tidying type related things up for printing
        tidyType,      tidyTypes,
        tidyOpenType,  tidyOpenTypes,
        tidyOpenKind,
        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars,
        tidyOpenTyCoVar, tidyOpenTyCoVars,
        tidyTyCoVarOcc,
        tidyTopType,
        tidyKind,
        tidyTyCoVarBinder, tidyTyCoVarBinders
    ) where

#include "HsVersions.h"

import GhcPrelude

import BasicTypes

-- We import the representation and primitive functions from TyCoRep.
-- Many things are reexported, but not the representation!

import Kind
import TyCoRep

-- friends:
import Var
import VarEnv
import VarSet
import UniqSet

import Class
import TyCon
import TysPrim
import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind, unitTy
                                 , typeSymbolKind, liftedTypeKind
                                 , constraintKind )
import PrelNames
import CoAxiom
import {-# SOURCE #-} Coercion( mkNomReflCo, mkGReflCo, mkReflCo
                              , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo
                              , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo
                              , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo
                              , mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo
                              , decomposePiCos, coercionKind, coercionType
                              , isReflexiveCo, seqCo )

-- others
import Util
import FV
import Outputable
import FastString
import Pair
import DynFlags  ( gopt_set, GeneralFlag(Opt_PrintExplicitRuntimeReps) )
import ListSetOps
import Unique ( nonDetCmpUnique )

import Maybes           ( orElse )
import Data.Maybe       ( isJust )
import Control.Monad    ( guard )

-- $type_classification
-- #type_classification#
--
-- Types are one of:
--
-- [Unboxed]            Iff its representation is other than a pointer
--                      Unboxed types are also unlifted.
--
-- [Lifted]             Iff it has bottom as an element.
--                      Closures always have lifted types: i.e. any
--                      let-bound identifier in Core must have a lifted
--                      type. Operationally, a lifted object is one that
--                      can be entered.
--                      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. This is /not/ the same as
--                      lifted types, because we also include unboxed
--                      tuples in this classification.
--
-- [Data]               Iff it is a type declared with @data@, or a boxed tuple.
--
-- [Primitive]          Iff it is a built-in type that can't be expressed in Haskell.
--
-- 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
*                                                                      *
************************************************************************

Note [coreView vs tcView]
~~~~~~~~~~~~~~~~~~~~~~~~~
So far as the typechecker is concerned, 'Constraint' and 'TYPE
LiftedRep' are distinct kinds.

But in Core these two are treated as identical.

We implement this by making 'coreView' convert 'Constraint' to 'TYPE
LiftedRep' on the fly.  The function tcView (used in the type checker)
does not do this.

See also Trac #11715, which tracks removing this inconsistency.

-}

-- | Gives the typechecker view of a type. This unwraps synonyms but
-- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into
-- TYPE LiftedRep. Returns Nothing if no unwrapping happens.
-- See also Note [coreView vs tcView]
{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
tcView :: Type -> Maybe Type
tcView (TyConApp tc :: TyCon
tc tys :: [Type]
tys) | Just (tenv :: [(TyVar, Type)]
tenv, rhs :: Type
rhs, tys' :: [Type]
tys') <- TyCon -> [Type] -> Maybe ([(TyVar, Type)], Type, [Type])
forall tyco.
TyCon -> [tyco] -> Maybe ([(TyVar, tyco)], Type, [tyco])
expandSynTyCon_maybe TyCon
tc [Type]
tys
  = Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> [Type] -> Type
mkAppTys (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy ([(TyVar, Type)] -> TCvSubst
mkTvSubstPrs [(TyVar, Type)]
tenv) Type
rhs) [Type]
tys')
               -- The free vars of 'rhs' should all be bound by 'tenv', so it's
               -- ok to use 'substTy' here.
               -- See also Note [The substitution invariant] in TyCoRep.
               -- Its important to use mkAppTys, rather than (foldl AppTy),
               -- because the function part might well return a
               -- partially-applied type constructor; indeed, usually will!
tcView _ = Maybe Type
forall a. Maybe a
Nothing

{-# INLINE coreView #-}
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 considers 'Constraint' to be a synonym of @TYPE LiftedRep@.
--
-- 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 ty :: Type
ty@(TyConApp tc :: TyCon
tc tys :: [Type]
tys)
  | Just (tenv :: [(TyVar, Type)]
tenv, rhs :: Type
rhs, tys' :: [Type]
tys') <- TyCon -> [Type] -> Maybe ([(TyVar, Type)], Type, [Type])
forall tyco.
TyCon -> [tyco] -> Maybe ([(TyVar, tyco)], Type, [tyco])
expandSynTyCon_maybe TyCon
tc [Type]
tys
  = Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> [Type] -> Type
mkAppTys (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy ([(TyVar, Type)] -> TCvSubst
mkTvSubstPrs [(TyVar, Type)]
tenv) Type
rhs) [Type]
tys')
    -- This equation is exactly like tcView

  -- At the Core level, Constraint = Type
  -- See Note [coreView vs tcView]
  | TyCon -> Bool
isConstraintKindCon TyCon
tc
  = ASSERT2( null tys, ppr ty )
    Type -> Maybe Type
forall a. a -> Maybe a
Just Type
liftedTypeKind

coreView _ = Maybe Type
forall a. Maybe a
Nothing

-----------------------------------------------
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 ty :: Type
ty
  = TCvSubst -> Type -> Type
go (InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope) Type
ty
  where
    in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (Type -> VarSet
tyCoVarsOfType Type
ty)

    go :: TCvSubst -> Type -> Type
go subst :: TCvSubst
subst (TyConApp tc :: TyCon
tc tys :: [Type]
tys)
      | Just (tenv :: [(TyVar, Type)]
tenv, rhs :: Type
rhs, tys' :: [Type]
tys') <- TyCon -> [Type] -> Maybe ([(TyVar, Type)], Type, [Type])
forall tyco.
TyCon -> [tyco] -> Maybe ([(TyVar, tyco)], Type, [tyco])
expandSynTyCon_maybe TyCon
tc [Type]
expanded_tys
      = let subst' :: TCvSubst
subst' = InScopeSet -> TvSubstEnv -> TCvSubst
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
            -- (Trac #11665)
        in  Type -> [Type] -> Type
mkAppTys (TCvSubst -> Type -> Type
go TCvSubst
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 (TCvSubst -> Type -> Type
go TCvSubst
subst) [Type]
tys)

    go _     (LitTy l :: TyLit
l)     = TyLit -> Type
LitTy TyLit
l
    go subst :: TCvSubst
subst (TyVarTy tv :: TyVar
tv)  = TCvSubst -> TyVar -> Type
substTyVar TCvSubst
subst TyVar
tv
    go subst :: TCvSubst
subst (AppTy t1 :: Type
t1 t2 :: Type
t2) = Type -> Type -> Type
mkAppTy (TCvSubst -> Type -> Type
go TCvSubst
subst Type
t1) (TCvSubst -> Type -> Type
go TCvSubst
subst Type
t2)
    go subst :: TCvSubst
subst (FunTy arg :: Type
arg res :: Type
res)
      = Type -> Type -> Type
mkFunTy (TCvSubst -> Type -> Type
go TCvSubst
subst Type
arg) (TCvSubst -> Type -> Type
go TCvSubst
subst Type
res)
    go subst :: TCvSubst
subst (ForAllTy (Bndr tv :: TyVar
tv vis :: ArgFlag
vis) t :: Type
t)
      = let (subst' :: TCvSubst
subst', tv' :: TyVar
tv') = (TCvSubst -> Type -> Type)
-> TCvSubst -> TyVar -> (TCvSubst, TyVar)
substVarBndrUsing TCvSubst -> Type -> Type
go TCvSubst
subst TyVar
tv in
        VarBndr TyVar ArgFlag -> Type -> Type
ForAllTy (TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' ArgFlag
vis) (TCvSubst -> Type -> Type
go TCvSubst
subst' Type
t)
    go subst :: TCvSubst
subst (CastTy ty :: Type
ty co :: KindCoercion
co)  = Type -> KindCoercion -> Type
mkCastTy (TCvSubst -> Type -> Type
go TCvSubst
subst Type
ty) (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co)
    go subst :: TCvSubst
subst (CoercionTy co :: KindCoercion
co) = KindCoercion -> Type
mkCoercionTy (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co)

    go_mco :: TCvSubst -> MCoercionN -> MCoercionN
go_mco _     MRefl    = MCoercionN
MRefl
    go_mco subst :: TCvSubst
subst (MCo co :: KindCoercion
co) = KindCoercion -> MCoercionN
MCo (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co)

    go_co :: TCvSubst -> KindCoercion -> KindCoercion
go_co subst :: TCvSubst
subst (Refl ty :: Type
ty)
      = Type -> KindCoercion
mkNomReflCo (TCvSubst -> Type -> Type
go TCvSubst
subst Type
ty)
    go_co subst :: TCvSubst
subst (GRefl r :: Role
r ty :: Type
ty mco :: MCoercionN
mco)
      = Role -> Type -> MCoercionN -> KindCoercion
mkGReflCo Role
r (TCvSubst -> Type -> Type
go TCvSubst
subst Type
ty) (TCvSubst -> MCoercionN -> MCoercionN
go_mco TCvSubst
subst MCoercionN
mco)
       -- NB: coercions are always expanded upon creation
    go_co subst :: TCvSubst
subst (TyConAppCo r :: Role
r tc :: TyCon
tc args :: [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 (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst) [KindCoercion]
args)
    go_co subst :: TCvSubst
subst (AppCo co :: KindCoercion
co arg :: KindCoercion
arg)
      = KindCoercion -> KindCoercion -> KindCoercion
mkAppCo (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co) (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
arg)
    go_co subst :: TCvSubst
subst (ForAllCo tv :: TyVar
tv kind_co :: KindCoercion
kind_co co :: KindCoercion
co)
      = let (subst' :: TCvSubst
subst', tv' :: TyVar
tv', kind_co' :: KindCoercion
kind_co') = TCvSubst
-> TyVar -> KindCoercion -> (TCvSubst, TyVar, KindCoercion)
go_cobndr TCvSubst
subst TyVar
tv KindCoercion
kind_co in
        TyVar -> KindCoercion -> KindCoercion -> KindCoercion
mkForAllCo TyVar
tv' KindCoercion
kind_co' (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst' KindCoercion
co)
    go_co subst :: TCvSubst
subst (FunCo r :: Role
r co1 :: KindCoercion
co1 co2 :: KindCoercion
co2)
      = Role -> KindCoercion -> KindCoercion -> KindCoercion
mkFunCo Role
r (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co1) (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co2)
    go_co subst :: TCvSubst
subst (CoVarCo cv :: TyVar
cv)
      = TCvSubst -> TyVar -> KindCoercion
substCoVar TCvSubst
subst TyVar
cv
    go_co subst :: TCvSubst
subst (AxiomInstCo ax :: CoAxiom Branched
ax ind :: Int
ind args :: [KindCoercion]
args)
      = CoAxiom Branched -> Int -> [KindCoercion] -> KindCoercion
mkAxiomInstCo CoAxiom Branched
ax Int
ind ((KindCoercion -> KindCoercion) -> [KindCoercion] -> [KindCoercion]
forall a b. (a -> b) -> [a] -> [b]
map (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst) [KindCoercion]
args)
    go_co subst :: TCvSubst
subst (UnivCo p :: UnivCoProvenance
p r :: Role
r t1 :: Type
t1 t2 :: Type
t2)
      = UnivCoProvenance -> Role -> Type -> Type -> KindCoercion
mkUnivCo (TCvSubst -> UnivCoProvenance -> UnivCoProvenance
go_prov TCvSubst
subst UnivCoProvenance
p) Role
r (TCvSubst -> Type -> Type
go TCvSubst
subst Type
t1) (TCvSubst -> Type -> Type
go TCvSubst
subst Type
t2)
    go_co subst :: TCvSubst
subst (SymCo co :: KindCoercion
co)
      = KindCoercion -> KindCoercion
mkSymCo (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co)
    go_co subst :: TCvSubst
subst (TransCo co1 :: KindCoercion
co1 co2 :: KindCoercion
co2)
      = KindCoercion -> KindCoercion -> KindCoercion
mkTransCo (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co1) (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co2)
    go_co subst :: TCvSubst
subst (NthCo r :: Role
r n :: Int
n co :: KindCoercion
co)
      = HasDebugCallStack => Role -> Int -> KindCoercion -> KindCoercion
Role -> Int -> KindCoercion -> KindCoercion
mkNthCo Role
r Int
n (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co)
    go_co subst :: TCvSubst
subst (LRCo lr :: LeftOrRight
lr co :: KindCoercion
co)
      = LeftOrRight -> KindCoercion -> KindCoercion
mkLRCo LeftOrRight
lr (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co)
    go_co subst :: TCvSubst
subst (InstCo co :: KindCoercion
co arg :: KindCoercion
arg)
      = KindCoercion -> KindCoercion -> KindCoercion
mkInstCo (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co) (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
arg)
    go_co subst :: TCvSubst
subst (KindCo co :: KindCoercion
co)
      = KindCoercion -> KindCoercion
mkKindCo (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co)
    go_co subst :: TCvSubst
subst (SubCo co :: KindCoercion
co)
      = KindCoercion -> KindCoercion
mkSubCo (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co)
    go_co subst :: TCvSubst
subst (AxiomRuleCo ax :: CoAxiomRule
ax cs :: [KindCoercion]
cs)
      = CoAxiomRule -> [KindCoercion] -> KindCoercion
AxiomRuleCo CoAxiomRule
ax ((KindCoercion -> KindCoercion) -> [KindCoercion] -> [KindCoercion]
forall a b. (a -> b) -> [a] -> [b]
map (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst) [KindCoercion]
cs)
    go_co _ (HoleCo h :: CoercionHole
h)
      = String -> SDoc -> KindCoercion
forall a. HasCallStack => String -> SDoc -> a
pprPanic "expandTypeSynonyms hit a hole" (CoercionHole -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionHole
h)

    go_prov :: TCvSubst -> UnivCoProvenance -> UnivCoProvenance
go_prov _     UnsafeCoerceProv    = UnivCoProvenance
UnsafeCoerceProv
    go_prov subst :: TCvSubst
subst (PhantomProv co :: KindCoercion
co)    = KindCoercion -> UnivCoProvenance
PhantomProv (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co)
    go_prov subst :: TCvSubst
subst (ProofIrrelProv co :: KindCoercion
co) = KindCoercion -> UnivCoProvenance
ProofIrrelProv (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst KindCoercion
co)
    go_prov _     p :: UnivCoProvenance
p@(PluginProv _)    = 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 :: TCvSubst
-> TyVar -> KindCoercion -> (TCvSubst, TyVar, KindCoercion)
go_cobndr subst :: TCvSubst
subst = Bool
-> (KindCoercion -> KindCoercion)
-> TCvSubst
-> TyVar
-> KindCoercion
-> (TCvSubst, TyVar, KindCoercion)
substForAllCoBndrUsing Bool
False (TCvSubst -> KindCoercion -> KindCoercion
go_co TCvSubst
subst) TCvSubst
subst

{-
************************************************************************
*                                                                      *
   Analyzing types
*                                                                      *
************************************************************************

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 mapCoercion ForAllCo case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As noted in Note [Forall coercions] in TyCoRep, 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 INLINABLE pragmas are indispensable. mapType/mapCoercion are used
to implement zonking, and it's vital that they get specialised to the TcM
monad. This specialisation happens automatically (that is, without a
SPECIALISE pragma) as long as the definitions are INLINABLE. For example,
this one change made a 20% allocation difference in perf/compiler/T5030.

-}

-- | This describes how a "map" operation over a type/coercion should behave
data TyCoMapper env m
  = TyCoMapper
      { TyCoMapper env m -> Bool
tcm_smart :: Bool -- ^ Should the new type be created with smart
                          -- constructors?
      , TyCoMapper env m -> env -> TyVar -> m Type
tcm_tyvar :: env -> TyVar -> m Type
      , TyCoMapper env m -> env -> TyVar -> m KindCoercion
tcm_covar :: env -> CoVar -> m Coercion
      , TyCoMapper env m -> env -> CoercionHole -> m KindCoercion
tcm_hole  :: env -> CoercionHole -> m Coercion
          -- ^ What to do with coercion holes.
          -- See Note [Coercion holes] in TyCoRep.

      , TyCoMapper env m -> env -> TyVar -> ArgFlag -> m (env, TyVar)
tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar)
          -- ^ The returned env is used in the extended scope

      , TyCoMapper env m -> TyCon -> m TyCon
tcm_tycon :: TyCon -> m TyCon
          -- ^ This is used only to turn 'TcTyCon's into 'TyCon's.
          -- See Note [Type checking recursive type and class declarations]
          -- in TcTyClsDecls
      }

{-# INLINABLE mapType #-}  -- See Note [Specialising mappers]
mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type
mapType :: TyCoMapper env m -> env -> Type -> m Type
mapType mapper :: TyCoMapper env m
mapper@(TyCoMapper { tcm_smart :: forall env (m :: * -> *). TyCoMapper env m -> Bool
tcm_smart = Bool
smart, 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 -> env -> TyVar -> ArgFlag -> m (env, TyVar)
tcm_tycobinder = env -> TyVar -> ArgFlag -> m (env, TyVar)
tycobinder, tcm_tycon :: forall env (m :: * -> *). TyCoMapper env m -> TyCon -> m TyCon
tcm_tycon = TyCon -> m TyCon
tycon })
        env :: env
env ty :: Type
ty
  = Type -> m Type
go Type
ty
  where
    go :: Type -> m Type
go (TyVarTy tv :: TyVar
tv) = env -> TyVar -> m Type
tyvar env
env TyVar
tv
    go (AppTy t1 :: Type
t1 t2 :: 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
<$> Type -> m Type
go Type
t1 m (Type -> Type) -> m Type -> m Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m Type
go Type
t2
    go t :: Type
t@(TyConApp tc :: TyCon
tc []) | Bool -> Bool
not (TyCon -> Bool
isTcTyCon TyCon
tc)
                          = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t  -- avoid allocation in this exceedingly
                                      -- common case (mostly, for *)
    go (TyConApp tc :: TyCon
tc tys :: [Type]
tys)
      = do { TyCon
tc' <- TyCon -> m TyCon
tycon TyCon
tc
           ; TyCon -> [Type] -> Type
mktyconapp TyCon
tc' ([Type] -> Type) -> m [Type] -> m Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> m Type) -> [Type] -> m [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> m Type
go [Type]
tys }
    go (FunTy arg :: Type
arg res :: Type
res)   = Type -> Type -> Type
FunTy (Type -> Type -> Type) -> m Type -> m (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m Type
go Type
arg m (Type -> Type) -> m Type -> m Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m Type
go Type
res
    go (ForAllTy (Bndr tv :: TyVar
tv vis :: ArgFlag
vis) inner :: Type
inner)
      = do { (env' :: env
env', tv' :: TyVar
tv') <- env -> TyVar -> ArgFlag -> m (env, TyVar)
tycobinder env
env TyVar
tv ArgFlag
vis
           ; Type
inner' <- TyCoMapper env m -> env -> Type -> m Type
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m -> env -> Type -> m Type
mapType TyCoMapper env m
mapper env
env' Type
inner
           ; Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ VarBndr TyVar ArgFlag -> Type -> Type
ForAllTy (TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' ArgFlag
vis) Type
inner' }
    go ty :: Type
ty@(LitTy {})   = Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    go (CastTy ty :: Type
ty co :: 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
<$> Type -> m Type
go Type
ty m (KindCoercion -> Type) -> m KindCoercion -> m Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyCoMapper env m -> env -> KindCoercion -> m KindCoercion
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m -> env -> KindCoercion -> m KindCoercion
mapCoercion TyCoMapper env m
mapper env
env KindCoercion
co
    go (CoercionTy co :: KindCoercion
co) = KindCoercion -> Type
CoercionTy (KindCoercion -> Type) -> m KindCoercion -> m Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCoMapper env m -> env -> KindCoercion -> m KindCoercion
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m -> env -> KindCoercion -> m KindCoercion
mapCoercion TyCoMapper env m
mapper env
env KindCoercion
co

    (mktyconapp :: TyCon -> [Type] -> Type
mktyconapp, mkappty :: Type -> Type -> Type
mkappty, mkcastty :: Type -> KindCoercion -> Type
mkcastty)
      | Bool
smart     = (TyCon -> [Type] -> Type
mkTyConApp, Type -> Type -> Type
mkAppTy, Type -> KindCoercion -> Type
mkCastTy)
      | Bool
otherwise = (TyCon -> [Type] -> Type
TyConApp,   Type -> Type -> Type
AppTy,   Type -> KindCoercion -> Type
CastTy)

{-# INLINABLE mapCoercion #-}  -- See Note [Specialising mappers]
mapCoercion :: Monad m
            => TyCoMapper env m -> env -> Coercion -> m Coercion
mapCoercion :: TyCoMapper env m -> env -> KindCoercion -> m KindCoercion
mapCoercion mapper :: TyCoMapper env m
mapper@(TyCoMapper { tcm_smart :: forall env (m :: * -> *). TyCoMapper env m -> Bool
tcm_smart = Bool
smart, 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, tcm_tycobinder :: forall env (m :: * -> *).
TyCoMapper env m -> env -> TyVar -> ArgFlag -> m (env, TyVar)
tcm_tycobinder = env -> TyVar -> ArgFlag -> m (env, TyVar)
tycobinder
                               , tcm_tycon :: forall env (m :: * -> *). TyCoMapper env m -> TyCon -> m TyCon
tcm_tycon = TyCon -> m TyCon
tycon })
            env :: env
env co :: KindCoercion
co
  = KindCoercion -> m KindCoercion
go KindCoercion
co
  where
    go_mco :: MCoercionN -> m MCoercionN
go_mco MRefl    = MCoercionN -> m MCoercionN
forall (m :: * -> *) a. Monad m => a -> m a
return MCoercionN
MRefl
    go_mco (MCo co :: KindCoercion
co) = KindCoercion -> MCoercionN
MCo (KindCoercion -> MCoercionN) -> m KindCoercion -> m MCoercionN
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (KindCoercion -> m KindCoercion
go KindCoercion
co)

    go :: KindCoercion -> m KindCoercion
go (Refl ty :: Type
ty) = Type -> KindCoercion
Refl (Type -> KindCoercion) -> m Type -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCoMapper env m -> env -> Type -> m Type
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m -> env -> Type -> m Type
mapType TyCoMapper env m
mapper env
env Type
ty
    go (GRefl r :: Role
r ty :: Type
ty mco :: 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
<$> TyCoMapper env m -> env -> Type -> m Type
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m -> env -> Type -> m Type
mapType TyCoMapper env m
mapper env
env Type
ty m (MCoercionN -> KindCoercion) -> m MCoercionN -> m KindCoercion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (MCoercionN -> m MCoercionN
go_mco MCoercionN
mco)
    go (TyConAppCo r :: Role
r tc :: TyCon
tc args :: [KindCoercion]
args)
      = do { TyCon
tc' <- TyCon -> m TyCon
tycon TyCon
tc
           ; 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
<$> (KindCoercion -> m KindCoercion)
-> [KindCoercion] -> m [KindCoercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM KindCoercion -> m KindCoercion
go [KindCoercion]
args }
    go (AppCo c1 :: KindCoercion
c1 c2 :: 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
<$> KindCoercion -> m KindCoercion
go KindCoercion
c1 m (KindCoercion -> KindCoercion)
-> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KindCoercion -> m KindCoercion
go KindCoercion
c2
    go (ForAllCo tv :: TyVar
tv kind_co :: KindCoercion
kind_co co :: KindCoercion
co)
      = do { KindCoercion
kind_co' <- KindCoercion -> m KindCoercion
go KindCoercion
kind_co
           ; (env' :: env
env', tv' :: TyVar
tv') <- env -> TyVar -> ArgFlag -> m (env, TyVar)
tycobinder env
env TyVar
tv ArgFlag
Inferred
           ; KindCoercion
co' <- TyCoMapper env m -> env -> KindCoercion -> m KindCoercion
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m -> env -> KindCoercion -> m KindCoercion
mapCoercion TyCoMapper env m
mapper env
env' KindCoercion
co
           ; KindCoercion -> m KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (KindCoercion -> m KindCoercion) -> KindCoercion -> m KindCoercion
forall a b. (a -> b) -> a -> b
$ TyVar -> KindCoercion -> KindCoercion -> KindCoercion
mkforallco TyVar
tv' KindCoercion
kind_co' KindCoercion
co' }
        -- See Note [Efficiency for mapCoercion ForAllCo case]
    go (FunCo r :: Role
r c1 :: KindCoercion
c1 c2 :: KindCoercion
c2) = Role -> KindCoercion -> KindCoercion -> KindCoercion
mkFunCo Role
r (KindCoercion -> KindCoercion -> KindCoercion)
-> m KindCoercion -> m (KindCoercion -> KindCoercion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindCoercion -> m KindCoercion
go KindCoercion
c1 m (KindCoercion -> KindCoercion)
-> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KindCoercion -> m KindCoercion
go KindCoercion
c2
    go (CoVarCo cv :: TyVar
cv) = env -> TyVar -> m KindCoercion
covar env
env TyVar
cv
    go (AxiomInstCo ax :: CoAxiom Branched
ax i :: Int
i args :: [KindCoercion]
args)
      = CoAxiom Branched -> Int -> [KindCoercion] -> KindCoercion
mkaxiominstco CoAxiom Branched
ax Int
i ([KindCoercion] -> KindCoercion)
-> m [KindCoercion] -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (KindCoercion -> m KindCoercion)
-> [KindCoercion] -> m [KindCoercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM KindCoercion -> m KindCoercion
go [KindCoercion]
args
    go (HoleCo hole :: CoercionHole
hole) = env -> CoercionHole -> m KindCoercion
cohole env
env CoercionHole
hole
    go (UnivCo p :: UnivCoProvenance
p r :: Role
r t1 :: Type
t1 t2 :: 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
<$> UnivCoProvenance -> m UnivCoProvenance
go_prov UnivCoProvenance
p m (Role -> Type -> Type -> KindCoercion)
-> m Role -> m (Type -> Type -> KindCoercion)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Role -> m Role
forall (f :: * -> *) a. Applicative f => a -> f a
pure Role
r
                 m (Type -> Type -> KindCoercion)
-> m Type -> m (Type -> KindCoercion)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyCoMapper env m -> env -> Type -> m Type
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m -> env -> Type -> m Type
mapType TyCoMapper env m
mapper env
env Type
t1 m (Type -> KindCoercion) -> m Type -> m KindCoercion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyCoMapper env m -> env -> Type -> m Type
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m -> env -> Type -> m Type
mapType TyCoMapper env m
mapper env
env Type
t2
    go (SymCo co :: KindCoercion
co) = KindCoercion -> KindCoercion
mksymco (KindCoercion -> KindCoercion) -> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindCoercion -> m KindCoercion
go KindCoercion
co
    go (TransCo c1 :: KindCoercion
c1 c2 :: 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
<$> KindCoercion -> m KindCoercion
go KindCoercion
c1 m (KindCoercion -> KindCoercion)
-> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KindCoercion -> m KindCoercion
go KindCoercion
c2
    go (AxiomRuleCo r :: CoAxiomRule
r cos :: [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
<$> (KindCoercion -> m KindCoercion)
-> [KindCoercion] -> m [KindCoercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM KindCoercion -> m KindCoercion
go [KindCoercion]
cos
    go (NthCo r :: Role
r i :: Int
i co :: KindCoercion
co)      = Role -> Int -> KindCoercion -> KindCoercion
mknthco Role
r Int
i (KindCoercion -> KindCoercion) -> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindCoercion -> m KindCoercion
go KindCoercion
co
    go (LRCo lr :: LeftOrRight
lr co :: 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
<$> KindCoercion -> m KindCoercion
go KindCoercion
co
    go (InstCo co :: KindCoercion
co arg :: 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
<$> KindCoercion -> m KindCoercion
go KindCoercion
co m (KindCoercion -> KindCoercion)
-> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KindCoercion -> m KindCoercion
go KindCoercion
arg
    go (KindCo co :: KindCoercion
co)         = KindCoercion -> KindCoercion
mkkindco (KindCoercion -> KindCoercion) -> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindCoercion -> m KindCoercion
go KindCoercion
co
    go (SubCo co :: KindCoercion
co)          = KindCoercion -> KindCoercion
mksubco (KindCoercion -> KindCoercion) -> m KindCoercion -> m KindCoercion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindCoercion -> m KindCoercion
go KindCoercion
co

    go_prov :: UnivCoProvenance -> m UnivCoProvenance
go_prov UnsafeCoerceProv    = UnivCoProvenance -> m UnivCoProvenance
forall (m :: * -> *) a. Monad m => a -> m a
return UnivCoProvenance
UnsafeCoerceProv
    go_prov (PhantomProv co :: KindCoercion
co)    = KindCoercion -> UnivCoProvenance
PhantomProv (KindCoercion -> UnivCoProvenance)
-> m KindCoercion -> m UnivCoProvenance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindCoercion -> m KindCoercion
go KindCoercion
co
    go_prov (ProofIrrelProv co :: KindCoercion
co) = KindCoercion -> UnivCoProvenance
ProofIrrelProv (KindCoercion -> UnivCoProvenance)
-> m KindCoercion -> m UnivCoProvenance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KindCoercion -> m KindCoercion
go KindCoercion
co
    go_prov p :: UnivCoProvenance
p@(PluginProv _)    = UnivCoProvenance -> m UnivCoProvenance
forall (m :: * -> *) a. Monad m => a -> m a
return UnivCoProvenance
p

    ( mktyconappco :: Role -> TyCon -> [KindCoercion] -> KindCoercion
mktyconappco, mkappco :: KindCoercion -> KindCoercion -> KindCoercion
mkappco, mkaxiominstco :: CoAxiom Branched -> Int -> [KindCoercion] -> KindCoercion
mkaxiominstco, mkunivco :: UnivCoProvenance -> Role -> Type -> Type -> KindCoercion
mkunivco
      , mksymco :: KindCoercion -> KindCoercion
mksymco, mktransco :: KindCoercion -> KindCoercion -> KindCoercion
mktransco, mknthco :: Role -> Int -> KindCoercion -> KindCoercion
mknthco, mklrco :: LeftOrRight -> KindCoercion -> KindCoercion
mklrco, mkinstco :: KindCoercion -> KindCoercion -> KindCoercion
mkinstco
      , mkkindco :: KindCoercion -> KindCoercion
mkkindco, mksubco :: KindCoercion -> KindCoercion
mksubco, mkforallco :: TyVar -> KindCoercion -> KindCoercion -> KindCoercion
mkforallco, mkgreflco :: Role -> Type -> MCoercionN -> KindCoercion
mkgreflco)
      | Bool
smart
      = ( HasDebugCallStack =>
Role -> TyCon -> [KindCoercion] -> KindCoercion
Role -> TyCon -> [KindCoercion] -> KindCoercion
mkTyConAppCo, KindCoercion -> KindCoercion -> KindCoercion
mkAppCo, CoAxiom Branched -> Int -> [KindCoercion] -> KindCoercion
mkAxiomInstCo, UnivCoProvenance -> Role -> Type -> Type -> KindCoercion
mkUnivCo
        , KindCoercion -> KindCoercion
mkSymCo, KindCoercion -> KindCoercion -> KindCoercion
mkTransCo, HasDebugCallStack => Role -> Int -> KindCoercion -> KindCoercion
Role -> Int -> KindCoercion -> KindCoercion
mkNthCo, LeftOrRight -> KindCoercion -> KindCoercion
mkLRCo, KindCoercion -> KindCoercion -> KindCoercion
mkInstCo
        , KindCoercion -> KindCoercion
mkKindCo, KindCoercion -> KindCoercion
mkSubCo, TyVar -> KindCoercion -> KindCoercion -> KindCoercion
mkForAllCo, Role -> Type -> MCoercionN -> KindCoercion
mkGReflCo )
      | Bool
otherwise
      = ( Role -> TyCon -> [KindCoercion] -> KindCoercion
TyConAppCo, KindCoercion -> KindCoercion -> KindCoercion
AppCo, CoAxiom Branched -> Int -> [KindCoercion] -> KindCoercion
AxiomInstCo, UnivCoProvenance -> Role -> Type -> Type -> KindCoercion
UnivCo
        , KindCoercion -> KindCoercion
SymCo, KindCoercion -> KindCoercion -> KindCoercion
TransCo, Role -> Int -> KindCoercion -> KindCoercion
NthCo, LeftOrRight -> KindCoercion -> KindCoercion
LRCo, KindCoercion -> KindCoercion -> KindCoercion
InstCo
        , KindCoercion -> KindCoercion
KindCo, KindCoercion -> KindCoercion
SubCo, TyVar -> KindCoercion -> KindCoercion -> KindCoercion
ForAllCo, Role -> Type -> MCoercionN -> KindCoercion
GRefl )

{-
************************************************************************
*                                                                      *
\subsection{Constructor-specific functions}
*                                                                      *
************************************************************************


---------------------------------------------------------------------
                                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 :: String -> Type -> TyVar
getTyVar :: String -> Type -> TyVar
getTyVar msg :: String
msg ty :: Type
ty = case Type -> Maybe TyVar
getTyVar_maybe Type
ty of
                    Just tv :: TyVar
tv -> TyVar
tv
                    Nothing -> String -> TyVar
forall a. String -> a
panic ("getTyVar: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)

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

-- | Attempts to obtain the type variable underlying a 'Type'
getTyVar_maybe :: Type -> Maybe TyVar
getTyVar_maybe :: Type -> Maybe TyVar
getTyVar_maybe ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe TyVar
getTyVar_maybe Type
ty'
                  | Bool
otherwise               = Type -> Maybe TyVar
repGetTyVar_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 ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (TyVar, KindCoercion)
getCastedTyVar_maybe Type
ty'
getCastedTyVar_maybe (CastTy (TyVarTy tv :: TyVar
tv) co :: KindCoercion
co)     = (TyVar, KindCoercion) -> Maybe (TyVar, KindCoercion)
forall a. a -> Maybe a
Just (TyVar
tv, KindCoercion
co)
getCastedTyVar_maybe (TyVarTy tv :: 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))
getCastedTyVar_maybe _                            = Maybe (TyVar, KindCoercion)
forall a. Maybe a
Nothing

-- | 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 tv :: TyVar
tv) = TyVar -> Maybe TyVar
forall a. a -> Maybe a
Just TyVar
tv
repGetTyVar_maybe _            = Maybe TyVar
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 (Trac #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.

This really only applies to the type checker; in Core, '=>' and '->'
are the same, as are 'Constraint' and '*'.  But for now I've put
the test in repSplitAppTy_maybe, which applies throughout, because
the other calls to splitAppTy are in 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 fun_ty :: Type
fun_ty co :: KindCoercion
co) arg_ty :: Type
arg_ty
  | ([arg_co :: KindCoercion
arg_co], res_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 tc :: TyCon
tc tys :: [Type]
tys) ty2 :: Type
ty2 = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Type]
tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
ty2])
mkAppTy ty1 :: Type
ty1               ty2 :: 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

mkAppTys :: Type -> [Type] -> Type
mkAppTys :: Type -> [Type] -> Type
mkAppTys ty1 :: Type
ty1                []   = Type
ty1
mkAppTys (CastTy fun_ty :: Type
fun_ty co :: KindCoercion
co) arg_tys :: [Type]
arg_tys  -- much more efficient then nested mkAppTy
                                     -- Why do this? See (EQ1) of
                                     -- Note [Respecting definitional equality]
                                     -- in TyCoRep
  = (Type -> Type -> Type) -> Type -> [Type] -> Type
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
    (arg_cos :: [KindCoercion]
arg_cos, res_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_tys
    (args_to_cast :: [Type]
args_to_cast, leftovers :: [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 tc :: TyCon
tc tys1 :: [Type]
tys1) tys2 :: [Type]
tys2 = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Type]
tys1 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
tys2)
mkAppTys ty1 :: Type
ty1                tys2 :: [Type]
tys2 = (Type -> Type -> Type) -> Type -> [Type] -> Type
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 ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty
                    = Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ty'
splitAppTy_maybe ty :: Type
ty = HasDebugCallStack => Type -> Maybe (Type, Type)
Type -> Maybe (Type, Type)
repSplitAppTy_maybe Type
ty

-------------
repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type)
-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that
-- any Core view stuff is already done
repSplitAppTy_maybe :: Type -> Maybe (Type, Type)
repSplitAppTy_maybe (FunTy ty1 :: Type
ty1 ty2 :: Type
ty2)
  = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (TyCon -> [Type] -> Type
TyConApp TyCon
funTyCon [Type
rep1, Type
rep2, Type
ty1], Type
ty2)
  where
    rep1 :: Type
rep1 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty1
    rep2 :: Type
rep2 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty2

repSplitAppTy_maybe (AppTy ty1 :: Type
ty1 ty2 :: Type
ty2)
  = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
ty1, Type
ty2)

repSplitAppTy_maybe (TyConApp tc :: TyCon
tc tys :: [Type]
tys)
  | TyCon -> Bool
mightBeUnsaturatedTyCon TyCon
tc Bool -> Bool -> Bool
|| [Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` TyCon -> Int
tyConArity TyCon
tc
  , Just (tys' :: [Type]
tys', ty' :: 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!

repSplitAppTy_maybe _other :: Type
_other = Maybe (Type, Type)
forall a. Maybe a
Nothing

-- This one doesn't break apart (c => t).
-- See Note [Decomposing fat arrow c=>t]
-- Defined here to avoid module loops between Unify and TcType.
tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type)
-- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that
-- any coreView stuff is already done. Refuses to look through (c => t)
tcRepSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcRepSplitAppTy_maybe (FunTy ty1 :: Type
ty1 ty2 :: Type
ty2)
  | Type -> Bool
isPredTy Type
ty1
  = Maybe (Type, Type)
forall a. Maybe a
Nothing  -- See Note [Decomposing fat arrow c=>t]

  | Bool
otherwise
  = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (TyCon -> [Type] -> Type
TyConApp TyCon
funTyCon [Type
rep1, Type
rep2, Type
ty1], Type
ty2)
  where
    rep1 :: Type
rep1 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty1
    rep2 :: Type
rep2 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty2

tcRepSplitAppTy_maybe (AppTy ty1 :: Type
ty1 ty2 :: Type
ty2)    = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
ty1, Type
ty2)
tcRepSplitAppTy_maybe (TyConApp tc :: TyCon
tc tys :: [Type]
tys)
  | TyCon -> Bool
mightBeUnsaturatedTyCon TyCon
tc Bool -> Bool -> Bool
|| [Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` TyCon -> Int
tyConArity TyCon
tc
  , Just (tys' :: [Type]
tys', ty' :: 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!
tcRepSplitAppTy_maybe _other :: Type
_other = Maybe (Type, Type)
forall a. Maybe a
Nothing

-- | Like 'tcSplitTyConApp_maybe' but doesn't look through type synonyms.
tcRepSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
-- Defined here to avoid module loops between Unify and TcType.
tcRepSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
tcRepSplitTyConApp_maybe (TyConApp tc :: TyCon
tc tys :: [Type]
tys)
  = (TyCon, [Type]) -> Maybe (TyCon, [Type])
forall a. a -> Maybe a
Just (TyCon
tc, [Type]
tys)

tcRepSplitTyConApp_maybe (FunTy arg :: Type
arg res :: Type
res)
  = (TyCon, [Type]) -> Maybe (TyCon, [Type])
forall a. a -> Maybe a
Just (TyCon
funTyCon, [Type
arg_rep, Type
res_rep, Type
arg, Type
res])
  where
    arg_rep :: Type
arg_rep = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
arg
    res_rep :: Type
res_rep = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
res

tcRepSplitTyConApp_maybe _
  = Maybe (TyCon, [Type])
forall a. Maybe a
Nothing

-- | Like 'tcSplitTyConApp' but doesn't look through type synonyms.
tcRepSplitTyConApp :: HasCallStack => Type -> (TyCon, [Type])
-- Defined here to avoid module loops between Unify and TcType.
tcRepSplitTyConApp :: Type -> (TyCon, [Type])
tcRepSplitTyConApp ty :: Type
ty =
  case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcRepSplitTyConApp_maybe Type
ty of
    Just stuff :: (TyCon, [Type])
stuff -> (TyCon, [Type])
stuff
    Nothing    -> String -> SDoc -> (TyCon, [Type])
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcRepSplitTyConApp" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

-------------
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 ty :: Type
ty = case Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ty of
                Just pr :: (Type, Type)
pr -> (Type, Type)
pr
                Nothing -> String -> (Type, Type)
forall a. String -> a
panic "splitAppTy"

-------------
splitAppTys :: 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 :: Type -> (Type, [Type])
splitAppTys ty :: Type
ty = Type -> Type -> [Type] -> (Type, [Type])
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [Type] -> (Type, [Type])
split orig_ty :: Type
orig_ty ty :: Type
ty args :: [Type]
args | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type -> [Type] -> (Type, [Type])
split Type
orig_ty Type
ty' [Type]
args
    split _       (AppTy ty :: Type
ty arg :: Type
arg)        args :: [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
split Type
ty Type
ty (Type
argType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args)
    split _       (TyConApp tc :: TyCon
tc tc_args :: [Type]
tc_args) args :: [Type]
args
      = let -- keep type families saturated
            n :: Int
n | TyCon -> Bool
mightBeUnsaturatedTyCon TyCon
tc = 0
              | Bool
otherwise                  = TyCon -> Int
tyConArity TyCon
tc
            (tc_args1 :: [Type]
tc_args1, tc_args2 :: [Type]
tc_args2) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
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 ty1 :: Type
ty1 ty2 :: Type
ty2) args :: [Type]
args
      = ASSERT( null args )
        (TyCon -> [Type] -> Type
TyConApp TyCon
funTyCon [], [Type
rep1, Type
rep2, Type
ty1, Type
ty2])
      where
        rep1 :: Type
rep1 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty1
        rep2 :: Type
rep2 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty2

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

-- | Like 'splitAppTys', but doesn't look through type synonyms
repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type])
repSplitAppTys :: Type -> (Type, [Type])
repSplitAppTys ty :: Type
ty = Type -> [Type] -> (Type, [Type])
split Type
ty []
  where
    split :: Type -> [Type] -> (Type, [Type])
split (AppTy ty :: Type
ty arg :: Type
arg) args :: [Type]
args = Type -> [Type] -> (Type, [Type])
split Type
ty (Type
argType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args)
    split (TyConApp tc :: TyCon
tc tc_args :: [Type]
tc_args) args :: [Type]
args
      = let n :: Int
n | TyCon -> Bool
mightBeUnsaturatedTyCon TyCon
tc = 0
              | Bool
otherwise                  = TyCon -> Int
tyConArity TyCon
tc
            (tc_args1 :: [Type]
tc_args1, tc_args2 :: [Type]
tc_args2) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
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 ty1 :: Type
ty1 ty2 :: Type
ty2) args :: [Type]
args
      = ASSERT( null args )
        (TyCon -> [Type] -> Type
TyConApp TyCon
funTyCon [], [Type
rep1, Type
rep2, Type
ty1, Type
ty2])
      where
        rep1 :: Type
rep1 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty1
        rep2 :: Type
rep2 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty2

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

{-
                      LitTy
                      ~~~~~
-}

mkNumLitTy :: Integer -> Type
mkNumLitTy :: Integer -> Type
mkNumLitTy n :: 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 ty :: Type
ty | Just ty1 :: Type
ty1 <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe Integer
isNumLitTy Type
ty1
isNumLitTy (LitTy (NumTyLit n :: Integer
n)) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n
isNumLitTy _                    = Maybe Integer
forall a. Maybe a
Nothing

mkStrLitTy :: FastString -> Type
mkStrLitTy :: FastString -> Type
mkStrLitTy s :: 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 ty :: Type
ty | Just ty1 :: Type
ty1 <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe FastString
isStrLitTy Type
ty1
isStrLitTy (LitTy (StrTyLit s :: FastString
s)) = FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
s
isStrLitTy _                    = Maybe FastString
forall a. Maybe a
Nothing

-- | Is this a type literal (symbol or numeric).
isLitTy :: Type -> Maybe TyLit
isLitTy :: Type -> Maybe TyLit
isLitTy ty :: Type
ty | Just ty1 :: Type
ty1 <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe TyLit
isLitTy Type
ty1
isLitTy (LitTy l :: TyLit
l)                    = TyLit -> Maybe TyLit
forall a. a -> Maybe a
Just TyLit
l
isLitTy _                            = Maybe TyLit
forall a. Maybe a
Nothing

-- | Is this type a custom user error?
-- If so, give us the kind and the error message.
userTypeError_maybe :: Type -> Maybe Type
userTypeError_maybe :: Type -> Maybe Type
userTypeError_maybe t :: Type
t
  = do { (tc :: TyCon
tc, _kind :: Type
_kind : msg :: Type
msg : _) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
          -- There may be more than 2 arguments, if the type error is
          -- used as a type constructor (e.g. at kind `Type -> Type`).

       ; Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
errorMessageTypeErrorFamName)
       ; Type -> Maybe Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
msg }

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

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

    -- ShowType t
    Just (tc :: TyCon
tc,[_k :: Type
_k,t :: 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 (tc :: TyCon
tc,[t1 :: Type
t1,t2 :: 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
<> Type -> SDoc
pprUserTypeErrorTy Type
t2

    -- t1 :$$: t2
    Just (tc :: TyCon
tc,[t1 :: Type
t1,t2 :: 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
$$ Type -> SDoc
pprUserTypeErrorTy Type
t2

    -- An unevaluated type function
    _ -> 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 (->)),

    (->) :: 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 recontructing 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.
-}

isFunTy :: Type -> Bool
isFunTy :: Type -> Bool
isFunTy ty :: Type
ty = Maybe (Type, Type) -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe (Type, Type)
splitFunTy_maybe Type
ty)

splitFunTy :: Type -> (Type, Type)
-- ^ Attempts to extract the argument and result types from a type, and
-- panics if that is not possible. See also 'splitFunTy_maybe'
splitFunTy :: Type -> (Type, Type)
splitFunTy ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> (Type, Type)
splitFunTy Type
ty'
splitFunTy (FunTy arg :: Type
arg res :: Type
res) = (Type
arg, Type
res)
splitFunTy other :: Type
other           = String -> SDoc -> (Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "splitFunTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
other)

splitFunTy_maybe :: Type -> Maybe (Type, Type)
-- ^ Attempts to extract the argument and result types from a type
splitFunTy_maybe :: Type -> Maybe (Type, Type)
splitFunTy_maybe ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (Type, Type)
splitFunTy_maybe Type
ty'
splitFunTy_maybe (FunTy arg :: Type
arg res :: Type
res) = (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
arg, Type
res)
splitFunTy_maybe _               = Maybe (Type, Type)
forall a. Maybe a
Nothing

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

funResultTy :: Type -> Type
-- ^ Extract the function result type and panic if that is not possible
funResultTy :: Type -> Type
funResultTy ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type
funResultTy Type
ty'
funResultTy (FunTy _ res :: Type
res) = Type
res
funResultTy ty :: Type
ty            = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "funResultTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

funArgTy :: Type -> Type
-- ^ Extract the function argument type and panic if that is not possible
funArgTy :: Type -> Type
funArgTy ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type
funArgTy Type
ty'
funArgTy (FunTy arg :: Type
arg _res :: Type
_res) = Type
arg
funArgTy ty :: Type
ty               = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 :: Type -> Type -> Type
piResultTy ty :: Type
ty arg :: Type
arg = case Type -> Type -> Maybe Type
piResultTy_maybe Type
ty Type
arg of
                      Just res :: Type
res -> Type
res
                      Nothing  -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "piResultTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg)

piResultTy_maybe :: Type -> Type -> Maybe Type
piResultTy_maybe :: Type -> Type -> Maybe Type
piResultTy_maybe ty :: Type
ty arg :: Type
arg
  | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type -> Maybe Type
piResultTy_maybe Type
ty' Type
arg

  | FunTy _ res :: Type
res <- Type
ty
  = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
res

  | ForAllTy (Bndr tv :: TyVar
tv _) res :: Type
res <- Type
ty
  = let empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (InScopeSet -> TCvSubst) -> InScopeSet -> TCvSubst
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 (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy (TCvSubst -> TyVar -> Type -> TCvSubst
extendTCvSubst TCvSubst
empty_subst TyVar
tv Type
arg) Type
res)

  | Bool
otherwise
  = 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 coreSyn/CoreLint.hs

-- 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 :: Type -> [Type] -> Type
piResultTys ty :: Type
ty [] = Type
ty
piResultTys ty :: Type
ty orig_args :: [Type]
orig_args@(arg :: Type
arg:args :: [Type]
args)
  | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty
  = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys Type
ty' [Type]
orig_args

  | FunTy _ res :: Type
res <- Type
ty
  = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys Type
res [Type]
args

  | ForAllTy (Bndr tv :: TyVar
tv _) res :: Type
res <- Type
ty
  = TCvSubst -> Type -> [Type] -> Type
go (TCvSubst -> TyVar -> Type -> TCvSubst
extendTCvSubst TCvSubst
init_subst TyVar
tv Type
arg) Type
res [Type]
args

  | Bool
otherwise
  = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "piResultTys1" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
orig_args)
  where
    init_subst :: TCvSubst
init_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (InScopeSet -> TCvSubst) -> InScopeSet -> TCvSubst
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 :: TCvSubst -> Type -> [Type] -> Type
    go :: TCvSubst -> Type -> [Type] -> Type
go subst :: TCvSubst
subst ty :: Type
ty [] = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
ty

    go subst :: TCvSubst
subst ty :: Type
ty all_args :: [Type]
all_args@(arg :: Type
arg:args :: [Type]
args)
      | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty
      = TCvSubst -> Type -> [Type] -> Type
go TCvSubst
subst Type
ty' [Type]
all_args

      | FunTy _ res :: Type
res <- Type
ty
      = TCvSubst -> Type -> [Type] -> Type
go TCvSubst
subst Type
res [Type]
args

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

      | Bool -> Bool
not (TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst)  -- See Note [Care with kind instantiation]
      = TCvSubst -> Type -> [Type] -> Type
go TCvSubst
init_subst
          (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
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 infniite loop, which is very unhelpful
        -- c.f. Trac #15473
        String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "piResultTys2" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
orig_args SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
all_args)

applyTysX :: [TyVar] -> Type -> [Type] -> Type
-- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys
-- Assumes that (/\tvs. body_ty) is closed
applyTysX :: [TyVar] -> Type -> [Type] -> Type
applyTysX tvs :: [TyVar]
tvs body_ty :: Type
body_ty arg_tys :: [Type]
arg_tys
  = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff )
    ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff )
    Type -> [Type] -> Type
mkAppTys (HasCallStack => [TyVar] -> [Type] -> Type -> Type
[TyVar] -> [Type] -> Type -> Type
substTyWith [TyVar]
tvs (Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take Int
n_tvs [Type]
arg_tys) Type
body_ty)
             (Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
n_tvs [Type]
arg_tys)
  where
    pp_stuff :: SDoc
pp_stuff = [SDoc] -> SDoc
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]
    n_tvs :: Int
n_tvs = [TyVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyVar]
tvs



{- 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 intantiate the forall!

Similarly (Trac #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 ToIface.toIfaceAppArgsX.


---------------------------------------------------------------------
                                TyConApp
                                ~~~~~~~~
-}

-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to
-- its arguments.  Applies its arguments to the constructor from left to right.
mkTyConApp :: TyCon -> [Type] -> Type
mkTyConApp :: TyCon -> [Type] -> Type
mkTyConApp tycon :: TyCon
tycon tys :: [Type]
tys
  | TyCon -> Bool
isFunTyCon TyCon
tycon
  , [_rep1 :: Type
_rep1,_rep2 :: Type
_rep2,ty1 :: Type
ty1,ty2 :: Type
ty2] <- [Type]
tys
  = Type -> Type -> Type
FunTy Type
ty1 Type
ty2

  | Bool
otherwise
  = TyCon -> [Type] -> Type
TyConApp TyCon
tycon [Type]
tys

-- 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 tc :: TyCon
tc _) = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc
tyConAppTyConPicky_maybe (FunTy {})      = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
funTyCon
tyConAppTyConPicky_maybe _               = Maybe TyCon
forall a. Maybe a
Nothing


-- | The same as @fst . splitTyConApp@
tyConAppTyCon_maybe :: Type -> Maybe TyCon
tyConAppTyCon_maybe :: Type -> Maybe TyCon
tyConAppTyCon_maybe ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty'
tyConAppTyCon_maybe (TyConApp tc :: TyCon
tc _) = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc
tyConAppTyCon_maybe (FunTy {})      = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
funTyCon
tyConAppTyCon_maybe _               = Maybe TyCon
forall a. Maybe a
Nothing

tyConAppTyCon :: Type -> TyCon
tyConAppTyCon :: Type -> TyCon
tyConAppTyCon ty :: 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 "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 ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe [Type]
tyConAppArgs_maybe Type
ty'
tyConAppArgs_maybe (TyConApp _ tys :: [Type]
tys) = [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type]
tys
tyConAppArgs_maybe (FunTy arg :: Type
arg res :: Type
res)
  | Just rep1 :: Type
rep1 <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
getRuntimeRep_maybe Type
arg
  , Just rep2 :: Type
rep2 <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
getRuntimeRep_maybe Type
res
  = [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type
rep1, Type
rep2, Type
arg, Type
res]
tyConAppArgs_maybe _  = Maybe [Type]
forall a. Maybe a
Nothing

tyConAppArgs :: Type -> [Type]
tyConAppArgs :: Type -> [Type]
tyConAppArgs ty :: 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 "tyConAppArgs" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

tyConAppArgN :: Int -> Type -> Type
-- Executing Nth
tyConAppArgN :: Int -> Type -> Type
tyConAppArgN n :: Int
n ty :: Type
ty
  = case Type -> Maybe [Type]
tyConAppArgs_maybe Type
ty of
      Just tys :: [Type]
tys -> ASSERT2( tys `lengthExceeds` n, ppr n <+> ppr tys ) tys `getNth` n
      Nothing  -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tyConAppArgN" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n SDoc -> SDoc -> SDoc
<+> 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 ty :: Type
ty = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
                   Just stuff :: (TyCon, [Type])
stuff -> (TyCon, [Type])
stuff
                   Nothing    -> String -> SDoc -> (TyCon, [Type])
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 :: Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty'
splitTyConApp_maybe ty :: Type
ty                           = HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
repSplitTyConApp_maybe Type
ty

-- | Like 'splitTyConApp_maybe', but doesn't look through synonyms. This
-- assumes the synonyms have already been dealt with.
repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
repSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
repSplitTyConApp_maybe (TyConApp tc :: TyCon
tc tys :: [Type]
tys) = (TyCon, [Type]) -> Maybe (TyCon, [Type])
forall a. a -> Maybe a
Just (TyCon
tc, [Type]
tys)
repSplitTyConApp_maybe (FunTy arg :: Type
arg res :: Type
res)
  | Just arg_rep :: Type
arg_rep <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
getRuntimeRep_maybe Type
arg
  , Just res_rep :: Type
res_rep <- HasDebugCallStack => Type -> Maybe Type
Type -> Maybe Type
getRuntimeRep_maybe Type
res
  = (TyCon, [Type]) -> Maybe (TyCon, [Type])
forall a. a -> Maybe a
Just (TyCon
funTyCon, [Type
arg_rep, Type
res_rep, Type
arg, Type
res])
repSplitTyConApp_maybe _ = Maybe (TyCon, [Type])
forall a. Maybe a
Nothing

-- | Attempts to tease a list type apart and gives the type of the elements if
-- successful (looks through type synonyms)
splitListTyConApp_maybe :: Type -> Maybe Type
splitListTyConApp_maybe :: Type -> Maybe Type
splitListTyConApp_maybe ty :: Type
ty = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
  Just (tc :: TyCon
tc,[e :: Type
e]) | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
listTyCon -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
e
  _other :: Maybe (TyCon, [Type])
_other                          -> Maybe Type
forall a. Maybe a
Nothing

nextRole :: Type -> Role
nextRole :: Type -> Role
nextRole ty :: Type
ty
  | Just (tc :: TyCon
tc, tys :: [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  , let num_tys :: Int
num_tys = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys
  , Int
num_tys Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< TyCon -> Int
tyConArity TyCon
tc
  = TyCon -> [Role]
tyConRoles TyCon
tc [Role] -> Int -> Role
forall a. Outputable a => [a] -> Int -> a
`getNth` Int
num_tys

  | Bool
otherwise
  = Role
Nominal

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
tycon tys :: [Type]
tys
    = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs )
      [TyVar] -> Type -> [Type] -> Type
applyTysX [TyVar]
tvs Type
rhs [Type]
tys
  where
    (tvs :: [TyVar]
tvs, rhs :: Type
rhs) = TyCon -> ([TyVar], Type)
newTyConEtadRhs TyCon
tycon

{-
---------------------------------------------------------------------
                           CastTy
                           ~~~~~~
A casted type has its *kind* casted into something new.
-}

splitCastTy_maybe :: Type -> Maybe (Type, Coercion)
splitCastTy_maybe :: Type -> Maybe (Type, KindCoercion)
splitCastTy_maybe ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (Type, KindCoercion)
splitCastTy_maybe Type
ty'
splitCastTy_maybe (CastTy ty :: Type
ty co :: KindCoercion
co)               = (Type, KindCoercion) -> Maybe (Type, KindCoercion)
forall a. a -> Maybe a
Just (Type
ty, KindCoercion
co)
splitCastTy_maybe _                            = 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 TyCoRep
mkCastTy :: Type -> Coercion -> Type
mkCastTy :: Type -> KindCoercion -> Type
mkCastTy ty :: Type
ty co :: KindCoercion
co | KindCoercion -> Bool
isReflexiveCo KindCoercion
co = Type
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 (CastTy ty :: Type
ty co1 :: KindCoercion
co1) co2 :: KindCoercion
co2
  -- (EQ3) from the Note
  = Type -> KindCoercion -> Type
mkCastTy Type
ty (KindCoercion
co1 KindCoercion -> KindCoercion -> KindCoercion
`mkTransCo` KindCoercion
co2)
      -- call mkCastTy again for the reflexivity check

mkCastTy (ForAllTy (Bndr tv :: TyVar
tv vis :: ArgFlag
vis) inner_ty :: Type
inner_ty) co :: KindCoercion
co
  -- (EQ4) from the Note
  | 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 :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet VarSet
fvs)
             (subst :: TCvSubst
subst, tv' :: TyVar
tv') = HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)
TCvSubst -> TyVar -> (TCvSubst, TyVar)
substVarBndr TCvSubst
empty_subst TyVar
tv
         in VarBndr TyVar ArgFlag -> Type -> Type
ForAllTy (TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' ArgFlag
vis) (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
inner_ty Type -> KindCoercion -> Type
`mkCastTy` KindCoercion
co)
    else VarBndr TyVar ArgFlag -> Type -> Type
ForAllTy (TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ArgFlag
vis) (Type
inner_ty Type -> KindCoercion -> Type
`mkCastTy` KindCoercion
co)

mkCastTy ty :: Type
ty co :: KindCoercion
co = Type -> KindCoercion -> Type
CastTy Type
ty KindCoercion
co

tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder]
-- Return the tyConBinders in TyCoBinder form
tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder]
tyConBindersTyCoBinders = (TyConBinder -> TyCoBinder) -> [TyConBinder] -> [TyCoBinder]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> TyCoBinder
to_tyb
  where
    to_tyb :: TyConBinder -> TyCoBinder
to_tyb (Bndr tv :: TyVar
tv (NamedTCB vis :: ArgFlag
vis)) = VarBndr TyVar ArgFlag -> TyCoBinder
Named (TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ArgFlag
vis)
    to_tyb (Bndr tv :: TyVar
tv AnonTCB)        = Type -> TyCoBinder
Anon (TyVar -> Type
varType TyVar
tv)

{-
--------------------------------------------------------------------
                            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 _) = Bool
True
isCoercionTy _              = Bool
False

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

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

{-
---------------------------------------------------------------------
                                SynTy
                                ~~~~~

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 TcBinds.hs.


---------------------------------------------------------------------
                                ForAllTy
                                ~~~~~~~~
-}

-- | Make a dependent forall over an Inferred variablem
mkTyCoInvForAllTy :: TyCoVar -> Type -> Type
mkTyCoInvForAllTy :: TyVar -> Type -> Type
mkTyCoInvForAllTy tv :: TyVar
tv ty :: Type
ty
  | TyVar -> Bool
isCoVar TyVar
tv
  , Bool -> Bool
not (TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
ty)
  = Type -> Type -> Type
mkFunTy (TyVar -> Type
varType TyVar
tv) Type
ty
  | Bool
otherwise
  = VarBndr TyVar ArgFlag -> Type -> Type
ForAllTy (TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ArgFlag
Inferred) Type
ty

-- | Like mkTyCoInvForAllTy, but tv should be a tyvar
mkInvForAllTy :: TyVar -> Type -> Type
mkInvForAllTy :: TyVar -> Type -> Type
mkInvForAllTy tv :: TyVar
tv ty :: Type
ty = ASSERT( isTyVar tv )
                      VarBndr TyVar ArgFlag -> Type -> Type
ForAllTy (TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ArgFlag
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 tvs :: [TyVar]
tvs ty :: Type
ty = (TyVar -> Type -> Type) -> Type -> [TyVar] -> Type
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
mkInvForAllTys :: [TyVar] -> Type -> Type
mkInvForAllTys :: [TyVar] -> Type -> Type
mkInvForAllTys tvs :: [TyVar]
tvs ty :: Type
ty = (TyVar -> Type -> Type) -> Type -> [TyVar] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyVar -> Type -> Type
mkInvForAllTy Type
ty [TyVar]
tvs

-- | Like mkForAllTys, but assumes all variables are dependent and Specified,
-- a common case
mkSpecForAllTys :: [TyVar] -> Type -> Type
mkSpecForAllTys :: [TyVar] -> Type -> Type
mkSpecForAllTys tvs :: [TyVar]
tvs = ASSERT( all isTyVar tvs )
                      -- covar is always Inferred, so all inputs should be tyvar
                      [VarBndr TyVar ArgFlag] -> Type -> Type
mkForAllTys [ TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv ArgFlag
Specified | TyVar
tv <- [TyVar]
tvs ]

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

mkLamType  :: Var -> Type -> Type
-- ^ Makes a @(->)@ type or an implicit forall type, depending
-- on whether it is given a type variable or a term variable.
-- This is used, for example, when producing the type of a lambda.
-- Always uses Inferred binders.
mkLamTypes :: [Var] -> Type -> Type
-- ^ 'mkLamType' for multiple type or value arguments

mkLamType :: TyVar -> Type -> Type
mkLamType v :: TyVar
v ty :: Type
ty
   | TyVar -> Bool
isCoVar TyVar
v
   , TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
ty
   = VarBndr TyVar ArgFlag -> Type -> Type
ForAllTy (TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
v ArgFlag
Inferred) Type
ty
   | TyVar -> Bool
isTyVar TyVar
v
   = VarBndr TyVar ArgFlag -> Type -> Type
ForAllTy (TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
v ArgFlag
Inferred) Type
ty
   | Bool
otherwise
   = Type -> Type -> Type
FunTy (TyVar -> Type
varType TyVar
v) Type
ty

mkLamTypes :: [TyVar] -> Type -> Type
mkLamTypes vs :: [TyVar]
vs ty :: Type
ty = (TyVar -> Type -> Type) -> Type -> [TyVar] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyVar -> Type -> Type
mkLamType Type
ty [TyVar]
vs

-- | Given a list of type-level vars and the free vars of a result kind,
-- makes TyCoBinders, 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 vars :: [TyVar]
vars inner_tkvs :: VarSet
inner_tkvs = ASSERT( all isTyVar 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 (v :: TyVar
v:vs :: [TyVar]
vs) | TyVar
v TyVar -> VarSet -> Bool
`elemVarSet` VarSet
fvs
              = ( TyVar -> TyConBndrVis -> TyConBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
v (ArgFlag -> TyConBndrVis
NamedTCB ArgFlag
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
        (binders :: [TyConBinder]
binders, fvs :: 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 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.
splitForAllTys :: Type -> ([TyCoVar], Type)
splitForAllTys :: Type -> ([TyVar], Type)
splitForAllTys ty :: Type
ty = Type -> Type -> [TyVar] -> ([TyVar], Type)
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [TyVar] -> ([TyVar], Type)
split orig_ty :: Type
orig_ty ty :: Type
ty tvs :: [TyVar]
tvs | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type -> [TyVar] -> ([TyVar], Type)
split Type
orig_ty Type
ty' [TyVar]
tvs
    split _       (ForAllTy (Bndr tv :: TyVar
tv _) ty :: Type
ty)    tvs :: [TyVar]
tvs = Type -> Type -> [TyVar] -> ([TyVar], Type)
split Type
ty Type
ty (TyVar
tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
tvs)
    split orig_ty :: Type
orig_ty _                            tvs :: [TyVar]
tvs = ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
tvs, Type
orig_ty)

-- | Like splitForAllTys, 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.
splitTyVarForAllTys :: Type -> ([TyVar], Type)
splitTyVarForAllTys :: Type -> ([TyVar], Type)
splitTyVarForAllTys ty :: Type
ty = Type -> Type -> [TyVar] -> ([TyVar], Type)
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [TyVar] -> ([TyVar], Type)
split orig_ty :: Type
orig_ty ty :: Type
ty tvs :: [TyVar]
tvs | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty     = Type -> Type -> [TyVar] -> ([TyVar], Type)
split Type
orig_ty Type
ty' [TyVar]
tvs
    split _ (ForAllTy (Bndr tv :: TyVar
tv _) ty :: Type
ty) tvs :: [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 orig_ty :: Type
orig_ty _                   tvs :: [TyVar]
tvs              = ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
tvs, Type
orig_ty)

-- | Checks whether this is a proper forall (with a named binder)
isForAllTy :: Type -> Bool
isForAllTy :: Type -> Bool
isForAllTy ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isForAllTy Type
ty'
isForAllTy (ForAllTy {}) = Bool
True
isForAllTy _             = Bool
False

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

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

-- | Is this a function or forall?
isPiTy :: Type -> Bool
isPiTy :: Type -> Bool
isPiTy ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isForAllTy Type
ty'
isPiTy (ForAllTy {}) = Bool
True
isPiTy (FunTy {})    = Bool
True
isPiTy _             = Bool
False

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

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

-- | Attempts to take a forall type apart, but only if it's a proper forall,
-- with a named binder
splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type)
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTy_maybe ty :: Type
ty = Type -> Maybe (TyVar, Type)
go Type
ty
  where
    go :: Type -> Maybe (TyVar, Type)
go ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (TyVar, Type)
go Type
ty'
    go (ForAllTy (Bndr tv :: TyVar
tv _) ty :: Type
ty)    = (TyVar, Type) -> Maybe (TyVar, Type)
forall a. a -> Maybe a
Just (TyVar
tv, Type
ty)
    go _                            = Maybe (TyVar, Type)
forall a. Maybe a
Nothing

-- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder.
splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type)
splitForAllTy_ty_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTy_ty_maybe ty :: Type
ty = Type -> Maybe (TyVar, Type)
go Type
ty
  where
    go :: Type -> Maybe (TyVar, Type)
go ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (TyVar, Type)
go Type
ty'
    go (ForAllTy (Bndr tv :: TyVar
tv _) ty :: Type
ty) | TyVar -> Bool
isTyVar TyVar
tv = (TyVar, Type) -> Maybe (TyVar, Type)
forall a. a -> Maybe a
Just (TyVar
tv, Type
ty)
    go _                            = Maybe (TyVar, Type)
forall a. Maybe a
Nothing

-- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder.
splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type)
splitForAllTy_co_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTy_co_maybe ty :: Type
ty = Type -> Maybe (TyVar, Type)
go Type
ty
  where
    go :: Type -> Maybe (TyVar, Type)
go ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (TyVar, Type)
go Type
ty'
    go (ForAllTy (Bndr tv :: TyVar
tv _) ty :: Type
ty) | TyVar -> Bool
isCoVar TyVar
tv = (TyVar, Type) -> Maybe (TyVar, Type)
forall a. a -> Maybe a
Just (TyVar
tv, Type
ty)
    go _                            = Maybe (TyVar, Type)
forall a. Maybe a
Nothing

-- | Attempts to take a forall type apart; works with proper foralls and
-- functions
splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type)
splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type)
splitPiTy_maybe ty :: Type
ty = Type -> Maybe (TyCoBinder, Type)
go Type
ty
  where
    go :: Type -> Maybe (TyCoBinder, Type)
go ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (TyCoBinder, Type)
go Type
ty'
    go (ForAllTy bndr :: VarBndr TyVar ArgFlag
bndr ty :: Type
ty) = (TyCoBinder, Type) -> Maybe (TyCoBinder, Type)
forall a. a -> Maybe a
Just (VarBndr TyVar ArgFlag -> TyCoBinder
Named VarBndr TyVar ArgFlag
bndr, Type
ty)
    go (FunTy arg :: Type
arg res :: Type
res)    = (TyCoBinder, Type) -> Maybe (TyCoBinder, Type)
forall a. a -> Maybe a
Just (Type -> TyCoBinder
Anon Type
arg, Type
res)
    go _                  = Maybe (TyCoBinder, Type)
forall a. Maybe a
Nothing

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

-- | Split off all TyCoBinders to a type, splitting both proper foralls
-- and functions
splitPiTys :: Type -> ([TyCoBinder], Type)
splitPiTys :: Type -> ([TyCoBinder], Type)
splitPiTys ty :: Type
ty = Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split Type
ty Type
ty []
  where
    split :: Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split orig_ty :: Type
orig_ty ty :: Type
ty bs :: [TyCoBinder]
bs | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split Type
orig_ty Type
ty' [TyCoBinder]
bs
    split _       (ForAllTy b :: VarBndr TyVar ArgFlag
b res :: Type
res) bs :: [TyCoBinder]
bs = Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split Type
res Type
res (VarBndr TyVar ArgFlag -> TyCoBinder
Named VarBndr TyVar ArgFlag
b  TyCoBinder -> [TyCoBinder] -> [TyCoBinder]
forall a. a -> [a] -> [a]
: [TyCoBinder]
bs)
    split _       (FunTy arg :: Type
arg res :: Type
res)  bs :: [TyCoBinder]
bs = Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split Type
res Type
res (Type -> TyCoBinder
Anon Type
arg TyCoBinder -> [TyCoBinder] -> [TyCoBinder]
forall a. a -> [a] -> [a]
: [TyCoBinder]
bs)
    split orig_ty :: Type
orig_ty _                bs :: [TyCoBinder]
bs = ([TyCoBinder] -> [TyCoBinder]
forall a. [a] -> [a]
reverse [TyCoBinder]
bs, Type
orig_ty)

-- | Like 'splitPiTys' but split off only /named/ binders
--   and returns TyCoVarBinders rather than TyCoBinders
splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type)
splitForAllVarBndrs :: Type -> ([VarBndr TyVar ArgFlag], Type)
splitForAllVarBndrs ty :: Type
ty = Type
-> Type
-> [VarBndr TyVar ArgFlag]
-> ([VarBndr TyVar ArgFlag], Type)
split Type
ty Type
ty []
  where
    split :: Type
-> Type
-> [VarBndr TyVar ArgFlag]
-> ([VarBndr TyVar ArgFlag], Type)
split orig_ty :: Type
orig_ty ty :: Type
ty bs :: [VarBndr TyVar ArgFlag]
bs | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type
-> Type
-> [VarBndr TyVar ArgFlag]
-> ([VarBndr TyVar ArgFlag], Type)
split Type
orig_ty Type
ty' [VarBndr TyVar ArgFlag]
bs
    split _       (ForAllTy b :: VarBndr TyVar ArgFlag
b res :: Type
res) bs :: [VarBndr TyVar ArgFlag]
bs = Type
-> Type
-> [VarBndr TyVar ArgFlag]
-> ([VarBndr TyVar ArgFlag], Type)
split Type
res Type
res (VarBndr TyVar ArgFlag
bVarBndr TyVar ArgFlag
-> [VarBndr TyVar ArgFlag] -> [VarBndr TyVar ArgFlag]
forall a. a -> [a] -> [a]
:[VarBndr TyVar ArgFlag]
bs)
    split orig_ty :: Type
orig_ty _                bs :: [VarBndr TyVar ArgFlag]
bs = ([VarBndr TyVar ArgFlag] -> [VarBndr TyVar ArgFlag]
forall a. [a] -> [a]
reverse [VarBndr TyVar ArgFlag]
bs, Type
orig_ty)
{-# INLINE splitForAllVarBndrs #-}

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 -> Int
invisibleTyBndrCount ty :: Type
ty = [TyCoBinder] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (Type -> ([TyCoBinder], Type)
splitPiTysInvisible Type
ty))

-- Like splitPiTys, but returns only *invisible* binders, including constraints
-- Stops at the first visible binder
splitPiTysInvisible :: Type -> ([TyCoBinder], Type)
splitPiTysInvisible :: Type -> ([TyCoBinder], Type)
splitPiTysInvisible ty :: Type
ty = Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split Type
ty Type
ty []
   where
    split :: Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split orig_ty :: Type
orig_ty ty :: Type
ty bs :: [TyCoBinder]
bs
      | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty  = Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split Type
orig_ty Type
ty' [TyCoBinder]
bs
    split _ (ForAllTy b :: VarBndr TyVar ArgFlag
b res :: Type
res) bs :: [TyCoBinder]
bs
      | Bndr _ vis :: ArgFlag
vis <- VarBndr TyVar ArgFlag
b
      , ArgFlag -> Bool
isInvisibleArgFlag ArgFlag
vis   = Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split Type
res Type
res (VarBndr TyVar ArgFlag -> TyCoBinder
Named VarBndr TyVar ArgFlag
b  TyCoBinder -> [TyCoBinder] -> [TyCoBinder]
forall a. a -> [a] -> [a]
: [TyCoBinder]
bs)
    split _ (FunTy arg :: Type
arg res :: Type
res)  bs :: [TyCoBinder]
bs
      | Type -> Bool
isPredTy Type
arg             = Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split Type
res Type
res (Type -> TyCoBinder
Anon Type
arg TyCoBinder -> [TyCoBinder] -> [TyCoBinder]
forall a. a -> [a] -> [a]
: [TyCoBinder]
bs)
    split orig_ty :: Type
orig_ty _          bs :: [TyCoBinder]
bs  = ([TyCoBinder] -> [TyCoBinder]
forall a. [a] -> [a]
reverse [TyCoBinder]
bs, Type
orig_ty)

splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type)
-- Same as splitPiTysInvisible, but stop when
--   - you have found 'n' TyCoBinders,
--   - or you run out of invisible binders
splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type)
splitPiTysInvisibleN n :: Int
n ty :: Type
ty = Int -> Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
forall a.
(Eq a, Num a) =>
a -> Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split Int
n Type
ty Type
ty []
   where
    split :: a -> Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split n :: a
n orig_ty :: Type
orig_ty ty :: Type
ty bs :: [TyCoBinder]
bs
      | a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0                  = ([TyCoBinder] -> [TyCoBinder]
forall a. [a] -> [a]
reverse [TyCoBinder]
bs, Type
orig_ty)
      | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = a -> Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split a
n Type
orig_ty Type
ty' [TyCoBinder]
bs
      | ForAllTy b :: VarBndr TyVar ArgFlag
b res :: Type
res <- Type
ty
      , Bndr _ vis :: ArgFlag
vis <- VarBndr TyVar ArgFlag
b
      , ArgFlag -> Bool
isInvisibleArgFlag ArgFlag
vis  = a -> Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split (a
na -> a -> a
forall a. Num a => a -> a -> a
-1) Type
res Type
res (VarBndr TyVar ArgFlag -> TyCoBinder
Named VarBndr TyVar ArgFlag
b  TyCoBinder -> [TyCoBinder] -> [TyCoBinder]
forall a. a -> [a] -> [a]
: [TyCoBinder]
bs)
      | FunTy arg :: Type
arg res :: Type
res <- Type
ty
      , Type -> Bool
isPredTy Type
arg            = a -> Type -> Type -> [TyCoBinder] -> ([TyCoBinder], Type)
split (a
na -> a -> a
forall a. Num a => a -> a -> a
-1) Type
res Type
res (Type -> TyCoBinder
Anon Type
arg TyCoBinder -> [TyCoBinder] -> [TyCoBinder]
forall a. a -> [a] -> [a]
: [TyCoBinder]
bs)
      | Bool
otherwise               = ([TyCoBinder] -> [TyCoBinder]
forall a. [a] -> [a]
reverse [TyCoBinder]
bs, Type
orig_ty)

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

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

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

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

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

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

-- | Given a function kind and a list of argument types (where each argument's
-- kind aligns with the corresponding position in the argument kind), determine
-- each argument's visibility ('Inferred', 'Specified', or 'Required').
fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag]
fun_kind_arg_flags :: Type -> [Type] -> [ArgFlag]
fun_kind_arg_flags = TCvSubst -> Type -> [Type] -> [ArgFlag]
go TCvSubst
emptyTCvSubst
  where
    go :: TCvSubst -> Type -> [Type] -> [ArgFlag]
go subst :: TCvSubst
subst ki :: Type
ki arg_tys :: [Type]
arg_tys
      | Just ki' :: Type
ki' <- Type -> Maybe Type
coreView Type
ki = TCvSubst -> Type -> [Type] -> [ArgFlag]
go TCvSubst
subst Type
ki' [Type]
arg_tys
    go _ _ [] = []
    go subst :: TCvSubst
subst (ForAllTy (Bndr tv :: TyVar
tv argf :: ArgFlag
argf) res_ki :: Type
res_ki) (arg_ty :: Type
arg_ty:arg_tys :: [Type]
arg_tys)
      = ArgFlag
argf ArgFlag -> [ArgFlag] -> [ArgFlag]
forall a. a -> [a] -> [a]
: TCvSubst -> Type -> [Type] -> [ArgFlag]
go TCvSubst
subst' Type
res_ki [Type]
arg_tys
      where
        subst' :: TCvSubst
subst' = TCvSubst -> TyVar -> Type -> TCvSubst
extendTvSubst TCvSubst
subst TyVar
tv Type
arg_ty
    go subst :: TCvSubst
subst (TyVarTy tv :: TyVar
tv) arg_tys :: [Type]
arg_tys
      | Just ki :: Type
ki <- TCvSubst -> TyVar -> Maybe Type
lookupTyVar TCvSubst
subst TyVar
tv = TCvSubst -> Type -> [Type] -> [ArgFlag]
go TCvSubst
subst Type
ki [Type]
arg_tys
    go _ _ arg_tys :: [Type]
arg_tys = (Type -> ArgFlag) -> [Type] -> [ArgFlag]
forall a b. (a -> b) -> [a] -> [b]
map (ArgFlag -> Type -> ArgFlag
forall a b. a -> b -> a
const ArgFlag
Required) [Type]
arg_tys
                        -- something is ill-kinded. But this can happen
                        -- when printing errors. Assume everything is Required.

-- @isTauTy@ tests if a type has no foralls
isTauTy :: Type -> Bool
isTauTy :: Type -> Bool
isTauTy ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isTauTy Type
ty'
isTauTy (TyVarTy _)           = Bool
True
isTauTy (LitTy {})            = Bool
True
isTauTy (TyConApp tc :: TyCon
tc tys :: [Type]
tys)     = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTauTy [Type]
tys Bool -> Bool -> Bool
&& TyCon -> Bool
isTauTyCon TyCon
tc
isTauTy (AppTy a :: Type
a b :: Type
b)           = Type -> Bool
isTauTy Type
a Bool -> Bool -> Bool
&& Type -> Bool
isTauTy Type
b
isTauTy (FunTy a :: Type
a b :: Type
b)           = Type -> Bool
isTauTy Type
a Bool -> Bool -> Bool
&& Type -> Bool
isTauTy Type
b
isTauTy (ForAllTy {})         = Bool
False
isTauTy (CastTy ty :: Type
ty _)         = Type -> Bool
isTauTy Type
ty
isTauTy (CoercionTy _)        = Bool
False  -- Not sure about this

{-
%************************************************************************
%*                                                                      *
   TyCoBinders
%*                                                                      *
%************************************************************************
-}

-- | Make an anonymous binder
mkAnonBinder :: Type -> TyCoBinder
mkAnonBinder :: Type -> TyCoBinder
mkAnonBinder = Type -> TyCoBinder
Anon

-- | Does this binder bind a variable that is /not/ erased? Returns
-- 'True' for anonymous binders.
isAnonTyCoBinder :: TyCoBinder -> Bool
isAnonTyCoBinder :: TyCoBinder -> Bool
isAnonTyCoBinder (Named {}) = Bool
False
isAnonTyCoBinder (Anon {})  = Bool
True

tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar
tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyVar
tyCoBinderVar_maybe (Named tv :: VarBndr TyVar ArgFlag
tv) = TyVar -> Maybe TyVar
forall a. a -> Maybe a
Just (TyVar -> Maybe TyVar) -> TyVar -> Maybe TyVar
forall a b. (a -> b) -> a -> b
$ VarBndr TyVar ArgFlag -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar VarBndr TyVar ArgFlag
tv
tyCoBinderVar_maybe _          = Maybe TyVar
forall a. Maybe a
Nothing

tyCoBinderType :: TyCoBinder -> Type
-- Barely used
tyCoBinderType :: TyCoBinder -> Type
tyCoBinderType (Named tvb :: VarBndr TyVar ArgFlag
tvb) = VarBndr TyVar ArgFlag -> Type
forall argf. VarBndr TyVar argf -> Type
binderType VarBndr TyVar ArgFlag
tvb
tyCoBinderType (Anon ty :: Type
ty)   = Type
ty

tyBinderType :: TyBinder -> Type
tyBinderType :: TyCoBinder -> Type
tyBinderType (Named (Bndr tv :: TyVar
tv _))
  = ASSERT( isTyVar tv )
    TyVar -> Type
tyVarKind TyVar
tv
tyBinderType (Anon ty :: Type
ty)   = Type
ty

-- | Extract a relevant type, if there is one.
binderRelevantType_maybe :: TyCoBinder -> Maybe Type
binderRelevantType_maybe :: TyCoBinder -> Maybe Type
binderRelevantType_maybe (Named {}) = Maybe Type
forall a. Maybe a
Nothing
binderRelevantType_maybe (Anon ty :: Type
ty)  = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty

-- | Like 'maybe', but for binders.
caseBinder :: TyCoBinder           -- ^ binder to scrutinize
           -> (TyCoVarBinder -> a) -- ^ named case
           -> (Type -> a)          -- ^ anonymous case
           -> a
caseBinder :: TyCoBinder -> (VarBndr TyVar ArgFlag -> a) -> (Type -> a) -> a
caseBinder (Named v :: VarBndr TyVar ArgFlag
v) f :: VarBndr TyVar ArgFlag -> a
f _ = VarBndr TyVar ArgFlag -> a
f VarBndr TyVar ArgFlag
v
caseBinder (Anon t :: Type
t)  _ d :: Type -> a
d = Type -> a
d Type
t


{-
%************************************************************************
%*                                                                      *
                         Pred
*                                                                      *
************************************************************************

Predicates on PredType

Note [Types for coercions, predicates, and evidence]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We treat differently:

  (a) Predicate types
        Test: isPredTy
        Binders: DictIds
        Kind: Constraint
        Examples: (Eq a), and (a ~ b)

  (b) Coercion types are primitive, unboxed equalities
        Test: isCoVarTy
        Binders: CoVars (can appear in coercions)
        Kind: TYPE (TupleRep [])
        Examples: (t1 ~# t2) or (t1 ~R# t2)

  (c) Evidence types is the type of evidence manipulated by
      the type constraint solver.
        Test: isEvVarType
        Binders: EvVars
        Kind: Constraint or TYPE (TupleRep [])
        Examples: all coercion types and predicate types

Coercion types and predicate types are mutually exclusive,
but evidence types are a superset of both.

When treated as a user type, predicates are invisible and are
implicitly instantiated; but coercion types, and non-pred evidence
types, are just regular old types.

Note [Evidence for quantified constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The superclass mechanism in TcCanonical.makeSuperClasses risks
taking a quantified constraint like
   (forall a. C a => a ~ b)
and generate superclass evidence
   (forall a. C a => a ~# b)

This is a funny thing: neither isPredTy nor isCoVarType are true
of it.  So we are careful not to generate it in the first place:
see Note [Equality superclasses in quantified constraints]
in TcCanonical.
-}

-- | Split a type constructor application into its type constructor and
-- applied types. Note that this may fail 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@). Consequently, you may need to zonk your
-- type before using this function.
--
-- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'.
tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
-- Defined here to avoid module loops between Unify and TcType.
tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
tcView Type
ty = HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty'
tcSplitTyConApp_maybe ty :: Type
ty                         = HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcRepSplitTyConApp_maybe Type
ty

-- tcIsConstraintKind stuf only makes sense in the typechecker
-- After that Constraint = Type
-- See Note [coreView vs tcView]
-- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh)
tcIsConstraintKind :: Kind -> Bool
tcIsConstraintKind :: Type -> Bool
tcIsConstraintKind ty :: Type
ty
  | Just (tc :: TyCon
tc, args :: [Type]
args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty    -- Note: tcSplit here
  , TyCon -> Bool
isConstraintKindCon TyCon
tc
  = ASSERT2( null args, ppr ty ) True

  | Bool
otherwise
  = Bool
False

-- | Is this kind equivalent to @*@?
--
-- This considers 'Constraint' to be distinct from @*@. For a version that
-- treats them as the same type, see 'isLiftedTypeKind'.
tcIsLiftedTypeKind :: Kind -> Bool
tcIsLiftedTypeKind :: Type -> Bool
tcIsLiftedTypeKind ty :: Type
ty
  | Just (tc :: TyCon
tc, [arg :: Type
arg]) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty    -- Note: tcSplit here
  , TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tYPETyConKey
  = Type -> Bool
isLiftedRuntimeRep Type
arg
  | Bool
otherwise
  = Bool
False

tcReturnsConstraintKind :: Kind -> Bool
-- True <=> the Kind ultimately returns a Constraint
--   E.g.  * -> Constraint
--         forall k. k -> Constraint
tcReturnsConstraintKind :: Type -> Bool
tcReturnsConstraintKind kind :: Type
kind
  | Just kind' :: Type
kind' <- Type -> Maybe Type
tcView Type
kind = Type -> Bool
tcReturnsConstraintKind Type
kind'
tcReturnsConstraintKind (ForAllTy _ ty :: Type
ty) = Type -> Bool
tcReturnsConstraintKind Type
ty
tcReturnsConstraintKind (FunTy    _ ty :: Type
ty) = Type -> Bool
tcReturnsConstraintKind Type
ty
tcReturnsConstraintKind (TyConApp tc :: TyCon
tc _) = TyCon -> Bool
isConstraintKindCon TyCon
tc
tcReturnsConstraintKind _               = Bool
False

isEvVarType :: Type -> Bool
-- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b)
--         (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2)
-- See Note [Types for coercions, predicates, and evidence]
-- See Note [Evidence for quantified constraints]
isEvVarType :: Type -> Bool
isEvVarType ty :: Type
ty = Type -> Bool
isCoVarType Type
ty Bool -> Bool -> Bool
|| Type -> Bool
isPredTy Type
ty

-- | Does this type classify a core (unlifted) Coercion?
-- At either role nominal or representational
--    (t1 ~# t2) or (t1 ~R# t2)
-- See Note [Types for coercions, predicates, and evidence]
isCoVarType :: Type -> Bool
isCoVarType :: Type -> Bool
isCoVarType ty :: Type
ty
  | Just (tc :: TyCon
tc,tys :: [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  , (TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqPrimTyConKey) Bool -> Bool -> Bool
|| (TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqReprPrimTyConKey)
  , [Type]
tys [Type] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` 4
  = Bool
True
isCoVarType _ = Bool
False

isClassPred, isEqPred, isNomEqPred, isIPPred :: PredType -> Bool
isClassPred :: Type -> Bool
isClassPred ty :: Type
ty = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
    Just tyCon :: TyCon
tyCon | TyCon -> Bool
isClassTyCon TyCon
tyCon -> Bool
True
    _                               -> Bool
False
isEqPred :: Type -> Bool
isEqPred ty :: Type
ty = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
    Just tyCon :: TyCon
tyCon -> TyCon
tyCon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqPrimTyConKey
               Bool -> Bool -> Bool
|| TyCon
tyCon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqReprPrimTyConKey
    _          -> Bool
False

isNomEqPred :: Type -> Bool
isNomEqPred ty :: Type
ty = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
    Just tyCon :: TyCon
tyCon -> TyCon
tyCon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqPrimTyConKey
    _          -> Bool
False

isIPPred :: Type -> Bool
isIPPred ty :: Type
ty = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
    Just tc :: TyCon
tc -> TyCon -> Bool
isIPTyCon TyCon
tc
    _       -> Bool
False

isIPTyCon :: TyCon -> Bool
isIPTyCon :: TyCon -> Bool
isIPTyCon tc :: TyCon
tc = TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ipClassKey
  -- Class and its corresponding TyCon have the same Unique

isIPClass :: Class -> Bool
isIPClass :: Class -> Bool
isIPClass cls :: Class
cls = Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ipClassKey

isCTupleClass :: Class -> Bool
isCTupleClass :: Class -> Bool
isCTupleClass cls :: Class
cls = TyCon -> Bool
isTupleTyCon (Class -> TyCon
classTyCon Class
cls)

isIPPred_maybe :: Type -> Maybe (FastString, Type)
isIPPred_maybe :: Type -> Maybe (FastString, Type)
isIPPred_maybe ty :: Type
ty =
  do (tc :: TyCon
tc,[t1 :: Type
t1,t2 :: Type
t2]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
     Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyCon -> Bool
isIPTyCon TyCon
tc)
     FastString
x <- Type -> Maybe FastString
isStrLitTy Type
t1
     (FastString, Type) -> Maybe (FastString, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString
x,Type
t2)

{-
Make PredTypes

--------------------- Equality types ---------------------------------
-}

-- | Makes a lifted equality predicate at the given role
mkPrimEqPredRole :: Role -> Type -> Type -> PredType
mkPrimEqPredRole :: Role -> Type -> Type -> Type
mkPrimEqPredRole Nominal          = Type -> Type -> Type
mkPrimEqPred
mkPrimEqPredRole Representational = Type -> Type -> Type
mkReprPrimEqPred
mkPrimEqPredRole Phantom          = String -> Type -> Type -> Type
forall a. String -> a
panic "mkPrimEqPredRole phantom"

-- | Creates a primitive type equality predicate.
-- Invariant: the types are not Coercions
mkPrimEqPred :: Type -> Type -> Type
mkPrimEqPred :: Type -> Type -> Type
mkPrimEqPred ty1 :: Type
ty1 ty2 :: Type
ty2
  = TyCon -> [Type] -> Type
TyConApp TyCon
eqPrimTyCon [Type
k1, Type
k2, Type
ty1, Type
ty2]
  where
    k1 :: Type
k1 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty1
    k2 :: Type
k2 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty2

-- | Creates a primite type equality predicate with explicit kinds
mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type
mkHeteroPrimEqPred :: Type -> Type -> Type -> Type -> Type
mkHeteroPrimEqPred k1 :: Type
k1 k2 :: Type
k2 ty1 :: Type
ty1 ty2 :: Type
ty2 = TyCon -> [Type] -> Type
TyConApp TyCon
eqPrimTyCon [Type
k1, Type
k2, Type
ty1, Type
ty2]

-- | Creates a primitive representational type equality predicate
-- with explicit kinds
mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type
mkHeteroReprPrimEqPred :: Type -> Type -> Type -> Type -> Type
mkHeteroReprPrimEqPred k1 :: Type
k1 k2 :: Type
k2 ty1 :: Type
ty1 ty2 :: Type
ty2
  = TyCon -> [Type] -> Type
TyConApp TyCon
eqReprPrimTyCon [Type
k1, Type
k2, Type
ty1, Type
ty2]

-- | Try to split up a coercion type into the types that it coerces
splitCoercionType_maybe :: Type -> Maybe (Type, Type)
splitCoercionType_maybe :: Type -> Maybe (Type, Type)
splitCoercionType_maybe ty :: Type
ty
  = do { (tc :: TyCon
tc, [_, _, ty1 :: Type
ty1, ty2 :: Type
ty2]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
       ; Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqPrimTyConKey Bool -> Bool -> Bool
|| TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqReprPrimTyConKey
       ; (Type, Type) -> Maybe (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty1, Type
ty2) }

mkReprPrimEqPred :: Type -> Type -> Type
mkReprPrimEqPred :: Type -> Type -> Type
mkReprPrimEqPred ty1 :: Type
ty1  ty2 :: Type
ty2
  = TyCon -> [Type] -> Type
TyConApp TyCon
eqReprPrimTyCon [Type
k1, Type
k2, Type
ty1, Type
ty2]
  where
    k1 :: Type
k1 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty1
    k2 :: Type
k2 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty2

equalityTyCon :: Role -> TyCon
equalityTyCon :: Role -> TyCon
equalityTyCon Nominal          = TyCon
eqPrimTyCon
equalityTyCon Representational = TyCon
eqReprPrimTyCon
equalityTyCon Phantom          = TyCon
eqPhantPrimTyCon

-- --------------------- Dictionary types ---------------------------------

mkClassPred :: Class -> [Type] -> PredType
mkClassPred :: Class -> [Type] -> Type
mkClassPred clas :: Class
clas tys :: [Type]
tys = TyCon -> [Type] -> Type
TyConApp (Class -> TyCon
classTyCon Class
clas) [Type]
tys

isDictTy :: Type -> Bool
isDictTy :: Type -> Bool
isDictTy = Type -> Bool
isClassPred

isDictLikeTy :: Type -> Bool
-- Note [Dictionary-like types]
isDictLikeTy :: Type -> Bool
isDictLikeTy ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isDictLikeTy Type
ty'
isDictLikeTy ty :: Type
ty = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
        Just (tc :: TyCon
tc, tys :: [Type]
tys) | TyCon -> Bool
isClassTyCon TyCon
tc -> Bool
True
                       | TyCon -> Bool
isTupleTyCon TyCon
tc -> (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isDictLikeTy [Type]
tys
        _other :: Maybe (TyCon, [Type])
_other                           -> Bool
False

{-
Note [Dictionary-like types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Being "dictionary-like" means either a dictionary type or a tuple thereof.
In GHC 6.10 we build implication constraints which construct such tuples,
and if we land up with a binding
    t :: (C [a], Eq [a])
    t = blah
then we want to treat t as cheap under "-fdicts-cheap" for example.
(Implication constraints are normally inlined, but sadly not if the
occurrence is itself inside an INLINE function!  Until we revise the
handling of implication constraints, that is.)  This turned out to
be important in getting good arities in DPH code.  Example:

    class C a
    class D a where { foo :: a -> a }
    instance C a => D (Maybe a) where { foo x = x }

    bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
    {-# INLINE bar #-}
    bar x y = (foo (Just x), foo (Just y))

Then 'bar' should jolly well have arity 4 (two dicts, two args), but
we ended up with something like
   bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
                                in \x,y. <blah>)

This is all a bit ad-hoc; eg it relies on knowing that implication
constraints build tuples.


Decomposing PredType
-}

-- | A choice of equality relation. This is separate from the type 'Role'
-- because 'Phantom' does not define a (non-trivial) equality relation.
data EqRel = NomEq | ReprEq
  deriving (EqRel -> EqRel -> Bool
(EqRel -> EqRel -> Bool) -> (EqRel -> EqRel -> Bool) -> Eq EqRel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EqRel -> EqRel -> Bool
$c/= :: EqRel -> EqRel -> Bool
== :: EqRel -> EqRel -> Bool
$c== :: EqRel -> EqRel -> Bool
Eq, Eq EqRel
Eq EqRel =>
(EqRel -> EqRel -> Ordering)
-> (EqRel -> EqRel -> Bool)
-> (EqRel -> EqRel -> Bool)
-> (EqRel -> EqRel -> Bool)
-> (EqRel -> EqRel -> Bool)
-> (EqRel -> EqRel -> EqRel)
-> (EqRel -> EqRel -> EqRel)
-> Ord EqRel
EqRel -> EqRel -> Bool
EqRel -> EqRel -> Ordering
EqRel -> EqRel -> EqRel
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EqRel -> EqRel -> EqRel
$cmin :: EqRel -> EqRel -> EqRel
max :: EqRel -> EqRel -> EqRel
$cmax :: EqRel -> EqRel -> EqRel
>= :: EqRel -> EqRel -> Bool
$c>= :: EqRel -> EqRel -> Bool
> :: EqRel -> EqRel -> Bool
$c> :: EqRel -> EqRel -> Bool
<= :: EqRel -> EqRel -> Bool
$c<= :: EqRel -> EqRel -> Bool
< :: EqRel -> EqRel -> Bool
$c< :: EqRel -> EqRel -> Bool
compare :: EqRel -> EqRel -> Ordering
$ccompare :: EqRel -> EqRel -> Ordering
$cp1Ord :: Eq EqRel
Ord)

instance Outputable EqRel where
  ppr :: EqRel -> SDoc
ppr NomEq  = String -> SDoc
text "nominal equality"
  ppr ReprEq = String -> SDoc
text "representational equality"

eqRelRole :: EqRel -> Role
eqRelRole :: EqRel -> Role
eqRelRole NomEq  = Role
Nominal
eqRelRole ReprEq = Role
Representational

data PredTree
  = ClassPred Class [Type]
  | EqPred EqRel Type Type
  | IrredPred PredType
  | ForAllPred [TyCoVarBinder] [PredType] PredType
     -- ForAllPred: see Note [Quantified constraints] in TcCanonical
  -- NB: There is no TuplePred case
  --     Tuple predicates like (Eq a, Ord b) are just treated
  --     as ClassPred, as if we had a tuple class with two superclasses
  --        class (c1, c2) => (%,%) c1 c2

classifyPredType :: PredType -> PredTree
classifyPredType :: Type -> PredTree
classifyPredType ev_ty :: Type
ev_ty = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ev_ty of
    Just (tc :: TyCon
tc, [_, _, ty1 :: Type
ty1, ty2 :: Type
ty2])
      | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqReprPrimTyConKey -> EqRel -> Type -> Type -> PredTree
EqPred EqRel
ReprEq Type
ty1 Type
ty2
      | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqPrimTyConKey     -> EqRel -> Type -> Type -> PredTree
EqPred EqRel
NomEq Type
ty1 Type
ty2

    Just (tc :: TyCon
tc, tys :: [Type]
tys)
      | Just clas :: Class
clas <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc
      -> Class -> [Type] -> PredTree
ClassPred Class
clas [Type]
tys

    _ | (tvs :: [VarBndr TyVar ArgFlag]
tvs, rho :: Type
rho) <- Type -> ([VarBndr TyVar ArgFlag], Type)
splitForAllVarBndrs Type
ev_ty
      , (theta :: [Type]
theta, pred :: Type
pred) <- Type -> ([Type], Type)
splitFunTys Type
rho
      , Bool -> Bool
not ([VarBndr TyVar ArgFlag] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VarBndr TyVar ArgFlag]
tvs Bool -> Bool -> Bool
&& [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta)
      -> [VarBndr TyVar ArgFlag] -> [Type] -> Type -> PredTree
ForAllPred [VarBndr TyVar ArgFlag]
tvs [Type]
theta Type
pred

      | Bool
otherwise
      -> Type -> PredTree
IrredPred Type
ev_ty

getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
getClassPredTys :: Type -> (Class, [Type])
getClassPredTys ty :: Type
ty = case Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
ty of
        Just (clas :: Class
clas, tys :: [Type]
tys) -> (Class
clas, [Type]
tys)
        Nothing          -> String -> SDoc -> (Class, [Type])
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getClassPredTys" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
getClassPredTys_maybe :: Type -> Maybe (Class, [Type])
getClassPredTys_maybe ty :: Type
ty = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
        Just (tc :: TyCon
tc, tys :: [Type]
tys) | Just clas :: Class
clas <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc -> (Class, [Type]) -> Maybe (Class, [Type])
forall a. a -> Maybe a
Just (Class
clas, [Type]
tys)
        _ -> Maybe (Class, [Type])
forall a. Maybe a
Nothing

getEqPredTys :: PredType -> (Type, Type)
getEqPredTys :: Type -> (Type, Type)
getEqPredTys ty :: Type
ty
  = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
      Just (tc :: TyCon
tc, [_, _, ty1 :: Type
ty1, ty2 :: Type
ty2])
        |  TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqPrimTyConKey
        Bool -> Bool -> Bool
|| TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqReprPrimTyConKey
        -> (Type
ty1, Type
ty2)
      _ -> String -> SDoc -> (Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getEqPredTys" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type)
getEqPredTys_maybe :: Type -> Maybe (Role, Type, Type)
getEqPredTys_maybe ty :: Type
ty
  = case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
      Just (tc :: TyCon
tc, [_, _, ty1 :: Type
ty1, ty2 :: Type
ty2])
        | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqPrimTyConKey     -> (Role, Type, Type) -> Maybe (Role, Type, Type)
forall a. a -> Maybe a
Just (Role
Nominal, Type
ty1, Type
ty2)
        | TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqReprPrimTyConKey -> (Role, Type, Type) -> Maybe (Role, Type, Type)
forall a. a -> Maybe a
Just (Role
Representational, Type
ty1, Type
ty2)
      _ -> Maybe (Role, Type, Type)
forall a. Maybe a
Nothing

getEqPredRole :: PredType -> Role
getEqPredRole :: Type -> Role
getEqPredRole ty :: Type
ty = EqRel -> Role
eqRelRole (Type -> EqRel
predTypeEqRel Type
ty)

-- | Get the equality relation relevant for a pred type.
predTypeEqRel :: PredType -> EqRel
predTypeEqRel :: Type -> EqRel
predTypeEqRel ty :: Type
ty
  | Just (tc :: TyCon
tc, _) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  , TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqReprPrimTyConKey
  = EqRel
ReprEq
  | Bool
otherwise
  = EqRel
NomEq

{-
%************************************************************************
%*                                                                      *
         Well-scoped tyvars
*                                                                      *
************************************************************************

Note [ScopedSort]
~~~~~~~~~~~~~~~~~
Consider

  foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> ()

This function type is implicitly generalised over [a, b, k, k2]. These
variables will be Specified; that is, they will be available for visible
type application. This is because they are written in the type signature
by the user.

However, we must ask: what order will they appear in? In cases without
dependency, this is easy: we just use the lexical left-to-right ordering
of first occurrence. With dependency, we cannot get off the hook so
easily.

We thus state:

 * These variables appear in the order as given by ScopedSort, where
   the input to ScopedSort is the left-to-right order of first occurrence.

Note that this applies only to *implicit* quantification, without a
`forall`. If the user writes a `forall`, then we just use the order given.

ScopedSort is defined thusly (as proposed in #15743):
  * Work left-to-right through the input list, with a cursor.
  * If variable v at the cursor is depended on by any earlier variable w,
    move v immediately before the leftmost such w.

INVARIANT: The prefix of variables before the cursor form a valid telescope.

Note that ScopedSort makes sense only after type inference is done and all
types/kinds are fully settled and zonked.

-}

-- | Do a topological sort on a list of tyvars,
--   so that binders occur before occurrences
-- E.g. given  [ a::k, k::*, b::k ]
-- it'll return a well-scoped list [ k::*, a::k, b::k ]
--
-- This is a deterministic sorting operation
-- (that is, doesn't depend on Uniques).
--
-- It is also meant to be stable: that is, variables should not
-- be reordered unnecessarily. This is specified in Note [ScopedSort]
-- See also Note [Ordering of implicit variables] in RnTypes

scopedSort :: [TyCoVar] -> [TyCoVar]
scopedSort :: [TyVar] -> [TyVar]
scopedSort = [TyVar] -> [VarSet] -> [TyVar] -> [TyVar]
go [] []
  where
    go :: [TyCoVar] -- already sorted, in reverse order
       -> [TyCoVarSet] -- each set contains all the variables which must be placed
                       -- before the tv corresponding to the set; they are accumulations
                       -- of the fvs in the sorted tvs' kinds

                       -- This list is in 1-to-1 correspondence with the sorted tyvars
                       -- INVARIANT:
                       --   all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list)
                       -- That is, each set in the list is a superset of all later sets.

       -> [TyCoVar] -- yet to be sorted
       -> [TyCoVar]
    go :: [TyVar] -> [VarSet] -> [TyVar] -> [TyVar]
go acc :: [TyVar]
acc _fv_list :: [VarSet]
_fv_list [] = [TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
acc
    go acc :: [TyVar]
acc  fv_list :: [VarSet]
fv_list (tv :: TyVar
tv:tvs :: [TyVar]
tvs)
      = [TyVar] -> [VarSet] -> [TyVar] -> [TyVar]
go [TyVar]
acc' [VarSet]
fv_list' [TyVar]
tvs
      where
        (acc' :: [TyVar]
acc', fv_list' :: [VarSet]
fv_list') = TyVar -> [TyVar] -> [VarSet] -> ([TyVar], [VarSet])
insert TyVar
tv [TyVar]
acc [VarSet]
fv_list

    insert :: TyCoVar       -- var to insert
           -> [TyCoVar]     -- sorted list, in reverse order
           -> [TyCoVarSet]  -- list of fvs, as above
           -> ([TyCoVar], [TyCoVarSet])   -- augmented lists
    insert :: TyVar -> [TyVar] -> [VarSet] -> ([TyVar], [VarSet])
insert tv :: TyVar
tv []     []         = ([TyVar
tv], [Type -> VarSet
tyCoVarsOfType (TyVar -> Type
tyVarKind TyVar
tv)])
    insert tv :: TyVar
tv (a :: TyVar
a:as :: [TyVar]
as) (fvs :: VarSet
fvs:fvss :: [VarSet]
fvss)
      | TyVar
tv TyVar -> VarSet -> Bool
`elemVarSet` VarSet
fvs
      , (as' :: [TyVar]
as', fvss' :: [VarSet]
fvss') <- TyVar -> [TyVar] -> [VarSet] -> ([TyVar], [VarSet])
insert TyVar
tv [TyVar]
as [VarSet]
fvss
      = (TyVar
aTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
as', VarSet
fvs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
fv_tv VarSet -> [VarSet] -> [VarSet]
forall a. a -> [a] -> [a]
: [VarSet]
fvss')

      | Bool
otherwise
      = (TyVar
tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:TyVar
aTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
as, VarSet
fvs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
fv_tv VarSet -> [VarSet] -> [VarSet]
forall a. a -> [a] -> [a]
: VarSet
fvs VarSet -> [VarSet] -> [VarSet]
forall a. a -> [a] -> [a]
: [VarSet]
fvss)
      where
        fv_tv :: VarSet
fv_tv = Type -> VarSet
tyCoVarsOfType (TyVar -> Type
tyVarKind TyVar
tv)

       -- lists not in correspondence
    insert _ _ _ = String -> ([TyVar], [VarSet])
forall a. String -> a
panic "scopedSort"

-- | Extract a well-scoped list of variables from a deterministic set of
-- variables. The result is deterministic.
-- NB: There used to exist varSetElemsWellScoped :: VarSet -> [Var] which
-- took a non-deterministic set and produced a non-deterministic
-- well-scoped list. If you care about the list being well-scoped you also
-- most likely care about it being in deterministic order.
dVarSetElemsWellScoped :: DVarSet -> [Var]
dVarSetElemsWellScoped :: DVarSet -> [TyVar]
dVarSetElemsWellScoped = [TyVar] -> [TyVar]
scopedSort ([TyVar] -> [TyVar]) -> (DVarSet -> [TyVar]) -> DVarSet -> [TyVar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DVarSet -> [TyVar]
dVarSetElems

-- | Get the free vars of a type in scoped order
tyCoVarsOfTypeWellScoped :: Type -> [TyVar]
tyCoVarsOfTypeWellScoped :: Type -> [TyVar]
tyCoVarsOfTypeWellScoped = [TyVar] -> [TyVar]
scopedSort ([TyVar] -> [TyVar]) -> (Type -> [TyVar]) -> Type -> [TyVar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [TyVar]
tyCoVarsOfTypeList

-- | Get the free vars of types in scoped order
tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]
tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]
tyCoVarsOfTypesWellScoped = [TyVar] -> [TyVar]
scopedSort ([TyVar] -> [TyVar]) -> ([Type] -> [TyVar]) -> [Type] -> [TyVar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> [TyVar]
tyCoVarsOfTypesList

-- | Given the suffix of a telescope, returns the prefix.
-- Ex: given [(k :: j), (a :: Proxy k)], returns [(j :: *)].
tyCoVarsOfBindersWellScoped :: [TyVar] -> [TyVar]
tyCoVarsOfBindersWellScoped :: [TyVar] -> [TyVar]
tyCoVarsOfBindersWellScoped tvs :: [TyVar]
tvs
  = Type -> [TyVar]
tyCoVarsOfTypeWellScoped ([TyVar] -> Type -> Type
mkInvForAllTys [TyVar]
tvs Type
unitTy)

------------- Closing over kinds -----------------

-- | Add the kind variables free in the kinds of the tyvars in the given set.
-- Returns a non-deterministic set.
closeOverKinds :: TyVarSet -> TyVarSet
closeOverKinds :: VarSet -> VarSet
closeOverKinds = FV -> VarSet
fvVarSet (FV -> VarSet) -> (VarSet -> FV) -> VarSet -> VarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVar] -> FV
closeOverKindsFV ([TyVar] -> FV) -> (VarSet -> [TyVar]) -> VarSet -> FV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarSet -> [TyVar]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet
  -- It's OK to use nonDetEltsUniqSet here because we immediately forget
  -- about the ordering by returning a set.

-- | Given a list of tyvars returns a deterministic FV computation that
-- returns the given tyvars with the kind variables free in the kinds of the
-- given tyvars.
closeOverKindsFV :: [TyVar] -> FV
closeOverKindsFV :: [TyVar] -> FV
closeOverKindsFV tvs :: [TyVar]
tvs =
  (TyVar -> FV) -> [TyVar] -> FV
forall a. (a -> FV) -> [a] -> FV
mapUnionFV (Type -> FV
tyCoFVsOfType (Type -> FV) -> (TyVar -> Type) -> TyVar -> FV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Type
tyVarKind) [TyVar]
tvs FV -> FV -> FV
`unionFV` [TyVar] -> FV
mkFVs [TyVar]
tvs

-- | Add the kind variables free in the kinds of the tyvars in the given set.
-- Returns a deterministically ordered list.
closeOverKindsList :: [TyVar] -> [TyVar]
closeOverKindsList :: [TyVar] -> [TyVar]
closeOverKindsList tvs :: [TyVar]
tvs = FV -> [TyVar]
fvVarList (FV -> [TyVar]) -> FV -> [TyVar]
forall a b. (a -> b) -> a -> b
$ [TyVar] -> FV
closeOverKindsFV [TyVar]
tvs

-- | Add the kind variables free in the kinds of the tyvars in the given set.
-- Returns a deterministic set.
closeOverKindsDSet :: DTyVarSet -> DTyVarSet
closeOverKindsDSet :: DVarSet -> DVarSet
closeOverKindsDSet = FV -> DVarSet
fvDVarSet (FV -> DVarSet) -> (DVarSet -> FV) -> DVarSet -> DVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVar] -> FV
closeOverKindsFV ([TyVar] -> FV) -> (DVarSet -> [TyVar]) -> DVarSet -> FV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DVarSet -> [TyVar]
dVarSetElems

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

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

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

-- | Pretty prints a 'TyCon', using the family instance in case of a
-- representation tycon.  For example:
--
-- > data T [a] = ...
--
-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
pprSourceTyCon :: TyCon -> SDoc
pprSourceTyCon :: TyCon -> SDoc
pprSourceTyCon tycon :: TyCon
tycon
  | Just (fam_tc :: TyCon
fam_tc, tys :: [Type]
tys) <- TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tycon
  = Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ TyCon
fam_tc TyCon -> [Type] -> Type
`TyConApp` [Type]
tys        -- can't be FunTyCon
  | Bool
otherwise
  = TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon

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

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

-- | Returns Just True if this type is surely lifted, Just False
-- if it is surely unlifted, Nothing if we can't be sure (i.e., it is
-- levity polymorphic), and panics if the kind does not have the shape
-- TYPE r.
isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool
isLiftedType_maybe :: Type -> Maybe Bool
isLiftedType_maybe ty :: Type
ty = Type -> Maybe Bool
go (HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
ty)
  where
    go :: Type -> Maybe Bool
go rr :: Type
rr | Just rr' :: Type
rr' <- Type -> Maybe Type
coreView Type
rr = Type -> Maybe Bool
go Type
rr'
          | Type -> Bool
isLiftedRuntimeRep Type
rr  = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
          | TyConApp {} <- Type
rr      = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False  -- Everything else is unlifted
          | Bool
otherwise              = Maybe Bool
forall a. Maybe a
Nothing     -- levity polymorphic

-- | See "Type#type_classification" for what an unlifted type is.
-- Panics on levity polymorphic types.
isUnliftedType :: HasDebugCallStack => Type -> Bool
        -- isUnliftedType returns True for forall'd unlifted types:
        --      x :: forall a. Int#
        -- I found bindings like these were getting floated to the top level.
        -- They are pretty bogus types, mind you.  It would be better never to
        -- construct them
isUnliftedType :: Type -> Bool
isUnliftedType ty :: Type
ty
  = Bool -> Bool
not (HasDebugCallStack => Type -> Maybe Bool
Type -> Maybe Bool
isLiftedType_maybe Type
ty Maybe Bool -> Bool -> Bool
forall a. Maybe a -> a -> a
`orElse`
         String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic "isUnliftedType" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)))

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

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

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

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

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


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

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

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

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

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

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

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

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

For instance, consider:

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

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

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

and now we can make f' a join point:

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

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


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

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

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

{-
************************************************************************
*                                                                      *
                Comparison for types
        (We don't use instances so that we know where it happens)
*                                                                      *
************************************************************************

Note [Equality on AppTys]
~~~~~~~~~~~~~~~~~~~~~~~~~
In our cast-ignoring equality, we want to say that the following two
are equal:

  (Maybe |> co) (Int |> co')   ~?       Maybe Int

But the left is an AppTy while the right is a TyConApp. The solution is
to use repSplitAppTy_maybe to break up the TyConApp into its pieces and
then continue. Easy to do, but also easy to forget to do.

-}

eqType :: Type -> Type -> Bool
-- ^ Type equality on source types. Does not look through @newtypes@ or
-- 'PredType's, but it does look through type synonyms.
-- This first checks that the kinds of the types are equal and then
-- checks whether the types are equal, ignoring casts and coercions.
-- (The kind check is a recursive call, but since all kinds have type
-- @Type@, there is no need to check the types of kinds.)
-- See also Note [Non-trivial definitional equality] in TyCoRep.
eqType :: Type -> Type -> Bool
eqType t1 :: Type
t1 t2 :: Type
t2 = Ordering -> Bool
isEqual (Ordering -> Bool) -> Ordering -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Ordering
nonDetCmpType Type
t1 Type
t2
  -- It's OK to use nonDetCmpType here and eqType is deterministic,
  -- nonDetCmpType does equality deterministically

-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.
eqTypeX :: RnEnv2 -> Type -> Type -> Bool
eqTypeX :: RnEnv2 -> Type -> Type -> Bool
eqTypeX env :: RnEnv2
env t1 :: Type
t1 t2 :: Type
t2 = Ordering -> Bool
isEqual (Ordering -> Bool) -> Ordering -> Bool
forall a b. (a -> b) -> a -> b
$ RnEnv2 -> Type -> Type -> Ordering
nonDetCmpTypeX RnEnv2
env Type
t1 Type
t2
  -- It's OK to use nonDetCmpType here and eqTypeX is deterministic,
  -- nonDetCmpTypeX does equality deterministically

-- | Type equality on lists of types, looking through type synonyms
-- but not newtypes.
eqTypes :: [Type] -> [Type] -> Bool
eqTypes :: [Type] -> [Type] -> Bool
eqTypes tys1 :: [Type]
tys1 tys2 :: [Type]
tys2 = Ordering -> Bool
isEqual (Ordering -> Bool) -> Ordering -> Bool
forall a b. (a -> b) -> a -> b
$ [Type] -> [Type] -> Ordering
nonDetCmpTypes [Type]
tys1 [Type]
tys2
  -- It's OK to use nonDetCmpType here and eqTypes is deterministic,
  -- nonDetCmpTypes does equality deterministically

eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2
-- Check that the var lists are the same length
-- and have matching kinds; if so, extend the RnEnv2
-- Returns Nothing if they don't match
eqVarBndrs :: RnEnv2 -> [TyVar] -> [TyVar] -> Maybe RnEnv2
eqVarBndrs env :: RnEnv2
env [] []
 = RnEnv2 -> Maybe RnEnv2
forall a. a -> Maybe a
Just RnEnv2
env
eqVarBndrs env :: RnEnv2
env (tv1 :: TyVar
tv1:tvs1 :: [TyVar]
tvs1) (tv2 :: TyVar
tv2:tvs2 :: [TyVar]
tvs2)
 | RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env (TyVar -> Type
varType TyVar
tv1) (TyVar -> Type
varType TyVar
tv2)
 = RnEnv2 -> [TyVar] -> [TyVar] -> Maybe RnEnv2
eqVarBndrs (RnEnv2 -> TyVar -> TyVar -> RnEnv2
rnBndr2 RnEnv2
env TyVar
tv1 TyVar
tv2) [TyVar]
tvs1 [TyVar]
tvs2
eqVarBndrs _ _ _= Maybe RnEnv2
forall a. Maybe a
Nothing

-- Now here comes the real worker

{-
Note [nonDetCmpType nondeterminism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX
uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for
ordering leads to nondeterminism. We hit the same problem in the TyVarTy case,
comparing type variables is nondeterministic, note the call to nonDetCmpVar in
nonDetCmpTypeX.
See Note [Unique Determinism] for more details.
-}

nonDetCmpType :: Type -> Type -> Ordering
nonDetCmpType :: Type -> Type -> Ordering
nonDetCmpType t1 :: Type
t1 t2 :: Type
t2
  -- we know k1 and k2 have the same kind, because they both have kind *.
  = RnEnv2 -> Type -> Type -> Ordering
nonDetCmpTypeX RnEnv2
rn_env Type
t1 Type
t2
  where
    rn_env :: RnEnv2
rn_env = InScopeSet -> RnEnv2
mkRnEnv2 (VarSet -> InScopeSet
mkInScopeSet ([Type] -> VarSet
tyCoVarsOfTypes [Type
t1, Type
t2]))

nonDetCmpTypes :: [Type] -> [Type] -> Ordering
nonDetCmpTypes :: [Type] -> [Type] -> Ordering
nonDetCmpTypes ts1 :: [Type]
ts1 ts2 :: [Type]
ts2 = RnEnv2 -> [Type] -> [Type] -> Ordering
nonDetCmpTypesX RnEnv2
rn_env [Type]
ts1 [Type]
ts2
  where
    rn_env :: RnEnv2
rn_env = InScopeSet -> RnEnv2
mkRnEnv2 (VarSet -> InScopeSet
mkInScopeSet ([Type] -> VarSet
tyCoVarsOfTypes ([Type]
ts1 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
ts2)))

-- | An ordering relation between two 'Type's (known below as @t1 :: k1@
-- and @t2 :: k2@)
data TypeOrdering = TLT  -- ^ @t1 < t2@
                  | TEQ  -- ^ @t1 ~ t2@ and there are no casts in either,
                         -- therefore we can conclude @k1 ~ k2@
                  | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so
                         -- they may differ in kind.
                  | TGT  -- ^ @t1 > t2@
                  deriving (TypeOrdering -> TypeOrdering -> Bool
(TypeOrdering -> TypeOrdering -> Bool)
-> (TypeOrdering -> TypeOrdering -> Bool) -> Eq TypeOrdering
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeOrdering -> TypeOrdering -> Bool
$c/= :: TypeOrdering -> TypeOrdering -> Bool
== :: TypeOrdering -> TypeOrdering -> Bool
$c== :: TypeOrdering -> TypeOrdering -> Bool
Eq, Eq TypeOrdering
Eq TypeOrdering =>
(TypeOrdering -> TypeOrdering -> Ordering)
-> (TypeOrdering -> TypeOrdering -> Bool)
-> (TypeOrdering -> TypeOrdering -> Bool)
-> (TypeOrdering -> TypeOrdering -> Bool)
-> (TypeOrdering -> TypeOrdering -> Bool)
-> (TypeOrdering -> TypeOrdering -> TypeOrdering)
-> (TypeOrdering -> TypeOrdering -> TypeOrdering)
-> Ord TypeOrdering
TypeOrdering -> TypeOrdering -> Bool
TypeOrdering -> TypeOrdering -> Ordering
TypeOrdering -> TypeOrdering -> TypeOrdering
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TypeOrdering -> TypeOrdering -> TypeOrdering
$cmin :: TypeOrdering -> TypeOrdering -> TypeOrdering
max :: TypeOrdering -> TypeOrdering -> TypeOrdering
$cmax :: TypeOrdering -> TypeOrdering -> TypeOrdering
>= :: TypeOrdering -> TypeOrdering -> Bool
$c>= :: TypeOrdering -> TypeOrdering -> Bool
> :: TypeOrdering -> TypeOrdering -> Bool
$c> :: TypeOrdering -> TypeOrdering -> Bool
<= :: TypeOrdering -> TypeOrdering -> Bool
$c<= :: TypeOrdering -> TypeOrdering -> Bool
< :: TypeOrdering -> TypeOrdering -> Bool
$c< :: TypeOrdering -> TypeOrdering -> Bool
compare :: TypeOrdering -> TypeOrdering -> Ordering
$ccompare :: TypeOrdering -> TypeOrdering -> Ordering
$cp1Ord :: Eq TypeOrdering
Ord, Int -> TypeOrdering
TypeOrdering -> Int
TypeOrdering -> [TypeOrdering]
TypeOrdering -> TypeOrdering
TypeOrdering -> TypeOrdering -> [TypeOrdering]
TypeOrdering -> TypeOrdering -> TypeOrdering -> [TypeOrdering]
(TypeOrdering -> TypeOrdering)
-> (TypeOrdering -> TypeOrdering)
-> (Int -> TypeOrdering)
-> (TypeOrdering -> Int)
-> (TypeOrdering -> [TypeOrdering])
-> (TypeOrdering -> TypeOrdering -> [TypeOrdering])
-> (TypeOrdering -> TypeOrdering -> [TypeOrdering])
-> (TypeOrdering -> TypeOrdering -> TypeOrdering -> [TypeOrdering])
-> Enum TypeOrdering
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TypeOrdering -> TypeOrdering -> TypeOrdering -> [TypeOrdering]
$cenumFromThenTo :: TypeOrdering -> TypeOrdering -> TypeOrdering -> [TypeOrdering]
enumFromTo :: TypeOrdering -> TypeOrdering -> [TypeOrdering]
$cenumFromTo :: TypeOrdering -> TypeOrdering -> [TypeOrdering]
enumFromThen :: TypeOrdering -> TypeOrdering -> [TypeOrdering]
$cenumFromThen :: TypeOrdering -> TypeOrdering -> [TypeOrdering]
enumFrom :: TypeOrdering -> [TypeOrdering]
$cenumFrom :: TypeOrdering -> [TypeOrdering]
fromEnum :: TypeOrdering -> Int
$cfromEnum :: TypeOrdering -> Int
toEnum :: Int -> TypeOrdering
$ctoEnum :: Int -> TypeOrdering
pred :: TypeOrdering -> TypeOrdering
$cpred :: TypeOrdering -> TypeOrdering
succ :: TypeOrdering -> TypeOrdering
$csucc :: TypeOrdering -> TypeOrdering
Enum, TypeOrdering
TypeOrdering -> TypeOrdering -> Bounded TypeOrdering
forall a. a -> a -> Bounded a
maxBound :: TypeOrdering
$cmaxBound :: TypeOrdering
minBound :: TypeOrdering
$cminBound :: TypeOrdering
Bounded)

nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering  -- Main workhorse
    -- See Note [Non-trivial definitional equality] in TyCoRep
nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering
nonDetCmpTypeX env :: RnEnv2
env orig_t1 :: Type
orig_t1 orig_t2 :: Type
orig_t2 =
    case RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
orig_t1 Type
orig_t2 of
      -- If there are casts then we also need to do a comparison of the kinds of
      -- the types being compared
      TEQX          -> TypeOrdering -> Ordering
toOrdering (TypeOrdering -> Ordering) -> TypeOrdering -> Ordering
forall a b. (a -> b) -> a -> b
$ RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
k1 Type
k2
      ty_ordering :: TypeOrdering
ty_ordering   -> TypeOrdering -> Ordering
toOrdering TypeOrdering
ty_ordering
  where
    k1 :: Type
k1 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
orig_t1
    k2 :: Type
k2 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
orig_t2

    toOrdering :: TypeOrdering -> Ordering
    toOrdering :: TypeOrdering -> Ordering
toOrdering TLT  = Ordering
LT
    toOrdering TEQ  = Ordering
EQ
    toOrdering TEQX = Ordering
EQ
    toOrdering TGT  = Ordering
GT

    liftOrdering :: Ordering -> TypeOrdering
    liftOrdering :: Ordering -> TypeOrdering
liftOrdering LT = TypeOrdering
TLT
    liftOrdering EQ = TypeOrdering
TEQ
    liftOrdering GT = TypeOrdering
TGT

    thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering
    thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering
thenCmpTy TEQ  rel :: TypeOrdering
rel  = TypeOrdering
rel
    thenCmpTy TEQX rel :: TypeOrdering
rel  = TypeOrdering -> TypeOrdering
hasCast TypeOrdering
rel
    thenCmpTy rel :: TypeOrdering
rel  _    = TypeOrdering
rel

    hasCast :: TypeOrdering -> TypeOrdering
    hasCast :: TypeOrdering -> TypeOrdering
hasCast TEQ = TypeOrdering
TEQX
    hasCast rel :: TypeOrdering
rel = TypeOrdering
rel

    -- Returns both the resulting ordering relation between the two types
    -- and whether either contains a cast.
    go :: RnEnv2 -> Type -> Type -> TypeOrdering
    go :: RnEnv2 -> Type -> Type -> TypeOrdering
go env :: RnEnv2
env t1 :: Type
t1 t2 :: Type
t2
      | Just t1' :: Type
t1' <- Type -> Maybe Type
coreView Type
t1 = RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
t1' Type
t2
      | Just t2' :: Type
t2' <- Type -> Maybe Type
coreView Type
t2 = RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
t1 Type
t2'

    go env :: RnEnv2
env (TyVarTy tv1 :: TyVar
tv1)       (TyVarTy tv2 :: TyVar
tv2)
      = Ordering -> TypeOrdering
liftOrdering (Ordering -> TypeOrdering) -> Ordering -> TypeOrdering
forall a b. (a -> b) -> a -> b
$ RnEnv2 -> TyVar -> TyVar
rnOccL RnEnv2
env TyVar
tv1 TyVar -> TyVar -> Ordering
`nonDetCmpVar` RnEnv2 -> TyVar -> TyVar
rnOccR RnEnv2
env TyVar
tv2
    go env :: RnEnv2
env (ForAllTy (Bndr tv1 :: TyVar
tv1 _) t1 :: Type
t1) (ForAllTy (Bndr tv2 :: TyVar
tv2 _) t2 :: Type
t2)
      = RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env (TyVar -> Type
varType TyVar
tv1) (TyVar -> Type
varType TyVar
tv2)
        TypeOrdering -> TypeOrdering -> TypeOrdering
`thenCmpTy` RnEnv2 -> Type -> Type -> TypeOrdering
go (RnEnv2 -> TyVar -> TyVar -> RnEnv2
rnBndr2 RnEnv2
env TyVar
tv1 TyVar
tv2) Type
t1 Type
t2
        -- See Note [Equality on AppTys]
    go env :: RnEnv2
env (AppTy s1 :: Type
s1 t1 :: Type
t1) ty2 :: Type
ty2
      | Just (s2 :: Type
s2, t2 :: Type
t2) <- HasDebugCallStack => Type -> Maybe (Type, Type)
Type -> Maybe (Type, Type)
repSplitAppTy_maybe Type
ty2
      = RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
s1 Type
s2 TypeOrdering -> TypeOrdering -> TypeOrdering
`thenCmpTy` RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
t1 Type
t2
    go env :: RnEnv2
env ty1 :: Type
ty1 (AppTy s2 :: Type
s2 t2 :: Type
t2)
      | Just (s1 :: Type
s1, t1 :: Type
t1) <- HasDebugCallStack => Type -> Maybe (Type, Type)
Type -> Maybe (Type, Type)
repSplitAppTy_maybe Type
ty1
      = RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
s1 Type
s2 TypeOrdering -> TypeOrdering -> TypeOrdering
`thenCmpTy` RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
t1 Type
t2
    go env :: RnEnv2
env (FunTy s1 :: Type
s1 t1 :: Type
t1) (FunTy s2 :: Type
s2 t2 :: Type
t2)
      = RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
s1 Type
s2 TypeOrdering -> TypeOrdering -> TypeOrdering
`thenCmpTy` RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
t1 Type
t2
    go env :: RnEnv2
env (TyConApp tc1 :: TyCon
tc1 tys1 :: [Type]
tys1) (TyConApp tc2 :: TyCon
tc2 tys2 :: [Type]
tys2)
      = Ordering -> TypeOrdering
liftOrdering (TyCon
tc1 TyCon -> TyCon -> Ordering
`nonDetCmpTc` TyCon
tc2) TypeOrdering -> TypeOrdering -> TypeOrdering
`thenCmpTy` RnEnv2 -> [Type] -> [Type] -> TypeOrdering
gos RnEnv2
env [Type]
tys1 [Type]
tys2
    go _   (LitTy l1 :: TyLit
l1)          (LitTy l2 :: TyLit
l2)          = Ordering -> TypeOrdering
liftOrdering (TyLit -> TyLit -> Ordering
forall a. Ord a => a -> a -> Ordering
compare TyLit
l1 TyLit
l2)
    go env :: RnEnv2
env (CastTy t1 :: Type
t1 _)       t2 :: Type
t2                  = TypeOrdering -> TypeOrdering
hasCast (TypeOrdering -> TypeOrdering) -> TypeOrdering -> TypeOrdering
forall a b. (a -> b) -> a -> b
$ RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
t1 Type
t2
    go env :: RnEnv2
env t1 :: Type
t1                  (CastTy t2 :: Type
t2 _)       = TypeOrdering -> TypeOrdering
hasCast (TypeOrdering -> TypeOrdering) -> TypeOrdering -> TypeOrdering
forall a b. (a -> b) -> a -> b
$ RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
t1 Type
t2

    go _   (CoercionTy {})     (CoercionTy {})     = TypeOrdering
TEQ

        -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy
    go _ ty1 :: Type
ty1 ty2 :: Type
ty2
      = Ordering -> TypeOrdering
liftOrdering (Ordering -> TypeOrdering) -> Ordering -> TypeOrdering
forall a b. (a -> b) -> a -> b
$ (Type -> Int
get_rank Type
ty1) Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (Type -> Int
get_rank Type
ty2)
      where get_rank :: Type -> Int
            get_rank :: Type -> Int
get_rank (CastTy {})
              = String -> SDoc -> Int
forall a. HasCallStack => String -> SDoc -> a
pprPanic "nonDetCmpTypeX.get_rank" ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type
ty1,Type
ty2])
            get_rank (TyVarTy {})    = 0
            get_rank (CoercionTy {}) = 1
            get_rank (AppTy {})      = 3
            get_rank (LitTy {})      = 4
            get_rank (TyConApp {})   = 5
            get_rank (FunTy {})      = 6
            get_rank (ForAllTy {})   = 7

    gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering
    gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering
gos _   []         []         = TypeOrdering
TEQ
    gos _   []         _          = TypeOrdering
TLT
    gos _   _          []         = TypeOrdering
TGT
    gos env :: RnEnv2
env (ty1 :: Type
ty1:tys1 :: [Type]
tys1) (ty2 :: Type
ty2:tys2 :: [Type]
tys2) = RnEnv2 -> Type -> Type -> TypeOrdering
go RnEnv2
env Type
ty1 Type
ty2 TypeOrdering -> TypeOrdering -> TypeOrdering
`thenCmpTy` RnEnv2 -> [Type] -> [Type] -> TypeOrdering
gos RnEnv2
env [Type]
tys1 [Type]
tys2

-------------
nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering
nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering
nonDetCmpTypesX _   []        []        = Ordering
EQ
nonDetCmpTypesX env :: RnEnv2
env (t1 :: Type
t1:tys1 :: [Type]
tys1) (t2 :: Type
t2:tys2 :: [Type]
tys2) = RnEnv2 -> Type -> Type -> Ordering
nonDetCmpTypeX RnEnv2
env Type
t1 Type
t2
                                          Ordering -> Ordering -> Ordering
`thenCmp`
                                          RnEnv2 -> [Type] -> [Type] -> Ordering
nonDetCmpTypesX RnEnv2
env [Type]
tys1 [Type]
tys2
nonDetCmpTypesX _   []        _         = Ordering
LT
nonDetCmpTypesX _   _         []        = Ordering
GT

-------------
-- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as
-- recognized by Kind.isConstraintKindCon) which is considered a synonym for
-- 'Type' in Core.
-- See Note [Kind Constraint and kind Type] in Kind.
-- See Note [nonDetCmpType nondeterminism]
nonDetCmpTc :: TyCon -> TyCon -> Ordering
nonDetCmpTc :: TyCon -> TyCon -> Ordering
nonDetCmpTc tc1 :: TyCon
tc1 tc2 :: TyCon
tc2
  = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) )
    Unique
u1 Unique -> Unique -> Ordering
`nonDetCmpUnique` Unique
u2
  where
    u1 :: Unique
u1  = TyCon -> Unique
tyConUnique TyCon
tc1
    u2 :: Unique
u2  = TyCon -> Unique
tyConUnique TyCon
tc2

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

Note [typeKind vs tcTypeKind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have two functions to get the kind of a type

  * typeKind   ignores  the distinction between Constraint and *
  * tcTypeKind respects the distinction between Constraint and *

tcTypeKind is used by the type inference engine, for which Constraint
and * are different; after that we use typeKind.

See also Note [coreView vs tcView]

Note [Kinding rules for types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In typeKind we consider Constraint and (TYPE LiftedRep) to be identical.
We then have

         t1 : TYPE rep1
         t2 : TYPE rep2
   (FUN) ----------------
         t1 -> t2 : Type

         ty : TYPE rep
         `a` is not free in rep
(FORALL) -----------------------
         forall a. ty : TYPE rep

In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct:

          t1 : TYPE rep1
          t2 : TYPE rep2
    (FUN) ----------------
          t1 -> t2 : Type

          t1 : Constraint
          t2 : TYPE rep
  (PRED1) ----------------
          t1 => t2 : Type

          t1 : Constraint
          t2 : Constraint
  (PRED2) ---------------------
          t1 => t2 : Constraint

          ty : TYPE rep
          `a` is not free in rep
(FORALL1) -----------------------
          forall a. ty : TYPE rep

          ty : Constraint
(FORALL2) -------------------------
          forall a. ty : Constraint

Note that:
* The only way we distinguish '->' from '=>' is by the fact
  that the argument is a PredTy.  Both are FunTys
-}

-----------------------------
typeKind :: HasDebugCallStack => Type -> Kind
typeKind :: Type -> Type
typeKind (TyConApp tc :: TyCon
tc tys :: [Type]
tys) = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys (TyCon -> Type
tyConKind TyCon
tc) [Type]
tys
typeKind (LitTy l :: TyLit
l)         = TyLit -> Type
typeLiteralKind TyLit
l
typeKind (FunTy {})        = Type
liftedTypeKind
typeKind (TyVarTy tyvar :: TyVar
tyvar)   = TyVar -> Type
tyVarKind TyVar
tyvar
typeKind (CastTy _ty :: Type
_ty co :: KindCoercion
co)   = Pair Type -> Type
forall a. Pair a -> a
pSnd (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ KindCoercion -> Pair Type
coercionKind KindCoercion
co
typeKind (CoercionTy co :: KindCoercion
co)   = KindCoercion -> Type
coercionType KindCoercion
co

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

typeKind ty :: Type
ty@(ForAllTy {})
  = case [TyVar] -> Type -> Maybe Type
occCheckExpand [TyVar]
tvs Type
body_kind of   -- We must make sure tv does not occur in kind
      Just k' :: Type
k' -> Type
k'                        -- As it is already out of scope!
      Nothing -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "typeKind"
                  (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_kind)
  where
    (tvs :: [TyVar]
tvs, body :: Type
body) = Type -> ([TyVar], Type)
splitTyVarForAllTys Type
ty
    body_kind :: Type
body_kind   = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
body

-----------------------------
tcTypeKind :: HasDebugCallStack => Type -> Kind
tcTypeKind :: Type -> Type
tcTypeKind (TyConApp tc :: TyCon
tc tys :: [Type]
tys) = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys (TyCon -> Type
tyConKind TyCon
tc) [Type]
tys
tcTypeKind (LitTy l :: TyLit
l)         = TyLit -> Type
typeLiteralKind TyLit
l
tcTypeKind (TyVarTy tyvar :: TyVar
tyvar)   = TyVar -> Type
tyVarKind TyVar
tyvar
tcTypeKind (CastTy _ty :: Type
_ty co :: KindCoercion
co)   = Pair Type -> Type
forall a. Pair a -> a
pSnd (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ KindCoercion -> Pair Type
coercionKind KindCoercion
co
tcTypeKind (CoercionTy co :: KindCoercion
co)   = KindCoercion -> Type
coercionType KindCoercion
co

tcTypeKind (FunTy arg :: Type
arg res :: Type
res)
  | Type -> Bool
isPredTy Type
arg Bool -> Bool -> Bool
&& Type -> Bool
isPredTy Type
res = Type
constraintKind
  | Bool
otherwise                    = Type
liftedTypeKind

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

tcTypeKind ty :: Type
ty@(ForAllTy {})
  | Type -> Bool
tcIsConstraintKind Type
body_kind
  = Type
constraintKind

  | Bool
otherwise
  = case [TyVar] -> Type -> Maybe Type
occCheckExpand [TyVar]
tvs Type
body_kind of   -- We must make sure tv does not occur in kind
      Just k' :: Type
k' -> Type
k'                        -- As it is already out of scope!
      Nothing -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcTypeKind"
                  (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_kind)
  where
    (tvs :: [TyVar]
tvs, body :: Type
body) = Type -> ([TyVar], Type)
splitTyVarForAllTys Type
ty
    body_kind :: Type
body_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
body


isPredTy :: Type -> Bool
-- See Note [Types for coercions, predicates, and evidence]
isPredTy :: Type -> Bool
isPredTy ty :: Type
ty = Type -> Bool
tcIsConstraintKind (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty)

--------------------------
typeLiteralKind :: TyLit -> Kind
typeLiteralKind :: TyLit -> Type
typeLiteralKind l :: TyLit
l =
  case TyLit
l of
    NumTyLit _ -> Type
typeNatKind
    StrTyLit _ -> Type
typeSymbolKind

-- | Returns True if a type is levity polymorphic. Should be the same
-- as (isKindLevPoly . typeKind) but much faster.
-- Precondition: The type has kind (TYPE blah)
isTypeLevPoly :: Type -> Bool
isTypeLevPoly :: Type -> Bool
isTypeLevPoly = Type -> Bool
go
  where
    go :: Type -> Bool
go ty :: Type
ty@(TyVarTy {})                           = Type -> Bool
check_kind Type
ty
    go ty :: Type
ty@(AppTy {})                             = Type -> Bool
check_kind Type
ty
    go ty :: Type
ty@(TyConApp tc :: TyCon
tc _) | Bool -> Bool
not (TyCon -> Bool
isTcLevPoly TyCon
tc) = Bool
False
                          | Bool
otherwise            = Type -> Bool
check_kind Type
ty
    go (ForAllTy _ ty :: Type
ty)                           = Type -> Bool
go Type
ty
    go (FunTy {})                                = Bool
False
    go (LitTy {})                                = Bool
False
    go ty :: Type
ty@(CastTy {})                            = Type -> Bool
check_kind Type
ty
    go ty :: Type
ty@(CoercionTy {})                        = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic "isTypeLevPoly co" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

    check_kind :: Type -> Bool
check_kind = Type -> Bool
isKindLevPoly (Type -> Bool) -> (Type -> Type) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Type
Type -> Type
typeKind

-- | Looking past all pi-types, is the end result potentially levity polymorphic?
-- Example: True for (forall r (a :: TYPE r). String -> a)
-- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)
resultIsLevPoly :: Type -> Bool
resultIsLevPoly :: Type -> Bool
resultIsLevPoly = Type -> Bool
isTypeLevPoly (Type -> Bool) -> (Type -> Type) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TyCoBinder], Type) -> Type
forall a b. (a, b) -> b
snd (([TyCoBinder], Type) -> Type)
-> (Type -> ([TyCoBinder], Type)) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([TyCoBinder], Type)
splitPiTys


{- **********************************************************************
*                                                                       *
           Occurs check expansion
%*                                                                      *
%********************************************************************* -}

{- Note [Occurs check expansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid
of occurrences of tv outside type function arguments, if that is
possible; otherwise, it returns Nothing.

For example, suppose we have
  type F a b = [a]
Then
  occCheckExpand b (F Int b) = Just [Int]
but
  occCheckExpand a (F a Int) = Nothing

We don't promise to do the absolute minimum amount of expanding
necessary, but we try not to do expansions we don't need to.  We
prefer doing inner expansions first.  For example,
  type F a b = (a, Int, a, [a])
  type G b   = Char
We have
  occCheckExpand b (F (G b)) = Just (F Char)
even though we could also expand F to get rid of b.
-}

occCheckExpand :: [Var] -> Type -> Maybe Type
-- See Note [Occurs check expansion]
-- We may have needed to do some type synonym unfolding in order to
-- get rid of the variable (or forall), so we also return the unfolded
-- version of the type, which is guaranteed to be syntactically free
-- of the given type variable.  If the type is already syntactically
-- free of the variable, then the same type is returned.
occCheckExpand :: [TyVar] -> Type -> Maybe Type
occCheckExpand vs_to_avoid :: [TyVar]
vs_to_avoid ty :: Type
ty
  = (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go ([TyVar] -> VarSet
mkVarSet [TyVar]
vs_to_avoid, VarEnv TyVar
forall a. VarEnv a
emptyVarEnv) Type
ty
  where
    go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type
          -- The VarSet is the set of variables we are trying to avoid
          -- The VarEnv carries mappings necessary
          -- because of kind expansion
    go :: (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go cxt :: (VarSet, VarEnv TyVar)
cxt@(as :: VarSet
as, env :: VarEnv TyVar
env) (TyVarTy tv' :: TyVar
tv')
      | TyVar
tv' TyVar -> VarSet -> Bool
`elemVarSet` VarSet
as               = Maybe Type
forall a. Maybe a
Nothing
      | Just tv'' :: TyVar
tv'' <- VarEnv TyVar -> TyVar -> Maybe TyVar
forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarEnv TyVar
env TyVar
tv' = Type -> Maybe Type
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Type
mkTyVarTy TyVar
tv'')
      | Bool
otherwise                         = do { TyVar
tv'' <- (VarSet, VarEnv TyVar) -> TyVar -> Maybe TyVar
go_var (VarSet, VarEnv TyVar)
cxt TyVar
tv'
                                               ; Type -> Maybe Type
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Type
mkTyVarTy TyVar
tv'') }

    go _   ty :: Type
ty@(LitTy {}) = Type -> Maybe Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    go cxt :: (VarSet, VarEnv TyVar)
cxt (AppTy ty1 :: Type
ty1 ty2 :: Type
ty2) = do { Type
ty1' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt Type
ty1
                                ; Type
ty2' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt Type
ty2
                                ; Type -> Maybe Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
mkAppTy Type
ty1' Type
ty2') }
    go cxt :: (VarSet, VarEnv TyVar)
cxt (FunTy ty1 :: Type
ty1 ty2 :: Type
ty2) = do { Type
ty1' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt Type
ty1
                                ; Type
ty2' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt Type
ty2
                                ; Type -> Maybe Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
mkFunTy Type
ty1' Type
ty2') }
    go cxt :: (VarSet, VarEnv TyVar)
cxt@(as :: VarSet
as, env :: VarEnv TyVar
env) (ForAllTy (Bndr tv :: TyVar
tv vis :: ArgFlag
vis) body_ty :: Type
body_ty)
       = do { Type
ki' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt (TyVar -> Type
varType TyVar
tv)
            ; let tv' :: TyVar
tv' = TyVar -> Type -> TyVar
setVarType TyVar
tv Type
ki'
                  env' :: VarEnv TyVar
env' = VarEnv TyVar -> TyVar -> TyVar -> VarEnv TyVar
forall a. VarEnv a -> TyVar -> a -> VarEnv a
extendVarEnv VarEnv TyVar
env TyVar
tv TyVar
tv'
                  as' :: VarSet
as'  = VarSet
as VarSet -> TyVar -> VarSet
`delVarSet` TyVar
tv
            ; Type
body' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet
as', VarEnv TyVar
env') Type
body_ty
            ; Type -> Maybe Type
forall (m :: * -> *) a. Monad m => a -> m a
return (VarBndr TyVar ArgFlag -> Type -> Type
ForAllTy (TyVar -> ArgFlag -> VarBndr TyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' ArgFlag
vis) Type
body') }

    -- For a type constructor application, first try expanding away the
    -- offending variable from the arguments.  If that doesn't work, next
    -- see if the type constructor is a type synonym, and if so, expand
    -- it and try again.
    go cxt :: (VarSet, VarEnv TyVar)
cxt ty :: Type
ty@(TyConApp tc :: TyCon
tc tys :: [Type]
tys)
      = case (Type -> Maybe Type) -> [Type] -> Maybe [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt) [Type]
tys of
          Just tys' :: [Type]
tys' -> Type -> Maybe Type
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tys')
          Nothing | Just ty' :: Type
ty' <- Type -> Maybe Type
tcView Type
ty -> (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt Type
ty'
                  | Bool
otherwise             -> Maybe Type
forall a. Maybe a
Nothing
                      -- Failing that, try to expand a synonym

    go cxt :: (VarSet, VarEnv TyVar)
cxt (CastTy ty :: Type
ty co :: KindCoercion
co) =  do { Type
ty' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt Type
ty
                                ; KindCoercion
co' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
                                ; Type -> Maybe Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> KindCoercion -> Type
mkCastTy Type
ty' KindCoercion
co') }
    go cxt :: (VarSet, VarEnv TyVar)
cxt (CoercionTy co :: KindCoercion
co) = do { KindCoercion
co' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
                                ; Type -> Maybe Type
forall (m :: * -> *) a. Monad m => a -> m a
return (KindCoercion -> Type
mkCoercionTy KindCoercion
co') }

    ------------------
    go_var :: (VarSet, VarEnv TyVar) -> TyVar -> Maybe TyVar
go_var cxt :: (VarSet, VarEnv TyVar)
cxt v :: TyVar
v = do { Type
k' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt (TyVar -> Type
varType TyVar
v)
                      ; TyVar -> Maybe TyVar
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Type -> TyVar
setVarType TyVar
v Type
k') }
           -- Works for TyVar and CoVar
           -- See Note [Occurrence checking: look inside kinds]

    ------------------
    go_mco :: (VarSet, VarEnv TyVar) -> MCoercionN -> Maybe MCoercionN
go_mco _   MRefl = MCoercionN -> Maybe MCoercionN
forall (m :: * -> *) a. Monad m => a -> m a
return MCoercionN
MRefl
    go_mco ctx :: (VarSet, VarEnv TyVar)
ctx (MCo co :: KindCoercion
co) = KindCoercion -> MCoercionN
MCo (KindCoercion -> MCoercionN)
-> Maybe KindCoercion -> Maybe MCoercionN
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
ctx KindCoercion
co

    ------------------
    go_co :: (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co cxt :: (VarSet, VarEnv TyVar)
cxt (Refl ty :: Type
ty)                 = do { Type
ty' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt Type
ty
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> KindCoercion
mkNomReflCo Type
ty') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (GRefl r :: Role
r ty :: Type
ty mco :: MCoercionN
mco)          = do { MCoercionN
mco' <- (VarSet, VarEnv TyVar) -> MCoercionN -> Maybe MCoercionN
go_mco (VarSet, VarEnv TyVar)
cxt MCoercionN
mco
                                             ; Type
ty' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt Type
ty
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Type -> MCoercionN -> KindCoercion
mkGReflCo Role
r Type
ty' MCoercionN
mco') }
      -- Note: Coercions do not contain type synonyms
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (TyConAppCo r :: Role
r tc :: TyCon
tc args :: [KindCoercion]
args)    = do { [KindCoercion]
args' <- (KindCoercion -> Maybe KindCoercion)
-> [KindCoercion] -> Maybe [KindCoercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt) [KindCoercion]
args
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack =>
Role -> TyCon -> [KindCoercion] -> KindCoercion
Role -> TyCon -> [KindCoercion] -> KindCoercion
mkTyConAppCo Role
r TyCon
tc [KindCoercion]
args') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (AppCo co :: KindCoercion
co arg :: KindCoercion
arg)            = do { KindCoercion
co' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
                                             ; KindCoercion
arg' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
arg
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (KindCoercion -> KindCoercion -> KindCoercion
mkAppCo KindCoercion
co' KindCoercion
arg') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt@(as :: VarSet
as, env :: VarEnv TyVar
env) (ForAllCo tv :: TyVar
tv kind_co :: KindCoercion
kind_co body_co :: KindCoercion
body_co)
      = do { KindCoercion
kind_co' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
kind_co
           ; let tv' :: TyVar
tv' = TyVar -> Type -> TyVar
setVarType TyVar
tv (Type -> TyVar) -> Type -> TyVar
forall a b. (a -> b) -> a -> b
$
                       Pair Type -> Type
forall a. Pair a -> a
pFst (KindCoercion -> Pair Type
coercionKind KindCoercion
kind_co')
                 env' :: VarEnv TyVar
env' = VarEnv TyVar -> TyVar -> TyVar -> VarEnv TyVar
forall a. VarEnv a -> TyVar -> a -> VarEnv a
extendVarEnv VarEnv TyVar
env TyVar
tv TyVar
tv'
                 as' :: VarSet
as'  = VarSet
as VarSet -> TyVar -> VarSet
`delVarSet` TyVar
tv
           ; KindCoercion
body' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet
as', VarEnv TyVar
env') KindCoercion
body_co
           ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> KindCoercion -> KindCoercion -> KindCoercion
ForAllCo TyVar
tv' KindCoercion
kind_co' KindCoercion
body') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (FunCo r :: Role
r co1 :: KindCoercion
co1 co2 :: KindCoercion
co2)         = do { KindCoercion
co1' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co1
                                             ; KindCoercion
co2' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co2
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> KindCoercion -> KindCoercion -> KindCoercion
mkFunCo Role
r KindCoercion
co1' KindCoercion
co2') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt@(as :: VarSet
as,env :: VarEnv TyVar
env) (CoVarCo c :: TyVar
c)
      | TyVar
c TyVar -> VarSet -> Bool
`elemVarSet` VarSet
as               = Maybe KindCoercion
forall a. Maybe a
Nothing
      | Just c' :: TyVar
c' <- VarEnv TyVar -> TyVar -> Maybe TyVar
forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarEnv TyVar
env TyVar
c   = KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> KindCoercion
mkCoVarCo TyVar
c')
      | Bool
otherwise                       = do { TyVar
c' <- (VarSet, VarEnv TyVar) -> TyVar -> Maybe TyVar
go_var (VarSet, VarEnv TyVar)
cxt TyVar
c
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> KindCoercion
mkCoVarCo TyVar
c') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (HoleCo h :: CoercionHole
h)                = do { TyVar
c' <- (VarSet, VarEnv TyVar) -> TyVar -> Maybe TyVar
go_var (VarSet, VarEnv TyVar)
cxt (CoercionHole -> TyVar
ch_co_var CoercionHole
h)
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (CoercionHole -> KindCoercion
HoleCo (CoercionHole
h { ch_co_var :: TyVar
ch_co_var = TyVar
c' })) }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (AxiomInstCo ax :: CoAxiom Branched
ax ind :: Int
ind args :: [KindCoercion]
args) = do { [KindCoercion]
args' <- (KindCoercion -> Maybe KindCoercion)
-> [KindCoercion] -> Maybe [KindCoercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt) [KindCoercion]
args
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (CoAxiom Branched -> Int -> [KindCoercion] -> KindCoercion
mkAxiomInstCo CoAxiom Branched
ax Int
ind [KindCoercion]
args') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (UnivCo p :: UnivCoProvenance
p r :: Role
r ty1 :: Type
ty1 ty2 :: Type
ty2)      = do { UnivCoProvenance
p' <- (VarSet, VarEnv TyVar)
-> UnivCoProvenance -> Maybe UnivCoProvenance
go_prov (VarSet, VarEnv TyVar)
cxt UnivCoProvenance
p
                                             ; Type
ty1' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt Type
ty1
                                             ; Type
ty2' <- (VarSet, VarEnv TyVar) -> Type -> Maybe Type
go (VarSet, VarEnv TyVar)
cxt Type
ty2
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (UnivCoProvenance -> Role -> Type -> Type -> KindCoercion
mkUnivCo UnivCoProvenance
p' Role
r Type
ty1' Type
ty2') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (SymCo co :: KindCoercion
co)                = do { KindCoercion
co' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (KindCoercion -> KindCoercion
mkSymCo KindCoercion
co') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (TransCo co1 :: KindCoercion
co1 co2 :: KindCoercion
co2)         = do { KindCoercion
co1' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co1
                                             ; KindCoercion
co2' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co2
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (KindCoercion -> KindCoercion -> KindCoercion
mkTransCo KindCoercion
co1' KindCoercion
co2') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (NthCo r :: Role
r n :: Int
n co :: KindCoercion
co)            = do { KindCoercion
co' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Role -> Int -> KindCoercion -> KindCoercion
Role -> Int -> KindCoercion -> KindCoercion
mkNthCo Role
r Int
n KindCoercion
co') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (LRCo lr :: LeftOrRight
lr co :: KindCoercion
co)              = do { KindCoercion
co' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (LeftOrRight -> KindCoercion -> KindCoercion
mkLRCo LeftOrRight
lr KindCoercion
co') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (InstCo co :: KindCoercion
co arg :: KindCoercion
arg)           = do { KindCoercion
co' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
                                             ; KindCoercion
arg' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
arg
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (KindCoercion -> KindCoercion -> KindCoercion
mkInstCo KindCoercion
co' KindCoercion
arg') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (KindCo co :: KindCoercion
co)               = do { KindCoercion
co' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (KindCoercion -> KindCoercion
mkKindCo KindCoercion
co') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (SubCo co :: KindCoercion
co)                = do { KindCoercion
co' <- (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (KindCoercion -> KindCoercion
mkSubCo KindCoercion
co') }
    go_co cxt :: (VarSet, VarEnv TyVar)
cxt (AxiomRuleCo ax :: CoAxiomRule
ax cs :: [KindCoercion]
cs)       = do { [KindCoercion]
cs' <- (KindCoercion -> Maybe KindCoercion)
-> [KindCoercion] -> Maybe [KindCoercion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt) [KindCoercion]
cs
                                             ; KindCoercion -> Maybe KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (CoAxiomRule -> [KindCoercion] -> KindCoercion
mkAxiomRuleCo CoAxiomRule
ax [KindCoercion]
cs') }

    ------------------
    go_prov :: (VarSet, VarEnv TyVar)
-> UnivCoProvenance -> Maybe UnivCoProvenance
go_prov _   UnsafeCoerceProv    = UnivCoProvenance -> Maybe UnivCoProvenance
forall (m :: * -> *) a. Monad m => a -> m a
return UnivCoProvenance
UnsafeCoerceProv
    go_prov cxt :: (VarSet, VarEnv TyVar)
cxt (PhantomProv co :: KindCoercion
co)    = KindCoercion -> UnivCoProvenance
PhantomProv (KindCoercion -> UnivCoProvenance)
-> Maybe KindCoercion -> Maybe UnivCoProvenance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
    go_prov cxt :: (VarSet, VarEnv TyVar)
cxt (ProofIrrelProv co :: KindCoercion
co) = KindCoercion -> UnivCoProvenance
ProofIrrelProv (KindCoercion -> UnivCoProvenance)
-> Maybe KindCoercion -> Maybe UnivCoProvenance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VarSet, VarEnv TyVar) -> KindCoercion -> Maybe KindCoercion
go_co (VarSet, VarEnv TyVar)
cxt KindCoercion
co
    go_prov _   p :: UnivCoProvenance
p@(PluginProv _)    = UnivCoProvenance -> Maybe UnivCoProvenance
forall (m :: * -> *) a. Monad m => a -> m a
return UnivCoProvenance
p


{-
%************************************************************************
%*                                                                      *
        Miscellaneous functions
%*                                                                      *
%************************************************************************

-}
-- | All type constructors occurring in the type; looking through type
--   synonyms, but not newtypes.
--  When it finds a Class, it returns the class TyCon.
tyConsOfType :: Type -> UniqSet TyCon
tyConsOfType :: Type -> UniqSet TyCon
tyConsOfType ty :: Type
ty
  = Type -> UniqSet TyCon
go Type
ty
  where
     go :: Type -> UniqSet TyCon  -- The UniqSet does duplicate elim
     go :: Type -> UniqSet TyCon
go ty :: Type
ty | Just ty' :: Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> UniqSet TyCon
go Type
ty'
     go (TyVarTy {})                = UniqSet TyCon
forall a. UniqSet a
emptyUniqSet
     go (LitTy {})                  = UniqSet TyCon
forall a. UniqSet a
emptyUniqSet
     go (TyConApp tc :: TyCon
tc tys :: [Type]
tys)           = TyCon -> UniqSet TyCon
forall a. Uniquable a => a -> UniqSet a
go_tc TyCon
tc UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` [Type] -> UniqSet TyCon
forall (t :: * -> *). Foldable t => t Type -> UniqSet TyCon
go_s [Type]
tys
     go (AppTy a :: Type
a b :: Type
b)                 = Type -> UniqSet TyCon
go Type
a UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` Type -> UniqSet TyCon
go Type
b
     go (FunTy a :: Type
a b :: Type
b)                 = Type -> UniqSet TyCon
go Type
a UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` Type -> UniqSet TyCon
go Type
b UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` TyCon -> UniqSet TyCon
forall a. Uniquable a => a -> UniqSet a
go_tc TyCon
funTyCon
     go (ForAllTy (Bndr tv :: TyVar
tv _) ty :: Type
ty)   = Type -> UniqSet TyCon
go Type
ty UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` Type -> UniqSet TyCon
go (TyVar -> Type
varType TyVar
tv)
     go (CastTy ty :: Type
ty co :: KindCoercion
co)              = Type -> UniqSet TyCon
go Type
ty UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` KindCoercion -> UniqSet TyCon
go_co KindCoercion
co
     go (CoercionTy co :: KindCoercion
co)             = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co

     go_co :: KindCoercion -> UniqSet TyCon
go_co (Refl ty :: Type
ty)               = Type -> UniqSet TyCon
go Type
ty
     go_co (GRefl _ ty :: Type
ty mco :: MCoercionN
mco)        = Type -> UniqSet TyCon
go Type
ty UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` MCoercionN -> UniqSet TyCon
go_mco MCoercionN
mco
     go_co (TyConAppCo _ tc :: TyCon
tc args :: [KindCoercion]
args)  = TyCon -> UniqSet TyCon
forall a. Uniquable a => a -> UniqSet a
go_tc TyCon
tc UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` [KindCoercion] -> UniqSet TyCon
go_cos [KindCoercion]
args
     go_co (AppCo co :: KindCoercion
co arg :: KindCoercion
arg)          = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` KindCoercion -> UniqSet TyCon
go_co KindCoercion
arg
     go_co (ForAllCo _ kind_co :: KindCoercion
kind_co co :: KindCoercion
co) = KindCoercion -> UniqSet TyCon
go_co KindCoercion
kind_co UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` KindCoercion -> UniqSet TyCon
go_co KindCoercion
co
     go_co (FunCo _ co1 :: KindCoercion
co1 co2 :: KindCoercion
co2)       = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co1 UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` KindCoercion -> UniqSet TyCon
go_co KindCoercion
co2
     go_co (AxiomInstCo ax :: CoAxiom Branched
ax _ args :: [KindCoercion]
args) = CoAxiom Branched -> UniqSet TyCon
forall (br :: BranchFlag). CoAxiom br -> UniqSet TyCon
go_ax CoAxiom Branched
ax UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` [KindCoercion] -> UniqSet TyCon
go_cos [KindCoercion]
args
     go_co (UnivCo p :: UnivCoProvenance
p _ t1 :: Type
t1 t2 :: Type
t2)      = UnivCoProvenance -> UniqSet TyCon
go_prov UnivCoProvenance
p UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` Type -> UniqSet TyCon
go Type
t1 UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` Type -> UniqSet TyCon
go Type
t2
     go_co (CoVarCo {})            = UniqSet TyCon
forall a. UniqSet a
emptyUniqSet
     go_co (HoleCo {})             = UniqSet TyCon
forall a. UniqSet a
emptyUniqSet
     go_co (SymCo co :: KindCoercion
co)              = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co
     go_co (TransCo co1 :: KindCoercion
co1 co2 :: KindCoercion
co2)       = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co1 UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` KindCoercion -> UniqSet TyCon
go_co KindCoercion
co2
     go_co (NthCo _ _ co :: KindCoercion
co)          = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co
     go_co (LRCo _ co :: KindCoercion
co)             = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co
     go_co (InstCo co :: KindCoercion
co arg :: KindCoercion
arg)         = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` KindCoercion -> UniqSet TyCon
go_co KindCoercion
arg
     go_co (KindCo co :: KindCoercion
co)             = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co
     go_co (SubCo co :: KindCoercion
co)              = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co
     go_co (AxiomRuleCo _ cs :: [KindCoercion]
cs)      = [KindCoercion] -> UniqSet TyCon
go_cos [KindCoercion]
cs

     go_mco :: MCoercionN -> UniqSet TyCon
go_mco MRefl    = UniqSet TyCon
forall a. UniqSet a
emptyUniqSet
     go_mco (MCo co :: KindCoercion
co) = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co

     go_prov :: UnivCoProvenance -> UniqSet TyCon
go_prov UnsafeCoerceProv    = UniqSet TyCon
forall a. UniqSet a
emptyUniqSet
     go_prov (PhantomProv co :: KindCoercion
co)    = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co
     go_prov (ProofIrrelProv co :: KindCoercion
co) = KindCoercion -> UniqSet TyCon
go_co KindCoercion
co
     go_prov (PluginProv _)      = UniqSet TyCon
forall a. UniqSet a
emptyUniqSet
        -- this last case can happen from the tyConsOfType used from
        -- checkTauTvUpdate

     go_s :: t Type -> UniqSet TyCon
go_s tys :: t Type
tys     = (Type -> UniqSet TyCon -> UniqSet TyCon)
-> UniqSet TyCon -> t Type -> UniqSet TyCon
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets (UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon)
-> (Type -> UniqSet TyCon)
-> Type
-> UniqSet TyCon
-> UniqSet TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> UniqSet TyCon
go)     UniqSet TyCon
forall a. UniqSet a
emptyUniqSet t Type
tys
     go_cos :: [KindCoercion] -> UniqSet TyCon
go_cos cos :: [KindCoercion]
cos   = (KindCoercion -> UniqSet TyCon -> UniqSet TyCon)
-> UniqSet TyCon -> [KindCoercion] -> UniqSet TyCon
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets (UniqSet TyCon -> UniqSet TyCon -> UniqSet TyCon)
-> (KindCoercion -> UniqSet TyCon)
-> KindCoercion
-> UniqSet TyCon
-> UniqSet TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindCoercion -> UniqSet TyCon
go_co)  UniqSet TyCon
forall a. UniqSet a
emptyUniqSet [KindCoercion]
cos

     go_tc :: a -> UniqSet a
go_tc tc :: a
tc = a -> UniqSet a
forall a. Uniquable a => a -> UniqSet a
unitUniqSet a
tc
     go_ax :: CoAxiom br -> UniqSet TyCon
go_ax ax :: CoAxiom br
ax = TyCon -> UniqSet TyCon
forall a. Uniquable a => a -> UniqSet a
go_tc (TyCon -> UniqSet TyCon) -> TyCon -> UniqSet TyCon
forall a b. (a -> b) -> a -> b
$ CoAxiom br -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom br
ax

-- | Find the result 'Kind' of a type synonym,
-- after applying it to its 'arity' number of type variables
-- Actually this function works fine on data types too,
-- but they'd always return '*', so we never need to ask
synTyConResKind :: TyCon -> Kind
synTyConResKind :: TyCon -> Type
synTyConResKind tycon :: TyCon
tycon = HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys (TyCon -> Type
tyConKind TyCon
tycon) ([TyVar] -> [Type]
mkTyVarTys (TyCon -> [TyVar]
tyConTyVars TyCon
tycon))

-- | Retrieve the free variables in this type, splitting them based
-- on whether they are used visibly or invisibly. Invisible ones come
-- first.
splitVisVarsOfType :: Type -> Pair TyCoVarSet
splitVisVarsOfType :: Type -> Pair VarSet
splitVisVarsOfType orig_ty :: Type
orig_ty = VarSet -> VarSet -> Pair VarSet
forall a. a -> a -> Pair a
Pair VarSet
invis_vars VarSet
vis_vars
  where
    Pair invis_vars1 :: VarSet
invis_vars1 vis_vars :: VarSet
vis_vars = Type -> Pair VarSet
go Type
orig_ty
    invis_vars :: VarSet
invis_vars = VarSet
invis_vars1 VarSet -> VarSet -> VarSet
`minusVarSet` VarSet
vis_vars

    go :: Type -> Pair VarSet
go (TyVarTy tv :: TyVar
tv)      = VarSet -> VarSet -> Pair VarSet
forall a. a -> a -> Pair a
Pair (Type -> VarSet
tyCoVarsOfType (Type -> VarSet) -> Type -> VarSet
forall a b. (a -> b) -> a -> b
$ TyVar -> Type
tyVarKind TyVar
tv) (TyVar -> VarSet
unitVarSet TyVar
tv)
    go (AppTy t1 :: Type
t1 t2 :: Type
t2)     = Type -> Pair VarSet
go Type
t1 Pair VarSet -> Pair VarSet -> Pair VarSet
forall a. Monoid a => a -> a -> a
`mappend` Type -> Pair VarSet
go Type
t2
    go (TyConApp tc :: TyCon
tc tys :: [Type]
tys) = TyCon -> [Type] -> Pair VarSet
go_tc TyCon
tc [Type]
tys
    go (FunTy t1 :: Type
t1 t2 :: Type
t2)     = Type -> Pair VarSet
go Type
t1 Pair VarSet -> Pair VarSet -> Pair VarSet
forall a. Monoid a => a -> a -> a
`mappend` Type -> Pair VarSet
go Type
t2
    go (ForAllTy (Bndr tv :: TyVar
tv _) ty :: Type
ty)
      = ((VarSet -> TyVar -> VarSet
`delVarSet` TyVar
tv) (VarSet -> VarSet) -> Pair VarSet -> Pair VarSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Pair VarSet
go Type
ty) Pair VarSet -> Pair VarSet -> Pair VarSet
forall a. Monoid a => a -> a -> a
`mappend`
        (VarSet -> Pair VarSet
invisible (Type -> VarSet
tyCoVarsOfType (Type -> VarSet) -> Type -> VarSet
forall a b. (a -> b) -> a -> b
$ TyVar -> Type
varType TyVar
tv))
    go (LitTy {}) = Pair VarSet
forall a. Monoid a => a
mempty
    go (CastTy ty :: Type
ty co :: KindCoercion
co) = Type -> Pair VarSet
go Type
ty Pair VarSet -> Pair VarSet -> Pair VarSet
forall a. Monoid a => a -> a -> a
`mappend` VarSet -> Pair VarSet
invisible (KindCoercion -> VarSet
tyCoVarsOfCo KindCoercion
co)
    go (CoercionTy co :: KindCoercion
co) = VarSet -> Pair VarSet
invisible (VarSet -> Pair VarSet) -> VarSet -> Pair VarSet
forall a b. (a -> b) -> a -> b
$ KindCoercion -> VarSet
tyCoVarsOfCo KindCoercion
co

    invisible :: VarSet -> Pair VarSet
invisible vs :: VarSet
vs = VarSet -> VarSet -> Pair VarSet
forall a. a -> a -> Pair a
Pair VarSet
vs VarSet
emptyVarSet

    go_tc :: TyCon -> [Type] -> Pair VarSet
go_tc tc :: TyCon
tc tys :: [Type]
tys = let (invis :: [Type]
invis, vis :: [Type]
vis) = TyCon -> [Type] -> ([Type], [Type])
partitionInvisibleTypes TyCon
tc [Type]
tys in
                   VarSet -> Pair VarSet
invisible ([Type] -> VarSet
tyCoVarsOfTypes [Type]
invis) Pair VarSet -> Pair VarSet -> Pair VarSet
forall a. Monoid a => a -> a -> a
`mappend` (Type -> Pair VarSet) -> [Type] -> Pair VarSet
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> Pair VarSet
go [Type]
vis

splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet
splitVisVarsOfTypes :: [Type] -> Pair VarSet
splitVisVarsOfTypes = (Type -> Pair VarSet) -> [Type] -> Pair VarSet
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Type -> Pair VarSet
splitVisVarsOfType

modifyJoinResTy :: Int            -- Number of binders to skip
                -> (Type -> Type) -- Function to apply to result type
                -> Type           -- Type of join point
                -> Type           -- New type
-- INVARIANT: If any of the first n binders are foralls, those tyvars cannot
-- appear in the original result type. See isValidJoinPointType.
modifyJoinResTy :: Int -> (Type -> Type) -> Type -> Type
modifyJoinResTy orig_ar :: Int
orig_ar f :: Type -> Type
f orig_ty :: Type
orig_ty
  = Int -> Type -> Type
forall t. (Eq t, Num t) => t -> Type -> Type
go Int
orig_ar Type
orig_ty
  where
    go :: t -> Type -> Type
go 0 ty :: Type
ty = Type -> Type
f Type
ty
    go n :: t
n ty :: Type
ty | Just (arg_bndr :: TyCoBinder
arg_bndr, res_ty :: Type
res_ty) <- Type -> Maybe (TyCoBinder, Type)
splitPiTy_maybe Type
ty
            = TyCoBinder -> Type -> Type
mkTyCoPiTy TyCoBinder
arg_bndr (t -> Type -> Type
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) Type
res_ty)
            | Bool
otherwise
            = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "modifyJoinResTy" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
orig_ar SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
orig_ty)

setJoinResTy :: Int  -- Number of binders to skip
             -> Type -- New result type
             -> Type -- Type of join point
             -> Type -- New type
-- INVARIANT: Same as for modifyJoinResTy
setJoinResTy :: Int -> Type -> Type -> Type
setJoinResTy ar :: Int
ar new_res_ty :: Type
new_res_ty ty :: Type
ty
  = Int -> (Type -> Type) -> Type -> Type
modifyJoinResTy Int
ar (Type -> Type -> Type
forall a b. a -> b -> a
const Type
new_res_ty) Type
ty


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

Most pretty-printing is either in TyCoRep or IfaceType.

-}

-- | This variant preserves any use of TYPE in a type, effectively
-- locally setting -fprint-explicit-runtime-reps.
pprWithTYPE :: Type -> SDoc
pprWithTYPE :: Type -> SDoc
pprWithTYPE ty :: Type
ty = (DynFlags -> DynFlags) -> SDoc -> SDoc
updSDocDynFlags ((DynFlags -> GeneralFlag -> DynFlags)
-> GeneralFlag -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_set GeneralFlag
Opt_PrintExplicitRuntimeReps) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                 Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty