module TcForeign
( tcForeignImports
, tcForeignExports
, isForeignImport, isForeignExport
, tcFImport, tcFExport
, tcForeignImports'
, tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
, normaliseFfiType
, nonIOok, mustBeIO
, checkSafe, noCheckSafe
, tcForeignExports'
, tcCheckFEType
) where
#include "HsVersions.h"
import HsSyn
import TcRnMonad
import TcHsType
import TcExpr
import TcEnv
import FamInst
import FamInstEnv
import Coercion
import Type
import TypeRep
import ForeignCall
import ErrUtils
import Id
import Name
import RdrName
import DataCon
import TyCon
import TcType
import PrelNames
import DynFlags
import Outputable
import Platform
import SrcLoc
import Bag
import FastString
import Hooks
import Control.Monad
isForeignImport :: LForeignDecl name -> Bool
isForeignImport (L _ (ForeignImport _ _ _ _)) = True
isForeignImport _ = False
isForeignExport :: LForeignDecl name -> Bool
isForeignExport (L _ (ForeignExport _ _ _ _)) = True
isForeignExport _ = False
normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType ty
= do fam_envs <- tcGetFamInstEnvs
normaliseFfiType' fam_envs ty
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType' env ty0 = go initRecTc ty0
where
go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go rec_nts ty | Just ty' <- coreView ty
= go rec_nts ty'
go rec_nts ty@(TyConApp tc tys)
| tc_key `elem` [ioTyConKey, funPtrTyConKey]
= children_only
| isNewTyCon tc
, Just rec_nts' <- checkRecTc rec_nts tc
= do { rdr_env <- getGlobalRdrEnv
; case checkNewtypeFFI rdr_env tc of
Nothing -> nothing
Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs
; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }
| isFamilyTyCon tc
, (co, ty) <- normaliseTcApp env Representational tc tys
, not (isReflCo co)
= do (co', ty', gres) <- go rec_nts ty
return (mkTransCo co co', ty', gres)
| otherwise
= nothing
where
tc_key = getUnique tc
children_only
= do xs <- mapM (go rec_nts) tys
let (cos, tys', gres) = unzip3 xs
cos' = zipWith3 downgradeRole (tyConRoles tc)
(repeat Representational) cos
return ( mkTyConAppCo Representational tc cos'
, mkTyConApp tc tys', unionManyBags gres)
nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys
nt_rhs = newTyConInstRhs tc tys
nothing = return (Refl Representational ty, ty, emptyBag)
go rec_nts (FunTy ty1 ty2)
= do (coi1,nty1,gres1) <- go rec_nts ty1
(coi2,nty2,gres2) <- go rec_nts ty2
return (mkFunCo Representational coi1 coi2, mkFunTy nty1 nty2, gres1 `unionBags` gres2)
go rec_nts (ForAllTy tyvar ty1)
= do (coi,nty1,gres1) <- go rec_nts ty1
return (mkForAllCo tyvar coi, ForAllTy tyvar nty1, gres1)
go _ ty@(TyVarTy {}) = return (Refl Representational ty, ty, emptyBag)
go _ ty@(LitTy {}) = return (Refl Representational ty, ty, emptyBag)
go _ ty@(AppTy {}) = return (Refl Representational ty, ty, emptyBag)
checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI rdr_env tc
| Just con <- tyConSingleDataCon_maybe tc
, [gre] <- lookupGRE_Name rdr_env (dataConName con)
= Just gre
| otherwise
= Nothing
tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)
tcForeignImports decls
= getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)
tcForeignImports' :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)
tcForeignImports' decls
= do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $
filter isForeignImport decls
; return (ids, decls, unionManyBags gres) }
tcFImport :: LForeignDecl Name -> TcM (Id, LForeignDecl Id, Bag GlobalRdrElt)
tcFImport (L dloc fo@(ForeignImport (L nloc nm) hs_ty _ imp_decl))
= setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $
do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
; let
(_, t_ty) = tcSplitForAllTys norm_sig_ty
(arg_tys, res_ty) = tcSplitFunTys t_ty
id = mkLocalId nm sig_ty
; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
; let fi_decl = ForeignImport (L nloc id) undefined (mkSymCo norm_co) imp_decl'
; return (id, L dloc fi_decl, gres) }
tcFImport d = pprPanic "tcFImport" (ppr d)
tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)
= do checkCg checkCOrAsmOrLlvmOrInterp
check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
cconv' <- checkCConv cconv
return (CImport (L lc cconv') safety mh l src)
tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do
checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv
case arg_tys of
[arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty
checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
where
(arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
_ -> addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "One argument expected")))
return (CImport (L lc cconv') safety mh CWrapper src)
tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
(CFunction target) src)
| isDynamicTarget target = do
checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv
case arg_tys of
[] ->
addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "At least one argument expected")))
(arg1_ty:arg_tys) -> do
dflags <- getDynFlags
let curried_res_ty = foldr FunTy res_ty arg_tys
check (isFFIDynTy curried_res_ty arg1_ty)
(illegalForeignTyErr argument)
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
| cconv == PrimCallConv = do
dflags <- getDynFlags
checkTc (xopt Opt_GHCForeignImportPrim dflags)
(text "Use GHCForeignImportPrim to allow `foreign import prim'.")
checkCg checkCOrAsmOrLlvmOrInterp
checkCTarget target
checkTc (playSafe safety)
(text "The safe/unsafe annotation should not be used with `foreign import prim'.")
checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
return idecl
| otherwise = do
checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv
checkCTarget target
dflags <- getDynFlags
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
checkMissingAmpersand dflags arg_tys res_ty
case target of
StaticTarget _ _ False
| not (null arg_tys) ->
addErrTc (text "`value' imports cannot have function types")
_ -> return ()
return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
checkCTarget :: CCallTarget -> TcM ()
checkCTarget (StaticTarget str _ _) = do
checkCg checkCOrAsmOrLlvmOrInterp
checkTc (isCLabelString str) (badCName str)
checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
checkMissingAmpersand dflags arg_tys res_ty
| null arg_tys && isFunPtrTy res_ty &&
wopt Opt_WarnDodgyForeignImports dflags
= addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
| otherwise
= return ()
tcForeignExports :: [LForeignDecl Name]
-> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)
tcForeignExports decls =
getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls)
tcForeignExports' :: [LForeignDecl Name]
-> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)
tcForeignExports' decls
= foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
where
combine (binds, fs, gres1) (L loc fe) = do
(b, f, gres2) <- setSrcSpan loc (tcFExport fe)
return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id, Bag GlobalRdrElt)
tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec)
= addErrCtxt (foreignDeclCtxt fo) $ do
sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
rhs <- tcPolyExpr (nlHsVar nm) sig_ty
(norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
spec' <- tcCheckFEType norm_sig_ty spec
id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec', gres)
tcFExport d = pprPanic "tcFExport" (ppr d)
tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
tcCheckFEType sig_ty (CExport (L l (CExportStatic str cconv)) src) = do
checkCg checkCOrAsmOrLlvm
checkTc (isCLabelString str) (badCName str)
cconv' <- checkCConv cconv
checkForeignArgs isFFIExternalTy arg_tys
checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
return (CExport (L l (CExportStatic str cconv')) src)
where
(_, t_ty) = tcSplitForAllTys sig_ty
(arg_tys, res_ty) = tcSplitFunTys t_ty
checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM ()
checkForeignArgs pred tys = mapM_ go tys
where
go ty = check (pred ty) (illegalForeignTyErr argument)
checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes non_io_result_ok check_safe pred_res_ty ty
| Just (_, res_ty) <- tcSplitIOType_maybe ty
=
check (pred_res_ty res_ty) (illegalForeignTyErr result)
| not non_io_result_ok
= addErrTc $ illegalForeignTyErr result (ptext (sLit "IO result type expected"))
| otherwise
= do { dflags <- getDynFlags
; case pred_res_ty ty of
NotValid msg -> addErrTc $ illegalForeignTyErr result msg
_ | check_safe && safeInferOn dflags
-> recordUnsafeInfer
_ | check_safe && safeLanguageOn dflags
-> addErrTc (illegalForeignTyErr result safeHsErr)
_ -> return () }
where
safeHsErr = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad"
nonIOok, mustBeIO :: Bool
nonIOok = True
mustBeIO = False
checkSafe, noCheckSafe :: Bool
checkSafe = True
noCheckSafe = False
checkCOrAsmOrLlvm :: HscTarget -> Validity
checkCOrAsmOrLlvm HscC = IsValid
checkCOrAsmOrLlvm HscAsm = IsValid
checkCOrAsmOrLlvm HscLlvm = IsValid
checkCOrAsmOrLlvm _
= NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity
checkCOrAsmOrLlvmOrInterp HscC = IsValid
checkCOrAsmOrLlvmOrInterp HscAsm = IsValid
checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid
checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid
checkCOrAsmOrLlvmOrInterp _
= NotValid (text "requires interpreted, unregisterised, llvm or native code generation")
checkCg :: (HscTarget -> Validity) -> TcM ()
checkCg check = do
dflags <- getDynFlags
let target = hscTarget dflags
case target of
HscNothing -> return ()
_ ->
case check target of
IsValid -> return ()
NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err)
checkCConv :: CCallConv -> TcM CCallConv
checkCConv CCallConv = return CCallConv
checkCConv CApiConv = return CApiConv
checkCConv StdCallConv = do dflags <- getDynFlags
let platform = targetPlatform dflags
if platformArch platform == ArchX86
then return StdCallConv
else do
when (wopt Opt_WarnUnsupportedCallingConventions dflags) $
addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
return CCallConv
checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
return PrimCallConv
checkCConv JavaScriptCallConv = do dflags <- getDynFlags
if platformArch (targetPlatform dflags) == ArchJavaScript
then return JavaScriptCallConv
else do addErrTc (text "The `javascript' calling convention is unsupported on this platform")
return JavaScriptCallConv
check :: Validity -> (MsgDoc -> MsgDoc) -> TcM ()
check IsValid _ = return ()
check (NotValid doc) err_fn = addErrTc (err_fn doc)
illegalForeignTyErr :: SDoc -> SDoc -> SDoc
illegalForeignTyErr arg_or_res extra
= hang msg 2 extra
where
msg = hsep [ ptext (sLit "Unacceptable"), arg_or_res
, ptext (sLit "type in foreign declaration:")]
argument, result :: SDoc
argument = text "argument"
result = text "result"
badCName :: CLabelString -> MsgDoc
badCName target
= sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
foreignDeclCtxt :: ForeignDecl Name -> SDoc
foreignDeclCtxt fo
= hang (ptext (sLit "When checking declaration:"))
2 (ppr fo)