Commit 5b988961 authored by Ian Lynagh's avatar Ian Lynagh

Handle newtypes and type functions correctly in FFI types; fixes #3008

You can now use type functions in FFI types.

Newtypes are now only looked through if the constructor is in scope.
parent 53191d55
......@@ -209,7 +209,7 @@ boxResult :: Type
-- State# RealWorld -> (# State# RealWorld #)
boxResult result_ty
| Just (io_tycon, io_res_ty, co) <- tcSplitIOType_maybe result_ty
| Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
-- isIOType_maybe handles the case where the type is a
-- simple wrapping of IO. E.g.
-- newtype Wrap a = W (IO a)
......@@ -236,7 +236,7 @@ boxResult result_ty
; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = dataConWrapId io_data_con
wrap the_call = mkCoerce (mkSymCo co) $
wrap the_call =
mkApps (Var toIOCon)
[ Type io_res_ty,
Lam state_id $
......
......@@ -18,7 +18,6 @@ import DsMonad
import HsSyn
import DataCon
import CoreUtils
import CoreUnfold
import Id
import Literal
......@@ -45,6 +44,7 @@ import Platform
import Config
import Constants
import OrdList
import Pair
import Data.Maybe
import Data.List
\end{code}
......@@ -84,14 +84,14 @@ dsForeigns fos = do
where
do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
do_decl (ForeignImport id _ spec) = do
do_decl (ForeignImport id _ co spec) = do
traceIf (text "fi start" <+> ppr id)
(bs, h, c) <- dsFImport (unLoc id) spec
(bs, h, c) <- dsFImport (unLoc id) co spec
traceIf (text "fi end" <+> ppr id)
return (h, c, [], bs)
do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) = do
(h, c, _, _) <- dsFExport id (idType id) ext_nm cconv False
do_decl (ForeignExport (L _ id) _ co (CExport (CExportStatic ext_nm cconv))) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
\end{code}
......@@ -122,20 +122,22 @@ because it exposes the boxing to the call site.
\begin{code}
dsFImport :: Id
-> Coercion
-> ForeignImport
-> DsM ([Binding], SDoc, SDoc)
dsFImport id (CImport cconv safety _ spec) = do
(ids, h, c) <- dsCImport id spec cconv safety
dsFImport id co (CImport cconv safety _ spec) = do
(ids, h, c) <- dsCImport id co spec cconv safety
return (ids, h, c)
dsCImport :: Id
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> DsM ([Binding], SDoc, SDoc)
dsCImport id (CLabel cid) cconv _ = do
let ty = idType id
fod = case tyConAppTyCon_maybe (repType ty) of
dsCImport id co (CLabel cid) cconv _ = do
let ty = pFst $ coercionKind co
fod = case tyConAppTyCon_maybe ty of
Just tycon
| tyConUnique tycon == funPtrTyConKey ->
IsFunction
......@@ -144,23 +146,24 @@ dsCImport id (CLabel cid) cconv _ = do
ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
let
rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
rhs' = Cast rhs co
stdcall_info = fun_type_arg_stdcall_info cconv ty
in
return ([(id, rhs)], empty, empty)
return ([(id, rhs')], empty, empty)
dsCImport id (CFunction target) cconv@PrimCallConv safety
= dsPrimCall id (CCall (CCallSpec target cconv safety))
dsCImport id (CFunction target) cconv safety
= dsFCall id (CCall (CCallSpec target cconv safety))
dsCImport id CWrapper cconv _
= dsFExportDynamic id cconv
dsCImport id co (CFunction target) cconv@PrimCallConv safety
= dsPrimCall id co (CCall (CCallSpec target cconv safety))
dsCImport id co (CFunction target) cconv safety
= dsFCall id co (CCall (CCallSpec target cconv safety))
dsCImport id co CWrapper cconv _
= dsFExportDynamic id co cconv
-- For stdcall labels, if the type was a FunPtr or newtype thereof,
-- then we need to calculate the size of the arguments in order to add
-- the @n suffix to the label.
fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
fun_type_arg_stdcall_info StdCallConv ty
| Just (tc,[arg_ty]) <- splitTyConApp_maybe (repType ty),
| Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
tyConUnique tc == funPtrTyConKey
= let
(_tvs,sans_foralls) = tcSplitForAllTys arg_ty
......@@ -178,10 +181,10 @@ fun_type_arg_stdcall_info _other_conv _
%************************************************************************
\begin{code}
dsFCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall fn_id fcall = do
dsFCall :: Id -> Coercion -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall fn_id co fcall = do
let
ty = idType fn_id
ty = pFst $ coercionKind co
(tvs, fun_ty) = tcSplitForAllTys ty
(arg_tys, io_res_ty) = tcSplitFunTys fun_ty
-- Must use tcSplit* functions because we want to
......@@ -208,9 +211,10 @@ dsFCall fn_id fcall = do
work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
wrap_rhs = mkLams (tvs ++ args) wrapper_body
fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs
wrap_rhs' = Cast wrap_rhs co
fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, empty)
\end{code}
......@@ -228,10 +232,11 @@ kind of Id, or perhaps to bundle them with PrimOps since semantically and
for calling convention they are really prim ops.
\begin{code}
dsPrimCall :: Id -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsPrimCall fn_id fcall = do
dsPrimCall :: Id -> Coercion -> ForeignCall
-> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsPrimCall fn_id co fcall = do
let
ty = idType fn_id
ty = pFst $ coercionKind co
(tvs, fun_ty) = tcSplitForAllTys ty
(arg_tys, io_res_ty) = tcSplitFunTys fun_ty
-- Must use tcSplit* functions because we want to
......@@ -243,7 +248,8 @@ dsPrimCall fn_id fcall = do
let
call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
rhs = mkLams tvs (mkLams args call_app)
return ([(fn_id, rhs)], empty, empty)
rhs' = Cast rhs co
return ([(fn_id, rhs')], empty, empty)
\end{code}
......@@ -267,7 +273,8 @@ the user-written Haskell function `@M.foo@'.
\begin{code}
dsFExport :: Id -- Either the exported Id,
-- or the foreign-export-dynamic constructor
-> Type -- The type of the thing callable from C
-> Coercion -- Coercion between the Haskell type callable
-- from C, and its representation type
-> CLabelString -- The name to export to C land
-> CCallConv
-> Bool -- True => foreign export dynamic
......@@ -279,8 +286,9 @@ dsFExport :: Id -- Either the exported Id,
, Int -- size of args to stub function
)
dsFExport fn_id ty ext_name cconv isDyn= do
dsFExport fn_id co ext_name cconv isDyn = do
let
ty = pSnd $ coercionKind co
(_tvs,sans_foralls) = tcSplitForAllTys ty
(fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls
-- We must use tcSplits here, because we want to see
......@@ -294,9 +302,8 @@ dsFExport fn_id ty ext_name cconv isDyn= do
(res_ty, -- t
is_IO_res_ty) <- -- Bool
case tcSplitIOType_maybe orig_res_ty of
Just (_ioTyCon, res_ty, _co) -> return (res_ty, True)
Just (_ioTyCon, res_ty) -> return (res_ty, True)
-- The function already returns IO t
-- ToDo: what about the coercion?
Nothing -> return (orig_res_ty, False)
-- The function returns t
......@@ -339,9 +346,10 @@ f_helper(StablePtr s, HsBool b, HsInt i)
\begin{code}
dsFExportDynamic :: Id
-> Coercion
-> CCallConv
-> DsM ([Binding], SDoc, SDoc)
dsFExportDynamic id cconv = do
dsFExportDynamic id co0 cconv = do
fe_id <- newSysLocalDs ty
mod <- getModuleDs
let
......@@ -356,7 +364,7 @@ dsFExportDynamic id cconv = do
export_ty = mkFunTy stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalDs stable_ptr_ty
(h_code, c_code, typestring, args_size) <- dsFExport id export_ty fe_nm cconv True
(h_code, c_code, typestring, args_size) <- dsFExport id (Refl export_ty) fe_nm cconv True
let
{-
The arguments to the external function which will
......@@ -386,7 +394,6 @@ dsFExportDynamic id cconv = do
let io_app = mkLams tvs $
Lam cback $
mkCoerce (mkSymCo co) $
mkApps (Var bindIOId)
[ Type stable_ptr_ty
, Type res_ty
......@@ -394,19 +401,18 @@ dsFExportDynamic id cconv = do
, Lam stbl_value ccall_adj
]
fed = (id `setInlineActivation` NeverActive, io_app)
fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
-- Never inline the f.e.d. function, because the litlit
-- might not be in scope in other modules.
return ([fed], h_code, c_code)
where
ty = idType id
ty = pFst (coercionKind co0)
(tvs,sans_foralls) = tcSplitForAllTys ty
([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
Just (io_tc, res_ty, co) = tcSplitIOType_maybe fn_res_ty
Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty
-- Must have an IO type; hence Just
-- co : fn_res_ty ~ IO res_ty
toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
......
......@@ -324,7 +324,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
repForD (L loc (ForeignImport name typ _ (CImport cc s ch cis)))
= do MkC name' <- lookupLOcc name
MkC typ' <- repLTy typ
MkC cc' <- repCCallConv cc
......
......@@ -370,7 +370,7 @@ cvtForD (ImportF callconv safety from nm ty)
(mkFastString (TH.nameBase nm)) from
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; return (ForeignImport nm' ty' impspec)
; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
}
| otherwise
= failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
......@@ -384,7 +384,7 @@ cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
; return $ ForeignExport nm' ty' e }
; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
cvt_conv :: TH.Callconv -> CCallConv
cvt_conv TH.CCall = CCallConv
......
......@@ -35,6 +35,7 @@ module HsDecls (
SpliceDecl(..),
-- ** Foreign function interface declarations
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
noForeignImportCoercionYet, noForeignExportCoercionYet,
CImportSpec(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl, ResType(..),
......@@ -64,6 +65,7 @@ import NameSet
import Name
import {- Kind parts of -} Type
import BasicTypes
import Coercion
import ForeignCall
-- others:
......@@ -911,9 +913,31 @@ instance (OutputableBndr name)
type LForeignDecl name = Located (ForeignDecl name)
data ForeignDecl name
= ForeignImport (Located name) (LHsType name) ForeignImport -- defines name
| ForeignExport (Located name) (LHsType name) ForeignExport -- uses name
= ForeignImport (Located name) -- defines this name
(LHsType name) -- sig_ty
Coercion -- rep_ty ~ sig_ty
ForeignImport
| ForeignExport (Located name) -- uses this name
(LHsType name) -- sig_ty
Coercion -- sig_ty ~ rep_ty
ForeignExport
deriving (Data, Typeable)
{-
In both ForeignImport and ForeignExport:
sig_ty is the type given in the Haskell code
rep_ty is the representation for this type, i.e. with newtypes
coerced away and type functions evaluated.
Thus if the declaration is valid, then rep_ty will only use types
such as Int and IO that we know how to make foreign calls with.
-}
noForeignImportCoercionYet :: Coercion
noForeignImportCoercionYet
= panic "ForeignImport coercion evaluated before typechecking"
noForeignExportCoercionYet :: Coercion
noForeignExportCoercionYet
= panic "ForeignExport coercion evaluated before typechecking"
-- Specification Of an imported external entity in dependence on the calling
-- convention
......@@ -956,10 +980,10 @@ data ForeignExport = CExport CExportSpec -- contains the calling convention
--
instance OutputableBndr name => Outputable (ForeignDecl name) where
ppr (ForeignImport n ty fimport) =
ppr (ForeignImport n ty _ fimport) =
hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n)
2 (dcolon <+> ppr ty)
ppr (ForeignExport n ty fexport) =
ppr (ForeignExport n ty _ fexport) =
hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n)
2 (dcolon <+> ppr ty)
......
......@@ -610,7 +610,7 @@ hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
hsForeignDeclsBinders foreign_decls
= [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
= [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
hsTyClDeclsBinders tycl_decls inst_decls
......
......@@ -920,12 +920,12 @@ mkImport cconv safety (L loc entity, v, ty)
| cconv == PrimCallConv = do
let funcTarget = CFunction (StaticTarget entity Nothing)
importSpec = CImport PrimCallConv safety nilFS funcTarget
return (ForD (ForeignImport v ty importSpec))
return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
| otherwise = do
case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of
Nothing -> parseErrorSDoc loc (text "Malformed entity string")
Just importSpec -> return (ForD (ForeignImport v ty importSpec))
Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
-- the string "foo" is ambigous: either a header or a C identifier. The
-- C identifier case comes first in the alternatives below, so we pick
......@@ -970,7 +970,7 @@ mkExport :: CCallConv
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
mkExport cconv (L _ entity, v, ty) = return $
ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
ForD (ForeignExport v ty noForeignExportCoercionYet (CExport (CExportStatic entity' cconv)))
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
......
......@@ -521,7 +521,7 @@ getLocalNonValBinders fixity_env
; return (envs, new_bndrs) } }
where
for_hs_bndrs :: [Located RdrName]
for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls]
for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls]
-- In a hs-boot file, the value binders come from the
-- *signatures*, and there should be no foreign binders
......
......@@ -363,7 +363,7 @@ rnDefaultDecl (DefaultDecl tys)
\begin{code}
rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
rnHsForeignDecl (ForeignImport name ty spec)
rnHsForeignDecl (ForeignImport name ty _ spec)
= do { topEnv :: HscEnv <- getTopEnv
; name' <- lookupLocatedTopBndrRn name
; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty
......@@ -372,12 +372,12 @@ rnHsForeignDecl (ForeignImport name ty spec)
; let packageId = thisPackage $ hsc_dflags topEnv
spec' = patchForeignImport packageId spec
; return (ForeignImport name' ty' spec', fvs) }
; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) }
rnHsForeignDecl (ForeignExport name ty spec)
rnHsForeignDecl (ForeignExport name ty _ spec)
= do { name' <- lookupLocatedOccRn name
; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty
; return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name') }
; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
-- NB: a foreign export is an *occurrence site* for name, so
-- we add it to the free-variable list. It might, for example,
-- be imported from another module
......
......@@ -27,6 +27,10 @@ import TcHsType
import TcExpr
import TcEnv
import FamInst
import FamInstEnv
import Type
import TypeRep
import ForeignCall
import ErrUtils
import Id
......@@ -48,13 +52,94 @@ import Util
\begin{code}
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
isForeignImport (L _ (ForeignImport _ _ _)) = True
isForeignImport _ = False
isForeignImport (L _ (ForeignImport _ _ _ _)) = True
isForeignImport _ = False
-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
isForeignExport (L _ (ForeignExport _ _ _)) = True
isForeignExport _ = False
isForeignExport (L _ (ForeignExport _ _ _ _)) = True
isForeignExport _ = False
\end{code}
\begin{code}
-- normaliseFfiType takes the type from an FFI declaration, and
-- evaluates any type synonyms, type functions, and newtypes. However,
-- we are only allowed to look through newtypes if the constructor is
-- in scope.
normaliseFfiType :: Type -> TcM (Coercion, Type)
normaliseFfiType ty
= do fam_envs <- tcGetFamInstEnvs
normaliseFfiType' fam_envs ty
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type)
normaliseFfiType' env ty0 = go [] ty0
where
go :: [TyCon] -> Type -> TcM (Coercion, Type)
go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
= go rec_nts ty'
go rec_nts ty@(TyConApp tc tys)
-- We don't want to look through the IO newtype, even if it is
-- in scope, so we have a special case for it:
| tc `hasKey` ioTyConKey
= children_only
| isNewTyCon tc -- Expand newtypes
-- We can't just use isRecursiveTyCon here, as we need to allow
-- some recursive types as described below
= if tc `elem` rec_nts -- See Note [Expanding newtypes] in Type.lhs
then -- If this is a recursive newtype then it will normally
-- be rejected later as not being a valid FFI type.
-- Sometimes recursion is OK though, e.g. with
-- newtype T = T (Ptr T)
-- we don't reject the type for being recursive.
return (Refl ty, ty)
else do newtypeOK <- do env <- getGblEnv
case tyConSingleDataCon_maybe tc of
Just dataCon ->
return $ notNull $ lookupGRE_Name (tcg_rdr_env env) $ dataConName dataCon
_ ->
return False
let newtypeForeign = nameModule_maybe (tyConName tc) `elem`
[Just (mkBaseModule (fsLit "Foreign.C.Types")),
Just (mkBaseModule (fsLit "System.Posix.Types"))]
if newtypeOK || newtypeForeign
then do let nt_co = mkAxInstCo (newTyConCo tc) tys
add_co nt_co rec_nts' nt_rhs
else children_only
| isFamilyTyCon tc -- Expand open tycons
, (co, ty) <- normaliseTcApp env tc tys
, not (isReflCo co)
= add_co co rec_nts ty
| otherwise
= children_only
where
children_only = do xs <- mapM (go rec_nts) tys
let (cos, tys') = unzip xs
return (mkTyConAppCo tc cos, mkTyConApp tc tys')
nt_rhs = newTyConInstRhs tc tys
rec_nts' | isRecursiveTyCon tc = tc:rec_nts
| otherwise = rec_nts
go rec_nts (AppTy ty1 ty2)
= do (coi1, nty1) <- go rec_nts ty1
(coi2, nty2) <- go rec_nts ty2
return (mkAppCo coi1 coi2, mkAppTy nty1 nty2)
go rec_nts (FunTy ty1 ty2)
= do (coi1,nty1) <- go rec_nts ty1
(coi2,nty2) <- go rec_nts ty2
return (mkFunCo coi1 coi2, mkFunTy nty1 nty2)
go rec_nts (ForAllTy tyvar ty1)
= do (coi,nty1) <- go rec_nts ty1
return (mkForAllCo tyvar coi, ForAllTy tyvar nty1)
go _ ty@(TyVarTy _)
= return (Refl ty, ty)
add_co co rec_nts ty
= do (co', ty') <- go rec_nts ty
return (mkTransCo co co', ty')
\end{code}
%************************************************************************
......@@ -69,13 +154,14 @@ tcForeignImports decls
= mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
tcFImport fo@(ForeignImport (L loc nm) hs_ty _ imp_decl)
= addErrCtxt (foreignDeclCtxt fo) $
do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
; (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty
; let
-- Drop the foralls before inspecting the
-- structure of the foreign type.
(_, t_ty) = tcSplitForAllTys sig_ty
(_, t_ty) = tcSplitForAllTys norm_sig_ty
(arg_tys, res_ty) = tcSplitFunTys t_ty
id = mkLocalId nm sig_ty
-- Use a LocalId to obey the invariant that locally-defined
......@@ -85,7 +171,7 @@ tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
-- Can't use sig_ty here because sig_ty :: Type and
-- we need HsType Id hence the undefined
; return (id, ForeignImport (L loc id) undefined imp_decl') }
; return (id, ForeignImport (L loc id) undefined (mkSymCo norm_co) imp_decl') }
tcFImport d = pprPanic "tcFImport" (ppr d)
\end{code}
......@@ -198,13 +284,15 @@ tcForeignExports decls
return (b `consBag` binds, f:fs)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
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
tcCheckFEType sig_ty spec
(norm_co, norm_sig_ty) <- normaliseFfiType sig_ty
tcCheckFEType norm_sig_ty spec
-- we're exporting a function, but at a type possibly more
-- constrained than its declared/inferred type. Hence the need
......@@ -216,7 +304,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
-- is *stable* (i.e. the compiler won't change it later),
-- because this name will be referred to by the C code stub.
id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec)
tcFExport d = pprPanic "tcFExport" (ppr d)
\end{code}
......@@ -264,49 +352,15 @@ nonIOok = True
mustBeIO = False
checkForeignRes non_io_result_ok safehs_check pred_res_ty ty
-- (IO t) is ok, and so is any newtype wrapping thereof
= do m <- tcSplitVisibleIOType_maybe ty
case m of
Just (_, res_ty, _)
| pred_res_ty res_ty ->
return ()
_ ->
check (non_io_result_ok && pred_res_ty ty)
(illegalForeignTyErr result ty $+$ safeHsErr safehs_check)
-- This is mostly a copy of TcType.tcSplitIOType_maybe, except it checks
-- that it doesn't look through any newtypes for which the constructor
-- is not exported.
tcSplitVisibleIOType_maybe :: Type -> TcM (Maybe (TyCon, Type, Coercion))
tcSplitVisibleIOType_maybe ty
= case tcSplitTyConApp_maybe ty of
-- This split absolutely has to be a tcSplit, because we must
-- see the IO type; and it's a newtype which is transparent to
-- splitTyConApp.
Just (io_tycon, [io_res_ty])
| io_tycon `hasKey` ioTyConKey
-> return $ Just (io_tycon, io_res_ty, mkReflCo ty)
Just (tc, tys)
| not (isRecursiveTyCon tc)
, Just (ty, co1) <- instNewTyCon_maybe tc tys
-- Newtypes that require a coercion are ok
-> do newtypeOK <- do env <- getGblEnv
case tyConSingleDataCon_maybe tc of
Just dataCon ->
return $ notNull $ lookupGRE_Name (tcg_rdr_env env) $ dataConName dataCon
Nothing ->
return False
if newtypeOK
then do m <- tcSplitVisibleIOType_maybe ty
return $ case m of
Nothing -> Nothing
Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2)
else return Nothing
_ -> return Nothing
-- We need an (IO t) result. Any newtype wrappers of type functions
-- have already been dealt with by normaliseFfiType.
= case tcSplitIOType_maybe ty of
Just (_, res_ty)
| pred_res_ty res_ty ->
return ()
_ ->
check (non_io_result_ok && pred_res_ty ty)
(illegalForeignTyErr result ty $+$ safeHsErr safehs_check)
\end{code}
\begin{code}
......
......@@ -964,8 +964,8 @@ zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
zonkForeignExport env (ForeignExport i _hs_ty spec) =
returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
zonkForeignExport env (ForeignExport i _hs_ty co spec) =
returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec)
zonkForeignExport _ for_imp
= returnM for_imp -- Foreign imports don't need zonking
\end{code}
......
......@@ -1230,28 +1230,17 @@ restricted set of types as arguments and results (the restricting factor
being the )
\begin{code}
tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, Coercion)
-- (isIOType t) returns Just (IO,t',co)
-- if co : t ~ IO t'
-- returns Nothing otherwise
tcSplitIOType_maybe ty
tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
-- (tcSplitIOType_maybe t) returns Just (IO,t',co)
-- if co : t ~ IO t'
-- returns Nothing otherwise
tcSplitIOType_maybe ty
= case tcSplitTyConApp_maybe ty of
-- This split absolutely has to be a tcSplit, because we must
-- see the IO type; and it's a newtype which is transparent to splitTyConApp.
Just (io_tycon, [io_res_ty])
| io_tycon `hasKey` ioTyConKey
-> Just (io_tycon, io_res_ty, mkReflCo ty)
Just (tc, tys)
| not (isRecursiveTyCon tc)
, Just (ty, co1) <- instNewTyCon_maybe tc tys
-- Newtypes that require a coercion are ok
-> case tcSplitIOType_maybe ty of
Nothing -> Nothing
Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2)
_ -> Nothing
Just (io_tycon, [io_res_ty])
| io_tycon `hasKey` ioTyConKey ->
Just (io_tycon, io_res_ty)
_ ->
Nothing
isFFITy :: Type -> Bool
-- True for any TyCon that can possibly be an arg or result of an FFI call
......@@ -1318,20 +1307,15 @@ isFFIDotnetObjTy ty