{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module GHC.Tc.Utils.TcType (
TcType, TcSigmaType, TcTypeFRR, TcSigmaTypeFRR,
TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,
TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder,
TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied,
ExpType(..), InferResult(..),
ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR,
ExpRhoType,
mkCheckExpType,
SyntaxOpType(..), synKnownType, mkSynFunTys,
TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,
strictlyDeeperThan, deeperThanOrSame, sameDepthAs,
tcTypeLevel, tcTyVarLevel, maxTcLevel,
TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTvUnk,
MetaDetails(Flexi, Indirect), MetaInfo(..), skolemSkolInfo,
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy,
tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar,
ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar,
isConcreteTyVarTy, isConcreteTyVarTy_maybe,
isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo,
isFlexi, isIndirect, isRuntimeUnkSkol,
metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,
isTouchableMetaTyVar, isPromotableMetaTyVar,
findDupTyVarTvs, mkTyVarNamePairs,
mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, mkPhiTy, tcMkPhiTy,
tcMkDFunSigmaTy, tcMkDFunPhiTy,
getTyVar, getTyVar_maybe, getCastedTyVar_maybe,
tcSplitForAllTyVarBinder_maybe,
tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars,
tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders,
tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBinders,
tcSplitPhiTy, tcSplitPredFunTy_maybe,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,
tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe,
tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe,
tcSplitSigmaTy, tcSplitNestedSigmaTys,
isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isNaturalTy,
isBoolTy, isUnitTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy,
isPredTy, isTyVarClassPred,
checkValidClsArgs, hasTyVarHead,
isRigidTy,
eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,
pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,
tcEqTyConApps, eqForAllVis, eqVarBndrs,
deNoteType,
orphNamesOfType, orphNamesOfCo,
orphNamesOfTypes, orphNamesOfCoCon,
getDFunTyKey, evVarPred,
ambigTkvsOfTy,
mkMinimalBySCs, transSuperClasses,
pickCapturedPreds,
immSuperClasses, boxEqPred,
isImprovementPred,
tcTyFamInsts, tcTyFamInstsAndVis, tcTyConAppTyFamInstsAndVis, isTyFamFree,
exactTyCoVarsOfType, exactTyCoVarsOfTypes,
anyRewritableTyVar, anyRewritableTyFamApp,
IllegalForeignTypeReason(..),
TypeCannotBeMarshaledReason(..),
isFFIArgumentTy,
isFFIImportResultTy,
isFFIExportResultTy,
isFFIExternalTy,
isFFIDynTy,
isFFIPrimArgumentTy,
isFFIPrimResultTy,
isFFILabelTy,
isFunPtrTy,
tcSplitIOType_maybe,
Kind, liftedTypeKind, constraintKind,
isLiftedTypeKind, isUnliftedTypeKind, isTYPEorCONSTRAINT,
Type, PredType, ThetaType, PiTyBinder,
ForAllTyFlag(..), FunTyFlag(..),
mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,
mkSpecForAllTys, mkTyCoInvForAllTy,
mkInfForAllTy, mkInfForAllTys,
mkVisFunTy, mkVisFunTyMany, mkVisFunTysMany,
mkScaledFunTys,
mkInvisFunTy, mkInvisFunTys,
mkTyConApp, mkAppTy, mkAppTys,
mkTyConTy, mkTyVarTy, mkTyVarTys,
mkTyCoVarTy, mkTyCoVarTys,
isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass,
mkClassPred,
tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
isRuntimeRepVar, isFixedRuntimeRepKind,
isVisiblePiTyBinder, isInvisiblePiTyBinder,
Subst(..),
TvSubstEnv, emptySubst, mkEmptySubst,
zipTvSubst,
mkTvSubstPrs, notElemSubst, unionSubst,
getTvSubstEnv, getSubstInScope, extendSubstInScope,
extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope,
Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,
Type.extendTvSubst,
isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv,
Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars,
substTyAddInScope,
substTyUnchecked, substTysUnchecked, substScaledTyUnchecked,
substThetaUnchecked,
substTyWithUnchecked,
substCoUnchecked, substCoWithUnchecked,
substTheta,
isUnliftedType,
isUnboxedTupleType,
isPrimitiveType,
coreView,
tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds,
tyCoFVsOfType, tyCoFVsOfTypes,
tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet,
tyCoVarsOfTypeList, tyCoVarsOfTypesList,
noFreeVarsOfType,
pprKind, pprParendKind, pprSigmaType,
pprType, pprParendType, pprTypeApp,
pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred,
pprTCvBndr, pprTCvBndrs,
TypeSize, sizeType, sizeTypes, scopedSort,
tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible
) where
import GHC.Prelude
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars )
import GHC.Core.TyCo.Compare
import GHC.Core.TyCo.FVs
import GHC.Core.TyCo.Ppr
import GHC.Core.Class
import GHC.Types.Var
import GHC.Types.ForeignCall
import GHC.Types.Var.Set
import GHC.Core.Coercion
import GHC.Core.Type as Type
import GHC.Core.Predicate
import GHC.Types.RepType
import GHC.Core.TyCon
import {-# SOURCE #-} GHC.Tc.Types.Origin
( SkolemInfo, unkSkol
, FixedRuntimeRepOrigin, FixedRuntimeRepContext )
import GHC.Driver.Session
import GHC.Core.FVs
import GHC.Types.Name as Name
import GHC.Types.Name.Set
import GHC.Builtin.Names
import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey
, listTyCon, constraintKind )
import GHC.Types.Basic
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Data.List.SetOps ( getNth, findDupsEq )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Error( Validity'(..) )
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef
import Data.List.NonEmpty( NonEmpty(..) )
import Data.List ( partition )
import GHC.Generics ( Generic )
type TcCoVar = CoVar
type TcType = Type
type TcTyCoVar = Var
type TcTypeFRR = TcType
type TcTyVarBinder = TyVarBinder
type TcInvisTVBinder = InvisTVBinder
type TcReqTVBinder = ReqTVBinder
type TcTyCon = TyCon
type MonoTcTyCon = TcTyCon
type PolyTcTyCon = TcTyCon
type TcTyConBinder = TyConBinder
type TcPredType = PredType
type TcThetaType = ThetaType
type TcSigmaType = TcType
type TcSigmaTypeFRR = TcSigmaType
type TcRhoType = TcType
type TcTauType = TcType
type TcKind = Kind
type TcTyVarSet = TyVarSet
type TcTyCoVarSet = TyCoVarSet
type TcDTyVarSet = DTyVarSet
type TcDTyCoVarSet = DTyCoVarSet
data ExpType = Check TcType
| Infer !InferResult
data InferResult
= IR { InferResult -> Unique
ir_uniq :: Unique
, InferResult -> TcLevel
ir_lvl :: TcLevel
, InferResult -> Maybe FixedRuntimeRepContext
ir_frr :: Maybe FixedRuntimeRepContext
, InferResult -> IORef (Maybe Type)
ir_ref :: IORef (Maybe TcType) }
type ExpSigmaType = ExpType
type ExpTypeFRR = ExpType
type ExpSigmaTypeFRR = ExpTypeFRR
type ExpRhoType = ExpType
instance Outputable ExpType where
ppr :: ExpType -> SDoc
ppr (Check Type
ty) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Check" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
ppr (Infer InferResult
ir) = InferResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr InferResult
ir
instance Outputable InferResult where
ppr :: InferResult -> SDoc
ppr (IR { ir_uniq :: InferResult -> Unique
ir_uniq = Unique
u, ir_lvl :: InferResult -> TcLevel
ir_lvl = TcLevel
lvl, ir_frr :: InferResult -> Maybe FixedRuntimeRepContext
ir_frr = Maybe FixedRuntimeRepContext
mb_frr })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Infer" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
mb_frr_text SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
lvl)
where
mb_frr_text :: SDoc
mb_frr_text = case Maybe FixedRuntimeRepContext
mb_frr of
Just FixedRuntimeRepContext
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FRR"
Maybe FixedRuntimeRepContext
Nothing -> SDoc
forall doc. IsOutput doc => doc
empty
mkCheckExpType :: TcType -> ExpType
mkCheckExpType :: Type -> ExpType
mkCheckExpType = Type -> ExpType
Check
data SyntaxOpType
= SynAny
| SynRho
| SynList
| SynFun SyntaxOpType SyntaxOpType
| SynType ExpType
infixr 0 `SynFun`
synKnownType :: TcType -> SyntaxOpType
synKnownType :: Type -> SyntaxOpType
synKnownType = ExpType -> SyntaxOpType
SynType (ExpType -> SyntaxOpType)
-> (Type -> ExpType) -> Type -> SyntaxOpType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ExpType
mkCheckExpType
mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType
mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType
mkSynFunTys [SyntaxOpType]
arg_tys ExpType
res_ty = (SyntaxOpType -> SyntaxOpType -> SyntaxOpType)
-> SyntaxOpType -> [SyntaxOpType] -> SyntaxOpType
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SyntaxOpType -> SyntaxOpType -> SyntaxOpType
SynFun (ExpType -> SyntaxOpType
SynType ExpType
res_ty) [SyntaxOpType]
arg_tys
data TcTyVarDetails
= SkolemTv
SkolemInfo
TcLevel
Bool
| RuntimeUnk
| MetaTv { TcTyVarDetails -> MetaInfo
mtv_info :: MetaInfo
, TcTyVarDetails -> IORef MetaDetails
mtv_ref :: IORef MetaDetails
, TcTyVarDetails -> TcLevel
mtv_tclvl :: TcLevel }
vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails
vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails
vanillaSkolemTvUnk = SkolemInfo -> TcLevel -> Bool -> TcTyVarDetails
SkolemTv SkolemInfo
HasCallStack => SkolemInfo
unkSkol TcLevel
topTcLevel Bool
False
instance Outputable TcTyVarDetails where
ppr :: TcTyVarDetails -> SDoc
ppr = TcTyVarDetails -> SDoc
pprTcTyVarDetails
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
pprTcTyVarDetails (RuntimeUnk {}) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rt"
pprTcTyVarDetails (SkolemTv SkolemInfo
_sk TcLevel
lvl Bool
True) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ssk" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
lvl
pprTcTyVarDetails (SkolemTv SkolemInfo
_sk TcLevel
lvl Bool
False) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sk" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
lvl
pprTcTyVarDetails (MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info, mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tclvl })
= MetaInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaInfo
info SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl
data MetaDetails
= Flexi
| Indirect TcType
data MetaInfo
= TauTv
| TyVarTv
| RuntimeUnkTv
| CycleBreakerTv
| ConcreteTv ConcreteTvOrigin
instance Outputable MetaDetails where
ppr :: MetaDetails -> SDoc
ppr MetaDetails
Flexi = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Flexi"
ppr (Indirect Type
ty) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Indirect" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty
instance Outputable MetaInfo where
ppr :: MetaInfo -> SDoc
ppr MetaInfo
TauTv = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tau"
ppr MetaInfo
TyVarTv = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tyv"
ppr MetaInfo
RuntimeUnkTv = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rutv"
ppr MetaInfo
CycleBreakerTv = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cbv"
ppr (ConcreteTv {}) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"conc"
data ConcreteTvOrigin
= ConcreteFRR FixedRuntimeRepOrigin
newtype TcLevel = TcLevel Int deriving( TcLevel -> TcLevel -> Bool
(TcLevel -> TcLevel -> Bool)
-> (TcLevel -> TcLevel -> Bool) -> Eq TcLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TcLevel -> TcLevel -> Bool
== :: TcLevel -> TcLevel -> Bool
$c/= :: TcLevel -> TcLevel -> Bool
/= :: TcLevel -> TcLevel -> Bool
Eq, Eq TcLevel
Eq TcLevel =>
(TcLevel -> TcLevel -> Ordering)
-> (TcLevel -> TcLevel -> Bool)
-> (TcLevel -> TcLevel -> Bool)
-> (TcLevel -> TcLevel -> Bool)
-> (TcLevel -> TcLevel -> Bool)
-> (TcLevel -> TcLevel -> TcLevel)
-> (TcLevel -> TcLevel -> TcLevel)
-> Ord TcLevel
TcLevel -> TcLevel -> Bool
TcLevel -> TcLevel -> Ordering
TcLevel -> TcLevel -> TcLevel
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TcLevel -> TcLevel -> Ordering
compare :: TcLevel -> TcLevel -> Ordering
$c< :: TcLevel -> TcLevel -> Bool
< :: TcLevel -> TcLevel -> Bool
$c<= :: TcLevel -> TcLevel -> Bool
<= :: TcLevel -> TcLevel -> Bool
$c> :: TcLevel -> TcLevel -> Bool
> :: TcLevel -> TcLevel -> Bool
$c>= :: TcLevel -> TcLevel -> Bool
>= :: TcLevel -> TcLevel -> Bool
$cmax :: TcLevel -> TcLevel -> TcLevel
max :: TcLevel -> TcLevel -> TcLevel
$cmin :: TcLevel -> TcLevel -> TcLevel
min :: TcLevel -> TcLevel -> TcLevel
Ord )
maxTcLevel :: TcLevel -> TcLevel -> TcLevel
maxTcLevel :: TcLevel -> TcLevel -> TcLevel
maxTcLevel (TcLevel Arity
a) (TcLevel Arity
b) = Arity -> TcLevel
TcLevel (Arity
a Arity -> Arity -> Arity
forall a. Ord a => a -> a -> a
`max` Arity
b)
topTcLevel :: TcLevel
topTcLevel :: TcLevel
topTcLevel = Arity -> TcLevel
TcLevel Arity
0
isTopTcLevel :: TcLevel -> Bool
isTopTcLevel :: TcLevel -> Bool
isTopTcLevel (TcLevel Arity
0) = Bool
True
isTopTcLevel TcLevel
_ = Bool
False
pushTcLevel :: TcLevel -> TcLevel
pushTcLevel :: TcLevel -> TcLevel
pushTcLevel (TcLevel Arity
us) = Arity -> TcLevel
TcLevel (Arity
us Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1)
strictlyDeeperThan :: TcLevel -> TcLevel -> Bool
strictlyDeeperThan :: TcLevel -> TcLevel -> Bool
strictlyDeeperThan (TcLevel Arity
tv_tclvl) (TcLevel Arity
ctxt_tclvl)
= Arity
tv_tclvl Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
ctxt_tclvl
deeperThanOrSame :: TcLevel -> TcLevel -> Bool
deeperThanOrSame :: TcLevel -> TcLevel -> Bool
deeperThanOrSame (TcLevel Arity
tv_tclvl) (TcLevel Arity
ctxt_tclvl)
= Arity
tv_tclvl Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
>= Arity
ctxt_tclvl
sameDepthAs :: TcLevel -> TcLevel -> Bool
sameDepthAs :: TcLevel -> TcLevel -> Bool
sameDepthAs (TcLevel Arity
ctxt_tclvl) (TcLevel Arity
tv_tclvl)
= Arity
ctxt_tclvl Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
tv_tclvl
checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool
checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool
checkTcLevelInvariant (TcLevel Arity
ctxt_tclvl) (TcLevel Arity
tv_tclvl)
= Arity
ctxt_tclvl Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
>= Arity
tv_tclvl
tcTyVarLevel :: TcTyVar -> TcLevel
tcTyVarLevel :: Var -> TcLevel
tcTyVarLevel Var
tv
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tv_lvl } -> TcLevel
tv_lvl
SkolemTv SkolemInfo
_ TcLevel
tv_lvl Bool
_ -> TcLevel
tv_lvl
TcTyVarDetails
RuntimeUnk -> TcLevel
topTcLevel
tcTypeLevel :: TcType -> TcLevel
tcTypeLevel :: Type -> TcLevel
tcTypeLevel Type
ty
= (Var -> TcLevel -> TcLevel) -> TcLevel -> DVarSet -> TcLevel
forall a. (Var -> a -> a) -> a -> DVarSet -> a
nonDetStrictFoldDVarSet Var -> TcLevel -> TcLevel
add TcLevel
topTcLevel (Type -> DVarSet
tyCoVarsOfTypeDSet Type
ty)
where
add :: Var -> TcLevel -> TcLevel
add Var
v TcLevel
lvl
| Var -> Bool
isTcTyVar Var
v = TcLevel
lvl TcLevel -> TcLevel -> TcLevel
`maxTcLevel` Var -> TcLevel
tcTyVarLevel Var
v
| Bool
otherwise = TcLevel
lvl
instance Outputable TcLevel where
ppr :: TcLevel -> SDoc
ppr (TcLevel Arity
us) = Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
us
tcTyFamInsts :: Type -> [(TyCon, [Type])]
tcTyFamInsts :: Type -> [(TyCon, [Type])]
tcTyFamInsts = ((Bool, TyCon, [Type]) -> (TyCon, [Type]))
-> [(Bool, TyCon, [Type])] -> [(TyCon, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
_,TyCon
b,[Type]
c) -> (TyCon
b,[Type]
c)) ([(Bool, TyCon, [Type])] -> [(TyCon, [Type])])
-> (Type -> [(Bool, TyCon, [Type])]) -> Type -> [(TyCon, [Type])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVis
tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVis = Bool -> Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVisX Bool
False
tcTyFamInstsAndVisX
:: Bool
-> Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVisX :: Bool -> Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVisX = Bool -> Type -> [(Bool, TyCon, [Type])]
go
where
go :: Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty
| Just Type
exp_ty <- Type -> Maybe Type
coreView Type
ty = Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
exp_ty
go Bool
_ (TyVarTy Var
_) = []
go Bool
is_invis_arg (TyConApp TyCon
tc [Type]
tys)
| TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
= [(Bool
is_invis_arg, TyCon
tc, Arity -> [Type] -> [Type]
forall a. Arity -> [a] -> [a]
take (TyCon -> Arity
tyConArity TyCon
tc) [Type]
tys)]
| Bool
otherwise
= Bool -> TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVisX Bool
is_invis_arg TyCon
tc [Type]
tys
go Bool
_ (LitTy {}) = []
go Bool
is_invis_arg (ForAllTy ForAllTyBinder
bndr Type
ty) = Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg (ForAllTyBinder -> Type
forall argf. VarBndr Var argf -> Type
binderType ForAllTyBinder
bndr)
[(Bool, TyCon, [Type])]
-> [(Bool, TyCon, [Type])] -> [(Bool, TyCon, [Type])]
forall a. [a] -> [a] -> [a]
++ Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty
go Bool
is_invis_arg (FunTy FunTyFlag
_ Type
w Type
ty1 Type
ty2) = Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
w
[(Bool, TyCon, [Type])]
-> [(Bool, TyCon, [Type])] -> [(Bool, TyCon, [Type])]
forall a. [a] -> [a] -> [a]
++ Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty1
[(Bool, TyCon, [Type])]
-> [(Bool, TyCon, [Type])] -> [(Bool, TyCon, [Type])]
forall a. [a] -> [a] -> [a]
++ Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty2
go Bool
is_invis_arg ty :: Type
ty@(AppTy Type
_ Type
_) =
let (Type
ty_head, [Type]
ty_args) = Type -> (Type, [Type])
splitAppTys Type
ty
ty_arg_flags :: [ForAllTyFlag]
ty_arg_flags = Type -> [Type] -> [ForAllTyFlag]
appTyForAllTyFlags Type
ty_head [Type]
ty_args
in Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty_head
[(Bool, TyCon, [Type])]
-> [(Bool, TyCon, [Type])] -> [(Bool, TyCon, [Type])]
forall a. [a] -> [a] -> [a]
++ [[(Bool, TyCon, [Type])]] -> [(Bool, TyCon, [Type])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ForAllTyFlag -> Type -> [(Bool, TyCon, [Type])])
-> [ForAllTyFlag] -> [Type] -> [[(Bool, TyCon, [Type])]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ForAllTyFlag
flag -> Bool -> Type -> [(Bool, TyCon, [Type])]
go (ForAllTyFlag -> Bool
isInvisibleForAllTyFlag ForAllTyFlag
flag))
[ForAllTyFlag]
ty_arg_flags [Type]
ty_args)
go Bool
is_invis_arg (CastTy Type
ty KindCoercion
_) = Bool -> Type -> [(Bool, TyCon, [Type])]
go Bool
is_invis_arg Type
ty
go Bool
_ (CoercionTy KindCoercion
_) = []
tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVis = Bool -> TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVisX Bool
False
tcTyConAppTyFamInstsAndVisX
:: Bool
-> TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVisX :: Bool -> TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVisX Bool
is_invis_arg TyCon
tc [Type]
tys =
let ([Type]
invis_tys, [Type]
vis_tys) = TyCon -> [Type] -> ([Type], [Type])
partitionInvisibleTypes TyCon
tc [Type]
tys
in [[(Bool, TyCon, [Type])]] -> [(Bool, TyCon, [Type])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Bool, TyCon, [Type])]] -> [(Bool, TyCon, [Type])])
-> [[(Bool, TyCon, [Type])]] -> [(Bool, TyCon, [Type])]
forall a b. (a -> b) -> a -> b
$ (Type -> [(Bool, TyCon, [Type])])
-> [Type] -> [[(Bool, TyCon, [Type])]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVisX Bool
True) [Type]
invis_tys
[[(Bool, TyCon, [Type])]]
-> [[(Bool, TyCon, [Type])]] -> [[(Bool, TyCon, [Type])]]
forall a. [a] -> [a] -> [a]
++ (Type -> [(Bool, TyCon, [Type])])
-> [Type] -> [[(Bool, TyCon, [Type])]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVisX Bool
is_invis_arg) [Type]
vis_tys
isTyFamFree :: Type -> Bool
isTyFamFree :: Type -> Bool
isTyFamFree = [(TyCon, [Type])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(TyCon, [Type])] -> Bool)
-> (Type -> [(TyCon, [Type])]) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [(TyCon, [Type])]
tcTyFamInsts
any_rewritable :: EqRel
-> (EqRel -> TcTyVar -> Bool)
-> (EqRel -> TyCon -> [TcType] -> Bool)
-> (TyCon -> Bool)
-> TcType -> Bool
{-# INLINE any_rewritable #-}
any_rewritable :: EqRel
-> (EqRel -> Var -> Bool)
-> (EqRel -> TyCon -> [Type] -> Bool)
-> (TyCon -> Bool)
-> Type
-> Bool
any_rewritable EqRel
role EqRel -> Var -> Bool
tv_pred EqRel -> TyCon -> [Type] -> Bool
tc_pred TyCon -> Bool
should_expand
= EqRel -> VarSet -> Type -> Bool
go EqRel
role VarSet
emptyVarSet
where
go_tv :: EqRel -> VarSet -> Var -> Bool
go_tv EqRel
rl VarSet
bvs Var
tv | Var
tv Var -> VarSet -> Bool
`elemVarSet` VarSet
bvs = Bool
False
| Bool
otherwise = EqRel -> Var -> Bool
tv_pred EqRel
rl Var
tv
go :: EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs ty :: Type
ty@(TyConApp TyCon
tc [Type]
tys)
| TyCon -> Bool
isTypeSynonymTyCon TyCon
tc
, TyCon -> Bool
should_expand TyCon
tc
, Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
= EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs Type
ty'
| EqRel -> TyCon -> [Type] -> Bool
tc_pred EqRel
rl TyCon
tc [Type]
tys
= Bool
True
| Bool
otherwise
= EqRel -> VarSet -> TyCon -> [Type] -> Bool
go_tc EqRel
rl VarSet
bvs TyCon
tc [Type]
tys
go EqRel
rl VarSet
bvs (TyVarTy Var
tv) = EqRel -> VarSet -> Var -> Bool
go_tv EqRel
rl VarSet
bvs Var
tv
go EqRel
_ VarSet
_ (LitTy {}) = Bool
False
go EqRel
rl VarSet
bvs (AppTy Type
fun Type
arg) = EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs Type
fun Bool -> Bool -> Bool
|| EqRel -> VarSet -> Type -> Bool
go EqRel
NomEq VarSet
bvs Type
arg
go EqRel
rl VarSet
bvs (FunTy FunTyFlag
_ Type
w Type
arg Type
res) = EqRel -> VarSet -> Type -> Bool
go EqRel
NomEq VarSet
bvs Type
arg_rep Bool -> Bool -> Bool
|| EqRel -> VarSet -> Type -> Bool
go EqRel
NomEq VarSet
bvs Type
res_rep Bool -> Bool -> Bool
||
EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs Type
arg Bool -> Bool -> Bool
|| EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs Type
res Bool -> Bool -> Bool
|| EqRel -> VarSet -> Type -> Bool
go EqRel
NomEq VarSet
bvs Type
w
where arg_rep :: Type
arg_rep = (() :: Constraint) => Type -> Type
Type -> Type
getRuntimeRep Type
arg
res_rep :: Type
res_rep = (() :: Constraint) => Type -> Type
Type -> Type
getRuntimeRep Type
res
go EqRel
rl VarSet
bvs (ForAllTy ForAllTyBinder
tv Type
ty) = EqRel -> VarSet -> Type -> Bool
go EqRel
rl (VarSet
bvs VarSet -> Var -> VarSet
`extendVarSet` ForAllTyBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar ForAllTyBinder
tv) Type
ty
go EqRel
rl VarSet
bvs (CastTy Type
ty KindCoercion
_) = EqRel -> VarSet -> Type -> Bool
go EqRel
rl VarSet
bvs Type
ty
go EqRel
_ VarSet
_ (CoercionTy KindCoercion
_) = Bool
False
go_tc :: EqRel -> VarSet -> TyCon -> [Type] -> Bool
go_tc EqRel
NomEq VarSet
bvs TyCon
_ [Type]
tys = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (EqRel -> VarSet -> Type -> Bool
go EqRel
NomEq VarSet
bvs) [Type]
tys
go_tc EqRel
ReprEq VarSet
bvs TyCon
tc [Type]
tys = ((Role, Type) -> Bool) -> [(Role, Type)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (VarSet -> (Role, Type) -> Bool
go_arg VarSet
bvs)
(TyCon -> [Role]
tyConRoleListRepresentational TyCon
tc [Role] -> [Type] -> [(Role, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
tys)
go_arg :: VarSet -> (Role, Type) -> Bool
go_arg VarSet
bvs (Role
Nominal, Type
ty) = EqRel -> VarSet -> Type -> Bool
go EqRel
NomEq VarSet
bvs Type
ty
go_arg VarSet
bvs (Role
Representational, Type
ty) = EqRel -> VarSet -> Type -> Bool
go EqRel
ReprEq VarSet
bvs Type
ty
go_arg VarSet
_ (Role
Phantom, Type
_) = Bool
False
anyRewritableTyVar :: EqRel
-> (EqRel -> TcTyVar -> Bool)
-> TcType -> Bool
anyRewritableTyVar :: EqRel -> (EqRel -> Var -> Bool) -> Type -> Bool
anyRewritableTyVar EqRel
role EqRel -> Var -> Bool
pred
= EqRel
-> (EqRel -> Var -> Bool)
-> (EqRel -> TyCon -> [Type] -> Bool)
-> (TyCon -> Bool)
-> Type
-> Bool
any_rewritable EqRel
role EqRel -> Var -> Bool
pred
(\ EqRel
_ TyCon
_ [Type]
_ -> Bool
False)
(\ TyCon
_ -> Bool
False)
anyRewritableTyFamApp :: EqRel
-> (EqRel -> TyCon -> [TcType] -> Bool)
-> TcType -> Bool
anyRewritableTyFamApp :: EqRel -> (EqRel -> TyCon -> [Type] -> Bool) -> Type -> Bool
anyRewritableTyFamApp EqRel
role EqRel -> TyCon -> [Type] -> Bool
check_tyconapp
= EqRel
-> (EqRel -> Var -> Bool)
-> (EqRel -> TyCon -> [Type] -> Bool)
-> (TyCon -> Bool)
-> Type
-> Bool
any_rewritable EqRel
role (\ EqRel
_ Var
_ -> Bool
False) EqRel -> TyCon -> [Type] -> Bool
check_tyconapp (Bool -> Bool
not (Bool -> Bool) -> (TyCon -> Bool) -> TyCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Bool
isFamFreeTyCon)
exactTyCoVarsOfType :: Type -> TyCoVarSet
exactTyCoVarsOfTypes :: [Type] -> TyCoVarSet
exactTyCoVarsOfType :: Type -> VarSet
exactTyCoVarsOfType Type
ty = Endo VarSet -> VarSet
runTyCoVars (Type -> Endo VarSet
exact_ty Type
ty)
exactTyCoVarsOfTypes :: [Type] -> VarSet
exactTyCoVarsOfTypes [Type]
tys = Endo VarSet -> VarSet
runTyCoVars ([Type] -> Endo VarSet
exact_tys [Type]
tys)
exact_ty :: Type -> Endo TyCoVarSet
exact_tys :: [Type] -> Endo TyCoVarSet
(Type -> Endo VarSet
exact_ty, [Type] -> Endo VarSet
exact_tys, KindCoercion -> Endo VarSet
_, [KindCoercion] -> Endo VarSet
_) = TyCoFolder VarSet (Endo VarSet)
-> VarSet
-> (Type -> Endo VarSet, [Type] -> Endo VarSet,
KindCoercion -> Endo VarSet, [KindCoercion] -> Endo VarSet)
forall a env.
Monoid a =>
TyCoFolder env a
-> env
-> (Type -> a, [Type] -> a, KindCoercion -> a, [KindCoercion] -> a)
foldTyCo TyCoFolder VarSet (Endo VarSet)
exactTcvFolder VarSet
emptyVarSet
exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)
exactTcvFolder :: TyCoFolder VarSet (Endo VarSet)
exactTcvFolder = TyCoFolder VarSet (Endo VarSet)
deepTcvFolder { tcf_view = coreView }
tcIsTcTyVar :: TcTyVar -> Bool
tcIsTcTyVar :: Var -> Bool
tcIsTcTyVar Var
tv = Var -> Bool
isTyVar Var
tv
isPromotableMetaTyVar :: TcTyVar -> Bool
isPromotableMetaTyVar :: Var -> Bool
isPromotableMetaTyVar Var
tv
| Var -> Bool
isTyVar Var
tv
, MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } <- Var -> TcTyVarDetails
tcTyVarDetails Var
tv
= MetaInfo -> Bool
isTouchableInfo MetaInfo
info
| Bool
otherwise
= Bool
False
isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isTouchableMetaTyVar :: TcLevel -> Var -> Bool
isTouchableMetaTyVar TcLevel
ctxt_tclvl Var
tv
| Var -> Bool
isTyVar Var
tv
, MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tv_tclvl, mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } <- Var -> TcTyVarDetails
tcTyVarDetails Var
tv
, MetaInfo -> Bool
isTouchableInfo MetaInfo
info
= Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TcLevel -> TcLevel -> Bool
checkTcLevelInvariant TcLevel
ctxt_tclvl TcLevel
tv_tclvl)
(Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tv SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tv_tclvl SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
ctxt_tclvl) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
TcLevel
tv_tclvl TcLevel -> TcLevel -> Bool
`sameDepthAs` TcLevel
ctxt_tclvl
| Bool
otherwise = Bool
False
isImmutableTyVar :: TyVar -> Bool
isImmutableTyVar :: Var -> Bool
isImmutableTyVar Var
tv = Var -> Bool
isSkolemTyVar Var
tv
isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
isMetaTyVar, isAmbiguousTyVar, isCycleBreakerTyVar :: TcTyVar -> Bool
isTyConableTyVar :: Var -> Bool
isTyConableTyVar Var
tv
| Var -> Bool
isTyVar Var
tv
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
TyVarTv } -> Bool
False
TcTyVarDetails
_ -> Bool
True
| Bool
otherwise = Bool
True
isSkolemTyVar :: Var -> Bool
isSkolemTyVar Var
tv
= Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Var -> Bool
tcIsTcTyVar Var
tv) (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tv) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
MetaTv {} -> Bool
False
TcTyVarDetails
_other -> Bool
True
skolemSkolInfo :: TcTyVar -> SkolemInfo
skolemSkolInfo :: Var -> SkolemInfo
skolemSkolInfo Var
tv
= Bool -> SkolemInfo -> SkolemInfo
forall a. HasCallStack => Bool -> a -> a
assert (Var -> Bool
isSkolemTyVar Var
tv) (SkolemInfo -> SkolemInfo) -> SkolemInfo -> SkolemInfo
forall a b. (a -> b) -> a -> b
$
case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
SkolemTv SkolemInfo
skol_info TcLevel
_ Bool
_ -> SkolemInfo
skol_info
TcTyVarDetails
RuntimeUnk -> String -> SkolemInfo
forall a. HasCallStack => String -> a
panic String
"RuntimeUnk"
MetaTv {} -> String -> SkolemInfo
forall a. HasCallStack => String -> a
panic String
"skolemSkolInfo"
isOverlappableTyVar :: Var -> Bool
isOverlappableTyVar Var
tv
| Var -> Bool
isTyVar Var
tv
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
SkolemTv SkolemInfo
_ TcLevel
_ Bool
overlappable -> Bool
overlappable
TcTyVarDetails
_ -> Bool
False
| Bool
otherwise = Bool
False
isMetaTyVar :: Var -> Bool
isMetaTyVar Var
tv
| Var -> Bool
isTyVar Var
tv
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
MetaTv {} -> Bool
True
TcTyVarDetails
_ -> Bool
False
| Bool
otherwise = Bool
False
isAmbiguousTyVar :: Var -> Bool
isAmbiguousTyVar Var
tv
| Var -> Bool
isTyVar Var
tv
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
MetaTv {} -> Bool
True
RuntimeUnk {} -> Bool
True
TcTyVarDetails
_ -> Bool
False
| Bool
otherwise = Bool
False
isCycleBreakerTyVar :: Var -> Bool
isCycleBreakerTyVar Var
tv
| Var -> Bool
isTyVar Var
tv
, MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
CycleBreakerTv } <- Var -> TcTyVarDetails
tcTyVarDetails Var
tv
= Bool
True
| Bool
otherwise
= Bool
False
isConcreteTyVar_maybe :: TcTyVar -> Maybe ConcreteTvOrigin
isConcreteTyVar_maybe :: Var -> Maybe ConcreteTvOrigin
isConcreteTyVar_maybe Var
tv
| Var -> Bool
isTcTyVar Var
tv
, MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = ConcreteTv ConcreteTvOrigin
conc_orig } <- Var -> TcTyVarDetails
tcTyVarDetails Var
tv
= ConcreteTvOrigin -> Maybe ConcreteTvOrigin
forall a. a -> Maybe a
Just ConcreteTvOrigin
conc_orig
| Bool
otherwise
= Maybe ConcreteTvOrigin
forall a. Maybe a
Nothing
isConcreteTyVar :: TcTyVar -> Bool
isConcreteTyVar :: Var -> Bool
isConcreteTyVar = Maybe ConcreteTvOrigin -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ConcreteTvOrigin -> Bool)
-> (Var -> Maybe ConcreteTvOrigin) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Maybe ConcreteTvOrigin
isConcreteTyVar_maybe
isConcreteTyVarTy :: TcType -> Bool
isConcreteTyVarTy :: Type -> Bool
isConcreteTyVarTy = Maybe (Var, ConcreteTvOrigin) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Var, ConcreteTvOrigin) -> Bool)
-> (Type -> Maybe (Var, ConcreteTvOrigin)) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (Var, ConcreteTvOrigin)
isConcreteTyVarTy_maybe
isConcreteTyVarTy_maybe :: TcType -> Maybe (TcTyVar, ConcreteTvOrigin)
isConcreteTyVarTy_maybe :: Type -> Maybe (Var, ConcreteTvOrigin)
isConcreteTyVarTy_maybe (TyVarTy Var
tv) = (Var
tv, ) (ConcreteTvOrigin -> (Var, ConcreteTvOrigin))
-> Maybe ConcreteTvOrigin -> Maybe (Var, ConcreteTvOrigin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var -> Maybe ConcreteTvOrigin
isConcreteTyVar_maybe Var
tv
isConcreteTyVarTy_maybe Type
_ = Maybe (Var, ConcreteTvOrigin)
forall a. Maybe a
Nothing
isMetaTyVarTy :: TcType -> Bool
isMetaTyVarTy :: Type -> Bool
isMetaTyVarTy (TyVarTy Var
tv) = Var -> Bool
isMetaTyVar Var
tv
isMetaTyVarTy Type
_ = Bool
False
metaTyVarInfo :: TcTyVar -> MetaInfo
metaTyVarInfo :: Var -> MetaInfo
metaTyVarInfo Var
tv
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } -> MetaInfo
info
TcTyVarDetails
_ -> String -> SDoc -> MetaInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"metaTyVarInfo" (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tv)
isTouchableInfo :: MetaInfo -> Bool
isTouchableInfo :: MetaInfo -> Bool
isTouchableInfo MetaInfo
info
| MetaInfo
CycleBreakerTv <- MetaInfo
info = Bool
False
| Bool
otherwise = Bool
True
metaTyVarTcLevel :: TcTyVar -> TcLevel
metaTyVarTcLevel :: Var -> TcLevel
metaTyVarTcLevel Var
tv
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tclvl } -> TcLevel
tclvl
TcTyVarDetails
_ -> String -> SDoc -> TcLevel
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"metaTyVarTcLevel" (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tv)
metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel
metaTyVarTcLevel_maybe :: Var -> Maybe TcLevel
metaTyVarTcLevel_maybe Var
tv
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tclvl } -> TcLevel -> Maybe TcLevel
forall a. a -> Maybe a
Just TcLevel
tclvl
TcTyVarDetails
_ -> Maybe TcLevel
forall a. Maybe a
Nothing
metaTyVarRef :: TyVar -> IORef MetaDetails
metaTyVarRef :: Var -> IORef MetaDetails
metaTyVarRef Var
tv
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
MetaTv { mtv_ref :: TcTyVarDetails -> IORef MetaDetails
mtv_ref = IORef MetaDetails
ref } -> IORef MetaDetails
ref
TcTyVarDetails
_ -> String -> SDoc -> IORef MetaDetails
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"metaTyVarRef" (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tv)
setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar
setMetaTyVarTcLevel :: Var -> TcLevel -> Var
setMetaTyVarTcLevel Var
tv TcLevel
tclvl
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
details :: TcTyVarDetails
details@(MetaTv {}) -> Var -> TcTyVarDetails -> Var
setTcTyVarDetails Var
tv (TcTyVarDetails
details { mtv_tclvl = tclvl })
TcTyVarDetails
_ -> String -> SDoc -> Var
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"metaTyVarTcLevel" (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tv)
isTyVarTyVar :: Var -> Bool
isTyVarTyVar :: Var -> Bool
isTyVarTyVar Var
tv
= case Var -> TcTyVarDetails
tcTyVarDetails Var
tv of
MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
TyVarTv } -> Bool
True
TcTyVarDetails
_ -> Bool
False
isFlexi, isIndirect :: MetaDetails -> Bool
isFlexi :: MetaDetails -> Bool
isFlexi MetaDetails
Flexi = Bool
True
isFlexi MetaDetails
_ = Bool
False
isIndirect :: MetaDetails -> Bool
isIndirect (Indirect Type
_) = Bool
True
isIndirect MetaDetails
_ = Bool
False
isRuntimeUnkSkol :: TyVar -> Bool
isRuntimeUnkSkol :: Var -> Bool
isRuntimeUnkSkol Var
x
| TcTyVarDetails
RuntimeUnk <- Var -> TcTyVarDetails
tcTyVarDetails Var
x = Bool
True
| Bool
otherwise = Bool
False
mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)]
mkTyVarNamePairs :: [Var] -> [(Name, Var)]
mkTyVarNamePairs [Var]
tvs = [(Var -> Name
tyVarName Var
tv, Var
tv) | Var
tv <- [Var]
tvs]
findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)]
findDupTyVarTvs :: [(Name, Var)] -> [(Name, Name)]
findDupTyVarTvs [(Name, Var)]
prs
= (NonEmpty (Name, Var) -> [(Name, Name)])
-> [NonEmpty (Name, Var)] -> [(Name, Name)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (Name, Var) -> [(Name, Name)]
forall {b} {b}. NonEmpty (b, b) -> [(b, b)]
mk_result_prs ([NonEmpty (Name, Var)] -> [(Name, Name)])
-> [NonEmpty (Name, Var)] -> [(Name, Name)]
forall a b. (a -> b) -> a -> b
$
((Name, Var) -> (Name, Var) -> Bool)
-> [(Name, Var)] -> [NonEmpty (Name, Var)]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (Name, Var) -> (Name, Var) -> Bool
forall {a} {a} {a}. Eq a => (a, a) -> (a, a) -> Bool
eq_snd [(Name, Var)]
prs
where
eq_snd :: (a, a) -> (a, a) -> Bool
eq_snd (a
_,a
tv1) (a
_,a
tv2) = a
tv1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
tv2
mk_result_prs :: NonEmpty (b, b) -> [(b, b)]
mk_result_prs ((b
n1,b
_) :| [(b, b)]
xs) = ((b, b) -> (b, b)) -> [(b, b)] -> [(b, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(b
n2,b
_) -> (b
n1,b
n2)) [(b, b)]
xs
ambigTkvsOfTy :: TcType -> ([Var],[Var])
ambigTkvsOfTy :: Type -> ([Var], [Var])
ambigTkvsOfTy Type
ty
= (Var -> Bool) -> [Var] -> ([Var], [Var])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Var -> VarSet -> Bool
`elemVarSet` VarSet
dep_tkv_set) [Var]
ambig_tkvs
where
tkvs :: [Var]
tkvs = Type -> [Var]
tyCoVarsOfTypeList Type
ty
ambig_tkvs :: [Var]
ambig_tkvs = (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
isAmbiguousTyVar [Var]
tkvs
dep_tkv_set :: VarSet
dep_tkv_set = [Type] -> VarSet
tyCoVarsOfTypes ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
tyVarKind [Var]
tkvs)
mkInfSigmaTy :: HasDebugCallStack => [TyCoVar] -> [PredType] -> Type -> Type
mkInfSigmaTy :: (() :: Constraint) => [Var] -> [Type] -> Type -> Type
mkInfSigmaTy [Var]
tyvars [Type]
theta Type
ty = [ForAllTyBinder] -> [Type] -> Type -> Type
(() :: Constraint) => [ForAllTyBinder] -> [Type] -> Type -> Type
mkSigmaTy (ForAllTyFlag -> [Var] -> [ForAllTyBinder]
forall vis. vis -> [Var] -> [VarBndr Var vis]
mkForAllTyBinders ForAllTyFlag
Inferred [Var]
tyvars) [Type]
theta Type
ty
mkSpecSigmaTy :: HasDebugCallStack => [TyVar] -> [PredType] -> Type -> Type
mkSpecSigmaTy :: (() :: Constraint) => [Var] -> [Type] -> Type -> Type
mkSpecSigmaTy [Var]
tyvars [Type]
preds Type
ty = [ForAllTyBinder] -> [Type] -> Type -> Type
(() :: Constraint) => [ForAllTyBinder] -> [Type] -> Type -> Type
mkSigmaTy (ForAllTyFlag -> [Var] -> [ForAllTyBinder]
forall vis. vis -> [Var] -> [VarBndr Var vis]
mkForAllTyBinders ForAllTyFlag
Specified [Var]
tyvars) [Type]
preds Type
ty
mkSigmaTy :: HasDebugCallStack => [ForAllTyBinder] -> [PredType] -> Type -> Type
mkSigmaTy :: (() :: Constraint) => [ForAllTyBinder] -> [Type] -> Type -> Type
mkSigmaTy [ForAllTyBinder]
bndrs [Type]
theta Type
tau = [ForAllTyBinder] -> Type -> Type
mkForAllTys [ForAllTyBinder]
bndrs ([Type] -> Type -> Type
(() :: Constraint) => [Type] -> Type -> Type
mkPhiTy [Type]
theta Type
tau)
tcMkDFunSigmaTy :: [TyVar] -> ThetaType -> Type -> Type
tcMkDFunSigmaTy :: [Var] -> [Type] -> Type -> Type
tcMkDFunSigmaTy [Var]
tvs [Type]
theta Type
res_ty
= [ForAllTyBinder] -> Type -> Type
mkForAllTys (ForAllTyFlag -> [Var] -> [ForAllTyBinder]
forall vis. vis -> [Var] -> [VarBndr Var vis]
mkForAllTyBinders ForAllTyFlag
Specified [Var]
tvs) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
(() :: Constraint) => [Type] -> Type -> Type
tcMkDFunPhiTy [Type]
theta Type
res_ty
mkPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type
mkPhiTy :: (() :: Constraint) => [Type] -> Type -> Type
mkPhiTy = [Type] -> Type -> Type
(() :: Constraint) => [Type] -> Type -> Type
mkInvisFunTys
tcMkPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type
tcMkPhiTy :: (() :: Constraint) => [Type] -> Type -> Type
tcMkPhiTy [Type]
tys Type
ty = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeOrConstraint -> Type -> Type -> Type
tcMkInvisFunTy TypeOrConstraint
TypeLike) Type
ty [Type]
tys
tcMkDFunPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type
tcMkDFunPhiTy :: (() :: Constraint) => [Type] -> Type -> Type
tcMkDFunPhiTy [Type]
preds Type
res = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeOrConstraint -> Type -> Type -> Type
tcMkInvisFunTy TypeOrConstraint
ConstraintLike) Type
res [Type]
preds
getDFunTyKey :: Type -> OccName
getDFunTyKey :: Type -> OccName
getDFunTyKey Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> OccName
getDFunTyKey Type
ty'
getDFunTyKey (TyVarTy Var
tv) = Var -> OccName
forall a. NamedThing a => a -> OccName
getOccName Var
tv
getDFunTyKey (TyConApp TyCon
tc [Type]
_) = TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tc
getDFunTyKey (LitTy TyLit
x) = TyLit -> OccName
getDFunTyLitKey TyLit
x
getDFunTyKey (AppTy Type
fun Type
_) = Type -> OccName
getDFunTyKey Type
fun
getDFunTyKey (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af }) = TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName (FunTyFlag -> TyCon
funTyFlagTyCon FunTyFlag
af)
getDFunTyKey (ForAllTy ForAllTyBinder
_ Type
t) = Type -> OccName
getDFunTyKey Type
t
getDFunTyKey (CastTy Type
ty KindCoercion
_) = Type -> OccName
getDFunTyKey Type
ty
getDFunTyKey t :: Type
t@(CoercionTy KindCoercion
_) = String -> SDoc -> OccName
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getDFunTyKey" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t)
getDFunTyLitKey :: TyLit -> OccName
getDFunTyLitKey :: TyLit -> OccName
getDFunTyLitKey (NumTyLit Integer
n) = NameSpace -> String -> OccName
mkOccName NameSpace
Name.varName (Integer -> String
forall a. Show a => a -> String
show Integer
n)
getDFunTyLitKey (StrTyLit FastString
n) = NameSpace -> String -> OccName
mkOccName NameSpace
Name.varName (FastString -> String
forall a. Show a => a -> String
show FastString
n)
getDFunTyLitKey (CharTyLit Char
n) = NameSpace -> String -> OccName
mkOccName NameSpace
Name.varName (Char -> String
forall a. Show a => a -> String
show Char
n)
tcSplitPiTys :: Type -> ([PiTyVarBinder], Type)
tcSplitPiTys :: Type -> ([PiTyVarBinder], Type)
tcSplitPiTys Type
ty
= Bool -> ([PiTyVarBinder], Type) -> ([PiTyVarBinder], Type)
forall a. HasCallStack => Bool -> a -> a
assert ((PiTyVarBinder -> Bool) -> [PiTyVarBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PiTyVarBinder -> Bool
isTyBinder (([PiTyVarBinder], Type) -> [PiTyVarBinder]
forall a b. (a, b) -> a
fst ([PiTyVarBinder], Type)
sty) )
([PiTyVarBinder], Type)
sty
where sty :: ([PiTyVarBinder], Type)
sty = Type -> ([PiTyVarBinder], Type)
splitPiTys Type
ty
tcSplitPiTy_maybe :: Type -> Maybe (PiTyVarBinder, Type)
tcSplitPiTy_maybe :: Type -> Maybe (PiTyVarBinder, Type)
tcSplitPiTy_maybe Type
ty
= Bool -> Maybe (PiTyVarBinder, Type) -> Maybe (PiTyVarBinder, Type)
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (PiTyVarBinder, Type) -> Bool
forall {b}. Maybe (PiTyVarBinder, b) -> Bool
isMaybeTyBinder Maybe (PiTyVarBinder, Type)
sty)
Maybe (PiTyVarBinder, Type)
sty
where
sty :: Maybe (PiTyVarBinder, Type)
sty = Type -> Maybe (PiTyVarBinder, Type)
splitPiTy_maybe Type
ty
isMaybeTyBinder :: Maybe (PiTyVarBinder, b) -> Bool
isMaybeTyBinder (Just (PiTyVarBinder
t,b
_)) = PiTyVarBinder -> Bool
isTyBinder PiTyVarBinder
t
isMaybeTyBinder Maybe (PiTyVarBinder, b)
_ = Bool
True
tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type)
tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (ForAllTyBinder, Type)
tcSplitForAllTyVarBinder_maybe Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (ForAllTyBinder, Type)
tcSplitForAllTyVarBinder_maybe Type
ty'
tcSplitForAllTyVarBinder_maybe (ForAllTy ForAllTyBinder
tv Type
ty) = Bool
-> ((ForAllTyBinder, Type) -> Maybe (ForAllTyBinder, Type))
-> (ForAllTyBinder, Type)
-> Maybe (ForAllTyBinder, Type)
forall a. HasCallStack => Bool -> a -> a
assert (ForAllTyBinder -> Bool
forall vis. VarBndr Var vis -> Bool
isTyVarBinder ForAllTyBinder
tv ) (ForAllTyBinder, Type) -> Maybe (ForAllTyBinder, Type)
forall a. a -> Maybe a
Just (ForAllTyBinder
tv, Type
ty)
tcSplitForAllTyVarBinder_maybe Type
_ = Maybe (ForAllTyBinder, Type)
forall a. Maybe a
Nothing
tcSplitForAllTyVars :: Type -> ([TyVar], Type)
tcSplitForAllTyVars :: Type -> ([Var], Type)
tcSplitForAllTyVars Type
ty
= Bool -> ([Var], Type) -> ([Var], Type)
forall a. HasCallStack => Bool -> a -> a
assert ((Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Var -> Bool
isTyVar (([Var], Type) -> [Var]
forall a b. (a, b) -> a
fst ([Var], Type)
sty) ) ([Var], Type)
sty
where sty :: ([Var], Type)
sty = Type -> ([Var], Type)
splitForAllTyCoVars Type
ty
tcSplitForAllInvisTyVars :: Type -> ([TyVar], Type)
tcSplitForAllInvisTyVars :: Type -> ([Var], Type)
tcSplitForAllInvisTyVars Type
ty = (ForAllTyFlag -> Bool) -> Type -> ([Var], Type)
tcSplitSomeForAllTyVars ForAllTyFlag -> Bool
isInvisibleForAllTyFlag Type
ty
tcSplitSomeForAllTyVars :: (ForAllTyFlag -> Bool) -> Type -> ([TyVar], Type)
tcSplitSomeForAllTyVars :: (ForAllTyFlag -> Bool) -> Type -> ([Var], Type)
tcSplitSomeForAllTyVars ForAllTyFlag -> Bool
argf_pred Type
ty
= Type -> Type -> [Var] -> ([Var], Type)
split Type
ty Type
ty []
where
split :: Type -> Type -> [Var] -> ([Var], Type)
split Type
_ (ForAllTy (Bndr Var
tv ForAllTyFlag
argf) Type
ty) [Var]
tvs
| ForAllTyFlag -> Bool
argf_pred ForAllTyFlag
argf = Type -> Type -> [Var] -> ([Var], Type)
split Type
ty Type
ty (Var
tvVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
tvs)
split Type
orig_ty Type
ty [Var]
tvs | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type -> [Var] -> ([Var], Type)
split Type
orig_ty Type
ty' [Var]
tvs
split Type
orig_ty Type
_ [Var]
tvs = ([Var] -> [Var]
forall a. [a] -> [a]
reverse [Var]
tvs, Type
orig_ty)
tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)
tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)
tcSplitForAllReqTVBinders Type
ty = Bool -> ([TcReqTVBinder], Type) -> ([TcReqTVBinder], Type)
forall a. HasCallStack => Bool -> a -> a
assert ((TcReqTVBinder -> Bool) -> [TcReqTVBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcReqTVBinder -> Bool
forall vis. VarBndr Var vis -> Bool
isTyVarBinder (([TcReqTVBinder], Type) -> [TcReqTVBinder]
forall a b. (a, b) -> a
fst ([TcReqTVBinder], Type)
sty) ) ([TcReqTVBinder], Type)
sty
where sty :: ([TcReqTVBinder], Type)
sty = Type -> ([TcReqTVBinder], Type)
splitForAllReqTyBinders Type
ty
tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type)
tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type)
tcSplitForAllInvisTVBinders Type
ty = Bool -> ([TcInvisTVBinder], Type) -> ([TcInvisTVBinder], Type)
forall a. HasCallStack => Bool -> a -> a
assert ((TcInvisTVBinder -> Bool) -> [TcInvisTVBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Var -> Bool
isTyVar (Var -> Bool)
-> (TcInvisTVBinder -> Var) -> TcInvisTVBinder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcInvisTVBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar) (([TcInvisTVBinder], Type) -> [TcInvisTVBinder]
forall a b. (a, b) -> a
fst ([TcInvisTVBinder], Type)
sty)) ([TcInvisTVBinder], Type)
sty
where sty :: ([TcInvisTVBinder], Type)
sty = Type -> ([TcInvisTVBinder], Type)
splitForAllInvisTyBinders Type
ty
tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type)
tcSplitForAllTyVarBinders :: Type -> ([ForAllTyBinder], Type)
tcSplitForAllTyVarBinders Type
ty = Bool -> ([ForAllTyBinder], Type) -> ([ForAllTyBinder], Type)
forall a. HasCallStack => Bool -> a -> a
assert ((ForAllTyBinder -> Bool) -> [ForAllTyBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ForAllTyBinder -> Bool
forall vis. VarBndr Var vis -> Bool
isTyVarBinder (([ForAllTyBinder], Type) -> [ForAllTyBinder]
forall a b. (a, b) -> a
fst ([ForAllTyBinder], Type)
sty)) ([ForAllTyBinder], Type)
sty
where sty :: ([ForAllTyBinder], Type)
sty = Type -> ([ForAllTyBinder], Type)
splitForAllForAllTyBinders Type
ty
tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
tcSplitPredFunTy_maybe :: Type -> Maybe (Type, Type)
tcSplitPredFunTy_maybe Type
ty
| Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (Type, Type)
tcSplitPredFunTy_maybe Type
ty'
tcSplitPredFunTy_maybe (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af, ft_arg :: Type -> Type
ft_arg = Type
arg, ft_res :: Type -> Type
ft_res = Type
res })
| FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af
= (Type, Type) -> Maybe (Type, Type)
forall a. a -> Maybe a
Just (Type
arg, Type
res)
tcSplitPredFunTy_maybe Type
_
= Maybe (Type, Type)
forall a. Maybe a
Nothing
tcSplitPhiTy :: Type -> (ThetaType, Type)
tcSplitPhiTy :: Type -> ([Type], Type)
tcSplitPhiTy Type
ty
= Type -> [Type] -> ([Type], Type)
split Type
ty []
where
split :: Type -> [Type] -> ([Type], Type)
split Type
ty [Type]
ts
= case Type -> Maybe (Type, Type)
tcSplitPredFunTy_maybe Type
ty of
Just (Type
pred, Type
ty) -> Type -> [Type] -> ([Type], Type)
split Type
ty (Type
predType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
ts)
Maybe (Type, Type)
Nothing -> ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
ts, Type
ty)
tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy :: Type -> ([Var], [Type], Type)
tcSplitSigmaTy Type
ty = case Type -> ([Var], Type)
tcSplitForAllInvisTyVars Type
ty of
([Var]
tvs, Type
rho) -> case Type -> ([Type], Type)
tcSplitPhiTy Type
rho of
([Type]
theta, Type
tau) -> ([Var]
tvs, [Type]
theta, Type
tau)
tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type)
tcSplitNestedSigmaTys :: Type -> ([Var], [Type], Type)
tcSplitNestedSigmaTys Type
ty
| ([Scaled Type]
arg_tys, Type
body_ty) <- Type -> ([Scaled Type], Type)
tcSplitFunTys Type
ty
, ([Var]
tvs1, [Type]
theta1, Type
rho1) <- Type -> ([Var], [Type], Type)
tcSplitSigmaTy Type
body_ty
, Bool -> Bool
not ([Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
tvs1 Bool -> Bool -> Bool
&& [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta1)
= let ([Var]
tvs2, [Type]
theta2, Type
rho2) = Type -> ([Var], [Type], Type)
tcSplitNestedSigmaTys Type
rho1
in ([Var]
tvs1 [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
tvs2, [Type]
theta1 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
theta2, [Scaled Type] -> Type -> Type
(() :: Constraint) => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
arg_tys Type
rho2)
| Bool
otherwise = ([], [], Type
ty)
tcTyConAppTyCon :: Type -> TyCon
tcTyConAppTyCon :: Type -> TyCon
tcTyConAppTyCon Type
ty
= case Type -> Maybe TyCon
tcTyConAppTyCon_maybe Type
ty of
Just TyCon
tc -> TyCon
tc
Maybe TyCon
Nothing -> String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcTyConAppTyCon" (Type -> SDoc
pprType Type
ty)
tcTyConAppTyCon_maybe :: Type -> Maybe TyCon
tcTyConAppTyCon_maybe :: Type -> Maybe TyCon
tcTyConAppTyCon_maybe Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe TyCon
tcTyConAppTyCon_maybe Type
ty'
tcTyConAppTyCon_maybe (TyConApp TyCon
tc [Type]
_) = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc
tcTyConAppTyCon_maybe (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af }) = TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just (FunTyFlag -> TyCon
funTyFlagTyCon FunTyFlag
af)
tcTyConAppTyCon_maybe Type
_ = Maybe TyCon
forall a. Maybe a
Nothing
tcTyConAppArgs :: Type -> [Type]
tcTyConAppArgs :: Type -> [Type]
tcTyConAppArgs Type
ty = case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
Just (TyCon
_, [Type]
args) -> [Type]
args
Maybe (TyCon, [Type])
Nothing -> String -> SDoc -> [Type]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcTyConAppArgs" (Type -> SDoc
pprType Type
ty)
tcSplitFunTys :: Type -> ([Scaled Type], Type)
tcSplitFunTys :: Type -> ([Scaled Type], Type)
tcSplitFunTys Type
ty = case Type -> Maybe (Scaled Type, Type)
tcSplitFunTy_maybe Type
ty of
Maybe (Scaled Type, Type)
Nothing -> ([], Type
ty)
Just (Scaled Type
arg,Type
res) -> (Scaled Type
argScaled Type -> [Scaled Type] -> [Scaled Type]
forall a. a -> [a] -> [a]
:[Scaled Type]
args, Type
res')
where
([Scaled Type]
args,Type
res') = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
res
tcSplitFunTy_maybe :: Type -> Maybe (Scaled Type, Type)
tcSplitFunTy_maybe :: Type -> Maybe (Scaled Type, Type)
tcSplitFunTy_maybe Type
ty
| Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (Scaled Type, Type)
tcSplitFunTy_maybe Type
ty'
tcSplitFunTy_maybe (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af, ft_mult :: Type -> Type
ft_mult = Type
w, ft_arg :: Type -> Type
ft_arg = Type
arg, ft_res :: Type -> Type
ft_res = Type
res })
| FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af = (Scaled Type, Type) -> Maybe (Scaled Type, Type)
forall a. a -> Maybe a
Just (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
w Type
arg, Type
res)
tcSplitFunTy_maybe Type
_ = Maybe (Scaled Type, Type)
forall a. Maybe a
Nothing
tcSplitFunTysN :: Arity
-> TcRhoType
-> Either Arity
([Scaled TcSigmaType],
TcSigmaType)
tcSplitFunTysN :: Arity -> Type -> Either Arity ([Scaled Type], Type)
tcSplitFunTysN Arity
n Type
ty
| Arity
n Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0
= ([Scaled Type], Type) -> Either Arity ([Scaled Type], Type)
forall a b. b -> Either a b
Right ([], Type
ty)
| Just (Scaled Type
arg,Type
res) <- Type -> Maybe (Scaled Type, Type)
tcSplitFunTy_maybe Type
ty
= case Arity -> Type -> Either Arity ([Scaled Type], Type)
tcSplitFunTysN (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) Type
res of
Left Arity
m -> Arity -> Either Arity ([Scaled Type], Type)
forall a b. a -> Either a b
Left Arity
m
Right ([Scaled Type]
args,Type
body) -> ([Scaled Type], Type) -> Either Arity ([Scaled Type], Type)
forall a b. b -> Either a b
Right (Scaled Type
argScaled Type -> [Scaled Type] -> [Scaled Type]
forall a. a -> [a] -> [a]
:[Scaled Type]
args, Type
body)
| Bool
otherwise
= Arity -> Either Arity ([Scaled Type], Type)
forall a b. a -> Either a b
Left Arity
n
tcSplitFunTy :: Type -> (Scaled Type, Type)
tcSplitFunTy :: Type -> (Scaled Type, Type)
tcSplitFunTy Type
ty = String -> Maybe (Scaled Type, Type) -> (Scaled Type, Type)
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"tcSplitFunTy" (Type -> Maybe (Scaled Type, Type)
tcSplitFunTy_maybe Type
ty)
tcFunArgTy :: Type -> Scaled Type
tcFunArgTy :: Type -> Scaled Type
tcFunArgTy Type
ty = (Scaled Type, Type) -> Scaled Type
forall a b. (a, b) -> a
fst (Type -> (Scaled Type, Type)
tcSplitFunTy Type
ty)
tcFunResultTy :: Type -> Type
tcFunResultTy :: Type -> Type
tcFunResultTy Type
ty = (Scaled Type, Type) -> Type
forall a b. (a, b) -> b
snd (Type -> (Scaled Type, Type)
tcSplitFunTy Type
ty)
tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type
tcFunResultTyN :: (() :: Constraint) => Arity -> Type -> Type
tcFunResultTyN Arity
n Type
ty
| Right ([Scaled Type]
_, Type
res_ty) <- Arity -> Type -> Either Arity ([Scaled Type], Type)
tcSplitFunTysN Arity
n Type
ty
= Type
res_ty
| Bool
otherwise
= String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcFunResultTyN" (Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty'
tcSplitAppTy_maybe Type
ty = Type -> Maybe (Type, Type)
tcSplitAppTyNoView_maybe Type
ty
tcSplitAppTy :: Type -> (Type, Type)
tcSplitAppTy :: Type -> (Type, Type)
tcSplitAppTy Type
ty = case Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty of
Just (Type, Type)
stuff -> (Type, Type)
stuff
Maybe (Type, Type)
Nothing -> String -> SDoc -> (Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSplitAppTy" (Type -> SDoc
pprType Type
ty)
tcSplitAppTys :: Type -> (Type, [Type])
tcSplitAppTys :: Type -> (Type, [Type])
tcSplitAppTys Type
ty
= Type -> [Type] -> (Type, [Type])
go Type
ty []
where
go :: Type -> [Type] -> (Type, [Type])
go Type
ty [Type]
args = case Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty of
Just (Type
ty', Type
arg) -> Type -> [Type] -> (Type, [Type])
go Type
ty' (Type
argType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args)
Maybe (Type, Type)
Nothing -> (Type
ty,[Type]
args)
tcIsTyVarTy :: Type -> Bool
tcIsTyVarTy :: Type -> Bool
tcIsTyVarTy Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
tcIsTyVarTy Type
ty'
tcIsTyVarTy (CastTy Type
ty KindCoercion
_) = Type -> Bool
tcIsTyVarTy Type
ty
tcIsTyVarTy (TyVarTy Var
_) = Bool
True
tcIsTyVarTy Type
_ = Bool
False
tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy :: Type -> ([Var], [Type], Class, [Type])
tcSplitDFunTy Type
ty
= case Type -> ([Var], Type)
tcSplitForAllInvisTyVars Type
ty of { ([Var]
tvs, Type
rho) ->
case Type -> ([Scaled Type], Type)
splitFunTys Type
rho of { ([Scaled Type]
theta, Type
tau) ->
case Type -> (Class, [Type])
tcSplitDFunHead Type
tau of { (Class
clas, [Type]
tys) ->
([Var]
tvs, (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
theta, Class
clas, [Type]
tys) }}}
tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead = (() :: Constraint) => Type -> (Class, [Type])
Type -> (Class, [Type])
getClassPredTys
tcSplitMethodTy :: Type -> ([TyVar], PredType, Type)
tcSplitMethodTy :: Type -> ([Var], Type, Type)
tcSplitMethodTy Type
ty
| ([Var]
sel_tyvars,Type
sel_rho) <- Type -> ([Var], Type)
tcSplitForAllInvisTyVars Type
ty
, Just (Type
first_pred, Type
local_meth_ty) <- Type -> Maybe (Type, Type)
tcSplitPredFunTy_maybe Type
sel_rho
= ([Var]
sel_tyvars, Type
first_pred, Type
local_meth_ty)
| Bool
otherwise
= String -> SDoc -> ([Var], Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSplitMethodTy" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
isTyVarClassPred :: PredType -> Bool
isTyVarClassPred :: Type -> Bool
isTyVarClassPred Type
ty = case Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
ty of
Just (Class
_, [Type]
tys) -> (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVarTy [Type]
tys
Maybe (Class, [Type])
_ -> Bool
False
checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool
checkValidClsArgs :: Bool -> Class -> [Type] -> Bool
checkValidClsArgs Bool
flexible_contexts Class
cls [Type]
kts
| Bool
flexible_contexts = Bool
True
| Bool
otherwise = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
hasTyVarHead [Type]
tys
where
tys :: [Type]
tys = TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [Type]
kts
hasTyVarHead :: Type -> Bool
hasTyVarHead :: Type -> Bool
hasTyVarHead Type
ty
| Type -> Bool
tcIsTyVarTy Type
ty = Bool
True
| Bool
otherwise
= case Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty of
Just (Type
ty, Type
_) -> Type -> Bool
hasTyVarHead Type
ty
Maybe (Type, Type)
Nothing -> Bool
False
evVarPred :: EvVar -> PredType
evVarPred :: Var -> Type
evVarPred Var
var = Var -> Type
varType Var
var
boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type])
boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type])
boxEqPred EqRel
eq_rel Type
ty1 Type
ty2
= case EqRel
eq_rel of
EqRel
NomEq | Bool
homo_kind -> (Class, [Type]) -> Maybe (Class, [Type])
forall a. a -> Maybe a
Just (Class
eqClass, [Type
k1, Type
ty1, Type
ty2])
| Bool
otherwise -> (Class, [Type]) -> Maybe (Class, [Type])
forall a. a -> Maybe a
Just (Class
heqClass, [Type
k1, Type
k2, Type
ty1, Type
ty2])
EqRel
ReprEq | Bool
homo_kind -> (Class, [Type]) -> Maybe (Class, [Type])
forall a. a -> Maybe a
Just (Class
coercibleClass, [Type
k1, Type
ty1, Type
ty2])
| Bool
otherwise -> Maybe (Class, [Type])
forall a. Maybe a
Nothing
where
k1 :: Type
k1 = (() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty1
k2 :: Type
k2 = (() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty2
homo_kind :: Bool
homo_kind = Type
k1 (() :: Constraint) => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
k2
pickCapturedPreds
:: TyVarSet
-> TcThetaType
-> TcThetaType
pickCapturedPreds :: VarSet -> [Type] -> [Type]
pickCapturedPreds VarSet
qtvs [Type]
theta
= (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
captured [Type]
theta
where
captured :: Type -> Bool
captured Type
pred = Type -> Bool
isIPLikePred Type
pred Bool -> Bool -> Bool
|| (Type -> VarSet
tyCoVarsOfType Type
pred VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
qtvs)
type PredWithSCs a = (PredType, [PredType], a)
mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a]
mkMinimalBySCs :: forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs a -> Type
get_pred [a]
xs = [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [PredWithSCs a]
preds_with_scs []
where
preds_with_scs :: [PredWithSCs a]
preds_with_scs :: [PredWithSCs a]
preds_with_scs = [ (Type
pred, Type -> [Type]
implicants Type
pred, a
x)
| a
x <- [a]
xs
, let pred :: Type
pred = a -> Type
get_pred a
x ]
go :: [PredWithSCs a]
-> [PredWithSCs a]
-> [a]
go :: [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [] [PredWithSCs a]
min_preds
= [a] -> [a]
forall a. [a] -> [a]
reverse ((PredWithSCs a -> a) -> [PredWithSCs a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map PredWithSCs a -> a
forall a b c. (a, b, c) -> c
thdOf3 [PredWithSCs a]
min_preds)
go (work_item :: PredWithSCs a
work_item@(Type
p,[Type]
_,a
_) : [PredWithSCs a]
work_list) [PredWithSCs a]
min_preds
| EqPred EqRel
_ Type
t1 Type
t2 <- Type -> Pred
classifyPredType Type
p
, Type
t1 (() :: Constraint) => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
t2
= [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [PredWithSCs a]
work_list [PredWithSCs a]
min_preds
| Type
p Type -> [PredWithSCs a] -> Bool
`in_cloud` [PredWithSCs a]
work_list Bool -> Bool -> Bool
|| Type
p Type -> [PredWithSCs a] -> Bool
`in_cloud` [PredWithSCs a]
min_preds
= [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [PredWithSCs a]
work_list [PredWithSCs a]
min_preds
| Bool
otherwise
= [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [PredWithSCs a]
work_list (PredWithSCs a
work_item PredWithSCs a -> [PredWithSCs a] -> [PredWithSCs a]
forall a. a -> [a] -> [a]
: [PredWithSCs a]
min_preds)
in_cloud :: PredType -> [PredWithSCs a] -> Bool
in_cloud :: Type -> [PredWithSCs a] -> Bool
in_cloud Type
p [PredWithSCs a]
ps = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Type
p (() :: Constraint) => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
p' | (Type
_, [Type]
scs, a
_) <- [PredWithSCs a]
ps, Type
p' <- [Type]
scs ]
implicants :: Type -> [Type]
implicants Type
pred
= Type
pred Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
eq_extras Type
pred [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Type -> [Type]
transSuperClasses Type
pred
eq_extras :: Type -> [Type]
eq_extras Type
pred
= case Type -> Pred
classifyPredType Type
pred of
EqPred EqRel
r Type
t1 Type
t2 -> [Role -> Type -> Type -> Type
mkPrimEqPredRole (EqRel -> Role
eqRelRole EqRel
r) Type
t2 Type
t1]
ClassPred Class
cls [Type
k1,Type
k2,Type
t1,Type
t2]
| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey -> [Class -> [Type] -> Type
mkClassPred Class
cls [Type
k2, Type
k1, Type
t2, Type
t1]]
ClassPred Class
cls [Type
k,Type
t1,Type
t2]
| Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey -> [Class -> [Type] -> Type
mkClassPred Class
cls [Type
k, Type
t2, Type
t1]]
Pred
_ -> []
transSuperClasses :: PredType -> [PredType]
transSuperClasses :: Type -> [Type]
transSuperClasses Type
p
= NameSet -> Type -> [Type]
go NameSet
emptyNameSet Type
p
where
go :: NameSet -> PredType -> [PredType]
go :: NameSet -> Type -> [Type]
go NameSet
rec_clss Type
p
| ClassPred Class
cls [Type]
tys <- Type -> Pred
classifyPredType Type
p
, let cls_nm :: Name
cls_nm = Class -> Name
className Class
cls
, Bool -> Bool
not (Name
cls_nm Name -> NameSet -> Bool
`elemNameSet` NameSet
rec_clss)
, let rec_clss' :: NameSet
rec_clss' | Class -> Bool
isCTupleClass Class
cls = NameSet
rec_clss
| Bool
otherwise = NameSet
rec_clss NameSet -> Name -> NameSet
`extendNameSet` Name
cls_nm
= [ Type
p' | Type
sc <- Class -> [Type] -> [Type]
immSuperClasses Class
cls [Type]
tys
, Type
p' <- Type
sc Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: NameSet -> Type -> [Type]
go NameSet
rec_clss' Type
sc ]
| Bool
otherwise
= []
immSuperClasses :: Class -> [Type] -> [PredType]
immSuperClasses :: Class -> [Type] -> [Type]
immSuperClasses Class
cls [Type]
tys
= (() :: Constraint) => Subst -> [Type] -> [Type]
Subst -> [Type] -> [Type]
substTheta ([Var] -> [Type] -> Subst
(() :: Constraint) => [Var] -> [Type] -> Subst
zipTvSubst [Var]
tyvars [Type]
tys) [Type]
sc_theta
where
([Var]
tyvars,[Type]
sc_theta,[Var]
_,[ClassOpItem]
_) = Class -> ([Var], [Type], [Var], [ClassOpItem])
classBigSig Class
cls
isImprovementPred :: PredType -> Bool
isImprovementPred :: Type -> Bool
isImprovementPred Type
ty
= case Type -> Pred
classifyPredType Type
ty of
EqPred EqRel
NomEq Type
t1 Type
t2 -> Bool -> Bool
not (Type
t1 (() :: Constraint) => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
t2)
EqPred EqRel
ReprEq Type
_ Type
_ -> Bool
False
ClassPred Class
cls [Type]
_ -> Class -> Bool
classHasFds Class
cls
IrredPred {} -> Bool
True
ForAllPred {} -> Bool
False
isSigmaTy :: TcType -> Bool
isSigmaTy :: Type -> Bool
isSigmaTy Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isSigmaTy Type
ty'
isSigmaTy (ForAllTy {}) = Bool
True
isSigmaTy (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af }) = FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af
isSigmaTy Type
_ = Bool
False
isRhoTy :: TcType -> Bool
isRhoTy :: Type -> Bool
isRhoTy Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isRhoTy Type
ty'
isRhoTy (ForAllTy {}) = Bool
False
isRhoTy (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af }) = FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af
isRhoTy Type
_ = Bool
True
isRhoExpTy :: ExpType -> Bool
isRhoExpTy :: ExpType -> Bool
isRhoExpTy (Check Type
ty) = Type -> Bool
isRhoTy Type
ty
isRhoExpTy (Infer {}) = Bool
True
isOverloadedTy :: Type -> Bool
isOverloadedTy :: Type -> Bool
isOverloadedTy Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Bool
isOverloadedTy Type
ty'
isOverloadedTy (ForAllTy ForAllTyBinder
_ Type
ty) = Type -> Bool
isOverloadedTy Type
ty
isOverloadedTy (FunTy { ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af }) = FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af
isOverloadedTy Type
_ = Bool
False
isFloatTy, isDoubleTy,
isFloatPrimTy, isDoublePrimTy,
isIntegerTy, isNaturalTy,
isIntTy, isWordTy, isBoolTy,
isUnitTy, isCharTy :: Type -> Bool
isFloatTy :: Type -> Bool
isFloatTy = Unique -> Type -> Bool
is_tc Unique
floatTyConKey
isDoubleTy :: Type -> Bool
isDoubleTy = Unique -> Type -> Bool
is_tc Unique
doubleTyConKey
isFloatPrimTy :: Type -> Bool
isFloatPrimTy = Unique -> Type -> Bool
is_tc Unique
floatPrimTyConKey
isDoublePrimTy :: Type -> Bool
isDoublePrimTy = Unique -> Type -> Bool
is_tc Unique
doublePrimTyConKey
isIntegerTy :: Type -> Bool
isIntegerTy = Unique -> Type -> Bool
is_tc Unique
integerTyConKey
isNaturalTy :: Type -> Bool
isNaturalTy = Unique -> Type -> Bool
is_tc Unique
naturalTyConKey
isIntTy :: Type -> Bool
isIntTy = Unique -> Type -> Bool
is_tc Unique
intTyConKey
isWordTy :: Type -> Bool
isWordTy = Unique -> Type -> Bool
is_tc Unique
wordTyConKey
isBoolTy :: Type -> Bool
isBoolTy = Unique -> Type -> Bool
is_tc Unique
boolTyConKey
isUnitTy :: Type -> Bool
isUnitTy = Unique -> Type -> Bool
is_tc Unique
unitTyConKey
isCharTy :: Type -> Bool
isCharTy = Unique -> Type -> Bool
is_tc Unique
charTyConKey
anyTy_maybe :: Type -> Maybe Kind
anyTy_maybe :: Type -> Maybe Type
anyTy_maybe Type
ty
| Just (TyCon
tc, [Type
k]) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
anyTyConKey
= Type -> Maybe Type
forall a. a -> Maybe a
Just Type
k
| Bool
otherwise
= Maybe Type
forall a. Maybe a
Nothing
isFloatingPrimTy :: Type -> Bool
isFloatingPrimTy :: Type -> Bool
isFloatingPrimTy Type
ty = Type -> Bool
isFloatPrimTy Type
ty Bool -> Bool -> Bool
|| Type -> Bool
isDoublePrimTy Type
ty
isStringTy :: Type -> Bool
isStringTy :: Type -> Bool
isStringTy Type
ty
= case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
Just (TyCon
tc, [Type
arg_ty]) -> TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
listTyCon Bool -> Bool -> Bool
&& Type -> Bool
isCharTy Type
arg_ty
Maybe (TyCon, [Type])
_ -> Bool
False
is_tc :: Unique -> Type -> Bool
is_tc :: Unique -> Type -> Bool
is_tc Unique
uniq Type
ty = case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
Just (TyCon
tc, [Type]
_) -> Unique
uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc
Maybe (TyCon, [Type])
Nothing -> Bool
False
isRigidTy :: TcType -> Bool
isRigidTy :: Type -> Bool
isRigidTy Type
ty
| Just (TyCon
tc,[Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty = TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
Nominal
| Just {} <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
ty = Bool
True
| Type -> Bool
isForAllTy Type
ty = Bool
True
| Bool
otherwise = Bool
False
deNoteType :: Type -> Type
deNoteType :: Type -> Type
deNoteType Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Type -> Type
deNoteType Type
ty'
deNoteType Type
ty = Type
ty
tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
ty
= case HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty of
Just (TyCon
io_tycon, [Type
io_res_ty])
| TyCon
io_tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ioTyConKey ->
(TyCon, Type) -> Maybe (TyCon, Type)
forall a. a -> Maybe a
Just (TyCon
io_tycon, Type
io_res_ty)
Maybe (TyCon, [Type])
_ ->
Maybe (TyCon, Type)
forall a. Maybe a
Nothing
data IllegalForeignTypeReason
= TypeCannotBeMarshaled !Type TypeCannotBeMarshaledReason
| ForeignDynNotPtr
!Type
!Type
| SafeHaskellMustBeInIO
| IOResultExpected
| UnexpectedNestedForall
| LinearTypesNotAllowed
| OneArgExpected
| AtLeastOneArgExpected
deriving (forall x.
IllegalForeignTypeReason -> Rep IllegalForeignTypeReason x)
-> (forall x.
Rep IllegalForeignTypeReason x -> IllegalForeignTypeReason)
-> Generic IllegalForeignTypeReason
forall x.
Rep IllegalForeignTypeReason x -> IllegalForeignTypeReason
forall x.
IllegalForeignTypeReason -> Rep IllegalForeignTypeReason x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
IllegalForeignTypeReason -> Rep IllegalForeignTypeReason x
from :: forall x.
IllegalForeignTypeReason -> Rep IllegalForeignTypeReason x
$cto :: forall x.
Rep IllegalForeignTypeReason x -> IllegalForeignTypeReason
to :: forall x.
Rep IllegalForeignTypeReason x -> IllegalForeignTypeReason
Generic
data TypeCannotBeMarshaledReason
= NotADataType
| NewtypeDataConNotInScope !(Maybe TyCon)
| UnliftedFFITypesNeeded
| NotABoxedMarshalableTyCon
| ForeignLabelNotAPtr
| NotSimpleUnliftedType
| NotBoxedKindAny
deriving (forall x.
TypeCannotBeMarshaledReason -> Rep TypeCannotBeMarshaledReason x)
-> (forall x.
Rep TypeCannotBeMarshaledReason x -> TypeCannotBeMarshaledReason)
-> Generic TypeCannotBeMarshaledReason
forall x.
Rep TypeCannotBeMarshaledReason x -> TypeCannotBeMarshaledReason
forall x.
TypeCannotBeMarshaledReason -> Rep TypeCannotBeMarshaledReason x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
TypeCannotBeMarshaledReason -> Rep TypeCannotBeMarshaledReason x
from :: forall x.
TypeCannotBeMarshaledReason -> Rep TypeCannotBeMarshaledReason x
$cto :: forall x.
Rep TypeCannotBeMarshaledReason x -> TypeCannotBeMarshaledReason
to :: forall x.
Rep TypeCannotBeMarshaledReason x -> TypeCannotBeMarshaledReason
Generic
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
isFFIArgumentTy DynFlags
dflags Safety
safety Type
ty
= (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags
-> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalOutgoingTyCon DynFlags
dflags Safety
safety) Type
ty
isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExternalTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEArgTyCon Type
ty
isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy DynFlags
dflags Type
ty
= (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIResultTyCon DynFlags
dflags) Type
ty
isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEResultTyCon Type
ty
isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason
isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason
isFFIDynTy Type
expected Type
ty
| Just (TyCon
tc, [Type
ty']) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, TyCon -> Unique
tyConUnique TyCon
tc Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
ptrTyConKey, Unique
funPtrTyConKey]
, Type -> Type -> Bool
eqType Type
ty' Type
expected
= Validity' IllegalForeignTypeReason
forall a. Validity' a
IsValid
| Bool
otherwise
= IllegalForeignTypeReason -> Validity' IllegalForeignTypeReason
forall a. a -> Validity' a
NotValid (Type -> Type -> IllegalForeignTypeReason
ForeignDynNotPtr Type
expected Type
ty)
isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason
isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason
isFFILabelTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
forall {a}.
Uniquable a =>
a -> Validity' TypeCannotBeMarshaledReason
ok Type
ty
where
ok :: a -> Validity' TypeCannotBeMarshaledReason
ok a
tc | a
tc a -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funPtrTyConKey Bool -> Bool -> Bool
|| a
tc a -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ptrTyConKey
= Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
| Bool
otherwise
= TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
ForeignLabelNotAPtr
checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
| Just Type
ki <- Type -> Maybe Type
anyTy_maybe Type
ty
= Validity' IllegalForeignTypeReason
-> Maybe (Validity' IllegalForeignTypeReason)
forall a. a -> Maybe a
Just (Validity' IllegalForeignTypeReason
-> Maybe (Validity' IllegalForeignTypeReason))
-> Validity' IllegalForeignTypeReason
-> Maybe (Validity' IllegalForeignTypeReason)
forall a b. (a -> b) -> a -> b
$
if Maybe Levity -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Levity -> Bool) -> Maybe Levity -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Levity
kindBoxedRepLevity_maybe Type
ki
then Validity' IllegalForeignTypeReason
forall a. Validity' a
IsValid
else IllegalForeignTypeReason -> Validity' IllegalForeignTypeReason
forall a. a -> Validity' a
NotValid (Type -> TypeCannotBeMarshaledReason -> IllegalForeignTypeReason
TypeCannotBeMarshaled Type
ty TypeCannotBeMarshaledReason
NotBoxedKindAny)
| Bool
otherwise
= Maybe (Validity' IllegalForeignTypeReason)
forall a. Maybe a
Nothing
isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimArgumentTy DynFlags
dflags Type
ty
| Just Validity' IllegalForeignTypeReason
validity <- Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
= Validity' IllegalForeignTypeReason
validity
| Bool
otherwise
= (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimArgTyCon DynFlags
dflags) Type
ty
isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimResultTy DynFlags
dflags Type
ty
| Just Validity' IllegalForeignTypeReason
validity <- Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
= Validity' IllegalForeignTypeReason
validity
| Bool
otherwise
= (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimResultTyCon DynFlags
dflags) Type
ty
isFunPtrTy :: Type -> Bool
isFunPtrTy :: Type -> Bool
isFunPtrTy Type
ty
| Just (TyCon
tc, [Type
_]) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
= TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funPtrTyConKey
| Bool
otherwise
= Bool
False
checkRepTyCon
:: (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type
-> Validity' IllegalForeignTypeReason
checkRepTyCon :: (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
check_tc Type
ty
= (TypeCannotBeMarshaledReason -> IllegalForeignTypeReason)
-> Validity' TypeCannotBeMarshaledReason
-> Validity' IllegalForeignTypeReason
forall a b. (a -> b) -> Validity' a -> Validity' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type -> TypeCannotBeMarshaledReason -> IllegalForeignTypeReason
TypeCannotBeMarshaled Type
ty) (Validity' TypeCannotBeMarshaledReason
-> Validity' IllegalForeignTypeReason)
-> Validity' TypeCannotBeMarshaledReason
-> Validity' IllegalForeignTypeReason
forall a b. (a -> b) -> a -> b
$ case (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
Just (TyCon
tc, [Type]
tys)
| TyCon -> Bool
isNewTyCon TyCon
tc -> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid (TyCon -> [Type] -> TypeCannotBeMarshaledReason
forall {t :: * -> *} {a}.
Foldable t =>
TyCon -> t a -> TypeCannotBeMarshaledReason
mk_nt_reason TyCon
tc [Type]
tys)
| Bool
otherwise -> TyCon -> Validity' TypeCannotBeMarshaledReason
check_tc TyCon
tc
Maybe (TyCon, [Type])
Nothing -> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotADataType
where
mk_nt_reason :: TyCon -> t a -> TypeCannotBeMarshaledReason
mk_nt_reason TyCon
tc t a
tys
| t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
tys = Maybe TyCon -> TypeCannotBeMarshaledReason
NewtypeDataConNotInScope Maybe TyCon
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe TyCon -> TypeCannotBeMarshaledReason
NewtypeDataConNotInScope (TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc)
legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEArgTyCon TyCon
tc
= TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc
legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIResultTyCon DynFlags
dflags TyCon
tc
| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon = Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
| Bool
otherwise = DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon DynFlags
dflags TyCon
tc
legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEResultTyCon TyCon
tc
| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon = Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
| Bool
otherwise = TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalOutgoingTyCon :: DynFlags
-> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalOutgoingTyCon DynFlags
dflags Safety
_ TyCon
tc
= DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon DynFlags
dflags TyCon
tc
marshalablePrimTyCon :: TyCon -> Bool
marshalablePrimTyCon :: TyCon -> Bool
marshalablePrimTyCon TyCon
tc = TyCon -> Bool
isPrimTyCon TyCon
tc Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isLiftedTypeKind (TyCon -> Type
tyConResKind TyCon
tc))
marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon DynFlags
dflags TyCon
tc
| TyCon -> Bool
marshalablePrimTyCon TyCon
tc
, Bool -> Bool
not ([PrimRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((() :: Constraint) => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc))
= DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
| Bool
otherwise
= TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc
boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc
| TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Unique
intTyConKey, Unique
int8TyConKey, Unique
int16TyConKey
, Unique
int32TyConKey, Unique
int64TyConKey
, Unique
wordTyConKey, Unique
word8TyConKey, Unique
word16TyConKey
, Unique
word32TyConKey, Unique
word64TyConKey
, Unique
floatTyConKey, Unique
doubleTyConKey
, Unique
ptrTyConKey, Unique
funPtrTyConKey
, Unique
charTyConKey
, Unique
stablePtrTyConKey
, Unique
boolTyConKey
]
= Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
| Bool
otherwise = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotABoxedMarshalableTyCon
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimArgTyCon DynFlags
dflags TyCon
tc
| TyCon -> Bool
marshalablePrimTyCon TyCon
tc
= DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
| Bool
otherwise
= TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotSimpleUnliftedType
legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimResultTyCon DynFlags
dflags TyCon
tc
| TyCon -> Bool
marshalablePrimTyCon TyCon
tc
, Bool -> Bool
not ([PrimRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((() :: Constraint) => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc))
= DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
| TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isUnboxedSumTyCon TyCon
tc
= DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
| Bool
otherwise
= TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid (TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason)
-> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a b. (a -> b) -> a -> b
$ TypeCannotBeMarshaledReason
NotSimpleUnliftedType
validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
| Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedFFITypes DynFlags
dflags = Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
| Bool
otherwise = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
UnliftedFFITypesNeeded
type TypeSize = IntWithInf
sizeType :: Type -> TypeSize
sizeType :: Type -> TypeSize
sizeType = Type -> TypeSize
go
where
go :: Type -> TypeSize
go Type
ty | Just Type
exp_ty <- Type -> Maybe Type
coreView Type
ty = Type -> TypeSize
go Type
exp_ty
go (TyVarTy {}) = TypeSize
1
go (TyConApp TyCon
tc [Type]
tys)
| TyCon -> Bool
isTypeFamilyTyCon TyCon
tc = TypeSize
infinity
| Bool
otherwise = [Type] -> TypeSize
sizeTypes (TyCon -> [Type] -> [Type]
filterOutInvisibleTypes TyCon
tc [Type]
tys) TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ TypeSize
1
go (LitTy {}) = TypeSize
1
go (FunTy FunTyFlag
_ Type
w Type
arg Type
res) = Type -> TypeSize
go Type
w TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ Type -> TypeSize
go Type
arg TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ Type -> TypeSize
go Type
res TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ TypeSize
1
go (AppTy Type
fun Type
arg) = Type -> TypeSize
go Type
fun TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ Type -> TypeSize
go Type
arg
go (ForAllTy (Bndr Var
tv ForAllTyFlag
vis) Type
ty)
| ForAllTyFlag -> Bool
isVisibleForAllTyFlag ForAllTyFlag
vis = Type -> TypeSize
go (Var -> Type
tyVarKind Var
tv) TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ Type -> TypeSize
go Type
ty TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ TypeSize
1
| Bool
otherwise = Type -> TypeSize
go Type
ty TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ TypeSize
1
go (CastTy Type
ty KindCoercion
_) = Type -> TypeSize
go Type
ty
go (CoercionTy {}) = TypeSize
0
sizeTypes :: [Type] -> TypeSize
sizeTypes :: [Type] -> TypeSize
sizeTypes [Type]
tys = [TypeSize] -> TypeSize
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Type -> TypeSize) -> [Type] -> [TypeSize]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeSize
sizeType [Type]
tys)
tcTyConVisibilities :: TyCon -> [Bool]
tcTyConVisibilities :: TyCon -> [Bool]
tcTyConVisibilities TyCon
tc = [Bool]
tc_binder_viss [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Bool]
tc_return_kind_viss [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True
where
tc_binder_viss :: [Bool]
tc_binder_viss = (VarBndr Var TyConBndrVis -> Bool)
-> [VarBndr Var TyConBndrVis] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map VarBndr Var TyConBndrVis -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder (TyCon -> [VarBndr Var TyConBndrVis]
tyConBinders TyCon
tc)
tc_return_kind_viss :: [Bool]
tc_return_kind_viss = (PiTyVarBinder -> Bool) -> [PiTyVarBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map PiTyVarBinder -> Bool
isVisiblePiTyBinder (([PiTyVarBinder], Type) -> [PiTyVarBinder]
forall a b. (a, b) -> a
fst (([PiTyVarBinder], Type) -> [PiTyVarBinder])
-> ([PiTyVarBinder], Type) -> [PiTyVarBinder]
forall a b. (a -> b) -> a -> b
$ Type -> ([PiTyVarBinder], Type)
tcSplitPiTys (TyCon -> Type
tyConResKind TyCon
tc))
isNextTyConArgVisible :: TyCon -> [Type] -> Bool
isNextTyConArgVisible :: TyCon -> [Type] -> Bool
isNextTyConArgVisible TyCon
tc [Type]
tys
= TyCon -> [Bool]
tcTyConVisibilities TyCon
tc [Bool] -> Arity -> Bool
forall a. Outputable a => [a] -> Arity -> a
`getNth` [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
tys
isNextArgVisible :: TcType -> Bool
isNextArgVisible :: Type -> Bool
isNextArgVisible Type
ty
| Just (PiTyVarBinder
bndr, Type
_) <- Type -> Maybe (PiTyVarBinder, Type)
tcSplitPiTy_maybe Type
ty = PiTyVarBinder -> Bool
isVisiblePiTyBinder PiTyVarBinder
bndr
| Bool
otherwise = Bool
True