{-# 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,
UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,
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,
mkNakedAppTy, mkNakedAppTys, mkNakedCastTy, nakedSubstTy,
getTyVar,
tcSplitForAllTy_maybe,
tcSplitForAllTys, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs,
tcSplitPhiTy, tcSplitPredFunTy_maybe,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,
tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe,
tcRepSplitTyConApp, tcRepSplitTyConApp_maybe, tcRepSplitTyConApp_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,
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, typeKind, tcTypeKind,
liftedTypeKind,
constraintKind,
isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues,
Type, PredType, ThetaType, TyCoBinder, ArgFlag(..),
mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy,
mkInvForAllTy, mkInvForAllTys,
mkFunTy, mkFunTys,
mkTyConApp, mkAppTy, mkAppTys,
mkTyConTy, mkTyVarTy, mkTyVarTys,
mkTyCoVarTy, mkTyCoVarTys,
isClassPred, isEqPred, isNomEqPred, isIPPred,
mkClassPred,
isDictLikeTy,
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 "HsVersions.h"
import GhcPrelude
import Kind
import TyCoRep
import Class
import Var
import ForeignCall
import VarSet
import Coercion
import Type
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.Functor.Identity( Identity(..) )
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"
data UserTypeCtxt
= FunSigCtxt
Name
Bool
| InfSigCtxt Name
| ExprSigCtxt
| KindSigCtxt
| TypeAppCtxt
| ConArgCtxt Name
| TySynCtxt Name
| PatSynCtxt Name
| PatSigCtxt
| RuleSigCtxt Name
| ResSigCtxt
| ForSigCtxt Name
| DefaultDeclCtxt
| InstDeclCtxt Bool
| SpecInstCtxt
| ThBrackCtxt
| GenSigCtxt
| GhciCtxt Bool
| ClassSCCtxt Name
| SigmaCtxt
| DataTyCtxt Name
| DerivClauseCtxt
| TyVarBndrKindCtxt Name
| DataKindCtxt Name
| TySynKindCtxt Name
| TyFamResKindCtxt Name
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt (FunSigCtxt n :: Name
n _) = String -> SDoc
text "the type signature for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (InfSigCtxt n :: Name
n) = String -> SDoc
text "the inferred type for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (RuleSigCtxt n :: Name
n) = String -> SDoc
text "a RULE for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt ExprSigCtxt = String -> SDoc
text "an expression type signature"
pprUserTypeCtxt KindSigCtxt = String -> SDoc
text "a kind signature"
pprUserTypeCtxt TypeAppCtxt = String -> SDoc
text "a type argument"
pprUserTypeCtxt (ConArgCtxt c :: Name
c) = String -> SDoc
text "the type of the constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
c)
pprUserTypeCtxt (TySynCtxt c :: Name
c) = String -> SDoc
text "the RHS of the type synonym" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
c)
pprUserTypeCtxt ThBrackCtxt = String -> SDoc
text "a Template Haskell quotation [t|...|]"
pprUserTypeCtxt PatSigCtxt = String -> SDoc
text "a pattern type signature"
pprUserTypeCtxt ResSigCtxt = String -> SDoc
text "a result type signature"
pprUserTypeCtxt (ForSigCtxt n :: Name
n) = String -> SDoc
text "the foreign declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt DefaultDeclCtxt = String -> SDoc
text "a type in a `default' declaration"
pprUserTypeCtxt (InstDeclCtxt False) = String -> SDoc
text "an instance declaration"
pprUserTypeCtxt (InstDeclCtxt True) = String -> SDoc
text "a stand-alone deriving instance declaration"
pprUserTypeCtxt SpecInstCtxt = String -> SDoc
text "a SPECIALISE instance pragma"
pprUserTypeCtxt GenSigCtxt = String -> SDoc
text "a type expected by the context"
pprUserTypeCtxt (GhciCtxt {}) = String -> SDoc
text "a type in a GHCi command"
pprUserTypeCtxt (ClassSCCtxt c :: Name
c) = String -> SDoc
text "the super-classes of class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
c)
pprUserTypeCtxt SigmaCtxt = String -> SDoc
text "the context of a polymorphic type"
pprUserTypeCtxt (DataTyCtxt tc :: Name
tc) = String -> SDoc
text "the context of the data type declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc)
pprUserTypeCtxt (PatSynCtxt n :: Name
n) = String -> SDoc
text "the signature for pattern synonym" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (UserTypeCtxt
DerivClauseCtxt) = String -> SDoc
text "a `deriving' clause"
pprUserTypeCtxt (TyVarBndrKindCtxt n :: Name
n) = String -> SDoc
text "the kind annotation on the type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (DataKindCtxt n :: Name
n) = String -> SDoc
text "the kind annotation on the declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (TySynKindCtxt n :: Name
n) = String -> SDoc
text "the kind annotation on the declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
pprUserTypeCtxt (TyFamResKindCtxt n :: Name
n) = String -> SDoc
text "the result kind for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
isSigMaybe :: UserTypeCtxt -> Maybe Name
isSigMaybe :: UserTypeCtxt -> Maybe Name
isSigMaybe (FunSigCtxt n :: Name
n _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe (ConArgCtxt n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe (ForSigCtxt n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe (PatSynCtxt n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
isSigMaybe _ = Maybe Name
forall a. Maybe a
Nothing
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
exactTyCoVarsOfType :: Type -> TyCoVarSet
exactTyCoVarsOfType :: TcType -> TyCoVarSet
exactTyCoVarsOfType ty :: TcType
ty
= TcType -> TyCoVarSet
go TcType
ty
where
go :: TcType -> TyCoVarSet
go ty :: TcType
ty | Just ty' :: TcType
ty' <- TcType -> Maybe TcType
tcView TcType
ty = TcType -> TyCoVarSet
go TcType
ty'
go (TyVarTy tv :: TcTyVar
tv) = TcTyVar -> TyCoVarSet
goVar TcTyVar
tv
go (TyConApp _ tys :: [TcType]
tys) = [TcType] -> TyCoVarSet
exactTyCoVarsOfTypes [TcType]
tys
go (LitTy {}) = TyCoVarSet
emptyVarSet
go (AppTy fun :: TcType
fun arg :: TcType
arg) = TcType -> TyCoVarSet
go TcType
fun TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go TcType
arg
go (FunTy arg :: TcType
arg res :: TcType
res) = TcType -> TyCoVarSet
go TcType
arg TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go TcType
res
go (ForAllTy bndr :: TyCoVarBinder
bndr ty :: TcType
ty) = TyCoVarSet -> TyCoVarBinder -> TyCoVarSet
delBinderVar (TcType -> TyCoVarSet
go TcType
ty) TyCoVarBinder
bndr TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go (TyCoVarBinder -> TcType
forall argf. VarBndr TcTyVar argf -> TcType
binderType TyCoVarBinder
bndr)
go (CastTy ty :: TcType
ty co :: KindCoercion
co) = TcType -> TyCoVarSet
go TcType
ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
co
go (CoercionTy co :: KindCoercion
co) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
goMCo :: MCoercionN -> TyCoVarSet
goMCo MRefl = TyCoVarSet
emptyVarSet
goMCo (MCo co :: KindCoercion
co) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
goCo :: KindCoercion -> TyCoVarSet
goCo (Refl ty :: TcType
ty) = TcType -> TyCoVarSet
go TcType
ty
goCo (GRefl _ ty :: TcType
ty mco :: MCoercionN
mco) = TcType -> TyCoVarSet
go TcType
ty TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` MCoercionN -> TyCoVarSet
goMCo MCoercionN
mco
goCo (TyConAppCo _ _ args :: [KindCoercion]
args)= [KindCoercion] -> TyCoVarSet
goCos [KindCoercion]
args
goCo (AppCo co :: KindCoercion
co arg :: KindCoercion
arg) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
arg
goCo (ForAllCo tv :: TcTyVar
tv k_co :: KindCoercion
k_co co :: KindCoercion
co)
= KindCoercion -> TyCoVarSet
goCo KindCoercion
co TyCoVarSet -> TcTyVar -> TyCoVarSet
`delVarSet` TcTyVar
tv TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
k_co
goCo (FunCo _ co1 :: KindCoercion
co1 co2 :: KindCoercion
co2) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co1 TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
co2
goCo (CoVarCo v :: TcTyVar
v) = TcTyVar -> TyCoVarSet
goVar TcTyVar
v
goCo (HoleCo h :: CoercionHole
h) = TcTyVar -> TyCoVarSet
goVar (CoercionHole -> TcTyVar
coHoleCoVar CoercionHole
h)
goCo (AxiomInstCo _ _ args :: [KindCoercion]
args) = [KindCoercion] -> TyCoVarSet
goCos [KindCoercion]
args
goCo (UnivCo p :: UnivCoProvenance
p _ t1 :: TcType
t1 t2 :: TcType
t2) = UnivCoProvenance -> TyCoVarSet
goProv UnivCoProvenance
p TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go TcType
t1 TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go TcType
t2
goCo (SymCo co :: KindCoercion
co) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
goCo (TransCo co1 :: KindCoercion
co1 co2 :: KindCoercion
co2) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co1 TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
co2
goCo (NthCo _ _ co :: KindCoercion
co) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
goCo (LRCo _ co :: KindCoercion
co) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
goCo (InstCo co :: KindCoercion
co arg :: KindCoercion
arg) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` KindCoercion -> TyCoVarSet
goCo KindCoercion
arg
goCo (KindCo co :: KindCoercion
co) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
goCo (SubCo co :: KindCoercion
co) = KindCoercion -> TyCoVarSet
goCo KindCoercion
co
goCo (AxiomRuleCo _ c :: [KindCoercion]
c) = [KindCoercion] -> TyCoVarSet
goCos [KindCoercion]
c
goCos :: [KindCoercion] -> TyCoVarSet
goCos cos :: [KindCoercion]
cos = (KindCoercion -> TyCoVarSet -> TyCoVarSet)
-> TyCoVarSet -> [KindCoercion] -> TyCoVarSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TyCoVarSet -> TyCoVarSet -> TyCoVarSet
unionVarSet (TyCoVarSet -> TyCoVarSet -> TyCoVarSet)
-> (KindCoercion -> TyCoVarSet)
-> KindCoercion
-> TyCoVarSet
-> TyCoVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindCoercion -> TyCoVarSet
goCo) TyCoVarSet
emptyVarSet [KindCoercion]
cos
goProv :: UnivCoProvenance -> TyCoVarSet
goProv UnsafeCoerceProv = TyCoVarSet
emptyVarSet
goProv (PhantomProv kco :: KindCoercion
kco) = KindCoercion -> TyCoVarSet
goCo KindCoercion
kco
goProv (ProofIrrelProv kco :: KindCoercion
kco) = KindCoercion -> TyCoVarSet
goCo KindCoercion
kco
goProv (PluginProv _) = TyCoVarSet
emptyVarSet
goVar :: TcTyVar -> TyCoVarSet
goVar v :: TcTyVar
v = TcTyVar -> TyCoVarSet
unitVarSet TcTyVar
v TyCoVarSet -> TyCoVarSet -> TyCoVarSet
`unionVarSet` TcType -> TyCoVarSet
go (TcTyVar -> TcType
varType TcTyVar
v)
exactTyCoVarsOfTypes :: [Type] -> TyVarSet
exactTyCoVarsOfTypes :: [TcType] -> TyCoVarSet
exactTyCoVarsOfTypes tys :: [TcType]
tys = (TcType -> TyCoVarSet) -> [TcType] -> TyCoVarSet
forall a. (a -> TyCoVarSet) -> [a] -> TyCoVarSet
mapUnionVarSet TcType -> TyCoVarSet
exactTyCoVarsOfType [TcType]
tys
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 -> TyCoVarSet -> TcType -> Bool
go EqRel
role TyCoVarSet
emptyVarSet TcType
ty
where
go_tv :: EqRel -> TyCoVarSet -> TcTyVar -> Bool
go_tv rl :: EqRel
rl bvs :: TyCoVarSet
bvs tv :: TcTyVar
tv | TcTyVar
tv TcTyVar -> TyCoVarSet -> Bool
`elemVarSet` TyCoVarSet
bvs = Bool
False
| Bool
otherwise = EqRel -> TcTyVar -> Bool
pred EqRel
rl TcTyVar
tv
go :: EqRel -> TyCoVarSet -> TcType -> Bool
go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (TyVarTy tv :: TcTyVar
tv) = EqRel -> TyCoVarSet -> TcTyVar -> Bool
go_tv EqRel
rl TyCoVarSet
bvs TcTyVar
tv
go _ _ (LitTy {}) = Bool
False
go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (TyConApp tc :: TyCon
tc tys :: [TcType]
tys) = EqRel -> TyCoVarSet -> TyCon -> [TcType] -> Bool
go_tc EqRel
rl TyCoVarSet
bvs TyCon
tc [TcType]
tys
go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (AppTy fun :: TcType
fun arg :: TcType
arg) = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
rl TyCoVarSet
bvs TcType
fun Bool -> Bool -> Bool
|| EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
NomEq TyCoVarSet
bvs TcType
arg
go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (FunTy arg :: TcType
arg res :: TcType
res) = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
rl TyCoVarSet
bvs TcType
arg Bool -> Bool -> Bool
|| EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
rl TyCoVarSet
bvs TcType
res
go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (ForAllTy tv :: TyCoVarBinder
tv ty :: TcType
ty) = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
rl (TyCoVarSet
bvs TyCoVarSet -> TcTyVar -> TyCoVarSet
`extendVarSet` TyCoVarBinder -> TcTyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
tv) TcType
ty
go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (CastTy ty :: TcType
ty co :: KindCoercion
co) = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
rl TyCoVarSet
bvs TcType
ty Bool -> Bool -> Bool
|| EqRel -> TyCoVarSet -> KindCoercion -> Bool
go_co EqRel
rl TyCoVarSet
bvs KindCoercion
co
go rl :: EqRel
rl bvs :: TyCoVarSet
bvs (CoercionTy co :: KindCoercion
co) = EqRel -> TyCoVarSet -> KindCoercion -> Bool
go_co EqRel
rl TyCoVarSet
bvs KindCoercion
co
go_tc :: EqRel -> TyCoVarSet -> TyCon -> [TcType] -> Bool
go_tc NomEq bvs :: TyCoVarSet
bvs _ tys :: [TcType]
tys = (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
NomEq TyCoVarSet
bvs) [TcType]
tys
go_tc ReprEq bvs :: TyCoVarSet
bvs tc :: TyCon
tc tys :: [TcType]
tys = ((Role, TcType) -> Bool) -> [(Role, TcType)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyCoVarSet -> (Role, TcType) -> Bool
go_arg TyCoVarSet
bvs)
(TyCon -> [Role]
tyConRolesRepresentational TyCon
tc [Role] -> [TcType] -> [(Role, TcType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcType]
tys)
go_arg :: TyCoVarSet -> (Role, TcType) -> Bool
go_arg bvs :: TyCoVarSet
bvs (Nominal, ty :: TcType
ty) = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
NomEq TyCoVarSet
bvs TcType
ty
go_arg bvs :: TyCoVarSet
bvs (Representational, ty :: TcType
ty) = EqRel -> TyCoVarSet -> TcType -> Bool
go EqRel
ReprEq TyCoVarSet
bvs TcType
ty
go_arg _ (Phantom, _) = Bool
False
go_co :: EqRel -> TyCoVarSet -> KindCoercion -> Bool
go_co rl :: EqRel
rl bvs :: TyCoVarSet
bvs co :: KindCoercion
co
| Bool
ignore_cos = Bool
False
| Bool
otherwise = (TcTyVar -> Bool) -> TyCoVarSet -> Bool
anyVarSet (EqRel -> TyCoVarSet -> TcTyVar -> Bool
go_tv EqRel
rl TyCoVarSet
bvs) (KindCoercion -> TyCoVarSet
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
mkFunTys
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)
mkNakedAppTys :: Type -> [Type] -> Type
mkNakedAppTys :: TcType -> [TcType] -> TcType
mkNakedAppTys ty1 :: TcType
ty1 [] = TcType
ty1
mkNakedAppTys (TyConApp tc :: TyCon
tc tys1 :: [TcType]
tys1) tys2 :: [TcType]
tys2 = TyCon -> [TcType] -> TcType
mkTyConApp TyCon
tc ([TcType]
tys1 [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
tys2)
mkNakedAppTys ty1 :: TcType
ty1 tys2 :: [TcType]
tys2 = (TcType -> TcType -> TcType) -> TcType -> [TcType] -> TcType
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TcType -> TcType -> TcType
AppTy TcType
ty1 [TcType]
tys2
mkNakedAppTy :: Type -> Type -> Type
mkNakedAppTy :: TcType -> TcType -> TcType
mkNakedAppTy ty1 :: TcType
ty1 ty2 :: TcType
ty2 = TcType -> [TcType] -> TcType
mkNakedAppTys TcType
ty1 [TcType
ty2]
mkNakedCastTy :: Type -> Coercion -> Type
mkNakedCastTy :: TcType -> KindCoercion -> TcType
mkNakedCastTy ty :: TcType
ty co :: KindCoercion
co = TcType -> KindCoercion -> TcType
CastTy TcType
ty KindCoercion
co
nakedSubstTy :: HasCallStack => TCvSubst -> TcType -> TcType
nakedSubstTy :: TCvSubst -> TcType -> TcType
nakedSubstTy subst :: TCvSubst
subst ty :: TcType
ty
| TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst = TcType
ty
| Bool
otherwise = Identity TcType -> TcType
forall a. Identity a -> a
runIdentity (Identity TcType -> TcType) -> Identity TcType -> TcType
forall a b. (a -> b) -> a -> b
$
TCvSubst
-> [TcType] -> [KindCoercion] -> Identity TcType -> Identity TcType
forall a.
HasCallStack =>
TCvSubst -> [TcType] -> [KindCoercion] -> a -> a
checkValidSubst TCvSubst
subst [TcType
ty] [] (Identity TcType -> Identity TcType)
-> Identity TcType -> Identity TcType
forall a b. (a -> b) -> a -> b
$
TyCoMapper TCvSubst Identity
-> TCvSubst -> TcType -> Identity TcType
forall (m :: * -> *) env.
Monad m =>
TyCoMapper env m -> env -> TcType -> m TcType
mapType TyCoMapper TCvSubst Identity
nakedSubstMapper TCvSubst
subst TcType
ty
nakedSubstMapper :: TyCoMapper TCvSubst Identity
nakedSubstMapper :: TyCoMapper TCvSubst Identity
nakedSubstMapper
= TyCoMapper :: forall env (m :: * -> *).
Bool
-> (env -> TcTyVar -> m TcType)
-> (env -> TcTyVar -> m KindCoercion)
-> (env -> CoercionHole -> m KindCoercion)
-> (env -> TcTyVar -> ArgFlag -> m (env, TcTyVar))
-> (TyCon -> m TyCon)
-> TyCoMapper env m
TyCoMapper { tcm_smart :: Bool
tcm_smart = Bool
False
, tcm_tyvar :: TCvSubst -> TcTyVar -> Identity TcType
tcm_tyvar = \subst :: TCvSubst
subst tv :: TcTyVar
tv -> TcType -> Identity TcType
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst -> TcTyVar -> TcType
substTyVar TCvSubst
subst TcTyVar
tv)
, tcm_covar :: TCvSubst -> TcTyVar -> Identity KindCoercion
tcm_covar = \subst :: TCvSubst
subst cv :: TcTyVar
cv -> KindCoercion -> Identity KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst -> TcTyVar -> KindCoercion
substCoVar TCvSubst
subst TcTyVar
cv)
, tcm_hole :: TCvSubst -> CoercionHole -> Identity KindCoercion
tcm_hole = \_ hole :: CoercionHole
hole -> KindCoercion -> Identity KindCoercion
forall (m :: * -> *) a. Monad m => a -> m a
return (CoercionHole -> KindCoercion
HoleCo CoercionHole
hole)
, tcm_tycobinder :: TCvSubst -> TcTyVar -> ArgFlag -> Identity (TCvSubst, TcTyVar)
tcm_tycobinder = \subst :: TCvSubst
subst tv :: TcTyVar
tv _ -> (TCvSubst, TcTyVar) -> Identity (TCvSubst, TcTyVar)
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar)
substVarBndr TCvSubst
subst TcTyVar
tv)
, tcm_tycon :: TyCon -> Identity TyCon
tcm_tycon = TyCon -> Identity TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return }
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
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 arg :: TcType
arg res :: TcType
res)
| TcType -> Bool
isPredTy TcType
arg = (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
mkFunTys [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 _ _)
= 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)
tcRepSplitTyConApp_maybe' :: HasCallStack => Type -> Maybe (TyCon, [Type])
tcRepSplitTyConApp_maybe' :: TcType -> Maybe (TyCon, [TcType])
tcRepSplitTyConApp_maybe' (TyConApp tc :: TyCon
tc tys :: [TcType]
tys) = (TyCon, [TcType]) -> Maybe (TyCon, [TcType])
forall a. a -> Maybe a
Just (TyCon
tc, [TcType]
tys)
tcRepSplitTyConApp_maybe' (FunTy arg :: TcType
arg res :: TcType
res)
| Just arg_rep :: TcType
arg_rep <- HasDebugCallStack => TcType -> Maybe TcType
TcType -> Maybe TcType
getRuntimeRep_maybe TcType
arg
, Just res_rep :: TcType
res_rep <- HasDebugCallStack => TcType -> Maybe TcType
TcType -> Maybe TcType
getRuntimeRep_maybe TcType
res
= (TyCon, [TcType]) -> Maybe (TyCon, [TcType])
forall a. a -> Maybe a
Just (TyCon
funTyCon, [TcType
arg_rep, TcType
res_rep, TcType
arg, TcType
res])
tcRepSplitTyConApp_maybe' _ = Maybe (TyCon, [TcType])
forall a. Maybe a
Nothing
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 arg :: TcType
arg res :: TcType
res) | Bool -> Bool
not (TcType -> Bool
isPredTy TcType
arg) = (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
= Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing ((TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type TcType -> Maybe TcType
tcView TcType
ki1 TcType
ki2) Bool -> Bool -> Bool
&&
Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing ((TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type TcType -> Maybe TcType
tcView 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
= Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type TcType -> Maybe TcType
tcView TcType
ty1 TcType
ty2
tcEqTypeVis :: TcType -> TcType -> Maybe Bool
tcEqTypeVis :: TcType -> TcType -> Maybe Bool
tcEqTypeVis ty1 :: TcType
ty1 ty2 :: TcType
ty2
= (TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type TcType -> Maybe TcType
tcView TcType
ty1 TcType
ty2 Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Maybe Bool -> Maybe Bool
invis ((TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type TcType -> Maybe TcType
tcView TcType
ki1 TcType
ki2)
where
ki1 :: TcType
ki1 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty1
ki2 :: TcType
ki2 = HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty2
invis :: Maybe Bool -> Maybe Bool
invis :: Maybe Bool -> Maybe Bool
invis = (Bool -> Bool) -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool -> Bool
forall a b. a -> b -> a
const Bool
False)
(<!>) :: Maybe Bool -> Maybe Bool -> Maybe Bool
Nothing <!> :: Maybe Bool -> Maybe Bool -> Maybe Bool
<!> x :: Maybe Bool
x = Maybe Bool
x
Just True <!> _ = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
Just _vis :: Bool
_vis <!> Just True = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
Just vis :: Bool
vis <!> _ = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
vis
infixr 3 <!>
tc_eq_type :: (TcType -> Maybe TcType)
-> Type -> Type -> Maybe Bool
tc_eq_type :: (TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type view_fun :: TcType -> Maybe TcType
view_fun orig_ty1 :: TcType
orig_ty1 orig_ty2 :: TcType
orig_ty2 = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
True RnEnv2
orig_env TcType
orig_ty1 TcType
orig_ty2
where
go :: Bool -> RnEnv2 -> Type -> Type -> Maybe Bool
go :: Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go vis :: Bool
vis env :: RnEnv2
env t1 :: TcType
t1 t2 :: TcType
t2 | Just t1' :: TcType
t1' <- TcType -> Maybe TcType
view_fun TcType
t1 = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1' TcType
t2
go vis :: Bool
vis env :: RnEnv2
env t1 :: TcType
t1 t2 :: TcType
t2 | Just t2' :: TcType
t2' <- TcType -> Maybe TcType
view_fun TcType
t2 = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1 TcType
t2'
go vis :: Bool
vis env :: RnEnv2
env (TyVarTy tv1 :: TcTyVar
tv1) (TyVarTy tv2 :: TcTyVar
tv2)
= Bool -> Bool -> Maybe Bool
check Bool
vis (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ 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 vis :: Bool
vis _ (LitTy lit1 :: TyLit
lit1) (LitTy lit2 :: TyLit
lit2)
= Bool -> Bool -> Maybe Bool
check Bool
vis (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ TyLit
lit1 TyLit -> TyLit -> Bool
forall a. Eq a => a -> a -> Bool
== TyLit
lit2
go vis :: Bool
vis 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)
= Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go (ArgFlag -> Bool
isVisibleArgFlag ArgFlag
vis1) RnEnv2
env (TcTyVar -> TcType
varType TcTyVar
tv1) (TcTyVar -> TcType
varType TcTyVar
tv2)
Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis (RnEnv2 -> TcTyVar -> TcTyVar -> RnEnv2
rnBndr2 RnEnv2
env TcTyVar
tv1 TcTyVar
tv2) TcType
ty1 TcType
ty2
Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> Bool -> Maybe Bool
check Bool
vis (ArgFlag
vis1 ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ArgFlag
vis2)
go vis :: Bool
vis env :: RnEnv2
env (FunTy arg1 :: TcType
arg1 res1 :: TcType
res1) (FunTy arg2 :: TcType
arg2 res2 :: TcType
res2)
= Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
arg1 TcType
arg2 Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
res1 TcType
res2
go vis :: Bool
vis env :: RnEnv2
env ty :: TcType
ty (FunTy arg :: TcType
arg res :: TcType
res)
= Bool -> RnEnv2 -> TcType -> TcType -> TcType -> Maybe Bool
eqFunTy Bool
vis RnEnv2
env TcType
arg TcType
res TcType
ty
go vis :: Bool
vis env :: RnEnv2
env (FunTy arg :: TcType
arg res :: TcType
res) ty :: TcType
ty
= Bool -> RnEnv2 -> TcType -> TcType -> TcType -> Maybe Bool
eqFunTy Bool
vis RnEnv2
env TcType
arg TcType
res TcType
ty
go vis :: Bool
vis 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
= Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
s1 TcType
s2 Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1 TcType
t2
go vis :: Bool
vis 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
= Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
s1 TcType
s2 Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1 TcType
t2
go vis :: Bool
vis env :: RnEnv2
env (TyConApp tc1 :: TyCon
tc1 ts1 :: [TcType]
ts1) (TyConApp tc2 :: TyCon
tc2 ts2 :: [TcType]
ts2)
= Bool -> Bool -> Maybe Bool
check Bool
vis (TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2) Maybe Bool -> Maybe Bool -> Maybe Bool
<!> [Bool] -> RnEnv2 -> [TcType] -> [TcType] -> Maybe Bool
gos (Bool -> TyCon -> [Bool]
tc_vis Bool
vis TyCon
tc1) RnEnv2
env [TcType]
ts1 [TcType]
ts2
go vis :: Bool
vis env :: RnEnv2
env (CastTy t1 :: TcType
t1 _) t2 :: TcType
t2 = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1 TcType
t2
go vis :: Bool
vis env :: RnEnv2
env t1 :: TcType
t1 (CastTy t2 :: TcType
t2 _) = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
t1 TcType
t2
go _ _ (CoercionTy {}) (CoercionTy {}) = Maybe Bool
forall a. Maybe a
Nothing
go vis :: Bool
vis _ _ _ = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
vis
gos :: [Bool] -> RnEnv2 -> [TcType] -> [TcType] -> Maybe Bool
gos _ _ [] [] = Maybe Bool
forall a. Maybe a
Nothing
gos (v :: Bool
v:vs :: [Bool]
vs) env :: RnEnv2
env (t1 :: TcType
t1:ts1 :: [TcType]
ts1) (t2 :: TcType
t2:ts2 :: [TcType]
ts2) = Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
v RnEnv2
env TcType
t1 TcType
t2 Maybe Bool -> Maybe Bool -> Maybe Bool
<!> [Bool] -> RnEnv2 -> [TcType] -> [TcType] -> Maybe Bool
gos [Bool]
vs RnEnv2
env [TcType]
ts1 [TcType]
ts2
gos (v :: Bool
v:_) _ _ _ = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
v
gos _ _ _ _ = String -> Maybe Bool
forall a. String -> a
panic "tc_eq_type"
tc_vis :: Bool -> TyCon -> [Bool]
tc_vis :: Bool -> TyCon -> [Bool]
tc_vis True tc :: TyCon
tc = [Bool]
viss [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True
where
bndrs :: [TyConBinder]
bndrs = TyCon -> [TyConBinder]
tyConBinders TyCon
tc
viss :: [Bool]
viss = (TyConBinder -> Bool) -> [TyConBinder] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder [TyConBinder]
bndrs
tc_vis False _ = Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False
check :: Bool -> Bool -> Maybe Bool
check :: Bool -> Bool -> Maybe Bool
check _ True = Maybe Bool
forall a. Maybe a
Nothing
check vis :: Bool
vis False = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
vis
orig_env :: RnEnv2
orig_env = InScopeSet -> RnEnv2
mkRnEnv2 (InScopeSet -> RnEnv2) -> InScopeSet -> RnEnv2
forall a b. (a -> b) -> a -> b
$ TyCoVarSet -> InScopeSet
mkInScopeSet (TyCoVarSet -> InScopeSet) -> TyCoVarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [TcType] -> TyCoVarSet
tyCoVarsOfTypes [TcType
orig_ty1, TcType
orig_ty2]
eqFunTy :: Bool -> RnEnv2 -> Type -> Type -> Type -> Maybe Bool
eqFunTy :: Bool -> RnEnv2 -> TcType -> TcType -> TcType -> Maybe Bool
eqFunTy vis :: Bool
vis env :: RnEnv2
env arg :: TcType
arg res :: TcType
res (FunTy arg' :: TcType
arg' res' :: TcType
res')
= Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
arg TcType
arg' Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
res TcType
res'
eqFunTy vis :: Bool
vis env :: RnEnv2
env arg :: TcType
arg res :: TcType
res ty :: TcType
ty@(AppTy{})
| Just (tc :: TyCon
tc, [_, _, arg' :: TcType
arg', res' :: TcType
res']) <- TcType -> [TcType] -> Maybe (TyCon, [TcType])
get_args TcType
ty []
, TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
funTyCon
= Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
arg TcType
arg' Maybe Bool -> Maybe Bool -> Maybe Bool
<!> Bool -> RnEnv2 -> TcType -> TcType -> Maybe Bool
go Bool
vis RnEnv2
env TcType
res TcType
res'
where
get_args :: Type -> [Type] -> Maybe (TyCon, [Type])
get_args :: TcType -> [TcType] -> Maybe (TyCon, [TcType])
get_args (AppTy f :: TcType
f x :: TcType
x) args :: [TcType]
args = TcType -> [TcType] -> Maybe (TyCon, [TcType])
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] -> Maybe (TyCon, [TcType])
get_args TcType
t [TcType]
args
get_args (TyConApp tc :: TyCon
tc tys :: [TcType]
tys) args :: [TcType]
args = (TyCon, [TcType]) -> Maybe (TyCon, [TcType])
forall a. a -> Maybe a
Just (TyCon
tc, [TcType]
tys [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
args)
get_args _ _ = Maybe (TyCon, [TcType])
forall a. Maybe a
Nothing
eqFunTy vis :: Bool
vis _ _ _ _
= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
vis
pickyEqType :: TcType -> TcType -> Bool
pickyEqType :: TcType -> TcType -> Bool
pickyEqType ty1 :: TcType
ty1 ty2 :: TcType
ty2
= Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$
(TcType -> Maybe TcType) -> TcType -> TcType -> Maybe Bool
tc_eq_type (Maybe TcType -> TcType -> Maybe TcType
forall a b. a -> b -> a
const Maybe TcType
forall a. Maybe a
Nothing) TcType
ty1 TcType
ty2
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
= ASSERT2( isEvVarType var_ty, ppr var <+> dcolon <+> ppr var_ty )
TcType
var_ty
where
var_ty :: TcType
var_ty = TcTyVar -> TcType
varType TcTyVar
var
pickQuantifiablePreds
:: TyVarSet
-> TcThetaType
-> TcThetaType
pickQuantifiablePreds :: TyCoVarSet -> [TcType] -> [TcType]
pickQuantifiablePreds qtvs :: TyCoVarSet
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 -> PredTree
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 -> TyCoVarSet
tyCoVarsOfType TcType
ty TyCoVarSet -> TyCoVarSet -> Bool
`intersectsVarSet` TyCoVarSet
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] -> TyCoVarSet
tyCoVarsOfTypes [TcType]
tys TyCoVarSet -> TyCoVarSet -> Bool
`intersectsVarSet` TyCoVarSet
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] -> TyCoVarSet
tyCoVarsOfTypes [TcType]
tys TyCoVarSet -> TyCoVarSet -> Bool
`intersectsVarSet` TyCoVarSet
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 :: TyCoVarSet -> [TcType] -> [TcType]
pickCapturedPreds qtvs :: TyCoVarSet
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 -> TyCoVarSet
tyCoVarsOfType TcType
pred TyCoVarSet -> TyCoVarSet -> Bool
`intersectsVarSet` TyCoVarSet
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 -> PredTree
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 -> PredTree
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 -> PredTree
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 a :: TcType
a _) = TcType -> Bool
isPredTy TcType
a
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 a :: TcType
a r :: TcType
r) = Bool -> Bool
not (TcType -> Bool
isPredTy TcType
a) Bool -> Bool -> Bool
&& 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 a :: TcType
a _) = TcType -> Bool
isPredTy TcType
a
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
hasIPPred :: PredType -> Bool
hasIPPred :: TcType -> Bool
hasIPPred pred :: TcType
pred
= case TcType -> PredTree
classifyPredType TcType
pred of
ClassPred cls :: Class
cls tys :: [TcType]
tys
| Class -> Bool
isIPClass Class
cls -> Bool
True
| Class -> Bool
isCTupleClass Class
cls -> (TcType -> Bool) -> [TcType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcType -> Bool
hasIPPred [TcType]
tys
_other :: PredTree
_other -> Bool
False
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
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
<