#include "HsVersions.h"
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
#include "HsVersions.h"
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
- ExtName(..), isDynamic, MonoBinds(..),
+ ExtName(Dynamic), isDynamicExtName, MonoBinds(..),
OutPat(..), ForKind(..)
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
import TcMonad
import TcEnv ( newLocalId )
OutPat(..), ForKind(..)
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
import TcMonad
import TcEnv ( newLocalId )
-import TcType ( tcInstTcType, typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
+import TcType ( typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
import TcMonoType ( tcHsTopBoxedType )
import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
TcForeignExportDecl )
import TcMonoType ( tcHsTopBoxedType )
import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
TcForeignExportDecl )
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
isFFIExternalTy, isAddrTy
)
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
isFFIExternalTy, isAddrTy
)
returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
(_, t_ty) = splitForAllTys sig_ty
in
check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
(_, t_ty) = splitForAllTys sig_ty
in
check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
- checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_`
- let i = (mkUserId nm ty) in
+ checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_`
+ let i = (mkVanillaId nm ty) in
returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl)
returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl)
-checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s ()
-checkForeignImport is_dynamic ty args res
+checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM s ()
+checkForeignImport is_dynamic is_safe ty args res
| is_dynamic =
-- * first arg has got to be an Addr
case args of
[] -> check False (illegalForeignTyErr True{-Arg-} ty)
(x:xs) ->
check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
| is_dynamic =
-- * first arg has got to be an Addr
case args of
[] -> check False (illegalForeignTyErr True{-Arg-} ty)
(x:xs) ->
check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
- mapTc (checkForeignArg isFFIArgumentTy) xs `thenTc_`
- checkForeignRes (isFFIResultTy) res
+ mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs `thenTc_`
+ checkForeignRes True {-NonIO ok-} isFFIResultTy res
- mapTc (checkForeignArg isFFIArgumentTy) args `thenTc_`
- checkForeignRes (isFFIResultTy) res
+ mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args `thenTc_`
+ checkForeignRes True {-NonIO ok-} isFFIResultTy res
checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()
checkForeignExport is_dynamic ty args res
| is_dynamic =
-- * the first (and only!) arg has got to be a function type
checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()
checkForeignExport is_dynamic ty args res
| is_dynamic =
-- * the first (and only!) arg has got to be a function type
- mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
- checkForeignRes (isFFIResultTy) res_ty `thenTc_`
- checkForeignRes (isAddrTy) res
+ mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
+ checkForeignRes True {-NonIO ok-} isFFIResultTy res_ty `thenTc_`
+ checkForeignRes False {-Must be IO-} isAddrTy res
_ -> check False (illegalForeignTyErr True{-Arg-} ty)
| otherwise =
mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
_ -> check False (illegalForeignTyErr True{-Arg-} ty)
| otherwise =
mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
checkForeignArg :: (Type -> Bool) -> Type -> TcM s ()
checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
checkForeignArg :: (Type -> Bool) -> Type -> TcM s ()
checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
illegalForeignTyErr isArg ty
= hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
4 (hsep [ppr ty])
illegalForeignTyErr isArg ty
= hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
4 (hsep [ppr ty])