\begin{code}
module TcType (
--------------------------------
+ -- TyThing
+ TyThing(..), -- instance NamedThing
+
+ --------------------------------
-- Types
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcKind,
--------------------------------
-- TyVarDetails
- TyVarDetails(..), isUserTyVar, isSkolemTyVar, isHoleTyVar,
+ TyVarDetails(..), isUserTyVar, isSkolemTyVar,
tyVarBindingInfo,
--------------------------------
isFFIDynArgumentTy, -- :: Type -> Bool
isFFIDynResultTy, -- :: Type -> Bool
isFFILabelTy, -- :: Type -> Bool
+ isFFIDotnetTy, -- :: DynFlags -> Type -> Bool
+ isFFIDotnetObjTy, -- :: Type -> Bool
+
+ toDNType, -- :: Type -> DNType
---------------------------------
-- Unifier and matcher
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
mkPredTys, isUnLiftedType,
isUnboxedTupleType, isPrimitiveType,
- splitNewType_maybe, splitTyConApp_maybe,
+ splitTyConApp_maybe,
tidyTopType, tidyType, tidyPred, tidyTypes,
tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar,
hasMoreBoxityInfo, liftedBoxity,
superBoxity, typeKind, superKind, repType
)
+import DataCon ( DataCon )
import TyCon ( TyCon, isUnLiftedTyCon )
import Class ( classHasFDs, Class )
-import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails )
-import ForeignCall ( Safety, playSafe )
+import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails )
+import ForeignCall ( Safety, playSafe
+ , DNType(..)
+ )
import VarEnv
import VarSet
import OccName ( OccName, mkDictOcc )
import NameSet
import PrelNames -- Lots (e.g. in isFFIArgumentTy)
-import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon )
+import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon,
+ charTyCon, listTyCon )
import BasicTypes ( IPName(..), ipNameName )
import Unique ( Unique, Uniquable(..) )
import SrcLoc ( SrcLoc )
%************************************************************************
%* *
+ TyThing
+%* *
+%************************************************************************
+
+\begin{code}
+data TyThing = AnId Id
+ | ADataCon DataCon
+ | ATyCon TyCon
+ | AClass Class
+
+instance NamedThing TyThing where
+ getName (AnId id) = getName id
+ getName (ATyCon tc) = getName tc
+ getName (AClass cl) = getName cl
+ getName (ADataCon dc) = getName dc
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Types}
%* *
%************************************************************************
\begin{code}
data TyVarDetails
- = HoleTv -- Used *only* by the type checker when passing in a type
- -- variable that should be side-effected to the result type.
- -- Always has kind openTypeKind.
- -- Never appears in types
-
- | SigTv -- Introduced when instantiating a type signature,
+ = SigTv -- Introduced when instantiating a type signature,
-- prior to checking that the defn of a fn does
-- have the expected type. Should not be instantiated.
--
InstTv -> True
oteher -> False
-isHoleTyVar :: TcTyVar -> Bool
--- NB: the hole might be filled in by now, and this
--- function does not check for that
-isHoleTyVar tv = ASSERT( isMutTyVar tv )
- case mutTyVarDetails tv of
- HoleTv -> True
- other -> False
-
tyVarBindingInfo :: TyVar -> SDoc -- Used in checkSigTyVars
tyVarBindingInfo tv
| isMutTyVar tv
details ClsTv = ptext SLIT("class declaration")
details InstTv = ptext SLIT("instance declaration")
details PatSigTv = ptext SLIT("pattern type signature")
- details HoleTv = ptext SLIT("//hole//") -- Should not happen
details VanillaTv = ptext SLIT("//vanilla//") -- Ditto
\end{code}
-- or a newtype of either.
isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
+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; hence the splitNewType_maybe
+ -- but recursive ones aren't
checkRepTyCon check_tc ty
| Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
| otherwise = False
-- bytearrays from a _ccall_ / foreign declaration
-- (or be passed them as arguments in foreign exported functions).
legalFEArgTyCon tc
- | getUnique tc `elem` [ byteArrayTyConKey, mutableByteArrayTyConKey ]
+ | 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
legalFIResultTyCon :: DynFlags -> TyCon -> Bool
legalFIResultTyCon dflags tc
- | getUnique tc `elem`
- [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False
- | tc == unitTyCon = True
- | otherwise = marshalableTyCon dflags tc
+ | isByteArrayLikeTyCon tc = False
+ | tc == unitTyCon = True
+ | otherwise = marshalableTyCon dflags tc
legalFEResultTyCon :: TyCon -> Bool
legalFEResultTyCon tc
- | getUnique tc `elem`
- [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False
- | tc == unitTyCon = True
- | otherwise = boxedMarshalableTyCon 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 && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
+ | playSafe safety && isByteArrayLikeTyCon tc
= False
| otherwise
= marshalableTyCon dflags tc
, byteArrayTyConKey, mutableByteArrayTyConKey
, boolTyConKey
]
+
+isByteArrayLikeTyCon :: TyCon -> Bool
+isByteArrayLikeTyCon tc =
+ getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
\end{code}
projects / ghc-hetmet.git / blobdiff