#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 ( tcLookupClassByKey, newLocalId, tcLookupGlobalValue )
-import TcType ( tcInstTcType, tcInstSigType, tcSplitRhoTy, zonkTcTypeToType )
-import TcMonoType ( tcHsType )
-import TcHsSyn ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl, TcIdOcc(..),
+import TcEnv ( newLocalId )
+import TcType ( typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
+import TcMonoType ( tcHsTopBoxedType )
+import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
TcForeignExportDecl )
import TcExpr ( tcId, tcPolyExpr )
import Inst ( emptyLIE, LIE, plusLIE )
import CoreSyn
import ErrUtils ( Message )
-import Id ( Id, idName )
+import Id ( Id, idName, mkVanillaId )
import Name ( nameOccName )
-import MkId ( mkUserId )
-import Type ( isUnpointedType
- , splitFunTys
+import Type ( splitFunTys
, splitTyConApp_maybe
, splitForAllTys
, splitRhoTy
, isForAllTy
, mkForAllTys
)
-import TyVar ( emptyTyVarEnv )
-
-
+import PprType ( {- instance Outputable Type -} )
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
isFFIExternalTy, isAddrTy
)
import Type ( Type )
import Unique
-import Unify ( unifyTauTy )
import Outputable
import Util
import CmdLineOpts ( opt_GlasgowExts )
tcForeignImports decls =
mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
-tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE s, TcMonoBinds s, [TcForeignExportDecl s])
+tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE, TcMonoBinds, [TcForeignExportDecl])
tcForeignExports decls =
foldlTc combine (emptyLIE, EmptyMonoBinds, [])
[ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
-- exports a binding
isForeignExport :: ForeignDecl name -> Bool
-isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamic ext_nm)
+isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamicExtName ext_nm)
isForeignExport _ = False
\end{code}
tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsType hs_ty `thenTc` \ sig_ty ->
+ tcHsTopBoxedType hs_ty `thenTc` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
case splitFunTys t_ty of
(arg_tys, res_ty) ->
checkForeignExport True t_ty arg_tys res_ty `thenTc_`
- let i = (mkUserId nm sig_ty) in
+ let i = (mkVanillaId nm sig_ty) in
returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsType hs_ty `thenTc` \ sig_ty ->
+ tcHsTopBoxedType hs_ty `thenTc` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
(_, t_ty) = splitForAllTys sig_ty
in
check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
- let i = (mkUserId nm sig_ty) in
+ let i = (mkVanillaId nm sig_ty) in
returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
-tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
+tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsType hs_ty `thenTc` \ ty ->
+ tcHsTopBoxedType hs_ty `thenTc` \ ty ->
-- Check that the type has the right shape
-- and that the argument and result types are acceptable.
let
in
case splitFunTys t_ty of
(arg_tys, res_ty) ->
- 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 s, TcMonoBinds s, TcForeignExportDecl s)
+tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl)
tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsType hs_ty `thenTc` \ sig_ty ->
- tcInstSigType sig_ty `thenNF_Tc` \ sig_tc_ty ->
- tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) ->
+ tcHsTopBoxedType hs_ty `thenTc` \ sig_ty ->
+ let sig_tc_ty = typeToTcType sig_ty in
+ tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) ->
let
-- drop the foralls before inspecting the structure
-- than its declared/inferred type. Hence the need
-- to create a local binding which will call the exported function
-- at a particular type (and, maybe, overloading).
- newLocalId (nameOccName nm) sig_tc_ty `thenNF_Tc` \ i ->
+ newLocalId (nameOccName nm) sig_tc_ty src_loc `thenNF_Tc` \ i ->
let
- i2 = TcId i
- bind = VarMonoBind i2 rhs
+ bind = VarMonoBind i rhs
in
- returnTc (lie, bind, ForeignDecl i2 imp_exp undefined ext_nm cconv src_loc)
+ returnTc (lie, bind, ForeignDecl i imp_exp undefined ext_nm cconv src_loc)
-- ^^^^^^^^^
-- ToDo: fill the type field in with something sensible.
\begin{code}
-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_`
- mapTc (checkForeignArg isFFIArgumentTy) xs `thenTc_`
- checkForeignRes (isFFIResultTy) res
+ mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs `thenTc_`
+ checkForeignRes True {-NonIO ok-} isFFIResultTy res
| otherwise =
- 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
- -- * result type is an Addr
+ -- and it must return IO t
+ -- * result type is an Addr or IO Addr
case args of
[arg] ->
case splitFunTys arg of
(arg_tys, res_ty) ->
- 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_`
- checkForeignRes (isFFIResultTy) res
+ checkForeignRes True {-NonIO ok-} isFFIResultTy res
-check :: Bool -> Message -> TcM s ()
-check True _ = returnTc ()
-check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
-
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) and that t satisfies the given predicate.
+-- (IO t) or (t) , and that t satisfies the given predicate.
--
-checkForeignRes :: (Type -> Bool) -> Type -> TcM s ()
-checkForeignRes pred_res_ty ty =
+checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM s ()
+checkForeignRes non_io_result_ok pred_res_ty ty =
case (splitTyConApp_maybe ty) of
Just (io, [res_ty])
- | (uniqueOf io) == ioTyConKey &&
- pred_res_ty res_ty
+ | (getUnique io) == ioTyConKey && pred_res_ty res_ty
-> returnTc ()
- _ -> check False (illegalForeignTyErr False{-Res-} ty)
-
+ _
+ -> check (non_io_result_ok && pred_res_ty ty)
+ (illegalForeignTyErr False{-Res-} ty)
\end{code}
Warnings
\begin{code}
+check :: Bool -> Message -> TcM s ()
+check True _ = returnTc ()
+check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
+
illegalForeignTyErr isArg ty
- = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration")])
- 4 (hsep [ ptext SLIT("type:"), ppr ty])
+ = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
+ 4 (hsep [ppr ty])
where
arg_or_res
| isArg = ptext SLIT("argument")
| otherwise = ptext SLIT("result")
foreignDeclCtxt fo =
- hang (ptext SLIT("When checking a foreign declaration:"))
+ hang (ptext SLIT("When checking declaration:"))
4 (ppr fo)
-
\end{code}
projects / ghc-hetmet.git / blobdiff