import TcMonad
import TcEnv ( newLocalId )
-import TcMonoType ( tcHsBoxedSigType )
+import TcMonoType ( tcHsLiftedSigType )
import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
TcForeignExportDecl )
import TcExpr ( tcPolyExpr )
import Inst ( emptyLIE, LIE, plusLIE )
import ErrUtils ( Message )
-import Id ( Id, mkVanillaId )
+import Id ( Id, mkLocalId )
import Name ( nameOccName )
import Type ( splitFunTys
, splitTyConApp_maybe
, splitForAllTys
)
-import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
+import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy,
+ isFFIExportResultTy,
isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
isFFILabelTy
)
tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsBoxedSigType hs_ty `thenTc` \ sig_ty ->
+ tcHsLiftedSigType 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 = (mkVanillaId nm sig_ty) in
+ let i = (mkLocalId 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) $
- tcHsBoxedSigType hs_ty `thenTc` \ sig_ty ->
+ tcHsLiftedSigType hs_ty `thenTc` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
in
check (isFFILabelTy t_ty)
(illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
- let i = (mkVanillaId nm sig_ty) in
+ let i = (mkLocalId nm sig_ty) in
returnTc (i, (ForeignDecl i FoLabel undefined 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) $
- tcHsBoxedSigType hs_ty `thenTc` \ ty ->
+ tcHsLiftedSigType hs_ty `thenTc` \ ty ->
-- Check that the type has the right shape
-- and that the argument and result types are acceptable.
let
case splitFunTys t_ty of
(arg_tys, res_ty) ->
checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_`
- let i = (mkVanillaId nm ty) in
+ let i = (mkLocalId nm ty) in
returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsBoxedSigType hs_ty `thenTc` \ sig_ty ->
+ tcHsLiftedSigType hs_ty `thenTc` \ sig_ty ->
tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) ->
let
case args of
[] -> check False (illegalForeignTyErr True{-Arg-} ty)
(x:xs) ->
+ getDOptsTc `thenTc` \ dflags ->
check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
- mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs `thenTc_`
- checkForeignRes True {-NonIO ok-} isFFIResultTy res
+ mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) xs `thenTc_`
+ checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
| otherwise =
- mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args `thenTc_`
- checkForeignRes True {-NonIO ok-} isFFIResultTy res
+ getDOptsTc `thenTc` \ dflags ->
+ mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) args `thenTc_`
+ checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM ()
checkForeignExport is_dynamic ty args res
case splitFunTys arg of
(arg_tys, res_ty) ->
mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
- checkForeignRes True {-NonIO ok-} isFFIResultTy res_ty `thenTc_`
+ checkForeignRes True {-NonIO ok-} isFFIExportResultTy res_ty
+ `thenTc_`
checkForeignRes False {-Must be IO-} isFFIDynResultTy res
_ -> check False (illegalForeignTyErr True{-Arg-} ty)
| otherwise =
mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
- checkForeignRes True {-NonIO ok-} isFFIResultTy res
+ checkForeignRes True {-NonIO ok-} isFFIExportResultTy res
checkForeignArg :: (Type -> Bool) -> Type -> TcM ()
checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)