-%
+
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcType]{Types used in the typechecker}
-\begin{code}
-module TcType (
-
- TcTyVar,
- TcTyVarSet,
- newTyVar,
- newTyVarTy, -- Kind -> NF_TcM TcType
- newTyVarTys, -- Int -> Kind -> NF_TcM [TcType]
-
- -----------------------------------------
- TcType, TcTauType, TcThetaType, TcRhoType, TcClassContext,
+This module provides the Type interface for front-end parts of the
+compiler. These parts
- -- Find the type to which a type variable is bound
- tcPutTyVar, -- :: TcTyVar -> TcType -> NF_TcM TcType
- tcGetTyVar, -- :: TcTyVar -> NF_TcM (Maybe TcType) does shorting out
+ * treat "source types" as opaque:
+ newtypes, and predicates are meaningful.
+ * look through usage types
+The "tc" prefix is for "typechechecker", because the type checker
+is the principal client.
- tcSplitRhoTy,
+\begin{code}
+module TcType (
+ --------------------------------
+ -- Types
+ TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
+ TcTyVar, TcTyVarSet, TcKind,
- tcInstTyVar, tcInstTyVars,
- tcInstSigVar,
- tcInstType,
+ --------------------------------
+ -- MetaDetails
+ TcTyVarDetails(..),
+ MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar,
+ isImmutableTyVar, isSkolemTyVar, isMetaTyVar, skolemTvInfo, metaTvRef,
+ isFlexi, isIndirect,
--------------------------------
- TcKind,
- newKindVar, newKindVars, newBoxityVar,
+ -- Builders
+ mkPhiTy, mkSigmaTy,
--------------------------------
- zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcSigTyVars,
- zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
+ -- Splitters
+ -- These are important because they do not look through newtypes
+ tcSplitForAllTys, tcSplitPhiTy,
+ tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
+ tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
+ tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
+ tcSplitMethodTy, tcGetTyVar_maybe, tcGetTyVar,
+
+ ---------------------------------
+ -- Predicates.
+ -- Again, newtypes are opaque
+ tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
+ isSigmaTy, isOverloadedTy,
+ isDoubleTy, isFloatTy, isIntTy,
+ isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
+ isTauTy, tcIsTyVarTy, tcIsForAllTy,
+
+ ---------------------------------
+ -- Misc type manipulators
+ deNoteType, classesOfTheta,
+ tyClsNamesOfType, tyClsNamesOfDFunHead,
+ getDFunTyKey,
+
+ ---------------------------------
+ -- Predicate types
+ getClassPredTys_maybe, getClassPredTys,
+ isClassPred, isTyVarClassPred,
+ mkDictTy, tcSplitPredTy_maybe,
+ isPredTy, isDictTy, tcSplitDFunTy, predTyUnique,
+ mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
+
+ ---------------------------------
+ -- Foreign import and export
+ isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool
+ isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
+ isFFIExportResultTy, -- :: Type -> Bool
+ isFFIExternalTy, -- :: Type -> Bool
+ isFFIDynArgumentTy, -- :: Type -> Bool
+ isFFIDynResultTy, -- :: Type -> Bool
+ isFFILabelTy, -- :: Type -> Bool
+ isFFIDotnetTy, -- :: DynFlags -> Type -> Bool
+ isFFIDotnetObjTy, -- :: Type -> Bool
+ isFFITy, -- :: Type -> Bool
+
+ toDNType, -- :: Type -> DNType
- zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv
+ --------------------------------
+ -- Rexported from Type
+ Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
+ unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
+ isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
+ isArgTypeKind, isSubKind, defaultKind,
+
+ Type, PredType(..), ThetaType,
+ mkForAllTy, mkForAllTys,
+ mkFunTy, mkFunTys, zipFunTys,
+ mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
+ mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
+
+ -- Type substitutions
+ TvSubst(..), -- Representation visible to a few friends
+ TvSubstEnv, emptyTvSubst,
+ mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ extendTvSubst, extendTvSubstList, isInScope,
+ substTy, substTys, substTyWith, substTheta, substTyVar,
+
+ isUnLiftedType, -- Source types are always lifted
+ isUnboxedTupleType, -- Ditto
+ isPrimitiveType,
+
+ tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
+ tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
+ typeKind,
+
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
+
+ pprKind, pprParendKind,
+ pprType, pprParendType, pprTyThingCategory,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
#include "HsVersions.h"
-
-- friends:
-import TypeRep ( Type(..), Kind, TyNote(..) ) -- friend
-import Type ( PredType(..),
- getTyVar, mkAppTy, mkUTy,
- splitPredTy_maybe, splitForAllTys,
- isTyVarTy, mkTyVarTy, mkTyVarTys,
- openTypeKind, liftedTypeKind,
- superKind, superBoxity, tyVarsOfTypes,
- defaultKind, liftedBoxity
+import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend
+
+import Type ( -- Re-exports
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
+ tyVarsOfTheta, Kind, Type, PredType(..),
+ ThetaType, unliftedTypeKind,
+ liftedTypeKind, openTypeKind, mkArrowKind,
+ isLiftedTypeKind, isUnliftedTypeKind,
+ isOpenTypeKind,
+ mkArrowKinds, mkForAllTy, mkForAllTys,
+ defaultKind, isArgTypeKind, isOpenTypeKind,
+ mkFunTy, mkFunTys, zipFunTys,
+ mkTyConApp, mkGenTyConApp, mkAppTy,
+ mkAppTys, mkSynTy, applyTy, applyTys,
+ mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
+ mkPredTys, isUnLiftedType,
+ isUnboxedTupleType, isPrimitiveType,
+ splitTyConApp_maybe,
+ tidyTopType, tidyType, tidyPred, tidyTypes,
+ tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
+ tidyTyVarBndr, tidyOpenTyVar,
+ tidyOpenTyVars,
+ isSubKind,
+ TvSubst(..),
+ TvSubstEnv, emptyTvSubst,
+ mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ extendTvSubst, extendTvSubstList, isInScope,
+ substTy, substTys, substTyWith, substTheta, substTyVar,
+
+ typeKind, repType,
+ pprKind, pprParendKind,
+ pprType, pprParendType, pprTyThingCategory,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred
)
-import Subst ( Subst, mkTopTyVarSubst, substTy )
-import TyCon ( mkPrimTyCon )
-import PrimRep ( PrimRep(VoidRep) )
-import Var ( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar )
+import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
+import DataCon ( DataCon )
+import Class ( Class )
+import Var ( TyVar, Id, isTcTyVar, tcTyVarDetails )
+import ForeignCall ( Safety, playSafe, DNType(..) )
+import VarEnv
+import VarSet
-- others:
-import TcMonad -- TcType, amongst others
-import TysWiredIn ( voidTy )
-
-import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName,
- mkLocalName, mkDerivedTyConOcc
- )
-import Unique ( Uniquable(..) )
-import SrcLoc ( noSrcLoc )
-import Util ( nOfThem )
+import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
+import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc )
+import NameSet
+import OccName ( OccName, mkDictOcc )
+import PrelNames -- Lots (e.g. in isFFIArgumentTy)
+import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
+import BasicTypes ( IPName(..), ipNameName )
+import Unique ( Unique, Uniquable(..) )
+import SrcLoc ( SrcLoc, SrcSpan )
+import Util ( cmpList, thenCmp, snocView )
+import Maybes ( maybeToBool, expectJust )
import Outputable
+import DATA_IOREF
\end{code}
-Utility functions
-~~~~~~~~~~~~~~~~~
-These tcSplit functions are like their non-Tc analogues, but they
-follow through bound type variables.
+%************************************************************************
+%* *
+\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
-No need for tcSplitForAllTy because a type variable can't be instantiated
-to a for-all type.
+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}
-tcSplitRhoTy :: TcType -> NF_TcM (TcThetaType, TcType)
-tcSplitRhoTy t
- = go t t []
- where
- -- A type variable is never instantiated to a dictionary type,
- -- so we don't need to do a tcReadVar on the "arg".
- go syn_t (FunTy arg res) ts = case splitPredTy_maybe arg of
- Just pair -> go res res (pair:ts)
- Nothing -> returnNF_Tc (reverse ts, syn_t)
- go syn_t (NoteTy _ t) ts = go syn_t t ts
- go syn_t (TyVarTy tv) ts = tcGetTyVar tv `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty | not (isTyVarTy ty) -> go syn_t ty ts
- other -> returnNF_Tc (reverse ts, syn_t)
- go syn_t (UsageTy _ t) ts = go syn_t t ts
- go syn_t t ts = returnNF_Tc (reverse ts, syn_t)
+type TcType = Type -- A TcType can have mutable type variables
+ -- Invariant on ForAllTy in TcTypes:
+ -- forall a. T
+ -- a cannot occur inside a MutTyVar in T; that is,
+ -- T is "flattened" before quantifying over a
+
+type TcPredType = PredType
+type TcThetaType = ThetaType
+type TcSigmaType = TcType
+type TcRhoType = TcType
+type TcTauType = TcType
+type TcKind = Kind
+type TcTyVarSet = TyVarSet
\end{code}
%************************************************************************
%* *
-\subsection{New type variables}
+\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.
+
\begin{code}
-newTyVar :: Kind -> NF_TcM TcTyVar
-newTyVar kind
- = tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq SLIT("t")) kind
-
-newTyVarTy :: Kind -> NF_TcM TcType
-newTyVarTy kind
- = newTyVar kind `thenNF_Tc` \ tc_tyvar ->
- returnNF_Tc (TyVarTy tc_tyvar)
-
-newTyVarTys :: Int -> Kind -> NF_TcM [TcType]
-newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind)
-
-newKindVar :: NF_TcM TcKind
-newKindVar
- = tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq SLIT("k")) superKind `thenNF_Tc` \ kv ->
- returnNF_Tc (TyVarTy kv)
-
-newKindVars :: Int -> NF_TcM [TcKind]
-newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ())
-
-newBoxityVar :: NF_TcM TcKind
-newBoxityVar
- = tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq SLIT("bx")) superBoxity `thenNF_Tc` \ kv ->
- returnNF_Tc (TyVarTy kv)
+type TcTyVar = TyVar -- Used only during type inference
+
+-- A TyVarDetails is inside a TyVar
+data TcTyVarDetails
+ = SkolemTv SkolemInfo -- A skolem constant
+ | MetaTv (IORef MetaDetails) -- A meta type variable stands for a tau-type
+
+data SkolemInfo
+ = SigSkol Name -- Bound at a type signature
+ | ClsSkol Class -- Bound at a class decl
+ | InstSkol Id -- Bound at an instance decl
+ | PatSkol DataCon -- An existential type variable bound by a pattern for
+ SrcSpan -- a data constructor with an existential type. E.g.
+ -- data T = forall a. Eq a => MkT a
+ -- f (MkT x) = ...
+ -- The pattern MkT x will allocate an existential type
+ -- variable for 'a'.
+ | ArrowSkol SrcSpan -- An arrow form (see TcArrows)
+
+ | GenSkol TcType -- Bound when doing a subsumption check for this type
+ SrcSpan
+
+data MetaDetails
+ = Flexi -- Flexi type variables unify to become
+ -- Indirects.
+
+ | Indirect TcType -- Type indirections, treated as wobbly
+ -- for the purpose of GADT unification.
+
+pprSkolemTyVar :: TcTyVar -> SDoc
+pprSkolemTyVar tv
+ = ASSERT( isSkolemTyVar tv )
+ quotes (ppr tv) <+> ptext SLIT("is bound by") <+> ppr (skolemTvInfo tv)
+
+instance Outputable SkolemInfo where
+ ppr (SigSkol id) = ptext SLIT("the type signature for") <+> quotes (ppr id)
+ ppr (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
+ ppr (InstSkol df) = ptext SLIT("the instance declaration at") <+> ppr (getSrcLoc df)
+ ppr (ArrowSkol loc) = ptext SLIT("the arrow form at") <+> ppr loc
+ ppr (PatSkol dc loc) = sep [ptext SLIT("the pattern for") <+> quotes (ppr dc),
+ nest 2 (ptext SLIT("at") <+> ppr loc)]
+ ppr (GenSkol ty loc) = sep [ptext SLIT("the polymorphic type") <+> quotes (ppr ty),
+ nest 2 (ptext SLIT("at") <+> ppr loc)]
+
+instance Outputable MetaDetails where
+ ppr Flexi = ptext SLIT("Flexi")
+ ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
+
+isImmutableTyVar, isSkolemTyVar, isMetaTyVar :: TyVar -> Bool
+isImmutableTyVar tv
+ | isTcTyVar tv = isSkolemTyVar tv
+ | otherwise = True
+
+isSkolemTyVar tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ SkolemTv _ -> True
+ MetaTv _ -> False
+
+isMetaTyVar tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ SkolemTv _ -> False
+ MetaTv _ -> True
+
+skolemTvInfo :: TyVar -> SkolemInfo
+skolemTvInfo tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ SkolemTv info -> info
+
+metaTvRef :: TyVar -> IORef MetaDetails
+metaTvRef tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ MetaTv ref -> ref
+
+isFlexi, isIndirect :: MetaDetails -> Bool
+isFlexi Flexi = True
+isFlexi other = False
+
+isIndirect (Indirect _) = True
+isIndirect other = False
\end{code}
%************************************************************************
%* *
-\subsection{Type instantiation}
+\subsection{Tau, sigma and rho}
%* *
%************************************************************************
-Instantiating a bunch of type variables
-
\begin{code}
-tcInstTyVars :: [TyVar]
- -> NF_TcM ([TcTyVar], [TcType], Subst)
-
-tcInstTyVars tyvars
- = mapNF_Tc tcInstTyVar tyvars `thenNF_Tc` \ tc_tyvars ->
- let
- tys = mkTyVarTys tc_tyvars
- in
- returnNF_Tc (tc_tyvars, tys, mkTopTyVarSubst tyvars tys)
- -- Since the tyvars are freshly made,
- -- they cannot possibly be captured by
- -- any existing for-alls. Hence mkTopTyVarSubst
-
-tcInstTyVar tyvar
- = tcGetUnique `thenNF_Tc` \ uniq ->
- let
- name = setNameUnique (tyVarName tyvar) uniq
- -- Note that we don't change the print-name
- -- This won't confuse the type checker but there's a chance
- -- that two different tyvars will print the same way
- -- in an error message. -dppr-debug will show up the difference
- -- Better watch out for this. If worst comes to worst, just
- -- use mkSysLocalName.
- in
- tcNewMutTyVar name (tyVarKind tyvar)
-
-tcInstSigVar tyvar -- Very similar to tcInstTyVar
- = tcGetUnique `thenNF_Tc` \ uniq ->
- let
- name = setNameUnique (tyVarName tyvar) uniq
- kind = tyVarKind tyvar
- in
- ASSERT( not (kind == openTypeKind) ) -- Shouldn't happen
- tcNewSigTyVar name kind
+mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
+
+mkPhiTy :: [PredType] -> Type -> Type
+mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
\end{code}
-@tcInstType@ instantiates the outer-level for-alls of a TcType with
-fresh type variables, splits off the dictionary part, and returns the results.
+@isTauTy@ tests for nested for-alls.
\begin{code}
-tcInstType :: TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType)
-tcInstType ty
- = case splitForAllTys ty of
- ([], _) -> returnNF_Tc ([], [], ty) -- Nothing to do
- (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
- tcSplitRhoTy (substTy tenv rho) `thenNF_Tc` \ (theta, tau) ->
- returnNF_Tc (tyvars', theta, tau)
+isTauTy :: Type -> Bool
+isTauTy (TyVarTy v) = True
+isTauTy (TyConApp _ tys) = all isTauTy tys
+isTauTy (NewTcApp _ tys) = all isTauTy tys
+isTauTy (AppTy a b) = isTauTy a && isTauTy b
+isTauTy (FunTy a b) = isTauTy a && isTauTy b
+isTauTy (PredTy p) = True -- Don't look through source types
+isTauTy (NoteTy _ ty) = isTauTy ty
+isTauTy other = False
\end{code}
+\begin{code}
+getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
+ -- construct a dictionary function name
+getDFunTyKey (TyVarTy tv) = getOccName tv
+getDFunTyKey (TyConApp tc _) = getOccName tc
+getDFunTyKey (NewTcApp tc _) = getOccName tc
+getDFunTyKey (AppTy fun _) = getDFunTyKey fun
+getDFunTyKey (NoteTy _ t) = getDFunTyKey t
+getDFunTyKey (FunTy arg _) = getOccName funTyCon
+getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
+getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty)
+-- PredTy shouldn't happen
+\end{code}
%************************************************************************
%* *
-\subsection{Putting and getting mutable type variables}
+\subsection{Expanding and splitting}
%* *
%************************************************************************
+These tcSplit functions are like their non-Tc analogues, but
+ a) they do not look through newtypes
+ b) they do not look through PredTys
+ c) [future] they ignore usage-type annotations
+
+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}
-tcPutTyVar :: TcTyVar -> TcType -> NF_TcM TcType
-tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType)
+tcSplitForAllTys :: Type -> ([TyVar], Type)
+tcSplitForAllTys ty = split ty ty []
+ where
+ split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
+ split orig_ty (NoteTy n ty) tvs = split orig_ty ty tvs
+ split orig_ty t tvs = (reverse tvs, orig_ty)
+
+tcIsForAllTy (ForAllTy tv ty) = True
+tcIsForAllTy (NoteTy n ty) = tcIsForAllTy ty
+tcIsForAllTy t = False
+
+tcSplitPhiTy :: Type -> ([PredType], Type)
+tcSplitPhiTy ty = split ty ty []
+ where
+ split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
+ Just p -> split res res (p:ts)
+ Nothing -> (reverse ts, orig_ty)
+ split orig_ty (NoteTy n ty) ts = split orig_ty ty ts
+ split orig_ty ty ts = (reverse ts, orig_ty)
+
+tcSplitSigmaTy ty = case tcSplitForAllTys ty of
+ (tvs, rho) -> case tcSplitPhiTy rho of
+ (theta, tau) -> (tvs, theta, tau)
+
+tcTyConAppTyCon :: Type -> TyCon
+tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
+
+tcTyConAppArgs :: Type -> [Type]
+tcTyConAppArgs ty = snd (tcSplitTyConApp 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 (TyConApp tc tys) = Just (tc, tys)
+tcSplitTyConApp_maybe (NewTcApp tc tys) = Just (tc, tys)
+tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
+tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty
+ -- Newtypes are opaque, so they may be split
+ -- However, predicates are not treated
+ -- as tycon applications by the type checker
+tcSplitTyConApp_maybe other = 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 (FunTy arg res) = Just (arg, res)
+tcSplitFunTy_maybe (NoteTy n ty) = tcSplitFunTy_maybe ty
+tcSplitFunTy_maybe other = Nothing
+
+tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
+tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
+
+
+tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
+tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
+tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
+tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty
+tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
+ Just (tys', ty') -> Just (TyConApp tc tys', ty')
+ Nothing -> Nothing
+tcSplitAppTy_maybe (NewTcApp tc tys) = case snocView tys of
+ Just (tys', ty') -> Just (NewTcApp tc tys', ty')
+ Nothing -> Nothing
+tcSplitAppTy_maybe other = Nothing
+
+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 (TyVarTy tv) = Just tv
+tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t
+tcGetTyVar_maybe other = Nothing
+
+tcGetTyVar :: String -> Type -> TyVar
+tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
+
+tcIsTyVarTy :: Type -> Bool
+tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
\end{code}
-Putting is easy:
+The type of a method for class C is always of the form:
+ Forall a1..an. C a1..an => sig_ty
+where sig_ty is the type given by the method's signature, and thus in general
+is a ForallTy. At the point that splitMethodTy is called, it is expected
+that the outer Forall has already been stripped off. splitMethodTy then
+returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes stripped off.
\begin{code}
-tcPutTyVar tyvar ty
- | not (isMutTyVar tyvar)
- = pprTrace "tcPutTyVar" (ppr tyvar) $
- returnNF_Tc ty
-
- | otherwise
- = ASSERT( isMutTyVar tyvar )
- UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty )
- tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_`
- returnNF_Tc ty
+tcSplitMethodTy :: Type -> (PredType, Type)
+tcSplitMethodTy ty = split ty
+ where
+ split (FunTy arg res) = case tcSplitPredTy_maybe arg of
+ Just p -> (p, res)
+ Nothing -> panic "splitMethodTy"
+ split (NoteTy n ty) = split ty
+ split _ = panic "splitMethodTy"
+
+tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
+-- Split the type of a dictionary function
+tcSplitDFunTy ty
+ = case tcSplitSigmaTy ty of { (tvs, theta, tau) ->
+ case tcSplitPredTy_maybe tau of { Just (ClassP clas tys) ->
+ (tvs, theta, clas, tys) }}
\end{code}
-Getting is more interesting. The easy thing to do is just to read, thus:
-\begin{verbatim}
-tcGetTyVar tyvar = tcReadMutTyVar tyvar
-\end{verbatim}
-But it's more fun to short out indirections on the way: If this
-version returns a TyVar, then that TyVar is unbound. If it returns
-any other type, then there might be bound TyVars embedded inside it.
+%************************************************************************
+%* *
+\subsection{Predicate types}
+%* *
+%************************************************************************
+
+\begin{code}
+tcSplitPredTy_maybe :: Type -> Maybe PredType
+ -- Returns Just for predicates only
+tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
+tcSplitPredTy_maybe (PredTy p) = Just p
+tcSplitPredTy_maybe other = Nothing
+
+predTyUnique :: PredType -> Unique
+predTyUnique (IParam n _) = getUnique (ipNameName n)
+predTyUnique (ClassP clas tys) = getUnique clas
+
+mkPredName :: Unique -> SrcLoc -> PredType -> Name
+mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
+mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc
+\end{code}
+
-We return Nothing iff the original box was unbound.
+--------------------- Dictionary types ---------------------------------
\begin{code}
-tcGetTyVar tyvar
- | not (isMutTyVar tyvar)
- = pprTrace "tcGetTyVar" (ppr tyvar) $
- returnNF_Tc (Just (mkTyVarTy tyvar))
+mkClassPred clas tys = ClassP clas tys
- | otherwise
- = ASSERT2( isMutTyVar tyvar, ppr tyvar )
- tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty -> short_out ty `thenNF_Tc` \ ty' ->
- tcWriteMutTyVar tyvar (Just ty') `thenNF_Tc_`
- returnNF_Tc (Just ty')
+isClassPred :: PredType -> Bool
+isClassPred (ClassP clas tys) = True
+isClassPred other = False
- Nothing -> returnNF_Tc Nothing
+isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
+isTyVarClassPred other = False
-short_out :: TcType -> NF_TcM TcType
-short_out ty@(TyVarTy tyvar)
- | not (isMutTyVar tyvar)
- = returnNF_Tc ty
+getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
+getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
+getClassPredTys_maybe _ = Nothing
- | otherwise
- = tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty' -> short_out ty' `thenNF_Tc` \ ty' ->
- tcWriteMutTyVar tyvar (Just ty') `thenNF_Tc_`
- returnNF_Tc ty'
+getClassPredTys :: PredType -> (Class, [Type])
+getClassPredTys (ClassP clas tys) = (clas, tys)
+
+mkDictTy :: Class -> [Type] -> Type
+mkDictTy clas tys = mkPredTy (ClassP clas tys)
- other -> returnNF_Tc ty
+isDictTy :: Type -> Bool
+isDictTy (PredTy p) = isClassPred p
+isDictTy (NoteTy _ ty) = isDictTy ty
+isDictTy other = False
+\end{code}
-short_out other_ty = returnNF_Tc other_ty
+--------------------- Implicit parameters ---------------------------------
+
+\begin{code}
+isIPPred :: PredType -> Bool
+isIPPred (IParam _ _) = True
+isIPPred other = False
+
+isInheritablePred :: PredType -> Bool
+-- Can be inherited by a context. For example, consider
+-- f x = let g y = (?v, y+x)
+-- in (g 3 with ?v = 8,
+-- g 4 with ?v = 9)
+-- The point is that g's type must be quantifed over ?v:
+-- g :: (?v :: a) => a -> a
+-- but it doesn't need to be quantified over the Num a dictionary
+-- which can be free in g's rhs, and shared by both calls to g
+isInheritablePred (ClassP _ _) = True
+isInheritablePred other = False
+
+isLinearPred :: TcPredType -> Bool
+isLinearPred (IParam (Linear n) _) = True
+isLinearPred other = False
\end{code}
%************************************************************************
%* *
-\subsection{Zonking -- the exernal interfaces}
+\subsection{Comparison}
%* *
%************************************************************************
------------------ Type variables
+Comparison, taking note of newtypes, predicates, etc,
\begin{code}
-zonkTcTyVars :: [TcTyVar] -> NF_TcM [TcType]
-zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars
-
-zonkTcTyVarsAndFV :: [TcTyVar] -> NF_TcM TcTyVarSet
-zonkTcTyVarsAndFV tyvars = mapNF_Tc zonkTcTyVar tyvars `thenNF_Tc` \ tys ->
- returnNF_Tc (tyVarsOfTypes tys)
-
-zonkTcTyVar :: TcTyVar -> NF_TcM TcType
-zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar
-
-zonkTcSigTyVars :: [TcTyVar] -> NF_TcM [TcTyVar]
--- This guy is to zonk the tyvars we're about to feed into tcSimplify
--- Usually this job is done by checkSigTyVars, but in a couple of places
--- that is overkill, so we use this simpler chap
-zonkTcSigTyVars tyvars
- = zonkTcTyVars tyvars `thenNF_Tc` \ tys ->
- returnNF_Tc (map (getTyVar "zonkTcSigTyVars") tys)
+tcEqType :: Type -> Type -> Bool
+tcEqType ty1 ty2 = case ty1 `tcCmpType` ty2 of { EQ -> True; other -> False }
+
+tcEqTypes :: [Type] -> [Type] -> Bool
+tcEqTypes ty1 ty2 = case ty1 `tcCmpTypes` ty2 of { EQ -> True; other -> False }
+
+tcEqPred :: PredType -> PredType -> Bool
+tcEqPred p1 p2 = case p1 `tcCmpPred` p2 of { EQ -> True; other -> False }
+
+-------------
+tcCmpType :: Type -> Type -> Ordering
+tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
+
+tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2
+
+tcCmpPred p1 p2 = cmpPredTy emptyVarEnv p1 p2
+-------------
+cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2
+
+-------------
+cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
+ -- The "env" maps type variables in ty1 to type variables in ty2
+ -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
+ -- we in effect substitute tv2 for tv1 in t1 before continuing
+
+ -- Look through NoteTy
+cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
+cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
+
+ -- Deal with equal constructors
+cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
+ Just tv1a -> tv1a `compare` tv2
+ Nothing -> tv1 `compare` tv2
+
+cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2
+cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
+cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
+cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
+cmpTy env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
+cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
+
+ -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < NewTcApp < ForAllTy < PredTy
+cmpTy env (AppTy _ _) (TyVarTy _) = GT
+
+cmpTy env (FunTy _ _) (TyVarTy _) = GT
+cmpTy env (FunTy _ _) (AppTy _ _) = GT
+
+cmpTy env (TyConApp _ _) (TyVarTy _) = GT
+cmpTy env (TyConApp _ _) (AppTy _ _) = GT
+cmpTy env (TyConApp _ _) (FunTy _ _) = GT
+
+cmpTy env (NewTcApp _ _) (TyVarTy _) = GT
+cmpTy env (NewTcApp _ _) (AppTy _ _) = GT
+cmpTy env (NewTcApp _ _) (FunTy _ _) = GT
+cmpTy env (NewTcApp _ _) (TyConApp _ _) = GT
+
+cmpTy env (ForAllTy _ _) (TyVarTy _) = GT
+cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
+cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
+cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
+cmpTy env (ForAllTy _ _) (NewTcApp _ _) = GT
+
+cmpTy env (PredTy _) t2 = GT
+
+cmpTy env _ _ = LT
\end{code}
------------------ Types
+\begin{code}
+cmpPredTy :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
+cmpPredTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
+ -- Compare types as well as names for implicit parameters
+ -- This comparison is used exclusively (I think) for the
+ -- finite map built in TcSimplify
+cmpPredTy env (IParam _ _) (ClassP _ _) = LT
+cmpPredTy env (ClassP _ _) (IParam _ _) = GT
+cmpPredTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
+\end{code}
+
+PredTypes are used as a FM key in TcSimplify,
+so we take the easy path and make them an instance of Ord
\begin{code}
-zonkTcType :: TcType -> NF_TcM TcType
-zonkTcType ty = zonkType (\ tv -> returnNF_Tc (TyVarTy tv)) ty
-
-zonkTcTypes :: [TcType] -> NF_TcM [TcType]
-zonkTcTypes tys = mapNF_Tc zonkTcType tys
-
-zonkTcClassConstraints cts = mapNF_Tc zonk cts
- where zonk (clas, tys)
- = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
- returnNF_Tc (clas, new_tys)
-
-zonkTcThetaType :: TcThetaType -> NF_TcM TcThetaType
-zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta
-
-zonkTcPredType :: TcPredType -> NF_TcM TcPredType
-zonkTcPredType (Class c ts) =
- zonkTcTypes ts `thenNF_Tc` \ new_ts ->
- returnNF_Tc (Class c new_ts)
-zonkTcPredType (IParam n t) =
- zonkTcType t `thenNF_Tc` \ new_t ->
- returnNF_Tc (IParam n new_t)
+instance Eq PredType where { (==) = tcEqPred }
+instance Ord PredType where { compare = tcCmpPred }
\end{code}
-------------------- These ...ToType, ...ToKind versions
- are used at the end of type checking
+
+%************************************************************************
+%* *
+\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}
-zonkKindEnv :: [(Name, TcKind)] -> NF_TcM [(Name, Kind)]
-zonkKindEnv pairs
- = mapNF_Tc zonk_it pairs
- where
- zonk_it (name, tc_kind) = zonkType zonk_unbound_kind_var tc_kind `thenNF_Tc` \ kind ->
- returnNF_Tc (name, kind)
-
- -- When zonking a kind, we want to
- -- zonk a *kind* variable to (Type *)
- -- zonk a *boxity* variable to *
- zonk_unbound_kind_var kv | tyVarKind kv == superKind = tcPutTyVar kv liftedTypeKind
- | tyVarKind kv == superBoxity = tcPutTyVar kv liftedBoxity
- | otherwise = pprPanic "zonkKindEnv" (ppr kv)
-
-zonkTcTypeToType :: TcType -> NF_TcM Type
-zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
- where
- -- Zonk a mutable but unbound type variable to
- -- Void if it has kind Lifted
- -- :Void otherwise
- zonk_unbound_tyvar tv
- | kind == liftedTypeKind
- = tcPutTyVar tv voidTy -- Just to avoid creating a new tycon in
- -- this vastly common case
- | otherwise
- = tcPutTyVar tv (TyConApp (mk_void_tycon tv kind) [])
- where
- kind = tyVarKind tv
-
- mk_void_tycon tv kind -- Make a new TyCon with the same kind as the
- -- type variable tv. Same name too, apart from
- -- making it start with a colon (sigh)
- -- I dread to think what will happen if this gets out into an
- -- interface file. Catastrophe likely. Major sigh.
- = pprTrace "Urk! Inventing strangely-kinded void TyCon" (ppr tc_name) $
- mkPrimTyCon tc_name kind 0 [] VoidRep
- where
- tc_name = mkLocalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
-
--- zonkTcTyVarToTyVar is applied to the *binding* occurrence
--- of a type variable, at the *end* of type checking. It changes
--- the *mutable* type variable into an *immutable* one.
---
--- It does this by making an immutable version of tv and binds tv to it.
--- Now any bound occurences of the original type variable will get
--- zonked to the immutable version.
-
-zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM TyVar
-zonkTcTyVarToTyVar tv
- = let
- -- Make an immutable version, defaulting
- -- the kind to lifted if necessary
- immut_tv = mkTyVar (tyVarName tv) (defaultKind (tyVarKind tv))
- immut_tv_ty = mkTyVarTy immut_tv
-
- zap tv = tcPutTyVar tv immut_tv_ty
- -- Bind the mutable version to the immutable one
- in
- -- If the type variable is mutable, then bind it to immut_tv_ty
- -- so that all other occurrences of the tyvar will get zapped too
- zonkTyVar zap tv `thenNF_Tc` \ ty2 ->
-
- WARN( immut_tv_ty /= ty2, ppr tv $$ ppr immut_tv $$ ppr ty2 )
-
- returnNF_Tc immut_tv
+isSigmaTy :: Type -> Bool
+isSigmaTy (ForAllTy tyvar ty) = True
+isSigmaTy (FunTy a b) = isPredTy a
+isSigmaTy (NoteTy n ty) = isSigmaTy ty
+isSigmaTy _ = False
+
+isOverloadedTy :: Type -> Bool
+isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
+isOverloadedTy (FunTy a b) = isPredTy a
+isOverloadedTy (NoteTy n ty) = isOverloadedTy ty
+isOverloadedTy _ = False
+
+isPredTy :: Type -> Bool -- Belongs in TcType because it does
+ -- not look through newtypes, or predtypes (of course)
+isPredTy (NoteTy _ ty) = isPredTy ty
+isPredTy (PredTy sty) = True
+isPredTy _ = False
+\end{code}
+
+\begin{code}
+isFloatTy = is_tc floatTyConKey
+isDoubleTy = is_tc doubleTyConKey
+isIntegerTy = is_tc integerTyConKey
+isIntTy = is_tc intTyConKey
+isAddrTy = is_tc addrTyConKey
+isBoolTy = is_tc boolTyConKey
+isUnitTy = is_tc unitTyConKey
+
+is_tc :: Unique -> Type -> Bool
+-- Newtypes are opaque to this
+is_tc uniq ty = case tcSplitTyConApp_maybe ty of
+ Just (tc, _) -> uniq == getUnique tc
+ Nothing -> False
\end{code}
%************************************************************************
%* *
-\subsection{Zonking -- the main work-horses: zonkType, zonkTyVar}
+\subsection{Misc}
+%* *
+%************************************************************************
+
+\begin{code}
+deNoteType :: Type -> Type
+ -- Remove synonyms, but not predicate types
+deNoteType ty@(TyVarTy tyvar) = ty
+deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
+deNoteType (NewTcApp tycon tys) = NewTcApp tycon (map deNoteType tys)
+deNoteType (PredTy p) = PredTy (deNotePredType p)
+deNoteType (NoteTy _ ty) = deNoteType ty
+deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
+deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
+deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
+
+deNotePredType :: PredType -> PredType
+deNotePredType (ClassP c tys) = ClassP c (map deNoteType tys)
+deNotePredType (IParam n ty) = IParam n (deNoteType ty)
+\end{code}
+
+Find the free tycons and classes of a type. This is used in the front
+end of the compiler.
+
+\begin{code}
+tyClsNamesOfType :: Type -> NameSet
+tyClsNamesOfType (TyVarTy tv) = emptyNameSet
+tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (NewTcApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
+tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2
+tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty
+tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
+tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
+tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty
+
+tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
+
+tyClsNamesOfDFunHead :: Type -> NameSet
+-- Find the free type constructors and classes
+-- of the head of the dfun instance type
+-- The 'dfun_head_type' is because of
+-- instance Foo a => Baz T where ...
+-- The decl is an orphan if Baz and T are both not locally defined,
+-- even if Foo *is* locally defined
+tyClsNamesOfDFunHead dfun_ty
+ = case tcSplitSigmaTy dfun_ty of
+ (tvs,_,head_ty) -> tyClsNamesOfType head_ty
+
+classesOfTheta :: ThetaType -> [Class]
+-- Looks just for ClassP things; maybe it should check
+classesOfTheta preds = [ c | ClassP c _ <- preds ]
+\end{code}
+
+
+%************************************************************************
%* *
-%* For internal use only! *
+\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}
--- zonkType is used for Kinds as well
-
--- For unbound, mutable tyvars, zonkType uses the function given to it
--- For tyvars bound at a for-all, zonkType zonks them to an immutable
--- type variable and zonks the kind too
-
-zonkType :: (TcTyVar -> NF_TcM Type) -- What to do with unbound mutable type variables
- -- see zonkTcType, and zonkTcTypeToType
- -> TcType
- -> NF_TcM Type
-zonkType unbound_var_fn ty
- = go ty
- where
- go (TyConApp tycon tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
- returnNF_Tc (TyConApp tycon tys')
-
- go (NoteTy (SynNote ty1) ty2) = go ty1 `thenNF_Tc` \ ty1' ->
- go ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (NoteTy (SynNote ty1') ty2')
-
- go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations
-
- go (PredTy p) = go_pred p `thenNF_Tc` \ p' ->
- returnNF_Tc (PredTy p')
-
- go (FunTy arg res) = go arg `thenNF_Tc` \ arg' ->
- go res `thenNF_Tc` \ res' ->
- returnNF_Tc (FunTy arg' res')
-
- go (AppTy fun arg) = go fun `thenNF_Tc` \ fun' ->
- go arg `thenNF_Tc` \ arg' ->
- returnNF_Tc (mkAppTy fun' arg')
-
- go (UsageTy u ty) = go u `thenNF_Tc` \ u' ->
- go ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (mkUTy u' ty')
-
- -- The two interesting cases!
- go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar
-
- go (ForAllTy tyvar ty) = zonkTcTyVarToTyVar tyvar `thenNF_Tc` \ tyvar' ->
- go ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (ForAllTy tyvar' ty')
-
- go_pred (Class c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
- returnNF_Tc (Class c tys')
- go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (IParam n ty')
-
-zonkTyVar :: (TcTyVar -> NF_TcM Type) -- What to do for an unbound mutable variable
- -> TcTyVar -> NF_TcM TcType
-zonkTyVar unbound_var_fn tyvar
- | not (isMutTyVar tyvar) -- Not a mutable tyvar. This can happen when
- -- zonking a forall type, when the bound type variable
- -- needn't be mutable
- = ASSERT( isTyVar tyvar ) -- Should not be any immutable kind vars
- returnNF_Tc (TyVarTy tyvar)
+isFFITy :: Type -> Bool
+-- True for any TyCon that can possibly be an arg or result of an FFI call
+isFFITy ty = checkRepTyCon legalFFITyCon ty
+
+isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
+-- Checks for valid argument type for a 'foreign import'
+isFFIArgumentTy dflags safety ty
+ = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
+
+isFFIExternalTy :: Type -> Bool
+-- Types that are allowed as arguments of a 'foreign export'
+isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
+
+isFFIImportResultTy :: DynFlags -> Type -> Bool
+isFFIImportResultTy dflags ty
+ = checkRepTyCon (legalFIResultTyCon dflags) ty
+
+isFFIExportResultTy :: Type -> Bool
+isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
+
+isFFIDynArgumentTy :: Type -> Bool
+-- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
+-- or a newtype of either.
+isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
+
+isFFIDynResultTy :: Type -> Bool
+-- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
+-- or a newtype of either.
+isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
+
+isFFILabelTy :: Type -> Bool
+-- The type of a foreign label must be Ptr, FunPtr, Addr,
+-- or a newtype of either.
+isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
+
+isFFIDotnetTy :: DynFlags -> Type -> Bool
+isFFIDotnetTy dflags ty
+ = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
+ (legalFIResultTyCon dflags tc ||
+ isFFIDotnetObjTy ty || isStringTy ty)) ty
+
+-- Support String as an argument or result from a .NET FFI call.
+isStringTy ty =
+ case tcSplitTyConApp_maybe (repType ty) of
+ Just (tc, [arg_ty])
+ | tc == listTyCon ->
+ case tcSplitTyConApp_maybe (repType arg_ty) of
+ Just (cc,[]) -> cc == charTyCon
+ _ -> False
+ _ -> False
+
+-- Support String as an argument or result from a .NET FFI call.
+isFFIDotnetObjTy ty =
+ let
+ (_, t_ty) = tcSplitForAllTys ty
+ in
+ case tcSplitTyConApp_maybe (repType t_ty) of
+ Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
+ _ -> False
+
+toDNType :: Type -> DNType
+toDNType ty
+ | isStringTy ty = DNString
+ | isFFIDotnetObjTy ty = DNObject
+ | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
+ case lookup (getUnique tc) dn_assoc of
+ Just x -> x
+ Nothing
+ | tc `hasKey` ioTyConKey -> toDNType (head argTys)
+ | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
+ where
+ dn_assoc :: [ (Unique, DNType) ]
+ dn_assoc = [ (unitTyConKey, DNUnit)
+ , (intTyConKey, DNInt)
+ , (int8TyConKey, DNInt8)
+ , (int16TyConKey, DNInt16)
+ , (int32TyConKey, DNInt32)
+ , (int64TyConKey, DNInt64)
+ , (wordTyConKey, DNInt)
+ , (word8TyConKey, DNWord8)
+ , (word16TyConKey, DNWord16)
+ , (word32TyConKey, DNWord32)
+ , (word64TyConKey, DNWord64)
+ , (floatTyConKey, DNFloat)
+ , (doubleTyConKey, DNDouble)
+ , (addrTyConKey, DNPtr)
+ , (ptrTyConKey, DNPtr)
+ , (funPtrTyConKey, DNPtr)
+ , (charTyConKey, DNChar)
+ , (boolTyConKey, DNBool)
+ ]
+
+checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
+ -- Look through newtypes
+ -- Non-recursive ones are transparent to splitTyConApp,
+ -- but recursive ones aren't. Manuel had:
+ -- newtype T = MkT (Ptr T)
+ -- and wanted it to work...
+checkRepTyCon check_tc ty
+ | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
+ | otherwise = False
+
+checkRepTyConKey :: [Unique] -> Type -> Bool
+-- Like checkRepTyCon, but just looks at the TyCon key
+checkRepTyConKey keys
+ = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
+\end{code}
+
+----------------------------------------------
+These chaps do the work; they are not exported
+----------------------------------------------
+\begin{code}
+legalFEArgTyCon :: TyCon -> Bool
+-- It's illegal to return foreign objects and (mutable)
+-- bytearrays from a _ccall_ / foreign declaration
+-- (or be passed them as arguments in foreign exported functions).
+legalFEArgTyCon tc
+ | isByteArrayLikeTyCon tc
+ = False
+ -- It's also illegal to make foreign exports that take unboxed
+ -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
| otherwise
- = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Nothing -> unbound_var_fn tyvar -- Mutable and unbound
- Just other_ty -> zonkType unbound_var_fn other_ty -- Bound
+ = boxedMarshalableTyCon tc
+
+legalFIResultTyCon :: DynFlags -> TyCon -> Bool
+legalFIResultTyCon dflags tc
+ | isByteArrayLikeTyCon tc = False
+ | tc == unitTyCon = True
+ | otherwise = marshalableTyCon dflags tc
+
+legalFEResultTyCon :: TyCon -> Bool
+legalFEResultTyCon tc
+ | isByteArrayLikeTyCon tc = False
+ | tc == unitTyCon = True
+ | otherwise = boxedMarshalableTyCon tc
+
+legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
+-- Checks validity of types going from Haskell -> external world
+legalOutgoingTyCon dflags safety tc
+ | playSafe safety && isByteArrayLikeTyCon tc
+ = False
+ | otherwise
+ = marshalableTyCon dflags tc
+
+legalFFITyCon :: TyCon -> Bool
+-- True for any TyCon that can possibly be an arg or result of an FFI call
+legalFFITyCon tc
+ = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
+
+marshalableTyCon dflags tc
+ = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
+ || boxedMarshalableTyCon tc
+
+boxedMarshalableTyCon tc
+ = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
+ , int32TyConKey, int64TyConKey
+ , wordTyConKey, word8TyConKey, word16TyConKey
+ , word32TyConKey, word64TyConKey
+ , floatTyConKey, doubleTyConKey
+ , addrTyConKey, ptrTyConKey, funPtrTyConKey
+ , charTyConKey
+ , stablePtrTyConKey
+ , byteArrayTyConKey, mutableByteArrayTyConKey
+ , boolTyConKey
+ ]
+
+isByteArrayLikeTyCon :: TyCon -> Bool
+isByteArrayLikeTyCon tc =
+ getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
\end{code}
+