tweag/asterius
1
1
Fork 0
mirror of https://github.com/tweag/asterius.git synced 2024-09-19 04:47:56 +03:00
Code Issues Projects Releases Wiki Activity

WIP

Browse Source
This commit is contained in:
Cheng Shao 2021-01-25 11:32:31 +00:00
parent 56702a3358
commit e336888475
1 changed files with 21 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
asterius/src/Asterius/Foreign/TcForeign.hs
View File

@ -37,26 +37,27 @@ asteriusTcForeignImports decls = do
asteriusTcFImport ::
LForeignDecl GhcRn -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
asteriusTcFImport (L dloc fo@ForeignImport {fd_name = L nloc nm, fd_sig_ty = hs_ty, fd_fi = 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 (bndrs, res_ty) = tcSplitPiTys norm_sig_ty
arg_tys = mapMaybe binderRelevantType_maybe bndrs
id = mkLocalId nm sig_ty
imp_decl' <- asteriusTcCheckFIType arg_tys res_ty imp_decl
let fi_decl =
ForeignImport
{ fd_name = L nloc id,
fd_sig_ty = undefined,
fd_i_ext = mkSymCo norm_co,
fd_fi = imp_decl'
}
return (id, L dloc fi_decl, gres)
setSrcSpan dloc $
addErrCtxt (foreignDeclCtxt fo) $ do
sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
(norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
let (bndrs, res_ty) = tcSplitPiTys norm_sig_ty
arg_tys = mapMaybe binderRelevantType_maybe bndrs
id = mkLocalId nm sig_ty
imp_decl' <- asteriusTcCheckFIType arg_tys res_ty imp_decl
let fi_decl =
ForeignImport
{ fd_name = L nloc id,
fd_sig_ty = undefined,
fd_i_ext = mkSymCo norm_co,
fd_fi = imp_decl'
}
return (id, L dloc fi_decl, gres)
asteriusTcFImport d = pprPanic "asteriusTcFImport" (ppr d)
asteriusTcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport
asteriusTcCheckFIType arg_tys res_ty (CImport (L lc JavaScriptCallConv) (L ls safety) mh (CFunction target) src)
| unLoc src
asteriusTcCheckFIType arg_tys res_ty (CImport (L lc cconv) (L ls safety) mh (CFunction target) src)
| cconv == JavaScriptCallConv && unLoc src
`elem` map
SourceText
["\"wrapper\"", "\"wrapper oneshot\""] =
@ -83,8 +84,8 @@ asteriusTcCheckFIType arg_tys res_ty (CImport (L lc JavaScriptCallConv) (L ls sa
_ ->
addErrTc
(illegalForeignTyErr Outputable.empty (text "One argument expected"))
return (CImport (L lc JavaScriptCallConv) (L ls safety) mh CWrapper src)
| otherwise =
return (CImport (L lc cconv) (L ls safety) mh CWrapper src)
| not (isDynamicTarget target || cconv == PrimCallConv) =
do
dflags <- getDynFlags
checkForeignArgs (asteriusIsFFIArgumentTy dflags safety) arg_tys
@ -93,7 +94,7 @@ asteriusTcCheckFIType arg_tys res_ty (CImport (L lc JavaScriptCallConv) (L ls sa
checkSafe
(asteriusIsFFIImportResultTy dflags)
res_ty
return $ CImport (L lc JavaScriptCallConv) (L ls safety) mh (CFunction target) src
return $ CImport (L lc cconv) (L ls safety) mh (CFunction target) src
asteriusTcCheckFIType arg_tys res_ty imp_decl =
tcCheckFIType arg_tys res_ty imp_decl