2 % (c) The AQUA Project, Glasgow University, 1998
4 \section[TcForeign]{Typechecking \tr{foreign} declarations}
6 A foreign declaration is used to either give an externally
7 implemented function a Haskell type (and calling interface) or
8 give a Haskell function an external calling interface. Either way,
9 the range of argument and result types these functions can accommodate
10 is restricted to what the outside world understands (read C), and this
11 module checks to see if a foreign declaration has got a legal type.
20 #include "HsVersions.h"
22 import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
23 ExtName(..), isDynamic, MonoBinds(..),
24 OutPat(..), ForKind(..)
26 import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
29 import TcEnv ( newLocalId )
30 import TcType ( tcInstTcType, typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
31 import TcMonoType ( tcHsTopBoxedType )
32 import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
34 import TcExpr ( tcId, tcPolyExpr )
35 import Inst ( emptyLIE, LIE, plusLIE )
38 import ErrUtils ( Message )
39 import Id ( Id, idName, mkUserId )
40 import Name ( nameOccName )
41 import Type ( splitFunTys
49 import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
50 isFFIExternalTy, isAddrTy
56 import CmdLineOpts ( opt_GlasgowExts )
57 import Maybes ( maybeToBool )
62 tcForeignImports :: [RenamedHsDecl] -> TcM s ([Id], [TypecheckedForeignDecl])
63 tcForeignImports decls =
64 mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
66 tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE, TcMonoBinds, [TcForeignExportDecl])
67 tcForeignExports decls =
68 foldlTc combine (emptyLIE, EmptyMonoBinds, [])
69 [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
71 combine (lie, binds, fs) fe =
72 tcFExport fe `thenTc ` \ (a_lie, b, f) ->
73 returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
76 isForeignImport :: ForeignDecl name -> Bool
77 isForeignImport (ForeignDecl _ k _ dyn _ _) =
80 FoExport -> case dyn of { Dynamic -> True ; _ -> False }
84 isForeignExport :: ForeignDecl name -> Bool
85 isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamic ext_nm)
86 isForeignExport _ = False
91 tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
92 tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
94 tcAddErrCtxt (foreignDeclCtxt fo) $
95 tcHsTopBoxedType hs_ty `thenTc` \ sig_ty ->
97 -- drop the foralls before inspecting the structure
98 -- of the foreign type.
99 (_, t_ty) = splitForAllTys sig_ty
101 case splitFunTys t_ty of
103 checkForeignExport True t_ty arg_tys res_ty `thenTc_`
104 let i = (mkUserId nm sig_ty) in
105 returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
107 tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
108 tcAddSrcLoc src_loc $
109 tcAddErrCtxt (foreignDeclCtxt fo) $
110 tcHsTopBoxedType hs_ty `thenTc` \ sig_ty ->
112 -- drop the foralls before inspecting the structure
113 -- of the foreign type.
114 (_, t_ty) = splitForAllTys sig_ty
116 check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
117 let i = (mkUserId nm sig_ty) in
118 returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
120 tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
121 tcAddSrcLoc src_loc $
122 tcAddErrCtxt (foreignDeclCtxt fo) $
124 tcHsTopBoxedType hs_ty `thenTc` \ ty ->
125 -- Check that the type has the right shape
126 -- and that the argument and result types are acceptable.
128 -- drop the foralls before inspecting the structure
129 -- of the foreign type.
130 (_, t_ty) = splitForAllTys ty
132 case splitFunTys t_ty of
134 checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_`
135 let i = (mkUserId nm ty) in
136 returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
138 tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl)
139 tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
140 tcAddSrcLoc src_loc $
141 tcAddErrCtxt (foreignDeclCtxt fo) $
143 tcHsTopBoxedType hs_ty `thenTc` \ sig_ty ->
144 let sig_tc_ty = typeToTcType sig_ty in
145 tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) ->
148 -- drop the foralls before inspecting the structure
149 -- of the foreign type.
150 (_, t_ty) = splitForAllTys sig_ty
152 case splitFunTys t_ty of
154 checkForeignExport False t_ty arg_tys res_ty `thenTc_`
155 -- we're exporting a function, but at a type possibly more constrained
156 -- than its declared/inferred type. Hence the need
157 -- to create a local binding which will call the exported function
158 -- at a particular type (and, maybe, overloading).
159 newLocalId (nameOccName nm) sig_tc_ty `thenNF_Tc` \ i ->
161 bind = VarMonoBind i rhs
163 returnTc (lie, bind, ForeignDecl i imp_exp undefined ext_nm cconv src_loc)
165 -- ToDo: fill the type field in with something sensible.
171 checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s ()
172 checkForeignImport is_dynamic ty args res
174 -- * first arg has got to be an Addr
176 [] -> check False (illegalForeignTyErr True{-Arg-} ty)
178 check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
179 mapTc (checkForeignArg isFFIArgumentTy) xs `thenTc_`
180 checkForeignRes (isFFIResultTy) res
182 mapTc (checkForeignArg isFFIArgumentTy) args `thenTc_`
183 checkForeignRes (isFFIResultTy) res
185 checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()
186 checkForeignExport is_dynamic ty args res
188 -- * the first (and only!) arg has got to be a function type
189 -- * result type is an Addr
192 case splitFunTys arg of
194 mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
195 checkForeignRes (isFFIResultTy) res_ty `thenTc_`
196 checkForeignRes (isAddrTy) res
197 _ -> check False (illegalForeignTyErr True{-Arg-} ty)
199 mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
200 checkForeignRes (isFFIResultTy) res
202 check :: Bool -> Message -> TcM s ()
203 check True _ = returnTc ()
204 check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
206 checkForeignArg :: (Type -> Bool) -> Type -> TcM s ()
207 checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
209 -- Check that the type has the form
210 -- (IO t) or (t) , and that t satisfies the given predicate.
212 checkForeignRes :: (Type -> Bool) -> Type -> TcM s ()
213 checkForeignRes pred_res_ty ty =
214 case (splitTyConApp_maybe ty) of
216 | (getUnique io) == ioTyConKey && pred_res_ty res_ty
219 | pred_res_ty ty -> returnTc ()
220 | otherwise -> check False (illegalForeignTyErr False{-Res-} ty)
227 illegalForeignTyErr isArg ty
228 = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
232 | isArg = ptext SLIT("argument")
233 | otherwise = ptext SLIT("result")
236 hang (ptext SLIT("When checking declaration:"))