{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-}
module TcType (
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,
TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon,
KnotTied,
ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType,
SyntaxOpType(..), synKnownType, mkSynFunTys,
TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,
strictlyDeeperThan, sameDepthAs,
tcTypeLevel, tcTyVarLevel, maxTcLevel,
promoteSkolem, promoteSkolemX, promoteSkolemsX,
TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
MetaDetails(Flexi, Indirect), MetaInfo(..),
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy,
tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar,
isFskTyVar, isFmvTyVar, isFlattenTyVar,
isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo,
isFlexi, isIndirect, isRuntimeUnkSkol,
metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,
isTouchableMetaTyVar,
isFloatedTouchableMetaTyVar,
findDupTyVarTvs, mkTyVarNamePairs,
mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy,
mkTcAppTy, mkTcAppTys, mkTcCastTy,
getTyVar,
tcSplitForAllTy_maybe,
tcSplitForAllTys, tcSplitForAllTysSameVis,
tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs,
tcSplitPhiTy, tcSplitPredFunTy_maybe,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,
tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe,
tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe,
tcRepGetNumAppTys,
tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, nextRole,
tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe,
eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,
pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,
isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,
hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck,
checkValidClsArgs, hasTyVarHead,
isRigidTy, isAlmostFunctionFree,
deNoteType,
orphNamesOfType, orphNamesOfCo,
orphNamesOfTypes, orphNamesOfCoCon,
getDFunTyKey, evVarPred,
mkMinimalBySCs, transSuperClasses,
pickQuantifiablePreds, pickCapturedPreds,
immSuperClasses, boxEqPred,
isImprovementPred,
tcTyFamInsts, tcTyFamInstsAndVis, tcTyConAppTyFamInstsAndVis, isTyFamFree,
exactTyCoVarsOfType, exactTyCoVarsOfTypes,
anyRewritableTyVar,
isFFIArgumentTy,
isFFIImportResultTy,
isFFIExportResultTy,
isFFIExternalTy,
isFFIDynTy,
isFFIPrimArgumentTy,
isFFIPrimResultTy,
isFFILabelTy,
isFFITy,
isFunPtrTy,
tcSplitIOType_maybe,
Kind, tcTypeKind,
liftedTypeKind,
constraintKind,
isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues,
Type, PredType, ThetaType, TyCoBinder,
ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..),
mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy,
mkInvForAllTy, mkInvForAllTys,
mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTys,
mkTyConApp, mkAppTy, mkAppTys,
mkTyConTy, mkTyVarTy, mkTyVarTys,
mkTyCoVarTy, mkTyCoVarTys,
isClassPred, isEqPrimPred, isIPPred, isEqPred, isEqPredClass,
mkClassPred,
tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
isRuntimeRepVar, isKindLevPoly,
isVisibleBinder, isInvisibleBinder,
TCvSubst(..),
TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst,
zipTvSubst,
mkTvSubstPrs, notElemTCvSubst, unionTCvSubst,
getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope,
extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope,
Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,
Type.extendTvSubst,
isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv,
Type.substTy, substTys, substTyWith, substTyWithCoVars,
substTyAddInScope,
substTyUnchecked, substTysUnchecked, substThetaUnchecked,
substTyWithUnchecked,
substCoUnchecked, substCoWithUnchecked,
substTheta,
isUnliftedType,
isUnboxedTupleType,
isPrimitiveType,
tcView, coreView,
tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds,
tyCoFVsOfType, tyCoFVsOfTypes,
tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet,
tyCoVarsOfTypeList, tyCoVarsOfTypesList,
noFreeVarsOfType,
pprKind, pprParendKind, pprSigmaType,
pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory,
pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred,
pprTCvBndr, pprTCvBndrs,
TypeSize, sizeType, sizeTypes, scopedSort,
tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible
) where
#include "GhclibHsVersions.h"
import GhcPrelude
import TyCoRep
import TyCoSubst ( mkTvSubst, substTyWithCoVars )
import TyCoFVs
import TyCoPpr
import Class
import Var
import ForeignCall
import VarSet
import Coercion
import Type
import Predicate
import RepType
import TyCon
import DynFlags
import CoreFVs
import Name
import NameSet
import VarEnv
import PrelNames
import TysWiredIn( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey
, listTyCon, constraintKind )
import BasicTypes
import Util
import Maybes
import ListSetOps ( getNth, findDupsEq )
import Outputable
import FastString
import ErrUtils( Validity(..), MsgDoc, isValid )
import qualified GHC.LanguageExtensions as LangExt
import Data.List ( mapAccumL )
import Data.IORef
import Data.List.NonEmpty( NonEmpty(..) )
type TcCoVar = CoVar
type TcType = Type
type TcTyCoVar = Var
type TcTyVarBinder = TyVarBinder
type TcTyCon = TyCon
type TcPredType = PredType
type TcThetaType = ThetaType
type TcSigmaType = TcType
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 -> Bool
ir_inst :: Bool
, InferResult -> IORef (Maybe TcType)
ir_ref :: IORef (Maybe TcType) }
type ExpSigmaType = ExpType
type ExpRhoType = ExpType
instance Outputable ExpType where
ppr :: ExpType -> SDoc
ppr (Check ty :: TcType
ty) = String -> SDoc
text "Check" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)
ppr (Infer ir :: 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_inst :: InferResult -> Bool
ir_inst = Bool
inst })
= String -> SDoc
text "Infer" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
lvl SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
inst)
mkCheckExpType :: TcType -> ExpType
mkCheckExpType :: TcType -> ExpType
mkCheckExpType = TcType -> ExpType
Check
data SyntaxOpType
= SynAny
| SynRho
| SynList
| SynFun SyntaxOpType SyntaxOpType
| SynType ExpType
infixr 0 `SynFun`
synKnownType :: TcType -> SyntaxOpType
synKnownType :: TcType -> SyntaxOpType
synKnownType = ExpType -> SyntaxOpType
SynType (ExpType -> SyntaxOpType)
-> (TcType -> ExpType) -> TcType -> SyntaxOpType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> ExpType
mkCheckExpType
mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType
mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType
mkSynFunTys arg_tys :: [SyntaxOpType]
arg_tys res_ty :: ExpType
res_ty = (SyntaxOpType -> SyntaxOpType -> SyntaxOpType)
-> SyntaxOpType -> [SyntaxOpType] -> SyntaxOpType
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
TcLevel
Bool
| RuntimeUnk
| MetaTv { TcTyVarDetails -> MetaInfo
mtv_info :: MetaInfo
, TcTyVarDetails -> IORef MetaDetails
mtv_ref :: IORef MetaDetails
, TcTyVarDetails -> TcLevel
mtv_tclvl :: TcLevel }
vanillaSkolemTv, superSkolemTv :: TcTyVarDetails
vanillaSkolemTv :: TcTyVarDetails
vanillaSkolemTv = TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
topTcLevel Bool
False
superSkolemTv :: TcTyVarDetails
superSkolemTv = TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
topTcLevel Bool
True
instance Outputable TcTyVarDetails where
ppr :: TcTyVarDetails -> SDoc
ppr = TcTyVarDetails -> SDoc
pprTcTyVarDetails
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
pprTcTyVarDetails (RuntimeUnk {}) = String -> SDoc
text "rt"
pprTcTyVarDetails (SkolemTv lvl :: TcLevel
lvl True) = String -> SDoc
text "ssk" SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
lvl
pprTcTyVarDetails (SkolemTv lvl :: TcLevel
lvl False) = String -> SDoc
text "sk" SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<> 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
<> SDoc
colon SDoc -> SDoc -> SDoc
<> TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl
data MetaDetails
= Flexi
| Indirect TcType
data MetaInfo
= TauTv
| TyVarTv
| FlatMetaTv
| FlatSkolTv
instance Outputable MetaDetails where
ppr :: MetaDetails -> SDoc
ppr Flexi = String -> SDoc
text "Flexi"
ppr (Indirect ty :: TcType
ty) = String -> SDoc
text "Indirect" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty
instance Outputable MetaInfo where
ppr :: MetaInfo -> SDoc
ppr TauTv = String -> SDoc
text "tau"
ppr TyVarTv = String -> SDoc
text "tyv"
ppr FlatMetaTv = String -> SDoc
text "fmv"
ppr FlatSkolTv = String -> SDoc
text "fsk"
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
/= :: TcLevel -> TcLevel -> Bool
$c/= :: TcLevel -> TcLevel -> Bool
== :: TcLevel -> TcLevel -> Bool
$c== :: 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
min :: TcLevel -> TcLevel -> TcLevel
$cmin :: TcLevel -> TcLevel -> TcLevel
max :: TcLevel -> TcLevel -> TcLevel
$cmax :: TcLevel -> TcLevel -> TcLevel
>= :: TcLevel -> TcLevel -> Bool
$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
compare :: TcLevel -> TcLevel -> Ordering
$ccompare :: TcLevel -> TcLevel -> Ordering
$cp1Ord :: Eq TcLevel
Ord )
maxTcLevel :: TcLevel -> TcLevel -> TcLevel
maxTcLevel :: TcLevel -> TcLevel -> TcLevel
maxTcLevel (TcLevel a :: Int
a) (TcLevel b :: Int
b) = Int -> TcLevel
TcLevel (Int
a Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
b)
topTcLevel :: TcLevel
topTcLevel :: TcLevel
topTcLevel = Int -> TcLevel
TcLevel 0
isTopTcLevel :: TcLevel -> Bool
isTopTcLevel :: TcLevel -> Bool
isTopTcLevel (TcLevel 0) = Bool
True
isTopTcLevel _ = Bool
False
pushTcLevel :: TcLevel -> TcLevel
pushTcLevel :: TcLevel -> TcLevel
pushTcLevel (TcLevel us :: Int
us) = Int -> TcLevel
TcLevel (Int
us Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
strictlyDeeperThan :: TcLevel -> TcLevel -> Bool
strictlyDeeperThan :: TcLevel -> TcLevel -> Bool
strictlyDeeperThan (TcLevel tv_tclvl :: Int
tv_tclvl) (TcLevel ctxt_tclvl :: Int
ctxt_tclvl)
= Int
tv_tclvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ctxt_tclvl
sameDepthAs :: TcLevel -> TcLevel -> Bool
sameDepthAs :: TcLevel -> TcLevel -> Bool
sameDepthAs (TcLevel ctxt_tclvl :: Int
ctxt_tclvl) (TcLevel tv_tclvl :: Int
tv_tclvl)
= Int
ctxt_tclvl Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tv_tclvl
checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool
checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool
checkTcLevelInvariant (TcLevel ctxt_tclvl :: Int
ctxt_tclvl) (TcLevel tv_tclvl :: Int
tv_tclvl)
= Int
ctxt_tclvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
tv_tclvl
tcTyVarLevel :: TcTyVar -> TcLevel
tcTyVarLevel :: TcTyVar -> TcLevel
tcTyVarLevel tv :: TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tv_lvl } -> TcLevel
tv_lvl
SkolemTv tv_lvl :: TcLevel
tv_lvl _ -> TcLevel
tv_lvl
RuntimeUnk -> TcLevel
topTcLevel
tcTypeLevel :: TcType -> TcLevel
tcTypeLevel :: TcType -> TcLevel
tcTypeLevel ty :: TcType
ty
= (TcTyVar -> TcLevel -> TcLevel) -> TcLevel -> DVarSet -> TcLevel
forall a. (TcTyVar -> a -> a) -> a -> DVarSet -> a
foldDVarSet TcTyVar -> TcLevel -> TcLevel
add TcLevel
topTcLevel (TcType -> DVarSet
tyCoVarsOfTypeDSet TcType
ty)
where
add :: TcTyVar -> TcLevel -> TcLevel
add v :: TcTyVar
v lvl :: TcLevel
lvl
| TcTyVar -> Bool
isTcTyVar TcTyVar
v = TcLevel
lvl TcLevel -> TcLevel -> TcLevel
`maxTcLevel` TcTyVar -> TcLevel
tcTyVarLevel TcTyVar
v
| Bool
otherwise = TcLevel
lvl
instance Outputable TcLevel where
ppr :: TcLevel -> SDoc
ppr (TcLevel us :: Int
us) = Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
us
promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar
promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar
promoteSkolem tclvl :: TcLevel
tclvl skol :: TcTyVar
skol
| TcLevel
tclvl TcLevel -> TcLevel -> Bool
forall a. Ord a => a -> a -> Bool
< TcTyVar -> TcLevel
tcTyVarLevel TcTyVar
skol
= ASSERT( isTcTyVar skol && isSkolemTyVar skol )
TcTyVar -> TcTyVarDetails -> TcTyVar
setTcTyVarDetails TcTyVar
skol (TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
tclvl (TcTyVar -> Bool
isOverlappableTyVar TcTyVar
skol))
| Bool
otherwise
= TcTyVar
skol
promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
promoteSkolemX tclvl :: TcLevel
tclvl subst :: TCvSubst
subst skol :: TcTyVar
skol
= ASSERT( isTcTyVar skol && isSkolemTyVar skol )
(TCvSubst
new_subst, TcTyVar
new_skol)
where
new_skol :: TcTyVar
new_skol
| TcLevel
tclvl TcLevel -> TcLevel -> Bool
forall a. Ord a => a -> a -> Bool
< TcTyVar -> TcLevel
tcTyVarLevel TcTyVar
skol
= TcTyVar -> TcTyVarDetails -> TcTyVar
setTcTyVarDetails ((TcType -> TcType) -> TcTyVar -> TcTyVar
updateTyVarKind (HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
substTy TCvSubst
subst) TcTyVar
skol)
(TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
tclvl (TcTyVar -> Bool
isOverlappableTyVar TcTyVar
skol))
| Bool
otherwise
= (TcType -> TcType) -> TcTyVar -> TcTyVar
updateTyVarKind (HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
substTy TCvSubst
subst) TcTyVar
skol
new_subst :: TCvSubst
new_subst = TCvSubst -> TcTyVar -> TcTyVar -> TCvSubst
extendTvSubstWithClone TCvSubst
subst TcTyVar
skol TcTyVar
new_skol
promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar])
promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar])
promoteSkolemsX tclvl :: TcLevel
tclvl = (TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar))
-> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
promoteSkolemX TcLevel
tclvl)
tcTyFamInsts :: Type -> [(TyCon, [Type])]
tcTyFamInsts :: TcType -> [(TyCon, [TcType])]
tcTyFamInsts = ((Bool, TyCon, [TcType]) -> (TyCon, [TcType]))
-> [(Bool, TyCon, [TcType])] -> [(TyCon, [TcType])]
forall a b. (a -> b) -> [a] -> [b]
map (\(_,b :: TyCon
b,c :: [TcType]
c) -> (TyCon
b,[TcType]
c)) ([(Bool, TyCon, [TcType])] -> [(TyCon, [TcType])])
-> (TcType -> [(Bool, TyCon, [TcType])])
-> TcType
-> [(TyCon, [TcType])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVis
tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVis :: TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVis = Bool -> TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVisX Bool
False
tcTyFamInstsAndVisX
:: Bool
-> Type -> [(Bool, TyCon, [Type])]
tcTyFamInstsAndVisX :: Bool -> TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVisX = Bool -> TcType -> [(Bool, TyCon, [TcType])]
go
where
go :: Bool -> TcType -> [(Bool, TyCon, [TcType])]
go is_invis_arg :: Bool
is_invis_arg ty :: TcType
ty
| Just exp_ty :: TcType
exp_ty <- TcType -> Maybe TcType
tcView TcType
ty = Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
exp_ty
go _ (TyVarTy _) = []
go is_invis_arg :: Bool
is_invis_arg (TyConApp tc :: TyCon
tc tys :: [TcType]
tys)
| TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
= [(Bool
is_invis_arg, TyCon
tc, Int -> [TcType] -> [TcType]
forall a. Int -> [a] -> [a]
take (TyCon -> Int
tyConArity TyCon
tc) [TcType]
tys)]
| Bool
otherwise
= Bool -> TyCon -> [TcType] -> [(Bool, TyCon, [TcType])]
tcTyConAppTyFamInstsAndVisX Bool
is_invis_arg TyCon
tc [TcType]
tys
go _ (LitTy {}) = []
go is_invis_arg :: Bool
is_invis_arg (ForAllTy bndr :: TyCoVarBinder
bndr ty :: TcType
ty) = Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg (TyCoVarBinder -> TcType
forall argf. VarBndr TcTyVar argf -> TcType
binderType TyCoVarBinder
bndr)
[(Bool, TyCon, [TcType])]
-> [(Bool, TyCon, [TcType])] -> [(Bool, TyCon, [TcType])]
forall a. [a] -> [a] -> [a]
++ Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
ty
go is_invis_arg :: Bool
is_invis_arg (FunTy _ ty1 :: TcType
ty1 ty2 :: TcType
ty2) = Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
ty1
[(Bool, TyCon, [TcType])]
-> [(Bool, TyCon, [TcType])] -> [(Bool, TyCon, [TcType])]
forall a. [a] -> [a] -> [a]
++ Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
ty2
go is_invis_arg :: Bool
is_invis_arg ty :: TcType
ty@(AppTy _ _) =
let (ty_head :: TcType
ty_head, ty_args :: [TcType]
ty_args) = TcType -> (TcType, [TcType])
splitAppTys TcType
ty
ty_arg_flags :: [ArgFlag]
ty_arg_flags = TcType -> [TcType] -> [ArgFlag]
appTyArgFlags TcType
ty_head [TcType]
ty_args
in Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
ty_head
[(Bool, TyCon, [TcType])]
-> [(Bool, TyCon, [TcType])] -> [(Bool, TyCon, [TcType])]
forall a. [a] -> [a] -> [a]
++ [[(Bool, TyCon, [TcType])]] -> [(Bool, TyCon, [TcType])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((ArgFlag -> TcType -> [(Bool, TyCon, [TcType])])
-> [ArgFlag] -> [TcType] -> [[(Bool, TyCon, [TcType])]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\flag :: ArgFlag
flag -> Bool -> TcType -> [(Bool, TyCon, [TcType])]
go (ArgFlag -> Bool
isInvisibleArgFlag ArgFlag
flag))
[ArgFlag]
ty_arg_flags [TcType]
ty_args)
go is_invis_arg :: Bool
is_invis_arg (CastTy ty :: TcType
ty _) = Bool -> TcType -> [(Bool, TyCon, [TcType])]
go Bool
is_invis_arg TcType
ty
go _ (CoercionTy _) = []
tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVis :: TyCon -> [TcType] -> [(Bool, TyCon, [TcType])]
tcTyConAppTyFamInstsAndVis = Bool -> TyCon -> [TcType] -> [(Bool, TyCon, [TcType])]
tcTyConAppTyFamInstsAndVisX Bool
False
tcTyConAppTyFamInstsAndVisX
:: Bool
-> TyCon -> [Type] -> [(Bool, TyCon, [Type])]
tcTyConAppTyFamInstsAndVisX :: Bool -> TyCon -> [TcType] -> [(Bool, TyCon, [TcType])]
tcTyConAppTyFamInstsAndVisX is_invis_arg :: Bool
is_invis_arg tc :: TyCon
tc tys :: [TcType]
tys =
let (invis_tys :: [TcType]
invis_tys, vis_tys :: [TcType]
vis_tys) = TyCon -> [TcType] -> ([TcType], [TcType])
partitionInvisibleTypes TyCon
tc [TcType]
tys
in [[(Bool, TyCon, [TcType])]] -> [(Bool, TyCon, [TcType])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Bool, TyCon, [TcType])]] -> [(Bool, TyCon, [TcType])])
-> [[(Bool, TyCon, [TcType])]] -> [(Bool, TyCon, [TcType])]
forall a b. (a -> b) -> a -> b
$ (TcType -> [(Bool, TyCon, [TcType])])
-> [TcType] -> [[(Bool, TyCon, [TcType])]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVisX Bool
True) [TcType]
invis_tys
[[(Bool, TyCon, [TcType])]]
-> [[(Bool, TyCon, [TcType])]] -> [[(Bool, TyCon, [TcType])]]
forall a. [a] -> [a] -> [a]
++ (TcType -> [(Bool, TyCon, [TcType])])
-> [TcType] -> [[(Bool, TyCon, [TcType])]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> TcType -> [(Bool, TyCon, [TcType])]
tcTyFamInstsAndVisX Bool
is_invis_arg) [TcType]
vis_tys
isTyFamFree :: Type -> Bool
isTyFamFree :: TcType -> Bool
isTyFamFree = [(TyCon, [TcType])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(TyCon, [TcType])] -> Bool)
-> (TcType -> [(TyCon, [TcType])]) -> TcType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> [(TyCon, [TcType])]
tcTyFamInsts
anyRewritableTyVar :: Bool
-> EqRel
-> (EqRel -> TcTyVar -> Bool)
-> TcType -> Bool
anyRewritableTyVar :: Bool -> EqRel -> (EqRel -> TcTyVar -> Bool) -> TcType -> Bool
anyRewritableTyVar ignore_cos :: Bool
ignore_cos role :: EqRel
role pred :: EqRel -> TcTyVar -> Bool
pred ty :: TcType
ty
= EqRel -> VarSet -> TcType -> Bool
go EqRel
role VarSet
emptyVarSet TcType
ty
where
go_tv :: EqRel -> VarSet -> TcTyVar -> Bool
go_tv rl :: EqRel
rl bvs :: VarSet
bvs tv :: TcTyVar
tv | TcTyVar
tv TcTyVar -> VarSet -> Bool
`elemVarSet` VarSet
bvs = Bool
False
| Bool
otherwise = EqRel -> TcTyVar -> Bool
pred EqRel
rl TcTyVar
tv
go :: EqRel -> VarSet -> TcType -> Bool
go rl :: EqRel
rl bvs :: VarSet
bvs (TyVarTy tv :: TcTyVar
tv) = EqRel -> VarSet -> TcTyVar -> Bool
go_tv EqRel
rl VarSet
bvs TcTyVar
tv
go _ _ (LitTy {}) = Bool
False
go rl :: EqRel
rl bvs :: VarSet
bvs (TyConApp tc :: TyCon
tc tys :: [TcType]
tys) = EqRel -> VarSet -> TyCon -> [TcType] -> Bool
go_tc EqRel
rl VarSet
bvs TyCon
tc [TcType]
tys
go rl :: EqRel
rl bvs :: VarSet
bvs (AppTy fun :: TcType
fun arg :: TcType
arg) = EqRel -> VarSet -> TcType -> Bool
go EqRel
rl VarSet
bvs TcType
fun Bool -> Bool -> Bool
|| EqRel -> VarSet -> TcType -> Bool
go EqRel
NomEq VarSet
bvs TcType
arg
go rl :: EqRel
rl bvs :: VarSet
bvs (FunTy _ arg :: TcType
arg res :: TcType
res) = EqRel -> VarSet -> TcType -> Bool
go EqRel
rl VarSet
bvs TcType
arg Bool -> Bool -> Bool
|| EqRel -> VarSet -> TcType -> Bool
go EqRel
rl VarSet
bvs TcType
res
go rl :: EqRel
rl bvs :: VarSet
bvs (ForAllTy tv :: TyCoVarBinder
tv ty :: TcType
ty) = EqRel -> VarSet -> TcType -> Bool
go EqRel
rl (VarSet
bvs VarSet -> TcTyVar -> VarSet
`extendVarSet` TyCoVarBinder -> TcTyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
tv) TcType
ty
go rl :: EqRel
rl bvs :: VarSet
bvs (CastTy ty :: TcType
ty co :: KindCoercion
co) = EqRel -> VarSet -> TcType -> Bool
go EqRel
rl VarSet
bvs TcType
ty Bool -> Bool -> Bool
|| EqRel -> VarSet -> KindCoercion -> Bool
go_co EqRel
rl VarSet
bvs KindCoercion
co
go rl :: EqRel
rl bvs :: VarSet
bvs (CoercionTy co :: KindCoercion
co) = EqRel -> VarSet -> KindCoercion -> Bool
go_co EqRel
rl VarSet
bvs KindCoercion
co
go_tc :: EqRel -> VarSet -> TyCon -> [TcType] -> Bool
go_tc NomEq bvs :: VarSet
bvs _ tys :: [TcType]
tys = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (EqRel -> VarSet -> TcType -> Bool
go EqRel
NomEq VarSet
bvs) [TcType]
tys
go_tc ReprEq bvs :: VarSet
bvs tc :: TyCon
tc tys :: [TcType]
tys = ((Role, TcType) -> Bool) -> [(Role, TcType)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (VarSet -> (Role, TcType) -> Bool
go_arg VarSet
bvs)
(TyCon -> [Role]
tyConRolesRepresentational TyCon
tc [Role] -> [TcType] -> [(Role, TcType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcType]
tys)
go_arg :: VarSet -> (Role, TcType) -> Bool
go_arg bvs :: VarSet
bvs (Nominal, ty :: TcType
ty) = EqRel -> VarSet -> TcType -> Bool
go EqRel
NomEq VarSet
bvs TcType
ty
go_arg bvs :: VarSet
bvs (Representational, ty :: TcType
ty) = EqRel -> VarSet -> TcType -> Bool
go EqRel
ReprEq VarSet
bvs TcType
ty
go_arg _ (Phantom, _) = Bool
False
go_co :: EqRel -> VarSet -> KindCoercion -> Bool
go_co rl :: EqRel
rl bvs :: VarSet
bvs co :: KindCoercion
co
| Bool
ignore_cos = Bool
False
| Bool
otherwise = (TcTyVar -> Bool) -> VarSet -> Bool
anyVarSet (EqRel -> VarSet -> TcTyVar -> Bool
go_tv EqRel
rl VarSet
bvs) (KindCoercion -> VarSet
tyCoVarsOfCo KindCoercion
co)
tcIsTcTyVar :: TcTyVar -> Bool
tcIsTcTyVar :: TcTyVar -> Bool
tcIsTcTyVar tv :: TcTyVar
tv = TcTyVar -> Bool
isTyVar TcTyVar
tv
isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isTouchableMetaTyVar ctxt_tclvl :: TcLevel
ctxt_tclvl tv :: TcTyVar
tv
| TcTyVar -> Bool
isTyVar TcTyVar
tv
, MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tv_tclvl, mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } <- TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv
, Bool -> Bool
not (MetaInfo -> Bool
isFlattenInfo MetaInfo
info)
= ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,
ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )
TcLevel
tv_tclvl TcLevel -> TcLevel -> Bool
`sameDepthAs` TcLevel
ctxt_tclvl
| Bool
otherwise = Bool
False
isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isFloatedTouchableMetaTyVar ctxt_tclvl :: TcLevel
ctxt_tclvl tv :: TcTyVar
tv
| TcTyVar -> Bool
isTyVar TcTyVar
tv
, MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tv_tclvl, mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } <- TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv
, Bool -> Bool
not (MetaInfo -> Bool
isFlattenInfo MetaInfo
info)
= TcLevel
tv_tclvl TcLevel -> TcLevel -> Bool
`strictlyDeeperThan` TcLevel
ctxt_tclvl
| Bool
otherwise = Bool
False
isImmutableTyVar :: TyVar -> Bool
isImmutableTyVar :: TcTyVar -> Bool
isImmutableTyVar tv :: TcTyVar
tv = TcTyVar -> Bool
isSkolemTyVar TcTyVar
tv
isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
isMetaTyVar, isAmbiguousTyVar,
isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool
isTyConableTyVar :: TcTyVar -> Bool
isTyConableTyVar tv :: TcTyVar
tv
| TcTyVar -> Bool
isTyVar TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
TyVarTv } -> Bool
False
_ -> Bool
True
| Bool
otherwise = Bool
True
isFmvTyVar :: TcTyVar -> Bool
isFmvTyVar tv :: TcTyVar
tv
= ASSERT2( tcIsTcTyVar tv, ppr tv )
case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
FlatMetaTv } -> Bool
True
_ -> Bool
False
isFskTyVar :: TcTyVar -> Bool
isFskTyVar tv :: TcTyVar
tv
= ASSERT2( tcIsTcTyVar tv, ppr tv )
case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
FlatSkolTv } -> Bool
True
_ -> Bool
False
isFlattenTyVar :: TcTyVar -> Bool
isFlattenTyVar tv :: TcTyVar
tv
= ASSERT2( tcIsTcTyVar tv, ppr tv )
case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } -> MetaInfo -> Bool
isFlattenInfo MetaInfo
info
_ -> Bool
False
isSkolemTyVar :: TcTyVar -> Bool
isSkolemTyVar tv :: TcTyVar
tv
= ASSERT2( tcIsTcTyVar tv, ppr tv )
case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv {} -> Bool
False
_other :: TcTyVarDetails
_other -> Bool
True
isOverlappableTyVar :: TcTyVar -> Bool
isOverlappableTyVar tv :: TcTyVar
tv
| TcTyVar -> Bool
isTyVar TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
SkolemTv _ overlappable :: Bool
overlappable -> Bool
overlappable
_ -> Bool
False
| Bool
otherwise = Bool
False
isMetaTyVar :: TcTyVar -> Bool
isMetaTyVar tv :: TcTyVar
tv
| TcTyVar -> Bool
isTyVar TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv {} -> Bool
True
_ -> Bool
False
| Bool
otherwise = Bool
False
isAmbiguousTyVar :: TcTyVar -> Bool
isAmbiguousTyVar tv :: TcTyVar
tv
| TcTyVar -> Bool
isTyVar TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv {} -> Bool
True
RuntimeUnk {} -> Bool
True
_ -> Bool
False
| Bool
otherwise = Bool
False
isMetaTyVarTy :: TcType -> Bool
isMetaTyVarTy :: TcType -> Bool
isMetaTyVarTy (TyVarTy tv :: TcTyVar
tv) = TcTyVar -> Bool
isMetaTyVar TcTyVar
tv
isMetaTyVarTy _ = Bool
False
metaTyVarInfo :: TcTyVar -> MetaInfo
metaTyVarInfo :: TcTyVar -> MetaInfo
metaTyVarInfo tv :: TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } -> MetaInfo
info
_ -> String -> SDoc -> MetaInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic "metaTyVarInfo" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv)
isFlattenInfo :: MetaInfo -> Bool
isFlattenInfo :: MetaInfo -> Bool
isFlattenInfo FlatMetaTv = Bool
True
isFlattenInfo FlatSkolTv = Bool
True
isFlattenInfo _ = Bool
False
metaTyVarTcLevel :: TcTyVar -> TcLevel
metaTyVarTcLevel :: TcTyVar -> TcLevel
metaTyVarTcLevel tv :: TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tclvl } -> TcLevel
tclvl
_ -> String -> SDoc -> TcLevel
forall a. HasCallStack => String -> SDoc -> a
pprPanic "metaTyVarTcLevel" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv)
metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel
metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel
metaTyVarTcLevel_maybe tv :: TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv { mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
tclvl } -> TcLevel -> Maybe TcLevel
forall a. a -> Maybe a
Just TcLevel
tclvl
_ -> Maybe TcLevel
forall a. Maybe a
Nothing
metaTyVarRef :: TyVar -> IORef MetaDetails
metaTyVarRef :: TcTyVar -> IORef MetaDetails
metaTyVarRef tv :: TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv { mtv_ref :: TcTyVarDetails -> IORef MetaDetails
mtv_ref = IORef MetaDetails
ref } -> IORef MetaDetails
ref
_ -> String -> SDoc -> IORef MetaDetails
forall a. HasCallStack => String -> SDoc -> a
pprPanic "metaTyVarRef" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv)
setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar
setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar
setMetaTyVarTcLevel tv :: TcTyVar
tv tclvl :: TcLevel
tclvl
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
details :: TcTyVarDetails
details@(MetaTv {}) -> TcTyVar -> TcTyVarDetails -> TcTyVar
setTcTyVarDetails TcTyVar
tv (TcTyVarDetails
details { mtv_tclvl :: TcLevel
mtv_tclvl = TcLevel
tclvl })
_ -> String -> SDoc -> TcTyVar
forall a. HasCallStack => String -> SDoc -> a
pprPanic "metaTyVarTcLevel" (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv)
isTyVarTyVar :: Var -> Bool
isTyVarTyVar :: TcTyVar -> Bool
isTyVarTyVar tv :: TcTyVar
tv
= case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
MetaTv { mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
TyVarTv } -> Bool
True
_ -> Bool
False
isFlexi, isIndirect :: MetaDetails -> Bool
isFlexi :: MetaDetails -> Bool
isFlexi Flexi = Bool
True
isFlexi _ = Bool
False
isIndirect :: MetaDetails -> Bool
isIndirect (Indirect _) = Bool
True
isIndirect _ = Bool
False
isRuntimeUnkSkol :: TyVar -> Bool
isRuntimeUnkSkol :: TcTyVar -> Bool
isRuntimeUnkSkol x :: TcTyVar
x
| TcTyVarDetails
RuntimeUnk <- TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
x = Bool
True
| Bool
otherwise = Bool
False
mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)]
mkTyVarNamePairs :: [TcTyVar] -> [(Name, TcTyVar)]
mkTyVarNamePairs tvs :: [TcTyVar]
tvs = [(TcTyVar -> Name
tyVarName TcTyVar
tv, TcTyVar
tv) | TcTyVar
tv <- [TcTyVar]
tvs]
findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)]
findDupTyVarTvs :: [(Name, TcTyVar)] -> [(Name, Name)]
findDupTyVarTvs prs :: [(Name, TcTyVar)]
prs
= (NonEmpty (Name, TcTyVar) -> [(Name, Name)])
-> [NonEmpty (Name, TcTyVar)] -> [(Name, Name)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (Name, TcTyVar) -> [(Name, Name)]
forall b b. NonEmpty (b, b) -> [(b, b)]
mk_result_prs ([NonEmpty (Name, TcTyVar)] -> [(Name, Name)])
-> [NonEmpty (Name, TcTyVar)] -> [(Name, Name)]
forall a b. (a -> b) -> a -> b
$
((Name, TcTyVar) -> (Name, TcTyVar) -> Bool)
-> [(Name, TcTyVar)] -> [NonEmpty (Name, TcTyVar)]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (Name, TcTyVar) -> (Name, TcTyVar) -> Bool
forall a a a. Eq a => (a, a) -> (a, a) -> Bool
eq_snd [(Name, TcTyVar)]
prs
where
eq_snd :: (a, a) -> (a, a) -> Bool
eq_snd (_,tv1 :: a
tv1) (_,tv2 :: 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 ((n1 :: b
n1,_) :| xs :: [(b, b)]
xs) = ((b, b) -> (b, b)) -> [(b, b)] -> [(b, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(n2 :: b
n2,_) -> (b
n1,b
n2)) [(b, b)]
xs
mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type
mkSigmaTy :: [TyCoVarBinder] -> [TcType] -> TcType -> TcType
mkSigmaTy bndrs :: [TyCoVarBinder]
bndrs theta :: [TcType]
theta tau :: TcType
tau = [TyCoVarBinder] -> TcType -> TcType
mkForAllTys [TyCoVarBinder]
bndrs ([TcType] -> TcType -> TcType
mkPhiTy [TcType]
theta TcType
tau)
mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type
mkInfSigmaTy :: [TcTyVar] -> [TcType] -> TcType -> TcType
mkInfSigmaTy tyvars :: [TcTyVar]
tyvars theta :: [TcType]
theta ty :: TcType
ty = [TyCoVarBinder] -> [TcType] -> TcType -> TcType
mkSigmaTy (ArgFlag -> [TcTyVar] -> [TyCoVarBinder]
mkTyCoVarBinders ArgFlag
Inferred [TcTyVar]
tyvars) [TcType]
theta TcType
ty
mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
mkSpecSigmaTy :: [TcTyVar] -> [TcType] -> TcType -> TcType
mkSpecSigmaTy tyvars :: [TcTyVar]
tyvars preds :: [TcType]
preds ty :: TcType
ty = [TyCoVarBinder] -> [TcType] -> TcType -> TcType
mkSigmaTy (ArgFlag -> [TcTyVar] -> [TyCoVarBinder]
mkTyCoVarBinders ArgFlag
Specified [TcTyVar]
tyvars) [TcType]
preds TcType
ty
mkPhiTy :: [PredType] -> Type -> Type
mkPhiTy :: [TcType] -> TcType -> TcType
mkPhiTy = [TcType] -> TcType -> TcType
mkInvisFunTys
getDFunTyKey :: Type -> OccName
getDFunTyKey :: TcType -> OccName
getDFunTyKey ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
coreView TcType
ty = TcType -> OccName
getDFunTyKey TcType
ty'
getDFunTyKey (TyVarTy tv :: TcTyVar
tv) = TcTyVar -> OccName
forall a. NamedThing a => a -> OccName
getOccName TcTyVar
tv
getDFunTyKey (TyConApp tc :: TyCon
tc _) = TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tc
getDFunTyKey (LitTy x :: TyLit
x) = TyLit -> OccName
getDFunTyLitKey TyLit
x
getDFunTyKey (AppTy fun :: TcType
fun _) = TcType -> OccName
getDFunTyKey TcType
fun
getDFunTyKey (FunTy {}) = TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
funTyCon
getDFunTyKey (ForAllTy _ t :: TcType
t) = TcType -> OccName
getDFunTyKey TcType
t
getDFunTyKey (CastTy ty :: TcType
ty _) = TcType -> OccName
getDFunTyKey TcType
ty
getDFunTyKey t :: TcType
t@(CoercionTy _) = String -> SDoc -> OccName
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getDFunTyKey" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
t)
getDFunTyLitKey :: TyLit -> OccName
getDFunTyLitKey :: TyLit -> OccName
getDFunTyLitKey (NumTyLit n :: Integer
n) = NameSpace -> String -> OccName
mkOccName NameSpace
Name.varName (Integer -> String
forall a. Show a => a -> String
show Integer
n)
getDFunTyLitKey (StrTyLit n :: FastString
n) = NameSpace -> String -> OccName
mkOccName NameSpace
Name.varName (FastString -> String
forall a. Show a => a -> String
show FastString
n)
mkTcAppTys :: Type -> [Type] -> Type
mkTcAppTys :: TcType -> [TcType] -> TcType
mkTcAppTys = TcType -> [TcType] -> TcType
mkAppTys
mkTcAppTy :: Type -> Type -> Type
mkTcAppTy :: TcType -> TcType -> TcType
mkTcAppTy = TcType -> TcType -> TcType
mkAppTy
mkTcCastTy :: Type -> Coercion -> Type
mkTcCastTy :: TcType -> KindCoercion -> TcType
mkTcCastTy = TcType -> KindCoercion -> TcType
mkCastTy
tcSplitPiTys :: Type -> ([TyBinder], Type)
tcSplitPiTys :: TcType -> ([TyBinder], TcType)
tcSplitPiTys ty :: TcType
ty
= ASSERT( all isTyBinder (fst sty) ) sty
where sty :: ([TyBinder], TcType)
sty = TcType -> ([TyBinder], TcType)
splitPiTys TcType
ty
tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type)
tcSplitPiTy_maybe :: TcType -> Maybe (TyBinder, TcType)
tcSplitPiTy_maybe ty :: TcType
ty
= ASSERT( isMaybeTyBinder sty ) sty
where
sty :: Maybe (TyBinder, TcType)
sty = TcType -> Maybe (TyBinder, TcType)
splitPiTy_maybe TcType
ty
isMaybeTyBinder :: Maybe (TyBinder, b) -> Bool
isMaybeTyBinder (Just (t :: TyBinder
t,_)) = TyBinder -> Bool
isTyBinder TyBinder
t
isMaybeTyBinder _ = Bool
True
tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type)
tcSplitForAllTy_maybe :: TcType -> Maybe (TyCoVarBinder, TcType)
tcSplitForAllTy_maybe ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe (TyCoVarBinder, TcType)
tcSplitForAllTy_maybe TcType
ty'
tcSplitForAllTy_maybe (ForAllTy tv :: TyCoVarBinder
tv ty :: TcType
ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty)
tcSplitForAllTy_maybe _ = Maybe (TyCoVarBinder, TcType)
forall a. Maybe a
Nothing
tcSplitForAllTys :: Type -> ([TyVar], Type)
tcSplitForAllTys :: TcType -> ([TcTyVar], TcType)
tcSplitForAllTys ty :: TcType
ty
= ASSERT( all isTyVar (fst sty) ) sty
where sty :: ([TcTyVar], TcType)
sty = TcType -> ([TcTyVar], TcType)
splitForAllTys TcType
ty
tcSplitForAllTysSameVis :: ArgFlag -> Type -> ([TyVar], Type)
tcSplitForAllTysSameVis :: ArgFlag -> TcType -> ([TcTyVar], TcType)
tcSplitForAllTysSameVis supplied_argf :: ArgFlag
supplied_argf ty :: TcType
ty = ASSERT( all isTyVar (fst sty) ) sty
where sty :: ([TcTyVar], TcType)
sty = ArgFlag -> TcType -> ([TcTyVar], TcType)
splitForAllTysSameVis ArgFlag
supplied_argf TcType
ty
tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type)
tcSplitForAllVarBndrs :: TcType -> ([TyCoVarBinder], TcType)
tcSplitForAllVarBndrs ty :: TcType
ty = ASSERT( all isTyVarBinder (fst sty)) sty
where sty :: ([TyCoVarBinder], TcType)
sty = TcType -> ([TyCoVarBinder], TcType)
splitForAllVarBndrs TcType
ty
tcIsForAllTy :: Type -> Bool
tcIsForAllTy :: TcType -> Bool
tcIsForAllTy ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
tcIsForAllTy TcType
ty'
tcIsForAllTy (ForAllTy {}) = Bool
True
tcIsForAllTy _ = Bool
False
tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
tcSplitPredFunTy_maybe :: TcType -> Maybe (TcType, TcType)
tcSplitPredFunTy_maybe ty :: TcType
ty
| Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe (TcType, TcType)
tcSplitPredFunTy_maybe TcType
ty'
tcSplitPredFunTy_maybe (FunTy { ft_af :: TcType -> AnonArgFlag
ft_af = AnonArgFlag
InvisArg
, ft_arg :: TcType -> TcType
ft_arg = TcType
arg, ft_res :: TcType -> TcType
ft_res = TcType
res })
= (TcType, TcType) -> Maybe (TcType, TcType)
forall a. a -> Maybe a
Just (TcType
arg, TcType
res)
tcSplitPredFunTy_maybe _
= Maybe (TcType, TcType)
forall a. Maybe a
Nothing
tcSplitPhiTy :: Type -> (ThetaType, Type)
tcSplitPhiTy :: TcType -> ([TcType], TcType)
tcSplitPhiTy ty :: TcType
ty
= TcType -> [TcType] -> ([TcType], TcType)
split TcType
ty []
where
split :: TcType -> [TcType] -> ([TcType], TcType)
split ty :: TcType
ty ts :: [TcType]
ts
= case TcType -> Maybe (TcType, TcType)
tcSplitPredFunTy_maybe TcType
ty of
Just (pred :: TcType
pred, ty :: TcType
ty) -> TcType -> [TcType] -> ([TcType], TcType)
split TcType
ty (TcType
predTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
ts)
Nothing -> ([TcType] -> [TcType]
forall a. [a] -> [a]
reverse [TcType]
ts, TcType
ty)
tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy :: TcType -> ([TcTyVar], [TcType], TcType)
tcSplitSigmaTy ty :: TcType
ty = case TcType -> ([TcTyVar], TcType)
tcSplitForAllTys TcType
ty of
(tvs :: [TcTyVar]
tvs, rho :: TcType
rho) -> case TcType -> ([TcType], TcType)
tcSplitPhiTy TcType
rho of
(theta :: [TcType]
theta, tau :: TcType
tau) -> ([TcTyVar]
tvs, [TcType]
theta, TcType
tau)
tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type)
tcSplitNestedSigmaTys :: TcType -> ([TcTyVar], [TcType], TcType)
tcSplitNestedSigmaTys ty :: TcType
ty
| Just (arg_tys :: [TcType]
arg_tys, tvs1 :: [TcTyVar]
tvs1, theta1 :: [TcType]
theta1, rho1 :: TcType
rho1) <- TcType -> Maybe ([TcType], [TcTyVar], [TcType], TcType)
tcDeepSplitSigmaTy_maybe TcType
ty
= let (tvs2 :: [TcTyVar]
tvs2, theta2 :: [TcType]
theta2, rho2 :: TcType
rho2) = TcType -> ([TcTyVar], [TcType], TcType)
tcSplitNestedSigmaTys TcType
rho1
in ([TcTyVar]
tvs1 [TcTyVar] -> [TcTyVar] -> [TcTyVar]
forall a. [a] -> [a] -> [a]
++ [TcTyVar]
tvs2, [TcType]
theta1 [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
theta2, [TcType] -> TcType -> TcType
mkVisFunTys [TcType]
arg_tys TcType
rho2)
| Bool
otherwise = ([], [], TcType
ty)
tcDeepSplitSigmaTy_maybe
:: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType)
tcDeepSplitSigmaTy_maybe :: TcType -> Maybe ([TcType], [TcTyVar], [TcType], TcType)
tcDeepSplitSigmaTy_maybe ty :: TcType
ty
| Just (arg_ty :: TcType
arg_ty, res_ty :: TcType
res_ty) <- TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe TcType
ty
, Just (arg_tys :: [TcType]
arg_tys, tvs :: [TcTyVar]
tvs, theta :: [TcType]
theta, rho :: TcType
rho) <- TcType -> Maybe ([TcType], [TcTyVar], [TcType], TcType)
tcDeepSplitSigmaTy_maybe TcType
res_ty
= ([TcType], [TcTyVar], [TcType], TcType)
-> Maybe ([TcType], [TcTyVar], [TcType], TcType)
forall a. a -> Maybe a
Just (TcType
arg_tyTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
arg_tys, [TcTyVar]
tvs, [TcType]
theta, TcType
rho)
| (tvs :: [TcTyVar]
tvs, theta :: [TcType]
theta, rho :: TcType
rho) <- TcType -> ([TcTyVar], [TcType], TcType)
tcSplitSigmaTy TcType
ty
, Bool -> Bool
not ([TcTyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tvs Bool -> Bool -> Bool
&& [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcType]
theta)
= ([TcType], [TcTyVar], [TcType], TcType)
-> Maybe ([TcType], [TcTyVar], [TcType], TcType)
forall a. a -> Maybe a
Just ([], [TcTyVar]
tvs, [TcType]
theta, TcType
rho)
| Bool
otherwise = Maybe ([TcType], [TcTyVar], [TcType], TcType)
forall a. Maybe a
Nothing
tcTyConAppTyCon :: Type -> TyCon
tcTyConAppTyCon :: TcType -> TyCon
tcTyConAppTyCon ty :: TcType
ty
= case TcType -> Maybe TyCon
tcTyConAppTyCon_maybe TcType
ty of
Just tc :: TyCon
tc -> TyCon
tc
Nothing -> String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcTyConAppTyCon" (TcType -> SDoc
pprType TcType
ty)
tcTyConAppTyCon_maybe :: Type -> Maybe TyCon
tcTyConAppTyCon_maybe :: TcType -> Maybe TyCon
tcTyConAppTyCon_maybe ty :: TcType
ty
| Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe TyCon
tcTyConAppTyCon_maybe TcType
ty'
tcTyConAppTyCon_maybe (TyConApp tc :: TyCon
tc _)
= TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tc
tcTyConAppTyCon_maybe (FunTy { ft_af :: TcType -> AnonArgFlag
ft_af = AnonArgFlag
VisArg })
= TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
funTyCon
tcTyConAppTyCon_maybe _
= Maybe TyCon
forall a. Maybe a
Nothing
tcTyConAppArgs :: Type -> [Type]
tcTyConAppArgs :: TcType -> [TcType]
tcTyConAppArgs ty :: TcType
ty = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
Just (_, args :: [TcType]
args) -> [TcType]
args
Nothing -> String -> SDoc -> [TcType]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcTyConAppArgs" (TcType -> SDoc
pprType TcType
ty)
tcSplitTyConApp :: Type -> (TyCon, [Type])
tcSplitTyConApp :: TcType -> (TyCon, [TcType])
tcSplitTyConApp ty :: TcType
ty = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
Just stuff :: (TyCon, [TcType])
stuff -> (TyCon, [TcType])
stuff
Nothing -> String -> SDoc -> (TyCon, [TcType])
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcSplitTyConApp" (TcType -> SDoc
pprType TcType
ty)
tcSplitFunTys :: Type -> ([Type], Type)
tcSplitFunTys :: TcType -> ([TcType], TcType)
tcSplitFunTys ty :: TcType
ty = case TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe TcType
ty of
Nothing -> ([], TcType
ty)
Just (arg :: TcType
arg,res :: TcType
res) -> (TcType
argTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
args, TcType
res')
where
(args :: [TcType]
args,res' :: TcType
res') = TcType -> ([TcType], TcType)
tcSplitFunTys TcType
res
tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
tcSplitFunTy_maybe :: TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe ty :: TcType
ty
| Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe TcType
ty'
tcSplitFunTy_maybe (FunTy { ft_af :: TcType -> AnonArgFlag
ft_af = AnonArgFlag
af, ft_arg :: TcType -> TcType
ft_arg = TcType
arg, ft_res :: TcType -> TcType
ft_res = TcType
res })
| AnonArgFlag
VisArg <- AnonArgFlag
af = (TcType, TcType) -> Maybe (TcType, TcType)
forall a. a -> Maybe a
Just (TcType
arg, TcType
res)
tcSplitFunTy_maybe _ = Maybe (TcType, TcType)
forall a. Maybe a
Nothing
tcSplitFunTysN :: Arity
-> TcRhoType
-> Either Arity
([TcSigmaType],
TcSigmaType)
tcSplitFunTysN :: Int -> TcType -> Either Int ([TcType], TcType)
tcSplitFunTysN n :: Int
n ty :: TcType
ty
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
= ([TcType], TcType) -> Either Int ([TcType], TcType)
forall a b. b -> Either a b
Right ([], TcType
ty)
| Just (arg :: TcType
arg,res :: TcType
res) <- TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe TcType
ty
= case Int -> TcType -> Either Int ([TcType], TcType)
tcSplitFunTysN (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) TcType
res of
Left m :: Int
m -> Int -> Either Int ([TcType], TcType)
forall a b. a -> Either a b
Left Int
m
Right (args :: [TcType]
args,body :: TcType
body) -> ([TcType], TcType) -> Either Int ([TcType], TcType)
forall a b. b -> Either a b
Right (TcType
argTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
args, TcType
body)
| Bool
otherwise
= Int -> Either Int ([TcType], TcType)
forall a b. a -> Either a b
Left Int
n
tcSplitFunTy :: Type -> (Type, Type)
tcSplitFunTy :: TcType -> (TcType, TcType)
tcSplitFunTy ty :: TcType
ty = String -> Maybe (TcType, TcType) -> (TcType, TcType)
forall a. HasCallStack => String -> Maybe a -> a
expectJust "tcSplitFunTy" (TcType -> Maybe (TcType, TcType)
tcSplitFunTy_maybe TcType
ty)
tcFunArgTy :: Type -> Type
tcFunArgTy :: TcType -> TcType
tcFunArgTy ty :: TcType
ty = (TcType, TcType) -> TcType
forall a b. (a, b) -> a
fst (TcType -> (TcType, TcType)
tcSplitFunTy TcType
ty)
tcFunResultTy :: Type -> Type
tcFunResultTy :: TcType -> TcType
tcFunResultTy ty :: TcType
ty = (TcType, TcType) -> TcType
forall a b. (a, b) -> b
snd (TcType -> (TcType, TcType)
tcSplitFunTy TcType
ty)
tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type
tcFunResultTyN :: Int -> TcType -> TcType
tcFunResultTyN n :: Int
n ty :: TcType
ty
| Right (_, res_ty :: TcType
res_ty) <- Int -> TcType -> Either Int ([TcType], TcType)
tcSplitFunTysN Int
n TcType
ty
= TcType
res_ty
| Bool
otherwise
= String -> SDoc -> TcType
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcFunResultTyN" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe :: TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty'
tcSplitAppTy_maybe ty :: TcType
ty = TcType -> Maybe (TcType, TcType)
tcRepSplitAppTy_maybe TcType
ty
tcSplitAppTy :: Type -> (Type, Type)
tcSplitAppTy :: TcType -> (TcType, TcType)
tcSplitAppTy ty :: TcType
ty = case TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty of
Just stuff :: (TcType, TcType)
stuff -> (TcType, TcType)
stuff
Nothing -> String -> SDoc -> (TcType, TcType)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcSplitAppTy" (TcType -> SDoc
pprType TcType
ty)
tcSplitAppTys :: Type -> (Type, [Type])
tcSplitAppTys :: TcType -> (TcType, [TcType])
tcSplitAppTys ty :: TcType
ty
= TcType -> [TcType] -> (TcType, [TcType])
go TcType
ty []
where
go :: TcType -> [TcType] -> (TcType, [TcType])
go ty :: TcType
ty args :: [TcType]
args = case TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty of
Just (ty' :: TcType
ty', arg :: TcType
arg) -> TcType -> [TcType] -> (TcType, [TcType])
go TcType
ty' (TcType
argTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
args)
Nothing -> (TcType
ty,[TcType]
args)
tcRepGetNumAppTys :: Type -> Arity
tcRepGetNumAppTys :: TcType -> Int
tcRepGetNumAppTys = [TcType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TcType] -> Int) -> (TcType -> [TcType]) -> TcType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcType, [TcType]) -> [TcType]
forall a b. (a, b) -> b
snd ((TcType, [TcType]) -> [TcType])
-> (TcType -> (TcType, [TcType])) -> TcType -> [TcType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => TcType -> (TcType, [TcType])
TcType -> (TcType, [TcType])
repSplitAppTys
tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)
tcGetCastedTyVar_maybe :: TcType -> Maybe (TcTyVar, KindCoercion)
tcGetCastedTyVar_maybe ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe (TcTyVar, KindCoercion)
tcGetCastedTyVar_maybe TcType
ty'
tcGetCastedTyVar_maybe (CastTy (TyVarTy tv :: TcTyVar
tv) co :: KindCoercion
co) = (TcTyVar, KindCoercion) -> Maybe (TcTyVar, KindCoercion)
forall a. a -> Maybe a
Just (TcTyVar
tv, KindCoercion
co)
tcGetCastedTyVar_maybe (TyVarTy tv :: TcTyVar
tv) = (TcTyVar, KindCoercion) -> Maybe (TcTyVar, KindCoercion)
forall a. a -> Maybe a
Just (TcTyVar
tv, TcType -> KindCoercion
mkNomReflCo (TcTyVar -> TcType
tyVarKind TcTyVar
tv))
tcGetCastedTyVar_maybe _ = Maybe (TcTyVar, KindCoercion)
forall a. Maybe a
Nothing
tcGetTyVar_maybe :: Type -> Maybe TyVar
tcGetTyVar_maybe :: TcType -> Maybe TcTyVar
tcGetTyVar_maybe ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Maybe TcTyVar
tcGetTyVar_maybe TcType
ty'
tcGetTyVar_maybe (TyVarTy tv :: TcTyVar
tv) = TcTyVar -> Maybe TcTyVar
forall a. a -> Maybe a
Just TcTyVar
tv
tcGetTyVar_maybe _ = Maybe TcTyVar
forall a. Maybe a
Nothing
tcGetTyVar :: String -> Type -> TyVar
tcGetTyVar :: String -> TcType -> TcTyVar
tcGetTyVar msg :: String
msg ty :: TcType
ty
= case TcType -> Maybe TcTyVar
tcGetTyVar_maybe TcType
ty of
Just tv :: TcTyVar
tv -> TcTyVar
tv
Nothing -> String -> SDoc -> TcTyVar
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
msg (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)
tcIsTyVarTy :: Type -> Bool
tcIsTyVarTy :: TcType -> Bool
tcIsTyVarTy ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
tcIsTyVarTy TcType
ty'
tcIsTyVarTy (CastTy ty :: TcType
ty _) = TcType -> Bool
tcIsTyVarTy TcType
ty
tcIsTyVarTy (TyVarTy _) = Bool
True
tcIsTyVarTy _ = Bool
False
tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy :: TcType -> ([TcTyVar], [TcType], Class, [TcType])
tcSplitDFunTy ty :: TcType
ty
= case TcType -> ([TcTyVar], TcType)
tcSplitForAllTys TcType
ty of { (tvs :: [TcTyVar]
tvs, rho :: TcType
rho) ->
case TcType -> ([TcType], TcType)
splitFunTys TcType
rho of { (theta :: [TcType]
theta, tau :: TcType
tau) ->
case TcType -> (Class, [TcType])
tcSplitDFunHead TcType
tau of { (clas :: Class
clas, tys :: [TcType]
tys) ->
([TcTyVar]
tvs, [TcType]
theta, Class
clas, [TcType]
tys) }}}
tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead :: TcType -> (Class, [TcType])
tcSplitDFunHead = HasDebugCallStack => TcType -> (Class, [TcType])
TcType -> (Class, [TcType])
getClassPredTys
tcSplitMethodTy :: Type -> ([TyVar], PredType, Type)
tcSplitMethodTy :: TcType -> ([TcTyVar], TcType, TcType)
tcSplitMethodTy ty :: TcType
ty
| (sel_tyvars :: [TcTyVar]
sel_tyvars,sel_rho :: TcType
sel_rho) <- TcType -> ([TcTyVar], TcType)
tcSplitForAllTys TcType
ty
, Just (first_pred :: TcType
first_pred, local_meth_ty :: TcType
local_meth_ty) <- TcType -> Maybe (TcType, TcType)
tcSplitPredFunTy_maybe TcType
sel_rho
= ([TcTyVar]
sel_tyvars, TcType
first_pred, TcType
local_meth_ty)
| Bool
otherwise
= String -> SDoc -> ([TcTyVar], TcType, TcType)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcSplitMethodTy" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)
tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool
tcEqKind :: TcType -> TcType -> Bool
tcEqKind = HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
tcEqType
tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool
tcEqType :: TcType -> TcType -> Bool
tcEqType ty1 :: TcType
ty1 ty2 :: TcType
ty2
= Bool -> Bool -> TcType -> TcType -> Bool
tc_eq_type Bool
False Bool
False TcType
ki1 TcType
ki2
Bool -> Bool -> Bool
&& Bool -> Bool -> TcType -> TcType -> Bool
tc_eq_type Bool
False Bool
False TcType
ty1 TcType
ty2
where
ki1 :: TcType
ki1 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty1
ki2 :: TcType
ki2 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty2
tcEqTypeNoKindCheck :: TcType -> TcType -> Bool
tcEqTypeNoKindCheck :: TcType -> TcType -> Bool
tcEqTypeNoKindCheck ty1 :: TcType
ty1 ty2 :: TcType
ty2
= Bool -> Bool -> TcType -> TcType -> Bool
tc_eq_type Bool
False Bool
False TcType
ty1 TcType
ty2
tcEqTypeVis :: TcType -> TcType -> Bool
tcEqTypeVis :: TcType -> TcType -> Bool
tcEqTypeVis ty1 :: TcType
ty1 ty2 :: TcType
ty2 = Bool -> Bool -> TcType -> TcType -> Bool
tc_eq_type Bool
False Bool
True TcType
ty1 TcType
ty2
pickyEqType :: TcType -> TcType -> Bool
pickyEqType :: TcType -> TcType -> Bool
pickyEqType ty1 :: TcType
ty1 ty2 :: TcType
ty2 = Bool -> Bool -> TcType -> TcType -> Bool
tc_eq_type Bool
True Bool
False TcType
ty1 TcType
ty2
tc_eq_type :: Bool
-> Bool
-> Type -> Type
-> Bool
tc_eq_type :: Bool -> Bool -> TcType -> TcType -> Bool
tc_eq_type keep_syns :: Bool
keep_syns vis_only :: Bool
vis_only orig_ty1 :: TcType
orig_ty1 orig_ty2 :: TcType
orig_ty2
= RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
orig_env TcType
orig_ty1 TcType
orig_ty2
where
go :: RnEnv2 -> Type -> Type -> Bool
go :: RnEnv2 -> TcType -> TcType -> Bool
go env :: RnEnv2
env t1 :: TcType
t1 t2 :: TcType
t2 | Bool -> Bool
not Bool
keep_syns, Just t1' :: TcType
t1' <- TcType -> Maybe TcType
tcView TcType
t1 = RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
t1' TcType
t2
go env :: RnEnv2
env t1 :: TcType
t1 t2 :: TcType
t2 | Bool -> Bool
not Bool
keep_syns, Just t2' :: TcType
t2' <- TcType -> Maybe TcType
tcView TcType
t2 = RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
t1 TcType
t2'
go env :: RnEnv2
env (TyVarTy tv1 :: TcTyVar
tv1) (TyVarTy tv2 :: TcTyVar
tv2)
= RnEnv2 -> TcTyVar -> TcTyVar
rnOccL RnEnv2
env TcTyVar
tv1 TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== RnEnv2 -> TcTyVar -> TcTyVar
rnOccR RnEnv2
env TcTyVar
tv2
go _ (LitTy lit1 :: TyLit
lit1) (LitTy lit2 :: TyLit
lit2)
= TyLit
lit1 TyLit -> TyLit -> Bool
forall a. Eq a => a -> a -> Bool
== TyLit
lit2
go env :: RnEnv2
env (ForAllTy (Bndr tv1 :: TcTyVar
tv1 vis1 :: ArgFlag
vis1) ty1 :: TcType
ty1)
(ForAllTy (Bndr tv2 :: TcTyVar
tv2 vis2 :: ArgFlag
vis2) ty2 :: TcType
ty2)
= ArgFlag
vis1 ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ArgFlag
vis2
Bool -> Bool -> Bool
&& (Bool
vis_only Bool -> Bool -> Bool
|| RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env (TcTyVar -> TcType
varType TcTyVar
tv1) (TcTyVar -> TcType
varType TcTyVar
tv2))
Bool -> Bool -> Bool
&& RnEnv2 -> TcType -> TcType -> Bool
go (RnEnv2 -> TcTyVar -> TcTyVar -> RnEnv2
rnBndr2 RnEnv2
env TcTyVar
tv1 TcTyVar
tv2) TcType
ty1 TcType
ty2
go env :: RnEnv2
env (FunTy _ arg1 :: TcType
arg1 res1 :: TcType
res1) (FunTy _ arg2 :: TcType
arg2 res2 :: TcType
res2)
= RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
arg1 TcType
arg2 Bool -> Bool -> Bool
&& RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
res1 TcType
res2
go env :: RnEnv2
env ty :: TcType
ty (FunTy _ arg :: TcType
arg res :: TcType
res) = RnEnv2 -> TcType -> TcType -> TcType -> Bool
eqFunTy RnEnv2
env TcType
arg TcType
res TcType
ty
go env :: RnEnv2
env (FunTy _ arg :: TcType
arg res :: TcType
res) ty :: TcType
ty = RnEnv2 -> TcType -> TcType -> TcType -> Bool
eqFunTy RnEnv2
env TcType
arg TcType
res TcType
ty
go env :: RnEnv2
env (AppTy s1 :: TcType
s1 t1 :: TcType
t1) ty2 :: TcType
ty2
| Just (s2 :: TcType
s2, t2 :: TcType
t2) <- TcType -> Maybe (TcType, TcType)
tcRepSplitAppTy_maybe TcType
ty2
= RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
s1 TcType
s2 Bool -> Bool -> Bool
&& RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
t1 TcType
t2
go env :: RnEnv2
env ty1 :: TcType
ty1 (AppTy s2 :: TcType
s2 t2 :: TcType
t2)
| Just (s1 :: TcType
s1, t1 :: TcType
t1) <- TcType -> Maybe (TcType, TcType)
tcRepSplitAppTy_maybe TcType
ty1
= RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
s1 TcType
s2 Bool -> Bool -> Bool
&& RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
t1 TcType
t2
go env :: RnEnv2
env (TyConApp tc1 :: TyCon
tc1 ts1 :: [TcType]
ts1) (TyConApp tc2 :: TyCon
tc2 ts2 :: [TcType]
ts2)
= TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2 Bool -> Bool -> Bool
&& RnEnv2 -> [Bool] -> [TcType] -> [TcType] -> Bool
gos RnEnv2
env (TyCon -> [Bool]
tc_vis TyCon
tc1) [TcType]
ts1 [TcType]
ts2
go env :: RnEnv2
env (CastTy t1 :: TcType
t1 _) t2 :: TcType
t2 = RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
t1 TcType
t2
go env :: RnEnv2
env t1 :: TcType
t1 (CastTy t2 :: TcType
t2 _) = RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
t1 TcType
t2
go _ (CoercionTy {}) (CoercionTy {}) = Bool
True
go _ _ _ = Bool
False
gos :: RnEnv2 -> [Bool] -> [TcType] -> [TcType] -> Bool
gos _ _ [] [] = Bool
True
gos env :: RnEnv2
env (ig :: Bool
ig:igs :: [Bool]
igs) (t1 :: TcType
t1:ts1 :: [TcType]
ts1) (t2 :: TcType
t2:ts2 :: [TcType]
ts2) = (Bool
ig Bool -> Bool -> Bool
|| RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
t1 TcType
t2)
Bool -> Bool -> Bool
&& RnEnv2 -> [Bool] -> [TcType] -> [TcType] -> Bool
gos RnEnv2
env [Bool]
igs [TcType]
ts1 [TcType]
ts2
gos _ _ _ _ = Bool
False
tc_vis :: TyCon -> [Bool]
tc_vis :: TyCon -> [Bool]
tc_vis tc :: TyCon
tc | Bool
vis_only = [Bool]
inviss [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False
| Bool
otherwise = Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False
where
bndrs :: [TyConBinder]
bndrs = TyCon -> [TyConBinder]
tyConBinders TyCon
tc
inviss :: [Bool]
inviss = (TyConBinder -> Bool) -> [TyConBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isInvisibleTyConBinder [TyConBinder]
bndrs
orig_env :: RnEnv2
orig_env = InScopeSet -> RnEnv2
mkRnEnv2 (InScopeSet -> RnEnv2) -> InScopeSet -> RnEnv2
forall a b. (a -> b) -> a -> b
$ VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [TcType] -> VarSet
tyCoVarsOfTypes [TcType
orig_ty1, TcType
orig_ty2]
eqFunTy :: RnEnv2 -> Type -> Type -> Type -> Bool
eqFunTy :: RnEnv2 -> TcType -> TcType -> TcType -> Bool
eqFunTy env :: RnEnv2
env arg :: TcType
arg res :: TcType
res ty :: TcType
ty@(AppTy{}) = TcType -> [TcType] -> Bool
get_args TcType
ty []
where
get_args :: Type -> [Type] -> Bool
get_args :: TcType -> [TcType] -> Bool
get_args (AppTy f :: TcType
f x :: TcType
x) args :: [TcType]
args = TcType -> [TcType] -> Bool
get_args TcType
f (TcType
xTcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
:[TcType]
args)
get_args (CastTy t :: TcType
t _) args :: [TcType]
args = TcType -> [TcType] -> Bool
get_args TcType
t [TcType]
args
get_args (TyConApp tc :: TyCon
tc tys :: [TcType]
tys) args :: [TcType]
args
| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
funTyCon
, [_, _, arg' :: TcType
arg', res' :: TcType
res'] <- [TcType]
tys [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
args
= RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
arg TcType
arg' Bool -> Bool -> Bool
&& RnEnv2 -> TcType -> TcType -> Bool
go RnEnv2
env TcType
res TcType
res'
get_args _ _ = Bool
False
eqFunTy _ _ _ _ = Bool
False
isTyVarClassPred :: PredType -> Bool
isTyVarClassPred :: TcType -> Bool
isTyVarClassPred ty :: TcType
ty = case TcType -> Maybe (Class, [TcType])
getClassPredTys_maybe TcType
ty of
Just (_, tys :: [TcType]
tys) -> (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcType -> Bool
isTyVarTy [TcType]
tys
_ -> Bool
False
checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool
checkValidClsArgs :: Bool -> Class -> [TcType] -> Bool
checkValidClsArgs flexible_contexts :: Bool
flexible_contexts cls :: Class
cls kts :: [TcType]
kts
| Bool
flexible_contexts = Bool
True
| Bool
otherwise = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcType -> Bool
hasTyVarHead [TcType]
tys
where
tys :: [TcType]
tys = TyCon -> [TcType] -> [TcType]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
cls) [TcType]
kts
hasTyVarHead :: Type -> Bool
hasTyVarHead :: TcType -> Bool
hasTyVarHead ty :: TcType
ty
| TcType -> Bool
tcIsTyVarTy TcType
ty = Bool
True
| Bool
otherwise
= case TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty of
Just (ty :: TcType
ty, _) -> TcType -> Bool
hasTyVarHead TcType
ty
Nothing -> Bool
False
evVarPred :: EvVar -> PredType
evVarPred :: TcTyVar -> TcType
evVarPred var :: TcTyVar
var = TcTyVar -> TcType
varType TcTyVar
var
pickQuantifiablePreds
:: TyVarSet
-> TcThetaType
-> TcThetaType
pickQuantifiablePreds :: VarSet -> [TcType] -> [TcType]
pickQuantifiablePreds qtvs :: VarSet
qtvs theta :: [TcType]
theta
= let flex_ctxt :: Bool
flex_ctxt = Bool
True in
(TcType -> Maybe TcType) -> [TcType] -> [TcType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Bool -> TcType -> Maybe TcType
pick_me Bool
flex_ctxt) [TcType]
theta
where
pick_me :: Bool -> TcType -> Maybe TcType
pick_me flex_ctxt :: Bool
flex_ctxt pred :: TcType
pred
= case TcType -> Pred
classifyPredType TcType
pred of
ClassPred cls :: Class
cls tys :: [TcType]
tys
| Just {} <- Class -> [TcType] -> Maybe FastString
isCallStackPred Class
cls [TcType]
tys
-> Maybe TcType
forall a. Maybe a
Nothing
| Class -> Bool
isIPClass Class
cls
-> TcType -> Maybe TcType
forall a. a -> Maybe a
Just TcType
pred
| Bool -> Class -> [TcType] -> Bool
pick_cls_pred Bool
flex_ctxt Class
cls [TcType]
tys
-> TcType -> Maybe TcType
forall a. a -> Maybe a
Just TcType
pred
EqPred eq_rel :: EqRel
eq_rel ty1 :: TcType
ty1 ty2 :: TcType
ty2
| EqRel -> TcType -> TcType -> Bool
quantify_equality EqRel
eq_rel TcType
ty1 TcType
ty2
, Just (cls :: Class
cls, tys :: [TcType]
tys) <- EqRel -> TcType -> TcType -> Maybe (Class, [TcType])
boxEqPred EqRel
eq_rel TcType
ty1 TcType
ty2
, Bool -> Class -> [TcType] -> Bool
pick_cls_pred Bool
flex_ctxt Class
cls [TcType]
tys
-> TcType -> Maybe TcType
forall a. a -> Maybe a
Just (Class -> [TcType] -> TcType
mkClassPred Class
cls [TcType]
tys)
IrredPred ty :: TcType
ty
| TcType -> VarSet
tyCoVarsOfType TcType
ty VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
qtvs
-> TcType -> Maybe TcType
forall a. a -> Maybe a
Just TcType
pred
_ -> Maybe TcType
forall a. Maybe a
Nothing
pick_cls_pred :: Bool -> Class -> [TcType] -> Bool
pick_cls_pred flex_ctxt :: Bool
flex_ctxt cls :: Class
cls tys :: [TcType]
tys
= [TcType] -> VarSet
tyCoVarsOfTypes [TcType]
tys VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
qtvs
Bool -> Bool -> Bool
&& (Bool -> Class -> [TcType] -> Bool
checkValidClsArgs Bool
flex_ctxt Class
cls [TcType]
tys)
quantify_equality :: EqRel -> TcType -> TcType -> Bool
quantify_equality NomEq ty1 :: TcType
ty1 ty2 :: TcType
ty2 = TcType -> Bool
quant_fun TcType
ty1 Bool -> Bool -> Bool
|| TcType -> Bool
quant_fun TcType
ty2
quantify_equality ReprEq _ _ = Bool
True
quant_fun :: TcType -> Bool
quant_fun ty :: TcType
ty
= case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
Just (tc :: TyCon
tc, tys :: [TcType]
tys) | TyCon -> Bool
isTypeFamilyTyCon TyCon
tc
-> [TcType] -> VarSet
tyCoVarsOfTypes [TcType]
tys VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
qtvs
_ -> Bool
False
boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type])
boxEqPred :: EqRel -> TcType -> TcType -> Maybe (Class, [TcType])
boxEqPred eq_rel :: EqRel
eq_rel ty1 :: TcType
ty1 ty2 :: TcType
ty2
= case EqRel
eq_rel of
NomEq | Bool
homo_kind -> (Class, [TcType]) -> Maybe (Class, [TcType])
forall a. a -> Maybe a
Just (Class
eqClass, [TcType
k1, TcType
ty1, TcType
ty2])
| Bool
otherwise -> (Class, [TcType]) -> Maybe (Class, [TcType])
forall a. a -> Maybe a
Just (Class
heqClass, [TcType
k1, TcType
k2, TcType
ty1, TcType
ty2])
ReprEq | Bool
homo_kind -> (Class, [TcType]) -> Maybe (Class, [TcType])
forall a. a -> Maybe a
Just (Class
coercibleClass, [TcType
k1, TcType
ty1, TcType
ty2])
| Bool
otherwise -> Maybe (Class, [TcType])
forall a. Maybe a
Nothing
where
k1 :: TcType
k1 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty1
k2 :: TcType
k2 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty2
homo_kind :: Bool
homo_kind = TcType
k1 HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
`tcEqType` TcType
k2
pickCapturedPreds
:: TyVarSet
-> TcThetaType
-> TcThetaType
pickCapturedPreds :: VarSet -> [TcType] -> [TcType]
pickCapturedPreds qtvs :: VarSet
qtvs theta :: [TcType]
theta
= (TcType -> Bool) -> [TcType] -> [TcType]
forall a. (a -> Bool) -> [a] -> [a]
filter TcType -> Bool
captured [TcType]
theta
where
captured :: TcType -> Bool
captured pred :: TcType
pred = TcType -> Bool
isIPPred TcType
pred Bool -> Bool -> Bool
|| (TcType -> VarSet
tyCoVarsOfType TcType
pred VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
qtvs)
type PredWithSCs a = (PredType, [PredType], a)
mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a]
mkMinimalBySCs :: (a -> TcType) -> [a] -> [a]
mkMinimalBySCs get_pred :: a -> TcType
get_pred xs :: [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 = [ (TcType
pred, TcType
pred TcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
: TcType -> [TcType]
transSuperClasses TcType
pred, a
x)
| a
x <- [a]
xs
, let pred :: TcType
pred = a -> TcType
get_pred a
x ]
go :: [PredWithSCs a]
-> [PredWithSCs a]
-> [a]
go :: [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [] min_preds :: [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@(p :: TcType
p,_,_) : work_list :: [PredWithSCs a]
work_list) min_preds :: [PredWithSCs a]
min_preds
| EqPred _ t1 :: TcType
t1 t2 :: TcType
t2 <- TcType -> Pred
classifyPredType TcType
p
, TcType
t1 HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
`tcEqType` TcType
t2
= [PredWithSCs a] -> [PredWithSCs a] -> [a]
go [PredWithSCs a]
work_list [PredWithSCs a]
min_preds
| TcType
p TcType -> [PredWithSCs a] -> Bool
`in_cloud` [PredWithSCs a]
work_list Bool -> Bool -> Bool
|| TcType
p TcType -> [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 :: TcType -> [PredWithSCs a] -> Bool
in_cloud p :: TcType
p ps :: [PredWithSCs a]
ps = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ TcType
p HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
`tcEqType` TcType
p' | (_, scs :: [TcType]
scs, _) <- [PredWithSCs a]
ps, TcType
p' <- [TcType]
scs ]
transSuperClasses :: PredType -> [PredType]
transSuperClasses :: TcType -> [TcType]
transSuperClasses p :: TcType
p
= NameSet -> TcType -> [TcType]
go NameSet
emptyNameSet TcType
p
where
go :: NameSet -> PredType -> [PredType]
go :: NameSet -> TcType -> [TcType]
go rec_clss :: NameSet
rec_clss p :: TcType
p
| ClassPred cls :: Class
cls tys :: [TcType]
tys <- TcType -> Pred
classifyPredType TcType
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
= [ TcType
p' | TcType
sc <- Class -> [TcType] -> [TcType]
immSuperClasses Class
cls [TcType]
tys
, TcType
p' <- TcType
sc TcType -> [TcType] -> [TcType]
forall a. a -> [a] -> [a]
: NameSet -> TcType -> [TcType]
go NameSet
rec_clss' TcType
sc ]
| Bool
otherwise
= []
immSuperClasses :: Class -> [Type] -> [PredType]
immSuperClasses :: Class -> [TcType] -> [TcType]
immSuperClasses cls :: Class
cls tys :: [TcType]
tys
= HasCallStack => TCvSubst -> [TcType] -> [TcType]
TCvSubst -> [TcType] -> [TcType]
substTheta ([TcTyVar] -> [TcType] -> TCvSubst
HasDebugCallStack => [TcTyVar] -> [TcType] -> TCvSubst
zipTvSubst [TcTyVar]
tyvars [TcType]
tys) [TcType]
sc_theta
where
(tyvars :: [TcTyVar]
tyvars,sc_theta :: [TcType]
sc_theta,_,_) = Class -> ([TcTyVar], [TcType], [TcTyVar], [ClassOpItem])
classBigSig Class
cls
isImprovementPred :: PredType -> Bool
isImprovementPred :: TcType -> Bool
isImprovementPred ty :: TcType
ty
= case TcType -> Pred
classifyPredType TcType
ty of
EqPred NomEq t1 :: TcType
t1 t2 :: TcType
t2 -> Bool -> Bool
not (TcType
t1 HasDebugCallStack => TcType -> TcType -> Bool
TcType -> TcType -> Bool
`tcEqType` TcType
t2)
EqPred ReprEq _ _ -> Bool
False
ClassPred cls :: Class
cls _ -> Class -> Bool
classHasFds Class
cls
IrredPred {} -> Bool
True
ForAllPred {} -> Bool
False
isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool
isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool
isInsolubleOccursCheck eq_rel :: EqRel
eq_rel tv :: TcTyVar
tv ty :: TcType
ty
= TcType -> Bool
go TcType
ty
where
go :: TcType -> Bool
go ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
go TcType
ty'
go (TyVarTy tv' :: TcTyVar
tv') = TcTyVar
tv TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
tv' Bool -> Bool -> Bool
|| TcType -> Bool
go (TcTyVar -> TcType
tyVarKind TcTyVar
tv')
go (LitTy {}) = Bool
False
go (AppTy t1 :: TcType
t1 t2 :: TcType
t2) = case EqRel
eq_rel of
NomEq -> TcType -> Bool
go TcType
t1 Bool -> Bool -> Bool
|| TcType -> Bool
go TcType
t2
ReprEq -> TcType -> Bool
go TcType
t1
go (FunTy _ t1 :: TcType
t1 t2 :: TcType
t2) = TcType -> Bool
go TcType
t1 Bool -> Bool -> Bool
|| TcType -> Bool
go TcType
t2
go (ForAllTy (Bndr tv' :: TcTyVar
tv' _) inner_ty :: TcType
inner_ty)
| TcTyVar
tv' TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
tv = Bool
False
| Bool
otherwise = TcType -> Bool
go (TcTyVar -> TcType
varType TcTyVar
tv') Bool -> Bool -> Bool
|| TcType -> Bool
go TcType
inner_ty
go (CastTy ty :: TcType
ty _) = TcType -> Bool
go TcType
ty
go (CoercionTy _) = Bool
False
go (TyConApp tc :: TyCon
tc tys :: [TcType]
tys)
| TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
role = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcType -> Bool
go [TcType]
tys
| Bool
otherwise = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcType -> Bool
go (Int -> [TcType] -> [TcType]
forall a. Int -> [a] -> [a]
drop (TyCon -> Int
tyConArity TyCon
tc) [TcType]
tys)
role :: Role
role = EqRel -> Role
eqRelRole EqRel
eq_rel
isSigmaTy :: TcType -> Bool
isSigmaTy :: TcType -> Bool
isSigmaTy ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
isSigmaTy TcType
ty'
isSigmaTy (ForAllTy {}) = Bool
True
isSigmaTy (FunTy { ft_af :: TcType -> AnonArgFlag
ft_af = AnonArgFlag
InvisArg }) = Bool
True
isSigmaTy _ = Bool
False
isRhoTy :: TcType -> Bool
isRhoTy :: TcType -> Bool
isRhoTy ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
isRhoTy TcType
ty'
isRhoTy (ForAllTy {}) = Bool
False
isRhoTy (FunTy { ft_af :: TcType -> AnonArgFlag
ft_af = AnonArgFlag
VisArg, ft_res :: TcType -> TcType
ft_res = TcType
r }) = TcType -> Bool
isRhoTy TcType
r
isRhoTy _ = Bool
True
isRhoExpTy :: ExpType -> Bool
isRhoExpTy :: ExpType -> Bool
isRhoExpTy (Check ty :: TcType
ty) = TcType -> Bool
isRhoTy TcType
ty
isRhoExpTy (Infer {}) = Bool
True
isOverloadedTy :: Type -> Bool
isOverloadedTy :: TcType -> Bool
isOverloadedTy ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
isOverloadedTy TcType
ty'
isOverloadedTy (ForAllTy _ ty :: TcType
ty) = TcType -> Bool
isOverloadedTy TcType
ty
isOverloadedTy (FunTy { ft_af :: TcType -> AnonArgFlag
ft_af = AnonArgFlag
InvisArg }) = Bool
True
isOverloadedTy _ = Bool
False
isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy,
isUnitTy, isCharTy, isAnyTy :: Type -> Bool
isFloatTy :: TcType -> Bool
isFloatTy = Unique -> TcType -> Bool
is_tc Unique
floatTyConKey
isDoubleTy :: TcType -> Bool
isDoubleTy = Unique -> TcType -> Bool
is_tc Unique
doubleTyConKey
isIntegerTy :: TcType -> Bool
isIntegerTy = Unique -> TcType -> Bool
is_tc Unique
integerTyConKey
isIntTy :: TcType -> Bool
isIntTy = Unique -> TcType -> Bool
is_tc Unique
intTyConKey
isWordTy :: TcType -> Bool
isWordTy = Unique -> TcType -> Bool
is_tc Unique
wordTyConKey
isBoolTy :: TcType -> Bool
isBoolTy = Unique -> TcType -> Bool
is_tc Unique
boolTyConKey
isUnitTy :: TcType -> Bool
isUnitTy = Unique -> TcType -> Bool
is_tc Unique
unitTyConKey
isCharTy :: TcType -> Bool
isCharTy = Unique -> TcType -> Bool
is_tc Unique
charTyConKey
isAnyTy :: TcType -> Bool
isAnyTy = Unique -> TcType -> Bool
is_tc Unique
anyTyConKey
isFloatingTy :: Type -> Bool
isFloatingTy :: TcType -> Bool
isFloatingTy ty :: TcType
ty = TcType -> Bool
isFloatTy TcType
ty Bool -> Bool -> Bool
|| TcType -> Bool
isDoubleTy TcType
ty
isStringTy :: Type -> Bool
isStringTy :: TcType -> Bool
isStringTy ty :: TcType
ty
= case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
Just (tc :: TyCon
tc, [arg_ty :: TcType
arg_ty]) -> TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
listTyCon Bool -> Bool -> Bool
&& TcType -> Bool
isCharTy TcType
arg_ty
_ -> Bool
False
isCallStackTy :: Type -> Bool
isCallStackTy :: TcType -> Bool
isCallStackTy ty :: TcType
ty
| Just tc :: TyCon
tc <- TcType -> Maybe TyCon
tyConAppTyCon_maybe TcType
ty
= TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
callStackTyConKey
| Bool
otherwise
= Bool
False
isCallStackPred :: Class -> [Type] -> Maybe FastString
isCallStackPred :: Class -> [TcType] -> Maybe FastString
isCallStackPred cls :: Class
cls tys :: [TcType]
tys
| [ty1 :: TcType
ty1, ty2 :: TcType
ty2] <- [TcType]
tys
, Class -> Bool
isIPClass Class
cls
, TcType -> Bool
isCallStackTy TcType
ty2
= TcType -> Maybe FastString
isStrLitTy TcType
ty1
| Bool
otherwise
= Maybe FastString
forall a. Maybe a
Nothing
is_tc :: Unique -> Type -> Bool
is_tc :: Unique -> TcType -> Bool
is_tc uniq :: Unique
uniq ty :: TcType
ty = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
Just (tc :: TyCon
tc, _) -> Unique
uniq Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc
Nothing -> Bool
False
isTyVarHead :: TcTyVar -> TcType -> Bool
isTyVarHead :: TcTyVar -> TcType -> Bool
isTyVarHead tv :: TcTyVar
tv (TyVarTy tv' :: TcTyVar
tv') = TcTyVar
tv TcTyVar -> TcTyVar -> Bool
forall a. Eq a => a -> a -> Bool
== TcTyVar
tv'
isTyVarHead tv :: TcTyVar
tv (AppTy fun :: TcType
fun _) = TcTyVar -> TcType -> Bool
isTyVarHead TcTyVar
tv TcType
fun
isTyVarHead tv :: TcTyVar
tv (CastTy ty :: TcType
ty _) = TcTyVar -> TcType -> Bool
isTyVarHead TcTyVar
tv TcType
ty
isTyVarHead _ (TyConApp {}) = Bool
False
isTyVarHead _ (LitTy {}) = Bool
False
isTyVarHead _ (ForAllTy {}) = Bool
False
isTyVarHead _ (FunTy {}) = Bool
False
isTyVarHead _ (CoercionTy {}) = Bool
False
isRigidTy :: TcType -> Bool
isRigidTy :: TcType -> Bool
isRigidTy ty :: TcType
ty
| Just (tc :: TyCon
tc,_) <- HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty = TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
Nominal
| Just {} <- TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty = Bool
True
| TcType -> Bool
isForAllTy TcType
ty = Bool
True
| Bool
otherwise = Bool
False
isAlmostFunctionFree :: TcType -> Bool
isAlmostFunctionFree :: TcType -> Bool
isAlmostFunctionFree ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> Bool
isAlmostFunctionFree TcType
ty'
isAlmostFunctionFree (TyVarTy {}) = Bool
True
isAlmostFunctionFree (AppTy ty1 :: TcType
ty1 ty2 :: TcType
ty2) = TcType -> Bool
isAlmostFunctionFree TcType
ty1 Bool -> Bool -> Bool
&&
TcType -> Bool
isAlmostFunctionFree TcType
ty2
isAlmostFunctionFree (TyConApp tc :: TyCon
tc args :: [TcType]
args)
| TyCon -> Bool
isTypeFamilyTyCon TyCon
tc = Bool
False
| Bool
otherwise = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcType -> Bool
isAlmostFunctionFree [TcType]
args
isAlmostFunctionFree (ForAllTy bndr :: TyCoVarBinder
bndr _) = TcType -> Bool
isAlmostFunctionFree (TyCoVarBinder -> TcType
forall argf. VarBndr TcTyVar argf -> TcType
binderType TyCoVarBinder
bndr)
isAlmostFunctionFree (FunTy _ ty1 :: TcType
ty1 ty2 :: TcType
ty2) = TcType -> Bool
isAlmostFunctionFree TcType
ty1 Bool -> Bool -> Bool
&&
TcType -> Bool
isAlmostFunctionFree TcType
ty2
isAlmostFunctionFree (LitTy {}) = Bool
True
isAlmostFunctionFree (CastTy ty :: TcType
ty _) = TcType -> Bool
isAlmostFunctionFree TcType
ty
isAlmostFunctionFree (CoercionTy {}) = Bool
True
deNoteType :: Type -> Type
deNoteType :: TcType -> TcType
deNoteType ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
coreView TcType
ty = TcType -> TcType
deNoteType TcType
ty'
deNoteType ty :: TcType
ty = TcType
ty
tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe :: TcType -> Maybe (TyCon, TcType)
tcSplitIOType_maybe ty :: TcType
ty
= case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
Just (io_tycon :: TyCon
io_tycon, [io_res_ty :: TcType
io_res_ty])
| TyCon
io_tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ioTyConKey ->
(TyCon, TcType) -> Maybe (TyCon, TcType)
forall a. a -> Maybe a
Just (TyCon
io_tycon, TcType
io_res_ty)
_ ->
Maybe (TyCon, TcType)
forall a. Maybe a
Nothing
isFFITy :: Type -> Bool
isFFITy :: TcType -> Bool
isFFITy ty :: TcType
ty = Validity -> Bool
isValid ((TyCon -> Validity) -> TcType -> Validity
checkRepTyCon TyCon -> Validity
legalFFITyCon TcType
ty)
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity
isFFIArgumentTy :: DynFlags -> Safety -> TcType -> Validity
isFFIArgumentTy dflags :: DynFlags
dflags safety :: Safety
safety ty :: TcType
ty
= (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon (DynFlags -> Safety -> TyCon -> Validity
legalOutgoingTyCon DynFlags
dflags Safety
safety) TcType
ty
isFFIExternalTy :: Type -> Validity
isFFIExternalTy :: TcType -> Validity
isFFIExternalTy ty :: TcType
ty = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon TyCon -> Validity
legalFEArgTyCon TcType
ty
isFFIImportResultTy :: DynFlags -> Type -> Validity
isFFIImportResultTy :: DynFlags -> TcType -> Validity
isFFIImportResultTy dflags :: DynFlags
dflags ty :: TcType
ty
= (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon (DynFlags -> TyCon -> Validity
legalFIResultTyCon DynFlags
dflags) TcType
ty
isFFIExportResultTy :: Type -> Validity
isFFIExportResultTy :: TcType -> Validity
isFFIExportResultTy ty :: TcType
ty = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon TyCon -> Validity
legalFEResultTyCon TcType
ty
isFFIDynTy :: Type -> Type -> Validity
isFFIDynTy :: TcType -> TcType -> Validity
isFFIDynTy expected :: TcType
expected ty :: TcType
ty
| Just (tc :: TyCon
tc, [ty' :: TcType
ty']) <- HasDebugCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
splitTyConApp_maybe TcType
ty
, TyCon -> Unique
tyConUnique TyCon
tc Unique -> [Unique] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
ptrTyConKey, Unique
funPtrTyConKey]
, TcType -> TcType -> Bool
eqType TcType
ty' TcType
expected
= Validity
IsValid
| Bool
otherwise
= SDoc -> Validity
NotValid ([SDoc] -> SDoc
vcat [ String -> SDoc
text "Expected: Ptr/FunPtr" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
pprParendType TcType
expected SDoc -> SDoc -> SDoc
<> SDoc
comma
, String -> SDoc
text " Actual:" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty ])
isFFILabelTy :: Type -> Validity
isFFILabelTy :: TcType -> Validity
isFFILabelTy ty :: TcType
ty = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon TyCon -> Validity
forall a. Uniquable a => a -> Validity
ok TcType
ty
where
ok :: a -> Validity
ok tc :: 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
IsValid
| Bool
otherwise
= SDoc -> Validity
NotValid (String -> SDoc
text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)")
isFFIPrimArgumentTy :: DynFlags -> Type -> Validity
isFFIPrimArgumentTy :: DynFlags -> TcType -> Validity
isFFIPrimArgumentTy dflags :: DynFlags
dflags ty :: TcType
ty
| TcType -> Bool
isAnyTy TcType
ty = Validity
IsValid
| Bool
otherwise = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon (DynFlags -> TyCon -> Validity
legalFIPrimArgTyCon DynFlags
dflags) TcType
ty
isFFIPrimResultTy :: DynFlags -> Type -> Validity
isFFIPrimResultTy :: DynFlags -> TcType -> Validity
isFFIPrimResultTy dflags :: DynFlags
dflags ty :: TcType
ty
| TcType -> Bool
isAnyTy TcType
ty = Validity
IsValid
| Bool
otherwise = (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon (DynFlags -> TyCon -> Validity
legalFIPrimResultTyCon DynFlags
dflags) TcType
ty
isFunPtrTy :: Type -> Bool
isFunPtrTy :: TcType -> Bool
isFunPtrTy ty :: TcType
ty
| Just (tc :: TyCon
tc, [_]) <- HasDebugCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
splitTyConApp_maybe TcType
ty
= TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funPtrTyConKey
| Bool
otherwise
= Bool
False
checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity
checkRepTyCon :: (TyCon -> Validity) -> TcType -> Validity
checkRepTyCon check_tc :: TyCon -> Validity
check_tc ty :: TcType
ty
= case HasDebugCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
splitTyConApp_maybe TcType
ty of
Just (tc :: TyCon
tc, tys :: [TcType]
tys)
| TyCon -> Bool
isNewTyCon TyCon
tc -> SDoc -> Validity
NotValid (SDoc -> Int -> SDoc -> SDoc
hang SDoc
msg 2 (TyCon -> [TcType] -> SDoc
forall (t :: * -> *) a a.
(Foldable t, Outputable a) =>
a -> t a -> SDoc
mk_nt_reason TyCon
tc [TcType]
tys SDoc -> SDoc -> SDoc
$$ SDoc
nt_fix))
| Bool
otherwise -> case TyCon -> Validity
check_tc TyCon
tc of
IsValid -> Validity
IsValid
NotValid extra :: SDoc
extra -> SDoc -> Validity
NotValid (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
extra)
Nothing -> SDoc -> Validity
NotValid (SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not a data type")
where
msg :: SDoc
msg = SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "cannot be marshalled in a foreign call"
mk_nt_reason :: a -> t a -> SDoc
mk_nt_reason tc :: a
tc tys :: t a
tys
| t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
tys = String -> SDoc
text "because its data constructor is not in scope"
| Bool
otherwise = String -> SDoc
text "because the data constructor for"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is not in scope"
nt_fix :: SDoc
nt_fix = String -> SDoc
text "Possible fix: import the data constructor to bring it into scope"
legalFEArgTyCon :: TyCon -> Validity
legalFEArgTyCon :: TyCon -> Validity
legalFEArgTyCon tc :: TyCon
tc
= TyCon -> Validity
boxedMarshalableTyCon TyCon
tc
legalFIResultTyCon :: DynFlags -> TyCon -> Validity
legalFIResultTyCon :: DynFlags -> TyCon -> Validity
legalFIResultTyCon dflags :: DynFlags
dflags tc :: TyCon
tc
| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon = Validity
IsValid
| Bool
otherwise = DynFlags -> TyCon -> Validity
marshalableTyCon DynFlags
dflags TyCon
tc
legalFEResultTyCon :: TyCon -> Validity
legalFEResultTyCon :: TyCon -> Validity
legalFEResultTyCon tc :: TyCon
tc
| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon = Validity
IsValid
| Bool
otherwise = TyCon -> Validity
boxedMarshalableTyCon TyCon
tc
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity
legalOutgoingTyCon dflags :: DynFlags
dflags _ tc :: TyCon
tc
= DynFlags -> TyCon -> Validity
marshalableTyCon DynFlags
dflags TyCon
tc
legalFFITyCon :: TyCon -> Validity
legalFFITyCon :: TyCon -> Validity
legalFFITyCon tc :: TyCon
tc
| TyCon -> Bool
isUnliftedTyCon TyCon
tc = Validity
IsValid
| TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon = Validity
IsValid
| Bool
otherwise = TyCon -> Validity
boxedMarshalableTyCon TyCon
tc
marshalableTyCon :: DynFlags -> TyCon -> Validity
marshalableTyCon :: DynFlags -> TyCon -> Validity
marshalableTyCon dflags :: DynFlags
dflags tc :: TyCon
tc
| TyCon -> Bool
isUnliftedTyCon TyCon
tc
, Bool -> Bool
not (TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isUnboxedSumTyCon TyCon
tc)
, Bool -> Bool
not ([PrimRep] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HasDebugCallStack => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc))
= DynFlags -> Validity
validIfUnliftedFFITypes DynFlags
dflags
| Bool
otherwise
= TyCon -> Validity
boxedMarshalableTyCon TyCon
tc
boxedMarshalableTyCon :: TyCon -> Validity
boxedMarshalableTyCon :: TyCon -> Validity
boxedMarshalableTyCon tc :: TyCon
tc
| TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc Unique -> [Unique] -> 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
IsValid
| Bool
otherwise = SDoc -> Validity
NotValid SDoc
empty
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity
legalFIPrimArgTyCon dflags :: DynFlags
dflags tc :: TyCon
tc
| TyCon -> Bool
isUnliftedTyCon TyCon
tc
, Bool -> Bool
not (TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isUnboxedSumTyCon TyCon
tc)
= DynFlags -> Validity
validIfUnliftedFFITypes DynFlags
dflags
| Bool
otherwise
= SDoc -> Validity
NotValid SDoc
unlifted_only
legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity
legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity
legalFIPrimResultTyCon dflags :: DynFlags
dflags tc :: TyCon
tc
| TyCon -> Bool
isUnliftedTyCon TyCon
tc
, TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isUnboxedSumTyCon TyCon
tc
Bool -> Bool -> Bool
|| Bool -> Bool
not ([PrimRep] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HasDebugCallStack => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc))
= DynFlags -> Validity
validIfUnliftedFFITypes DynFlags
dflags
| Bool
otherwise
= SDoc -> Validity
NotValid SDoc
unlifted_only
unlifted_only :: MsgDoc
unlifted_only :: SDoc
unlifted_only = String -> SDoc
text "foreign import prim only accepts simple unlifted types"
validIfUnliftedFFITypes :: DynFlags -> Validity
validIfUnliftedFFITypes :: DynFlags -> Validity
validIfUnliftedFFITypes dflags :: DynFlags
dflags
| Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedFFITypes DynFlags
dflags = Validity
IsValid
| Bool
otherwise = SDoc -> Validity
NotValid (String -> SDoc
text "To marshal unlifted types, use UnliftedFFITypes")
type TypeSize = IntWithInf
sizeType :: Type -> TypeSize
sizeType :: TcType -> TypeSize
sizeType = TcType -> TypeSize
go
where
go :: TcType -> TypeSize
go ty :: TcType
ty | Just exp_ty :: TcType
exp_ty <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> TypeSize
go TcType
exp_ty
go (TyVarTy {}) = 1
go (TyConApp tc :: TyCon
tc tys :: [TcType]
tys)
| TyCon -> Bool
isTypeFamilyTyCon TyCon
tc = TypeSize
infinity
| Bool
otherwise = [TcType] -> TypeSize
sizeTypes (TyCon -> [TcType] -> [TcType]
filterOutInvisibleTypes TyCon
tc [TcType]
tys) TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ 1
go (LitTy {}) = 1
go (FunTy _ arg :: TcType
arg res :: TcType
res) = TcType -> TypeSize
go TcType
arg TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ TcType -> TypeSize
go TcType
res TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ 1
go (AppTy fun :: TcType
fun arg :: TcType
arg) = TcType -> TypeSize
go TcType
fun TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ TcType -> TypeSize
go TcType
arg
go (ForAllTy (Bndr tv :: TcTyVar
tv vis :: ArgFlag
vis) ty :: TcType
ty)
| ArgFlag -> Bool
isVisibleArgFlag ArgFlag
vis = TcType -> TypeSize
go (TcTyVar -> TcType
tyVarKind TcTyVar
tv) TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ TcType -> TypeSize
go TcType
ty TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ 1
| Bool
otherwise = TcType -> TypeSize
go TcType
ty TypeSize -> TypeSize -> TypeSize
forall a. Num a => a -> a -> a
+ 1
go (CastTy ty :: TcType
ty _) = TcType -> TypeSize
go TcType
ty
go (CoercionTy {}) = 0
sizeTypes :: [Type] -> TypeSize
sizeTypes :: [TcType] -> TypeSize
sizeTypes tys :: [TcType]
tys = [TypeSize] -> TypeSize
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((TcType -> TypeSize) -> [TcType] -> [TypeSize]
forall a b. (a -> b) -> [a] -> [b]
map TcType -> TypeSize
sizeType [TcType]
tys)
tcTyConVisibilities :: TyCon -> [Bool]
tcTyConVisibilities :: TyCon -> [Bool]
tcTyConVisibilities tc :: 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 = (TyConBinder -> Bool) -> [TyConBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder (TyCon -> [TyConBinder]
tyConBinders TyCon
tc)
tc_return_kind_viss :: [Bool]
tc_return_kind_viss = (TyBinder -> Bool) -> [TyBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TyBinder -> Bool
isVisibleBinder (([TyBinder], TcType) -> [TyBinder]
forall a b. (a, b) -> a
fst (([TyBinder], TcType) -> [TyBinder])
-> ([TyBinder], TcType) -> [TyBinder]
forall a b. (a -> b) -> a -> b
$ TcType -> ([TyBinder], TcType)
tcSplitPiTys (TyCon -> TcType
tyConResKind TyCon
tc))
isNextTyConArgVisible :: TyCon -> [Type] -> Bool
isNextTyConArgVisible :: TyCon -> [TcType] -> Bool
isNextTyConArgVisible tc :: TyCon
tc tys :: [TcType]
tys
= TyCon -> [Bool]
tcTyConVisibilities TyCon
tc [Bool] -> Int -> Bool
forall a. Outputable a => [a] -> Int -> a
`getNth` [TcType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TcType]
tys
isNextArgVisible :: TcType -> Bool
isNextArgVisible :: TcType -> Bool
isNextArgVisible ty :: TcType
ty
| Just (bndr :: TyBinder
bndr, _) <- TcType -> Maybe (TyBinder, TcType)
tcSplitPiTy_maybe TcType
ty = TyBinder -> Bool
isVisibleBinder TyBinder
bndr
| Bool
otherwise = Bool
True