module TcType (
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcKind, TcCoVar,
TcLevel(..), topTcLevel, pushTcLevel,
strictlyDeeperThan, sameDepthAs, fskTcLevel,
UserTypeCtxt(..), pprUserTypeCtxt, pprSigCtxt,
TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
MetaDetails(Flexi, Indirect), MetaInfo(..),
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy,
isSigTyVar, isOverlappableTyVar, isTyConableTyVar,
isFskTyVar, isFmvTyVar, isFlattenTyVar, isReturnTyVar,
isAmbiguousTyVar, metaTvRef, metaTyVarInfo,
isFlexi, isIndirect, isRuntimeUnkSkol,
isTypeVar, isKindVar,
metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,
isTouchableMetaTyVar, isTouchableOrFmv,
isFloatedTouchableMetaTyVar,
canUnifyWithPolyType,
mkPhiTy, mkSigmaTy, mkTcEqPred, mkTcReprEqPred, mkTcEqPredRole,
tcView,
tcSplitForAllTys, tcSplitPhiTy, tcSplitPredFunTy_maybe,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
tcGetTyVar_maybe, tcGetTyVar, nextRole,
tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe,
eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX,
pickyEqType, tcEqType, tcEqKind,
isSigmaTy, isRhoTy, isOverloadedTy,
isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isBoolTy, isUnitTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
isPredTy, isTyVarClassPred, isTyVarExposed,
deNoteType, occurCheckExpand, OccCheckResult(..),
orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo,
orphNamesOfTypes, orphNamesOfCoCon,
getDFunTyKey,
evVarPred_maybe, evVarPred,
mkMinimalBySCs, transSuperClasses, immSuperClasses,
tcTyFamInsts,
exactTyVarsOfType, exactTyVarsOfTypes,
isFFIArgumentTy,
isFFIImportResultTy,
isFFIExportResultTy,
isFFIExternalTy,
isFFIDynTy,
isFFIPrimArgumentTy,
isFFIPrimResultTy,
isFFILabelTy,
isFFITy,
isFunPtrTy,
tcSplitIOType_maybe,
Kind, typeKind,
unliftedTypeKind, liftedTypeKind,
openTypeKind, constraintKind, mkArrowKind, mkArrowKinds,
isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind,
tcIsSubKind, splitKindFunTys, defaultKind,
Type, PredType, ThetaType,
mkForAllTy, mkForAllTys,
mkFunTy, mkFunTys, zipFunTys,
mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy,
isClassPred, isEqPred, isIPPred,
mkClassPred,
isDictLikeTy,
tcSplitDFunTy, tcSplitDFunHead,
mkEqPred,
TvSubst(..),
TvSubstEnv, emptyTvSubst,
mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst,
mkTopTvSubst, notElemTvSubst, unionTvSubst,
getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
Type.lookupTyVar, Type.extendTvSubst, Type.substTyVarBndr,
extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
Type.substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars,
isUnLiftedType,
isUnboxedTupleType,
isPrimitiveType,
tyVarsOfType, tyVarsOfTypes, closeOverKinds,
tcTyVarsOfType, tcTyVarsOfTypes,
pprKind, pprParendKind, pprSigmaType,
pprType, pprParendType, pprTypeApp, pprTyThingCategory,
pprTheta, pprThetaArrowTy, pprClassPred
) where
#include "HsVersions.h"
import Kind
import TypeRep
import Class
import Var
import ForeignCall
import VarSet
import Coercion
import Type
import TyCon
import CoAxiom
import DynFlags
import Name
import NameSet
import VarEnv
import PrelNames
import TysWiredIn
import BasicTypes
import Util
import Maybes
import ListSetOps
import Outputable
import FastString
import ErrUtils( Validity(..), isValid )
import Data.IORef
import Control.Monad (liftM, ap)
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
#endif
type TcTyVar = TyVar
type TcCoVar = CoVar
type TcType = Type
type TcPredType = PredType
type TcThetaType = ThetaType
type TcSigmaType = TcType
type TcRhoType = TcType
type TcTauType = TcType
type TcKind = Kind
type TcTyVarSet = TyVarSet
data TcTyVarDetails
= SkolemTv
Bool
| FlatSkol
TcType
| RuntimeUnk
| MetaTv { mtv_info :: MetaInfo
, mtv_ref :: IORef MetaDetails
, mtv_tclvl :: TcLevel }
vanillaSkolemTv, superSkolemTv :: TcTyVarDetails
vanillaSkolemTv = SkolemTv False
superSkolemTv = SkolemTv True
data MetaDetails
= Flexi
| Indirect TcType
instance Outputable MetaDetails where
ppr Flexi = ptext (sLit "Flexi")
ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty
data MetaInfo
= TauTv Bool
| ReturnTv
| SigTv
| FlatMetaTv
data UserTypeCtxt
= FunSigCtxt Name
| InfSigCtxt Name
| ExprSigCtxt
| ConArgCtxt Name
| TySynCtxt Name
| PatSigCtxt
| RuleSigCtxt Name
| ResSigCtxt
| ForSigCtxt Name
| DefaultDeclCtxt
| InstDeclCtxt
| SpecInstCtxt
| ThBrackCtxt
| GenSigCtxt
| GhciCtxt
| ClassSCCtxt Name
| SigmaCtxt
| DataTyCtxt Name
newtype TcLevel = TcLevel Int deriving( Eq )
fskTcLevel :: TcLevel
fskTcLevel = TcLevel 0
topTcLevel :: TcLevel
topTcLevel = TcLevel 1
pushTcLevel :: TcLevel -> TcLevel
pushTcLevel (TcLevel us) = TcLevel (us+1)
strictlyDeeperThan :: TcLevel -> TcLevel -> Bool
strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl)
= tv_tclvl > ctxt_tclvl
sameDepthAs :: TcLevel -> TcLevel -> Bool
sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)
= ctxt_tclvl == tv_tclvl
checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool
checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)
= ctxt_tclvl >= tv_tclvl
instance Outputable TcLevel where
ppr (TcLevel us) = ppr us
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
pprTcTyVarDetails (SkolemTv True) = ptext (sLit "ssk")
pprTcTyVarDetails (SkolemTv False) = ptext (sLit "sk")
pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt")
pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk")
pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl })
= pp_info <> colon <> ppr tclvl
where
pp_info = case info of
ReturnTv -> ptext (sLit "ret")
TauTv True -> ptext (sLit "twc")
TauTv False -> ptext (sLit "tau")
SigTv -> ptext (sLit "sig")
FlatMetaTv -> ptext (sLit "fuv")
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n)
pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n)
pprUserTypeCtxt (RuleSigCtxt n) = ptext (sLit "a RULE for") <+> quotes (ppr n)
pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature")
pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c)
pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c)
pprUserTypeCtxt ThBrackCtxt = ptext (sLit "a Template Haskell quotation [t|...|]")
pprUserTypeCtxt PatSigCtxt = ptext (sLit "a pattern type signature")
pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature")
pprUserTypeCtxt (ForSigCtxt n) = ptext (sLit "the foreign declaration for") <+> quotes (ppr n)
pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration")
pprUserTypeCtxt InstDeclCtxt = ptext (sLit "an instance declaration")
pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma")
pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context")
pprUserTypeCtxt GhciCtxt = ptext (sLit "a type in a GHCi command")
pprUserTypeCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c)
pprUserTypeCtxt SigmaCtxt = ptext (sLit "the context of a polymorphic type")
pprUserTypeCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc)
pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc -> SDoc
pprSigCtxt ctxt extra pp_ty
= sep [ ptext (sLit "In") <+> extra <+> pprUserTypeCtxt ctxt <> colon
, nest 2 (pp_sig ctxt) ]
where
pp_sig (FunSigCtxt n) = pp_n_colon n
pp_sig (ConArgCtxt n) = pp_n_colon n
pp_sig (ForSigCtxt n) = pp_n_colon n
pp_sig _ = pp_ty
pp_n_colon n = pprPrefixOcc n <+> dcolon <+> pp_ty
tcTyFamInsts :: Type -> [(TyCon, [Type])]
tcTyFamInsts ty
| Just exp_ty <- tcView ty = tcTyFamInsts exp_ty
tcTyFamInsts (TyVarTy _) = []
tcTyFamInsts (TyConApp tc tys)
| isTypeFamilyTyCon tc = [(tc, tys)]
| otherwise = concat (map tcTyFamInsts tys)
tcTyFamInsts (LitTy {}) = []
tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2
tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2
tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty
exactTyVarsOfType :: Type -> TyVarSet
exactTyVarsOfType ty
= go ty
where
go ty | Just ty' <- tcView ty = go ty'
go (TyVarTy tv) = unitVarSet tv
go (TyConApp _ tys) = exactTyVarsOfTypes tys
go (LitTy {}) = emptyVarSet
go (FunTy arg res) = go arg `unionVarSet` go res
go (AppTy fun arg) = go fun `unionVarSet` go arg
go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
exactTyVarsOfTypes :: [Type] -> TyVarSet
exactTyVarsOfTypes = mapUnionVarSet exactTyVarsOfType
isTouchableOrFmv :: TcLevel -> TcTyVar -> Bool
isTouchableOrFmv ctxt_tclvl tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info }
-> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,
ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )
case info of
FlatMetaTv -> True
_ -> tv_tclvl `sameDepthAs` ctxt_tclvl
_ -> False
isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isTouchableMetaTyVar ctxt_tclvl tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv { mtv_tclvl = tv_tclvl }
-> ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,
ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )
tv_tclvl `sameDepthAs` ctxt_tclvl
_ -> False
isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
isFloatedTouchableMetaTyVar ctxt_tclvl tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv { mtv_tclvl = tv_tclvl } -> tv_tclvl `strictlyDeeperThan` ctxt_tclvl
_ -> False
isImmutableTyVar :: TyVar -> Bool
isImmutableTyVar tv
| isTcTyVar tv = isSkolemTyVar tv
| otherwise = True
isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
isMetaTyVar, isAmbiguousTyVar,
isFmvTyVar, isFskTyVar, isFlattenTyVar, isReturnTyVar :: TcTyVar -> Bool
isTyConableTyVar tv
= ASSERT( isTcTyVar tv)
case tcTyVarDetails tv of
MetaTv { mtv_info = SigTv } -> False
_ -> True
isFmvTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv { mtv_info = FlatMetaTv } -> True
_ -> False
isFlattenTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
FlatSkol {} -> True
MetaTv { mtv_info = FlatMetaTv } -> True
_ -> False
isFskTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
FlatSkol {} -> True
_ -> False
isSkolemTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv {} -> False
_other -> True
isOverlappableTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
SkolemTv overlappable -> overlappable
_ -> False
isMetaTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv {} -> True
_ -> False
isReturnTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv { mtv_info = ReturnTv } -> True
_ -> False
isAmbiguousTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv {} -> True
RuntimeUnk {} -> True
_ -> False
isMetaTyVarTy :: TcType -> Bool
isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv
isMetaTyVarTy _ = False
metaTyVarInfo :: TcTyVar -> MetaInfo
metaTyVarInfo tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
MetaTv { mtv_info = info } -> info
_ -> pprPanic "metaTyVarInfo" (ppr tv)
metaTyVarTcLevel :: TcTyVar -> TcLevel
metaTyVarTcLevel tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
MetaTv { mtv_tclvl = tclvl } -> tclvl
_ -> pprPanic "metaTyVarTcLevel" (ppr tv)
metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel
metaTyVarTcLevel_maybe tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
MetaTv { mtv_tclvl = tclvl } -> Just tclvl
_ -> Nothing
setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar
setMetaTyVarTcLevel tv tclvl
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl })
_ -> pprPanic "metaTyVarTcLevel" (ppr tv)
isSigTyVar :: Var -> Bool
isSigTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
MetaTv { mtv_info = SigTv } -> True
_ -> False
metaTvRef :: TyVar -> IORef MetaDetails
metaTvRef tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv { mtv_ref = ref } -> ref
_ -> pprPanic "metaTvRef" (ppr tv)
isFlexi, isIndirect :: MetaDetails -> Bool
isFlexi Flexi = True
isFlexi _ = False
isIndirect (Indirect _) = True
isIndirect _ = False
isRuntimeUnkSkol :: TyVar -> Bool
isRuntimeUnkSkol x
| isTcTyVar x, RuntimeUnk <- tcTyVarDetails x = True
| otherwise = False
mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
mkPhiTy :: [PredType] -> Type -> Type
mkPhiTy theta ty = foldr mkFunTy ty theta
mkTcEqPred :: TcType -> TcType -> Type
mkTcEqPred ty1 ty2
= mkTyConApp eqTyCon [k, ty1, ty2]
where
k = typeKind ty1
mkTcReprEqPred :: TcType -> TcType -> Type
mkTcReprEqPred ty1 ty2
= mkTyConApp coercibleTyCon [k, ty1, ty2]
where
k = typeKind ty1
mkTcEqPredRole :: Role -> TcType -> TcType -> Type
mkTcEqPredRole Nominal = mkTcEqPred
mkTcEqPredRole Representational = mkTcReprEqPred
mkTcEqPredRole Phantom = panic "mkTcEqPredRole Phantom"
isTauTy :: Type -> Bool
isTauTy ty | Just ty' <- tcView ty = isTauTy ty'
isTauTy (TyVarTy _) = True
isTauTy (LitTy {}) = True
isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc
isTauTy (AppTy a b) = isTauTy a && isTauTy b
isTauTy (FunTy a b) = isTauTy a && isTauTy b
isTauTy (ForAllTy {}) = False
isTauTyCon :: TyCon -> Bool
isTauTyCon tc
| Just (_, rhs) <- synTyConDefn_maybe tc = isTauTy rhs
| otherwise = True
getDFunTyKey :: Type -> OccName
getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty'
getDFunTyKey (TyVarTy tv) = getOccName tv
getDFunTyKey (TyConApp tc _) = getOccName tc
getDFunTyKey (LitTy x) = getDFunTyLitKey x
getDFunTyKey (AppTy fun _) = getDFunTyKey fun
getDFunTyKey (FunTy _ _) = getOccName funTyCon
getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
getDFunTyLitKey :: TyLit -> OccName
getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n)
getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n)
tcSplitForAllTys :: Type -> ([TyVar], Type)
tcSplitForAllTys ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
split orig_ty _ tvs = (reverse tvs, orig_ty)
tcIsForAllTy :: Type -> Bool
tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
tcIsForAllTy (ForAllTy {}) = True
tcIsForAllTy _ = False
tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
tcSplitPredFunTy_maybe ty
| Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
tcSplitPredFunTy_maybe (FunTy arg res)
| isPredTy arg = Just (arg, res)
tcSplitPredFunTy_maybe _
= Nothing
tcSplitPhiTy :: Type -> (ThetaType, Type)
tcSplitPhiTy ty
= split ty []
where
split ty ts
= case tcSplitPredFunTy_maybe ty of
Just (pred, ty) -> split ty (pred:ts)
Nothing -> (reverse ts, ty)
tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy ty = case tcSplitForAllTys ty of
(tvs, rho) -> case tcSplitPhiTy rho of
(theta, tau) -> (tvs, theta, tau)
tcDeepSplitSigmaTy_maybe
:: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType)
tcDeepSplitSigmaTy_maybe ty
| Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty
, Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty
= Just (arg_ty:arg_tys, tvs, theta, rho)
| (tvs, theta, rho) <- tcSplitSigmaTy ty
, not (null tvs && null theta)
= Just ([], tvs, theta, rho)
| otherwise = Nothing
tcTyConAppTyCon :: Type -> TyCon
tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of
Just (tc, _) -> tc
Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty)
tcTyConAppArgs :: Type -> [Type]
tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of
Just (_, args) -> args
Nothing -> pprPanic "tcTyConAppArgs" (pprType ty)
tcSplitTyConApp :: Type -> (TyCon, [Type])
tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic "tcSplitTyConApp" (pprType ty)
tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
tcSplitTyConApp_maybe _ = Nothing
tcSplitFunTys :: Type -> ([Type], Type)
tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
Nothing -> ([], ty)
Just (arg,res) -> (arg:args, res')
where
(args,res') = tcSplitFunTys res
tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty'
tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res)
tcSplitFunTy_maybe _ = Nothing
tcSplitFunTysN
:: TcRhoType
-> Arity
-> ([TcSigmaType],
TcSigmaType)
tcSplitFunTysN ty n_args
| n_args == 0
= ([], ty)
| Just (arg,res) <- tcSplitFunTy_maybe ty
= case tcSplitFunTysN res (n_args 1) of
(args, res) -> (arg:args, res)
| otherwise
= ([], ty)
tcSplitFunTy :: Type -> (Type, Type)
tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)
tcFunArgTy :: Type -> Type
tcFunArgTy ty = fst (tcSplitFunTy ty)
tcFunResultTy :: Type -> Type
tcFunResultTy ty = snd (tcSplitFunTy ty)
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty'
tcSplitAppTy_maybe ty = repSplitAppTy_maybe ty
tcSplitAppTy :: Type -> (Type, Type)
tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic "tcSplitAppTy" (pprType ty)
tcSplitAppTys :: Type -> (Type, [Type])
tcSplitAppTys ty
= go ty []
where
go ty args = case tcSplitAppTy_maybe ty of
Just (ty', arg) -> go ty' (arg:args)
Nothing -> (ty,args)
tcGetTyVar_maybe :: Type -> Maybe TyVar
tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'
tcGetTyVar_maybe (TyVarTy tv) = Just tv
tcGetTyVar_maybe _ = Nothing
tcGetTyVar :: String -> Type -> TyVar
tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
tcIsTyVarTy :: Type -> Bool
tcIsTyVarTy ty = isJust (tcGetTyVar_maybe ty)
tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type])
tcSplitDFunTy ty
= case tcSplitForAllTys ty of { (tvs, rho) ->
case splitFunTys rho of { (theta, tau) ->
case tcSplitDFunHead tau of { (clas, tys) ->
(tvs, theta, clas, tys) }}}
tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead = getClassPredTys
tcInstHeadTyNotSynonym :: Type -> Bool
tcInstHeadTyNotSynonym ty
= case ty of
TyConApp tc _ -> not (isTypeSynonymTyCon tc)
_ -> True
tcInstHeadTyAppAllTyVars :: Type -> Bool
tcInstHeadTyAppAllTyVars ty
| Just ty' <- tcView ty
= tcInstHeadTyAppAllTyVars ty'
| otherwise
= case ty of
TyConApp _ tys -> ok (filter (not . isKind) tys)
FunTy arg res -> ok [arg, res]
_ -> False
where
ok tys = equalLength tvs tys && hasNoDups tvs
where
tvs = mapMaybe get_tv tys
get_tv (TyVarTy tv) = Just tv
get_tv _ = Nothing
tcEqKind :: TcKind -> TcKind -> Bool
tcEqKind = tcEqType
tcEqType :: TcType -> TcType -> Bool
tcEqType ty1 ty2
= go init_env ty1 ty2
where
init_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2))
go env t1 t2 | Just t1' <- tcView t1 = go env t1' t2
| Just t2' <- tcView t2 = go env t1 t2'
go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2
go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = go env (tyVarKind tv1) (tyVarKind tv2)
&& go (rnBndr2 env tv1 tv2) t1 t2
go env (AppTy s1 t1) (AppTy s2 t2) = go env s1 s2 && go env t1 t2
go env (FunTy s1 t1) (FunTy s2 t2) = go env s1 s2 && go env t1 t2
go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = (tc1 == tc2) && gos env ts1 ts2
go _ _ _ = False
gos _ [] [] = True
gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2
gos _ _ _ = False
pickyEqType :: TcType -> TcType -> Bool
pickyEqType ty1 ty2
= go init_env ty1 ty2
where
init_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2))
go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2
go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = go env (tyVarKind tv1) (tyVarKind tv2)
&& go (rnBndr2 env tv1 tv2) t1 t2
go env (AppTy s1 t1) (AppTy s2 t2) = go env s1 s2 && go env t1 t2
go env (FunTy s1 t1) (FunTy s2 t2) = go env s1 s2 && go env t1 t2
go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = (tc1 == tc2) && gos env ts1 ts2
go _ _ _ = False
gos _ [] [] = True
gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2
gos _ _ _ = False
data OccCheckResult a
= OC_OK a
| OC_Forall
| OC_NonTyVar
| OC_Occurs
instance Functor OccCheckResult where
fmap = liftM
instance Applicative OccCheckResult where
pure = return
(<*>) = ap
instance Monad OccCheckResult where
return x = OC_OK x
OC_OK x >>= k = k x
OC_Forall >>= _ = OC_Forall
OC_NonTyVar >>= _ = OC_NonTyVar
OC_Occurs >>= _ = OC_Occurs
occurCheckExpand :: DynFlags -> TcTyVar -> Type -> OccCheckResult Type
occurCheckExpand dflags tv ty
| MetaTv { mtv_info = SigTv } <- details
= go_sig_tv ty
| fast_check ty = return ty
| otherwise = go ty
where
details = ASSERT2( isTcTyVar tv, ppr tv ) tcTyVarDetails tv
impredicative = canUnifyWithPolyType dflags details (tyVarKind tv)
go_sig_tv ty@(TyVarTy {}) = OC_OK ty
go_sig_tv ty | Just ty' <- tcView ty = go_sig_tv ty'
go_sig_tv _ = OC_NonTyVar
fast_check (LitTy {}) = True
fast_check (TyVarTy tv') = tv /= tv'
fast_check (TyConApp _ tys) = all fast_check tys
fast_check (FunTy arg res) = fast_check arg && fast_check res
fast_check (AppTy fun arg) = fast_check fun && fast_check arg
fast_check (ForAllTy tv' ty) = impredicative
&& fast_check (tyVarKind tv')
&& (tv == tv' || fast_check ty)
go t@(TyVarTy tv') | tv == tv' = OC_Occurs
| otherwise = return t
go ty@(LitTy {}) = return ty
go (AppTy ty1 ty2) = do { ty1' <- go ty1
; ty2' <- go ty2
; return (mkAppTy ty1' ty2') }
go (FunTy ty1 ty2) = do { ty1' <- go ty1
; ty2' <- go ty2
; return (mkFunTy ty1' ty2') }
go ty@(ForAllTy tv' body_ty)
| not impredicative = OC_Forall
| not (fast_check (tyVarKind tv')) = OC_Occurs
| tv == tv' = return ty
| otherwise = do { body' <- go body_ty
; return (ForAllTy tv' body') }
go ty@(TyConApp tc tys)
= case do { tys <- mapM go tys; return (mkTyConApp tc tys) } of
OC_OK ty -> return ty
bad | Just ty' <- tcView ty -> go ty'
| otherwise -> bad
canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> TcKind -> Bool
canUnifyWithPolyType dflags details kind
= case details of
MetaTv { mtv_info = ReturnTv } -> True
MetaTv { mtv_info = SigTv } -> False
MetaTv { mtv_info = TauTv _ } -> xopt Opt_ImpredicativeTypes dflags
|| isOpenTypeKind kind
_other -> True
isTyVarClassPred :: PredType -> Bool
isTyVarClassPred ty = case getClassPredTys_maybe ty of
Just (_, tys) -> all isTyVarTy tys
_ -> False
evVarPred_maybe :: EvVar -> Maybe PredType
evVarPred_maybe v = if isPredTy ty then Just ty else Nothing
where ty = varType v
evVarPred :: EvVar -> PredType
evVarPred var
| debugIsOn
= case evVarPred_maybe var of
Just pred -> pred
Nothing -> pprPanic "tcEvVarPred" (ppr var <+> ppr (varType var))
| otherwise
= varType var
mkMinimalBySCs :: [PredType] -> [PredType]
mkMinimalBySCs ptys = [ ploc | ploc <- ptys
, ploc `not_in_preds` rec_scs ]
where
rec_scs = concatMap trans_super_classes ptys
not_in_preds p ps = not (any (eqPred p) ps)
trans_super_classes pred
= case classifyPredType pred of
ClassPred cls tys -> transSuperClasses cls tys
TuplePred ts -> concatMap trans_super_classes ts
_ -> []
transSuperClasses :: Class -> [Type] -> [PredType]
transSuperClasses cls tys
= concatMap trans_sc (immSuperClasses cls tys)
where
trans_sc :: PredType -> [PredType]
trans_sc p = case classifyPredType p of
ClassPred cls tys -> p : transSuperClasses cls tys
TuplePred ps -> concatMap trans_sc ps
_ -> [p]
immSuperClasses :: Class -> [Type] -> [PredType]
immSuperClasses cls tys
= substTheta (zipTopTvSubst tyvars tys) sc_theta
where
(tyvars,sc_theta,_,_) = classBigSig cls
isSigmaTy :: TcType -> Bool
isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty'
isSigmaTy (ForAllTy _ _) = True
isSigmaTy (FunTy a _) = isPredTy a
isSigmaTy _ = False
isRhoTy :: TcType -> Bool
isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty'
isRhoTy (ForAllTy {}) = False
isRhoTy (FunTy a r) = not (isPredTy a) && isRhoTy r
isRhoTy _ = True
isOverloadedTy :: Type -> Bool
isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty
isOverloadedTy (FunTy a _) = isPredTy a
isOverloadedTy _ = False
isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy,
isUnitTy, isCharTy, isAnyTy :: Type -> Bool
isFloatTy = is_tc floatTyConKey
isDoubleTy = is_tc doubleTyConKey
isIntegerTy = is_tc integerTyConKey
isIntTy = is_tc intTyConKey
isWordTy = is_tc wordTyConKey
isBoolTy = is_tc boolTyConKey
isUnitTy = is_tc unitTyConKey
isCharTy = is_tc charTyConKey
isAnyTy = is_tc anyTyConKey
isStringTy :: Type -> Bool
isStringTy ty
= case tcSplitTyConApp_maybe ty of
Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty
_ -> False
is_tc :: Unique -> Type -> Bool
is_tc uniq ty = case tcSplitTyConApp_maybe ty of
Just (tc, _) -> uniq == getUnique tc
Nothing -> False
isTyVarExposed :: TcTyVar -> TcType -> Bool
isTyVarExposed tv (TyVarTy tv') = tv == tv'
isTyVarExposed tv (TyConApp tc tys)
| isNewTyCon tc = any (isTyVarExposed tv) tys
| otherwise = False
isTyVarExposed _ (LitTy {}) = False
isTyVarExposed _ (FunTy {}) = False
isTyVarExposed tv (AppTy fun arg) = isTyVarExposed tv fun
|| isTyVarExposed tv arg
isTyVarExposed _ (ForAllTy {}) = False
deNoteType :: Type -> Type
deNoteType ty | Just ty' <- tcView ty = deNoteType ty'
deNoteType ty = ty
tcTyVarsOfType :: Type -> TcTyVarSet
tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv
else emptyVarSet
tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys
tcTyVarsOfType (LitTy {}) = emptyVarSet
tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar
tcTyVarsOfTypes :: [Type] -> TyVarSet
tcTyVarsOfTypes = mapUnionVarSet tcTyVarsOfType
orphNamesOfTyCon :: TyCon -> NameSet
orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of
Nothing -> emptyNameSet
Just cls -> unitNameSet (getName cls)
orphNamesOfType :: Type -> NameSet
orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty'
orphNamesOfType (TyVarTy _) = emptyNameSet
orphNamesOfType (LitTy {}) = emptyNameSet
orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
`unionNameSet` orphNamesOfTypes tys
orphNamesOfType (FunTy arg res) = orphNamesOfTyCon funTyCon
`unionNameSet` orphNamesOfType arg
`unionNameSet` orphNamesOfType res
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty
orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet
orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet
orphNamesOfTypes :: [Type] -> NameSet
orphNamesOfTypes = orphNamesOfThings orphNamesOfType
orphNamesOfDFunHead :: Type -> NameSet
orphNamesOfDFunHead dfun_ty
= case tcSplitSigmaTy dfun_ty of
(_, _, head_ty) -> orphNamesOfType head_ty
orphNamesOfCo :: Coercion -> NameSet
orphNamesOfCo (Refl _ ty) = orphNamesOfType ty
orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co
orphNamesOfCo (CoVarCo _) = emptyNameSet
orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos
orphNamesOfCo (UnivCo _ _ ty1 ty2) = orphNamesOfType ty1 `unionNameSet` orphNamesOfType ty2
orphNamesOfCo (SymCo co) = orphNamesOfCo co
orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
orphNamesOfCo (NthCo _ co) = orphNamesOfCo co
orphNamesOfCo (LRCo _ co) = orphNamesOfCo co
orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSet` orphNamesOfType ty
orphNamesOfCo (SubCo co) = orphNamesOfCo co
orphNamesOfCo (AxiomRuleCo _ ts cs) = orphNamesOfTypes ts `unionNameSet`
orphNamesOfCos cs
orphNamesOfCos :: [Coercion] -> NameSet
orphNamesOfCos = orphNamesOfThings orphNamesOfCo
orphNamesOfCoCon :: CoAxiom br -> NameSet
orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
= orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches
orphNamesOfCoAxBranches :: BranchList CoAxBranch br -> NameSet
orphNamesOfCoAxBranches = brListFoldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet
orphNamesOfCoAxBranch :: CoAxBranch -> NameSet
orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
= orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs
tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe ty
= case tcSplitTyConApp_maybe ty of
Just (io_tycon, [io_res_ty])
| io_tycon `hasKey` ioTyConKey ->
Just (io_tycon, io_res_ty)
_ ->
Nothing
isFFITy :: Type -> Bool
isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty empty)
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity
isFFIArgumentTy dflags safety ty
= checkRepTyCon (legalOutgoingTyCon dflags safety) ty empty
isFFIExternalTy :: Type -> Validity
isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty empty
isFFIImportResultTy :: DynFlags -> Type -> Validity
isFFIImportResultTy dflags ty
= checkRepTyCon (legalFIResultTyCon dflags) ty empty
isFFIExportResultTy :: Type -> Validity
isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty empty
isFFIDynTy :: Type -> Type -> Validity
isFFIDynTy expected ty
| Just (tc, [ty']) <- splitTyConApp_maybe ty
, tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey]
, eqType ty' expected
= IsValid
| otherwise
= NotValid (vcat [ ptext (sLit "Expected: Ptr/FunPtr") <+> pprParendType expected <> comma
, ptext (sLit " Actual:") <+> ppr ty ])
isFFILabelTy :: Type -> Validity
isFFILabelTy ty = checkRepTyCon ok ty extra
where
ok tc = tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey
extra = ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)")
isFFIPrimArgumentTy :: DynFlags -> Type -> Validity
isFFIPrimArgumentTy dflags ty
| isAnyTy ty = IsValid
| otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty empty
isFFIPrimResultTy :: DynFlags -> Type -> Validity
isFFIPrimResultTy dflags ty
= checkRepTyCon (legalFIPrimResultTyCon dflags) ty empty
isFunPtrTy :: Type -> Bool
isFunPtrTy ty = isValid (checkRepTyCon (`hasKey` funPtrTyConKey) ty empty)
checkRepTyCon :: (TyCon -> Bool) -> Type -> SDoc -> Validity
checkRepTyCon check_tc ty extra
= case splitTyConApp_maybe ty of
Just (tc, tys)
| isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix))
| check_tc tc -> IsValid
| otherwise -> NotValid (msg $$ extra)
Nothing -> NotValid (quotes (ppr ty) <+> ptext (sLit "is not a data type") $$ extra)
where
msg = quotes (ppr ty) <+> ptext (sLit "cannot be marshalled in a foreign call")
mk_nt_reason tc tys
| null tys = ptext (sLit "because its data construtor is not in scope")
| otherwise = ptext (sLit "because the data construtor for")
<+> quotes (ppr tc) <+> ptext (sLit "is not in scope")
nt_fix = ptext (sLit "Possible fix: import the data constructor to bring it into scope")
legalFEArgTyCon :: TyCon -> Bool
legalFEArgTyCon tc
= boxedMarshalableTyCon tc
legalFIResultTyCon :: DynFlags -> TyCon -> Bool
legalFIResultTyCon dflags tc
| tc == unitTyCon = True
| otherwise = marshalableTyCon dflags tc
legalFEResultTyCon :: TyCon -> Bool
legalFEResultTyCon tc
| tc == unitTyCon = True
| otherwise = boxedMarshalableTyCon tc
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
legalOutgoingTyCon dflags _ tc
= marshalableTyCon dflags tc
legalFFITyCon :: TyCon -> Bool
legalFFITyCon tc
| isUnLiftedTyCon tc = True
| tc == unitTyCon = True
| otherwise = boxedMarshalableTyCon tc
marshalableTyCon :: DynFlags -> TyCon -> Bool
marshalableTyCon dflags tc
| (xopt Opt_UnliftedFFITypes dflags
&& isUnLiftedTyCon tc
&& not (isUnboxedTupleTyCon tc)
&& case tyConPrimRep tc of
VoidRep -> False
_ -> True)
= True
| otherwise
= boxedMarshalableTyCon tc
boxedMarshalableTyCon :: TyCon -> Bool
boxedMarshalableTyCon tc
| getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
, int32TyConKey, int64TyConKey
, wordTyConKey, word8TyConKey, word16TyConKey
, word32TyConKey, word64TyConKey
, floatTyConKey, doubleTyConKey
, ptrTyConKey, funPtrTyConKey
, charTyConKey
, stablePtrTyConKey
, boolTyConKey
]
= True
| otherwise = False
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool
legalFIPrimArgTyCon dflags tc
| xopt Opt_UnliftedFFITypes dflags
&& isUnLiftedTyCon tc
&& not (isUnboxedTupleTyCon tc)
= True
| otherwise
= False
legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool
legalFIPrimResultTyCon dflags tc
| xopt Opt_UnliftedFFITypes dflags
&& isUnLiftedTyCon tc
&& (isUnboxedTupleTyCon tc
|| case tyConPrimRep tc of
VoidRep -> False
_ -> True)
= True
| otherwise
= False