%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcType]{Types used in the typechecker}
This module provides the Type interface for front-end parts of the
compiler. These parts
* treat "source types" as opaque:
newtypes, and predicates are meaningful.
* look through usage types
The "tc" prefix is for "TypeChecker", because the type checker
is the principal client.
\begin{code}
module TcType (
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcKind, TcCoVar,
Untouchables(..), noUntouchables, pushUntouchables, isTouchable,
UserTypeCtxt(..), pprUserTypeCtxt,
TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
MetaDetails(Flexi, Indirect), MetaInfo(..),
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy,
isSigTyVar, isOverlappableTyVar, isTyConableTyVar, isFlatSkolTyVar,
isAmbiguousTyVar, metaTvRef, metaTyVarInfo,
isFlexi, isIndirect, isRuntimeUnkSkol,
isTypeVar, isKindVar,
metaTyVarUntouchables, setMetaTyVarUntouchables,
isTouchableMetaTyVar, isFloatedTouchableMetaTyVar,
mkPhiTy, mkSigmaTy, mkTcEqPred,
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,
tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe,
eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX,
pickyEqType, tcEqType, tcEqKind,
isSigmaTy, isOverloadedTy,
isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isBoolTy, isUnitTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
isSynFamilyTyConApp,
isPredTy, isTyVarClassPred,
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,
isFFIDotnetTy,
isFFIDotnetObjTy,
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 Data.IORef
import Control.Monad (liftM, ap)
import Control.Applicative (Applicative(..))
\end{code}
%************************************************************************
%* *
\subsection{Types}
%* *
%************************************************************************
The type checker divides the generic Type world into the
following more structured beasts:
sigma ::= forall tyvars. phi
-- A sigma type is a qualified type
--
-- Note that even if 'tyvars' is empty, theta
-- may not be: e.g. (?x::Int) => Int
-- Note that 'sigma' is in prenex form:
-- all the foralls are at the front.
-- A 'phi' type has no foralls to the right of
-- an arrow
phi :: theta => rho
rho ::= sigma -> rho
| tau
-- A 'tau' type has no quantification anywhere
-- Note that the args of a type constructor must be taus
tau ::= tyvar
| tycon tau_1 .. tau_n
| tau_1 tau_2
| tau_1 -> tau_2
-- In all cases, a (saturated) type synonym application is legal,
-- provided it expands to the required form.
\begin{code}
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
\end{code}
%************************************************************************
%* *
\subsection{TyVarDetails}
%* *
%************************************************************************
TyVarDetails gives extra info about type variables, used during type
checking. It's attached to mutable type variables only.
It's knot-tied back to Var.lhs. There is no reason in principle
why Var.lhs shouldn't actually have the definition, but it "belongs" here.
Note [Signature skolems]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
f :: forall a. [a] -> Int
f (x::b : xs) = 3
Here 'b' is a lexically scoped type variable, but it turns out to be
the same as the skolem 'a'. So we have a special kind of skolem
constant, SigTv, which can unify with other SigTvs. They are used
*only* for pattern type signatures.
Similarly consider
data T (a:k1) = MkT (S a)
data S (b:k2) = MkS (T b)
When doing kind inference on {S,T} we don't want *skolems* for k1,k2,
because they end up unifying; we want those SigTvs again.
\begin{code}
data TcTyVarDetails
= SkolemTv
Bool
| RuntimeUnk
| FlatSkol TcType
| MetaTv { mtv_info :: MetaInfo
, mtv_ref :: IORef MetaDetails
, mtv_untch :: Untouchables }
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
| PolyTv
| SigTv
data UserTypeCtxt
= FunSigCtxt Name
| InfSigCtxt Name
| ExprSigCtxt
| ConArgCtxt Name
| TySynCtxt Name
| LamPatSigCtxt
| BindPatSigCtxt
| RuleSigCtxt Name
| ResSigCtxt
| ForSigCtxt Name
| DefaultDeclCtxt
| InstDeclCtxt
| SpecInstCtxt
| ThBrackCtxt
| GenSigCtxt
| GhciCtxt
| ClassSCCtxt Name
| SigmaCtxt
| DataTyCtxt Name
\end{code}
-- Notes re TySynCtxt
-- We allow type synonyms that aren't types; e.g. type List = []
--
-- If the RHS mentions tyvars that aren't in scope, we'll
-- quantify over them:
-- e.g. type T = a->a
-- will become type T = forall a. a->a
--
-- With gla-exts that's right, but for H98 we should complain.
%************************************************************************
%* *
Untoucable type variables
%* *
%************************************************************************
Note [Untouchable type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Each unification variable (MetaTv)
and each Implication
has a level number (of type Untouchables)
* INVARIANTS. In a tree of Implications,
(ImplicInv) The level number of an Implication is
STRICTLY GREATER THAN that of its parent
(MetaTvInv) The level number of a unification variable is
LESS THAN OR EQUAL TO that of its parent
implication
* A unification variable is *touchable* if its level number
is EQUAL TO that of its immediate parent implication.
* INVARIANT
(GivenInv) The free variables of the ic_given of an
implication are all untouchable; ie their level
numbers are LESS THAN the ic_untch of the implication
Note [Skolem escape prevention]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We only unify touchable unification variables. Because of
(MetaTvInv), there can be no occurrences of he variable further out,
so the unification can't cause the kolems to escape. Example:
data T = forall a. MkT a (a->Int)
f x (MkT v f) = length [v,x]
We decide (x::alpha), and generate an implication like
[1]forall a. (a ~ alpha[0])
But we must not unify alpha:=a, because the skolem would escape.
For the cases where we DO want to unify, we rely on floating the
equality. Example (with same T)
g x (MkT v f) = x && True
We decide (x::alpha), and generate an implication like
[1]forall a. (Bool ~ alpha[0])
We do NOT unify directly, bur rather float out (if the constraint
does not mention 'a') to get
(Bool ~ alpha[0]) /\ [1]forall a.()
and NOW we can unify alpha.
The same idea of only unifying touchables solves another problem.
Suppose we had
(F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1])
In this example, beta is touchable inside the implication. The
first solveInteract step leaves 'uf' un-unified. Then we move inside
the implication where a new constraint
uf ~ beta
emerges. If we (wrongly) spontaneously solved it to get uf := beta,
the whole implication disappears but when we pop out again we are left with
(F Int ~ uf) which will be unified by our final solveCTyFunEqs stage and
uf will get unified *once more* to (F Int).
\begin{code}
newtype Untouchables = Untouchables Int
noUntouchables :: Untouchables
noUntouchables = Untouchables 0
pushUntouchables :: Untouchables -> Untouchables
pushUntouchables (Untouchables us) = Untouchables (us+1)
isFloatedTouchable :: Untouchables -> Untouchables -> Bool
isFloatedTouchable (Untouchables ctxt_untch) (Untouchables tv_untch)
= ctxt_untch < tv_untch
isTouchable :: Untouchables -> Untouchables -> Bool
isTouchable (Untouchables ctxt_untch) (Untouchables tv_untch)
= ctxt_untch == tv_untch
checkTouchableInvariant :: Untouchables -> Untouchables -> Bool
checkTouchableInvariant (Untouchables ctxt_untch) (Untouchables tv_untch)
= ctxt_untch >= tv_untch
instance Outputable Untouchables where
ppr (Untouchables us) = ppr us
\end{code}
%************************************************************************
%* *
Pretty-printing
%* *
%************************************************************************
\begin{code}
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_untch = untch })
= pp_info <> brackets (ppr untch)
where
pp_info = case info of
PolyTv -> ptext (sLit "poly")
TauTv -> ptext (sLit "tau")
SigTv -> ptext (sLit "sig")
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 LamPatSigCtxt = ptext (sLit "a pattern type signature")
pprUserTypeCtxt BindPatSigCtxt = 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)
\end{code}
%************************************************************************
%* *
Finding type family instances
%* *
%************************************************************************
\begin{code}
tcTyFamInsts :: Type -> [(TyCon, [Type])]
tcTyFamInsts ty
| Just exp_ty <- tcView ty = tcTyFamInsts exp_ty
tcTyFamInsts (TyVarTy _) = []
tcTyFamInsts (TyConApp tc tys)
| isSynFamilyTyCon 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
\end{code}
%************************************************************************
%* *
The "exact" free variables of a type
%* *
%************************************************************************
Note [Silly type synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
type T a = Int
What are the free tyvars of (T x)? Empty, of course!
Here's the example that Ralf Laemmel showed me:
foo :: (forall a. C u a -> C u a) -> u
mappend :: Monoid u => u -> u -> u
bar :: Monoid u => u
bar = foo (\t -> t `mappend` t)
We have to generalise at the arg to f, and we don't
want to capture the constraint (Monad (C u a)) because
it appears to mention a. Pretty silly, but it was useful to him.
exactTyVarsOfType is used by the type checker to figure out exactly
which type variables are mentioned in a type. It's also used in the
smart-app checking code --- see TcExpr.tcIdApp
On the other hand, consider a *top-level* definition
f = (\x -> x) :: T a -> T a
If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then
if we have an application like (f "x") we get a confusing error message
involving Any. So the conclusion is this: when generalising
- at top level use tyVarsOfType
- in nested bindings use exactTyVarsOfType
See Trac #1813 for example.
\begin{code}
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 tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
\end{code}
%************************************************************************
%* *
Predicates
%* *
%************************************************************************
\begin{code}
isTouchableMetaTyVar :: Untouchables -> TcTyVar -> Bool
isTouchableMetaTyVar ctxt_untch tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv { mtv_untch = tv_untch }
-> ASSERT2( checkTouchableInvariant ctxt_untch tv_untch,
ppr tv $$ ppr tv_untch $$ ppr ctxt_untch )
isTouchable ctxt_untch tv_untch
_ -> False
isFloatedTouchableMetaTyVar :: Untouchables -> TcTyVar -> Bool
isFloatedTouchableMetaTyVar ctxt_untch tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv { mtv_untch = tv_untch } -> isFloatedTouchable ctxt_untch tv_untch
_ -> False
isImmutableTyVar :: TyVar -> Bool
isImmutableTyVar tv
| isTcTyVar tv = isSkolemTyVar tv
| otherwise = True
isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
isMetaTyVar, isAmbiguousTyVar, isFlatSkolTyVar :: TcTyVar -> Bool
isTyConableTyVar tv
= ASSERT( isTcTyVar tv)
case tcTyVarDetails tv of
MetaTv { mtv_info = SigTv } -> False
_ -> True
isFlatSkolTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
FlatSkol {} -> True
_ -> False
isSkolemTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
SkolemTv {} -> True
FlatSkol {} -> True
RuntimeUnk {} -> True
MetaTv {} -> False
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
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)
metaTyVarUntouchables :: TcTyVar -> Untouchables
metaTyVarUntouchables tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
MetaTv { mtv_untch = untch } -> untch
_ -> pprPanic "metaTyVarUntouchables" (ppr tv)
setMetaTyVarUntouchables :: TcTyVar -> Untouchables -> TcTyVar
setMetaTyVarUntouchables tv untch
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_untch = untch })
_ -> pprPanic "metaTyVarUntouchables" (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
\end{code}
%************************************************************************
%* *
\subsection{Tau, sigma and rho}
%* *
%************************************************************************
\begin{code}
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 = defaultKind (typeKind ty1)
\end{code}
@isTauTy@ tests for nested for-alls. It should not be called on a boxy type.
\begin{code}
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)
\end{code}
%************************************************************************
%* *
\subsection{Expanding and splitting}
%* *
%************************************************************************
These tcSplit functions are like their non-Tc analogues, but
*) they do not look through newtypes
However, they are non-monadic and do not follow through mutable type
variables. It's up to you to make sure this doesn't matter.
\begin{code}
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 = maybeToBool (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 = mapCatMaybes get_tv tys
get_tv (TyVarTy tv) = Just tv
get_tv _ = Nothing
\end{code}
\begin{code}
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
\end{code}
Note [Occurs check expansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid
of occurrences of tv outside type function arguments, if that is
possible; otherwise, it returns Nothing.
For example, suppose we have
type F a b = [a]
Then
occurCheckExpand b (F Int b) = Just [Int]
but
occurCheckExpand a (F a Int) = Nothing
We don't promise to do the absolute minimum amount of expanding
necessary, but we try not to do expansions we don't need to. We
prefer doing inner expansions first. For example,
type F a b = (a, Int, a, [a])
type G b = Char
We have
occurCheckExpand b (F (G b)) = F Char
even though we could also expand F to get rid of b.
See also Note [occurCheckExpand] in TcCanonical
\begin{code}
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
= case details of
MetaTv { mtv_info = PolyTv } -> True
MetaTv { mtv_info = SigTv } -> False
MetaTv { mtv_info = TauTv } -> xopt Opt_ImpredicativeTypes dflags
|| isOpenTypeKind (tyVarKind tv)
_other -> True
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
\end{code}
%************************************************************************
%* *
\subsection{Predicate types}
%* *
%************************************************************************
Deconstructors and tests on predicate types
\begin{code}
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
\end{code}
Superclasses
\begin{code}
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
\end{code}
%************************************************************************
%* *
\subsection{Predicates}
%* *
%************************************************************************
isSigmaTy returns true of any qualified type. It doesn't *necessarily* have
any foralls. E.g.
f :: (?x::Int) => Int -> Int
\begin{code}
isSigmaTy :: Type -> Bool
isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty'
isSigmaTy (ForAllTy _ _) = True
isSigmaTy (FunTy a _) = isPredTy a
isSigmaTy _ = False
isOverloadedTy :: Type -> Bool
isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty
isOverloadedTy (FunTy a _) = isPredTy a
isOverloadedTy _ = False
\end{code}
\begin{code}
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
\end{code}
\begin{code}
isSynFamilyTyConApp :: TcTauType -> Bool
isSynFamilyTyConApp (TyConApp tc tys) = isSynFamilyTyCon tc &&
length tys == tyConArity tc
isSynFamilyTyConApp _other = False
\end{code}
%************************************************************************
%* *
\subsection{Misc}
%* *
%************************************************************************
\begin{code}
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 tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
\end{code}
Find the free tycons and classes of a type. This is used in the front
end of the compiler.
\begin{code}
orphNamesOfTyCon :: TyCon -> NameSet
orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSets` 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
`unionNameSets` orphNamesOfTypes tys
orphNamesOfType (FunTy arg res) = orphNamesOfTyCon funTyCon
`unionNameSets` orphNamesOfType arg
`unionNameSets` orphNamesOfType res
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSets` orphNamesOfType arg
orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty
orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet
orphNamesOfThings f = foldr (unionNameSets . 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) `unionNameSets` orphNamesOfCos cos
orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co
orphNamesOfCo (CoVarCo _) = emptyNameSet
orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos
orphNamesOfCo (UnivCo _ ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
orphNamesOfCo (SymCo co) = orphNamesOfCo co
orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
orphNamesOfCo (NthCo _ co) = orphNamesOfCo co
orphNamesOfCo (LRCo _ co) = orphNamesOfCo co
orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty
orphNamesOfCo (SubCo co) = orphNamesOfCo co
orphNamesOfCo (AxiomRuleCo _ ts cs) = orphNamesOfTypes ts `unionNameSets`
orphNamesOfCos cs
orphNamesOfCos :: [Coercion] -> NameSet
orphNamesOfCos = orphNamesOfThings orphNamesOfCo
orphNamesOfCoCon :: CoAxiom br -> NameSet
orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
= orphNamesOfTyCon tc `unionNameSets` orphNamesOfCoAxBranches branches
orphNamesOfCoAxBranches :: BranchList CoAxBranch br -> NameSet
orphNamesOfCoAxBranches = brListFoldr (unionNameSets . orphNamesOfCoAxBranch) emptyNameSet
orphNamesOfCoAxBranch :: CoAxBranch -> NameSet
orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
= orphNamesOfTypes lhs `unionNameSets` orphNamesOfType rhs
\end{code}
%************************************************************************
%* *
\subsection[TysWiredIn-ext-type]{External types}
%* *
%************************************************************************
The compiler's foreign function interface supports the passing of a
restricted set of types as arguments and results (the restricting factor
being the )
\begin{code}
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 = checkRepTyCon legalFFITyCon ty
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
isFFIArgumentTy dflags safety ty
= checkRepTyCon (legalOutgoingTyCon dflags safety) ty
isFFIExternalTy :: Type -> Bool
isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
isFFIImportResultTy :: DynFlags -> Type -> Bool
isFFIImportResultTy dflags ty
= checkRepTyCon (legalFIResultTyCon dflags) ty
isFFIExportResultTy :: Type -> Bool
isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
isFFIDynTy :: Type -> Type -> Bool
isFFIDynTy expected ty
| Just (tc, [ty']) <- splitTyConApp_maybe ty
, tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey]
, eqType ty' expected
= True
| otherwise
= False
isFFILabelTy :: Type -> Bool
isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
isFFIPrimArgumentTy :: DynFlags -> Type -> Bool
isFFIPrimArgumentTy dflags ty
= isAnyTy ty || checkRepTyCon (legalFIPrimArgTyCon dflags) ty
isFFIPrimResultTy :: DynFlags -> Type -> Bool
isFFIPrimResultTy dflags ty
= checkRepTyCon (legalFIPrimResultTyCon dflags) ty
isFFIDotnetTy :: DynFlags -> Type -> Bool
isFFIDotnetTy dflags ty
= checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc ||
isFFIDotnetObjTy ty || isStringTy ty)) ty
isFFIDotnetObjTy :: Type -> Bool
isFFIDotnetObjTy ty
= checkRepTyCon check_tc t_ty
where
(_, t_ty) = tcSplitForAllTys ty
check_tc tc = getName tc == objectTyConName
isFunPtrTy :: Type -> Bool
isFunPtrTy = checkRepTyConKey [funPtrTyConKey]
checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
checkRepTyCon check_tc ty
| Just (tc, _) <- splitTyConApp_maybe ty
= check_tc tc
| otherwise
= False
checkRepTyConKey :: [Unique] -> Type -> Bool
checkRepTyConKey keys
= checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
\end{code}
Note [Foreign import dynamic]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign
type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'.
We use isFFIDynTy to check whether a signature is well-formed. For example,
given a (illegal) declaration like:
foreign import ccall "dynamic"
foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO ()
isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried
result type 'CInt -> IO ()', and return False, as they are not equal.
----------------------------------------------
These chaps do the work; they are not exported
----------------------------------------------
\begin{code}
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 || boxedMarshalableTyCon tc || tc == unitTyCon
marshalableTyCon :: DynFlags -> TyCon -> Bool
marshalableTyCon dflags tc
= (xopt Opt_UnliftedFFITypes dflags
&& isUnLiftedTyCon tc
&& not (isUnboxedTupleTyCon tc)
&& case tyConPrimRep tc of
VoidRep -> False
_ -> True)
|| 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
]
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool
legalFIPrimArgTyCon dflags tc
= xopt Opt_UnliftedFFITypes dflags
&& isUnLiftedTyCon tc
&& not (isUnboxedTupleTyCon tc)
legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool
legalFIPrimResultTyCon dflags tc
= xopt Opt_UnliftedFFITypes dflags
&& isUnLiftedTyCon tc
&& (isUnboxedTupleTyCon tc
|| case tyConPrimRep tc of
VoidRep -> False
_ -> True)
\end{code}
Note [Marshalling VoidRep]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't treat State# (whose PrimRep is VoidRep) as marshalable.
In turn that means you can't write
foreign import foo :: Int -> State# RealWorld
Reason: the back end falls over with panic "primRepHint:VoidRep";
and there is no compelling reason to permit it