--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1998
+%
+\section[TcForeign]{Typechecking \tr{foreign} declarations}
+
+A foreign declaration is used to either give an externally
+implemented function a Haskell type (and calling interface) or
+give a Haskell function an external calling interface. Either way,
+the range of argument and result types these functions can accommodate
+is restricted to what the outside world understands (read C), and this
+module checks to see if a foreign declaration has got a legal type.
+
+\begin{code}
+module TcForeign
+ (
+ tcForeignImports
+ , tcForeignExports
+ ) where
+
+#include "HsVersions.h"
+
+import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
+ ExtName(..), isDynamic, MonoBinds(..),
+ OutPat(..)
+ )
+import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
+
+import TcMonad
+import TcEnv ( tcLookupClassByKey, newLocalId, tcLookupGlobalValue )
+import TcType ( tcInstTcType, tcInstSigType, tcSplitRhoTy, zonkTcTypeToType )
+import TcMonoType ( tcHsType )
+import TcHsSyn ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl, TcIdOcc(..),
+ TcForeignExportDecl )
+import TcExpr ( tcId, tcPolyExpr )
+import Inst ( emptyLIE, LIE, plusLIE )
+import CoreSyn
+
+import ErrUtils ( Message )
+import Id ( Id, idName )
+import Name ( nameOccName )
+import MkId ( mkUserId )
+import Type ( isUnpointedType
+ , splitFunTys
+ , splitTyConApp_maybe
+ , splitForAllTys
+ , splitRhoTy
+ , isForAllTy
+ , mkForAllTys
+ )
+import TyVar ( emptyTyVarEnv )
+
+
+import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
+ isFFIExternalTy, isAddrTy
+ )
+import Type ( Type )
+import Unique
+import Unify ( unifyTauTy )
+import Outputable
+import Util
+import CmdLineOpts ( opt_GlasgowExts )
+import Maybes ( maybeToBool )
+
+\end{code}
+
+\begin{code}
+tcForeignImports :: [RenamedHsDecl] -> TcM s ([Id], [TypecheckedForeignDecl])
+tcForeignImports decls =
+ mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
+
+tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE s, TcMonoBinds s, [TcForeignExportDecl s])
+tcForeignExports decls =
+ foldlTc combine (emptyLIE, EmptyMonoBinds, [])
+ [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
+ where
+ combine (lie, binds, fs) fe =
+ tcFExport fe `thenTc ` \ (a_lie, b, f) ->
+ returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
+
+-- defines a binding
+isForeignImport :: ForeignDecl name -> Bool
+isForeignImport (ForeignDecl _ (Just _) _ _ _ _) = True
+isForeignImport (ForeignDecl _ Nothing _ Dynamic _ _) = True
+isForeignImport _ = False
+
+-- exports a binding
+isForeignExport :: ForeignDecl name -> Bool
+isForeignExport (ForeignDecl _ Nothing _ ext_nm _ _) = not (isDynamic ext_nm)
+isForeignExport _ = False
+
+\end{code}
+
+\begin{code}
+tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
+tcFImport fo@(ForeignDecl nm Nothing hs_ty Dynamic cconv src_loc) =
+ tcAddSrcLoc src_loc $
+ tcAddErrCtxt (foreignDeclCtxt fo) $
+ tcHsType hs_ty `thenTc` \ sig_ty ->
+ let
+ -- drop the foralls before inspecting the structure
+ -- of the foreign type.
+ (_, t_ty) = splitForAllTys sig_ty
+ in
+ case splitFunTys t_ty of
+ (arg_tys, res_ty) ->
+ checkForeignExport True t_ty arg_tys res_ty `thenTc_`
+ let i = (mkUserId nm sig_ty) in
+ returnTc (i, (ForeignDecl i Nothing undefined Dynamic cconv src_loc))
+
+tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
+ tcAddSrcLoc src_loc $
+ tcAddErrCtxt (foreignDeclCtxt fo) $
+
+ tcHsType hs_ty `thenTc` \ ty ->
+ -- Check that the type has the right shape
+ -- and that the argument and result types are acceptable.
+ let
+ -- drop the foralls before inspecting the structure
+ -- of the foreign type.
+ (_, t_ty) = splitForAllTys ty
+ in
+ case splitFunTys t_ty of
+ (arg_tys, res_ty) ->
+ checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_`
+ let i = (mkUserId nm ty) in
+ returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
+
+tcFExport :: RenamedForeignDecl -> TcM s (LIE s, TcMonoBinds s, TcForeignExportDecl s)
+tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
+ tcAddSrcLoc src_loc $
+ tcAddErrCtxt (foreignDeclCtxt fo) $
+
+ tcHsType hs_ty `thenTc` \ sig_ty ->
+ tcInstSigType sig_ty `thenNF_Tc` \ sig_tc_ty ->
+ tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) ->
+
+ let
+ -- drop the foralls before inspecting the structure
+ -- of the foreign type.
+ (_, t_ty) = splitForAllTys sig_ty
+ in
+ case splitFunTys t_ty of
+ (arg_tys, res_ty) ->
+ checkForeignExport False t_ty arg_tys res_ty `thenTc_`
+ -- we're exporting a function, but at a type possibly more constrained
+ -- than its declared/inferred type. Hence the need
+ -- to create a local binding which will call the exported function
+ -- at a particular type (and, maybe, overloading).
+ newLocalId (nameOccName nm) sig_tc_ty `thenNF_Tc` \ i ->
+ let
+ i2 = TcId i
+ bind = VarMonoBind i2 rhs
+ in
+ returnTc (lie, bind, ForeignDecl i2 imp_exp undefined ext_nm cconv src_loc)
+ -- ^^^^^^^^^
+ -- ToDo: fill the type field in with something sensible.
+
+\end{code}
+
+
+\begin{code}
+checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s ()
+checkForeignImport is_dynamic ty args res
+ | is_dynamic =
+ -- * first arg has got to be an Addr
+ case args of
+ [] -> check False (illegalForeignTyErr True{-Arg-} ty)
+ (x:xs) ->
+ check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
+ mapTc (checkForeignArg isFFIArgumentTy) xs `thenTc_`
+ checkForeignRes (isFFIResultTy) res
+ | otherwise =
+ mapTc (checkForeignArg isFFIArgumentTy) args `thenTc_`
+ checkForeignRes (isFFIResultTy) res
+
+checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()
+checkForeignExport is_dynamic ty args res
+ | is_dynamic =
+ -- * the first (and only!) arg has got to be a function type
+ -- * result type is an Addr
+ case args of
+ [arg] ->
+ case splitFunTys arg of
+ (arg_tys, res_ty) ->
+ mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
+ checkForeignRes (isFFIResultTy) res_ty `thenTc_`
+ checkForeignRes (isAddrTy) res
+ _ -> check False (illegalForeignTyErr True{-Arg-} ty)
+ | otherwise =
+ mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
+ checkForeignRes (isFFIResultTy) res
+
+check :: Bool -> Message -> TcM s ()
+check True _ = returnTc ()
+check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
+
+checkForeignArg :: (Type -> Bool) -> Type -> TcM s ()
+checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
+
+-- Check that the type has the form
+-- (IO t) and that t satisfies the given predicate.
+--
+checkForeignRes :: (Type -> Bool) -> Type -> TcM s ()
+checkForeignRes pred_res_ty ty =
+ case (splitTyConApp_maybe ty) of
+ Just (io, [res_ty])
+ | (uniqueOf io) == ioTyConKey &&
+ pred_res_ty res_ty
+ -> returnTc ()
+ _ -> check False (illegalForeignTyErr False{-Res-} ty)
+
+\end{code}
+
+Warnings
+
+\begin{code}
+illegalForeignTyErr isArg ty
+ = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration")])
+ 4 (hsep [ ptext SLIT("type:"), ppr ty])
+ where
+ arg_or_res
+ | isArg = ptext SLIT("argument")
+ | otherwise = ptext SLIT("result")
+
+foreignDeclCtxt fo =
+ hang (ptext SLIT("When checking a foreign declaration:"))
+ 4 (ppr fo)
+
+\end{code}
TcExpr, TcGRHSsAndBinds, TcGRHS, TcMatch,
TcStmt, TcArithSeqInfo, TcRecordBinds,
TcHsModule, TcCoreExpr, TcDictBinds,
+ TcForeignExportDecl,
TypecheckedHsBinds,
TypecheckedMonoBinds, TypecheckedPat,
TypecheckedHsExpr, TypecheckedArithSeqInfo,
- TypecheckedStmt,
+ TypecheckedStmt, TypecheckedForeignDecl,
TypecheckedMatch, TypecheckedHsModule,
TypecheckedGRHSsAndBinds, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
maybeBoxedPrimType,
- zonkTopBinds, zonkBinds, zonkMonoBinds, zonkTcId
+ zonkTopBinds, zonkBinds, zonkMonoBinds, zonkTcId,
+ zonkForeignExports
) where
#include "HsVersions.h"
type TcRecordBinds s = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s)
type TcHsModule s = HsModule (TcBox s) (TcIdOcc s) (TcPat s)
-type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcBox s)
+type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcBox s)
+type TcForeignExportDecl s = ForeignDecl (TcIdOcc s)
type TypecheckedPat = OutPat Unused Id
type TypecheckedMonoBinds = MonoBinds Unused Id TypecheckedPat
type TypecheckedGRHS = GRHS Unused Id TypecheckedPat
type TypecheckedRecordBinds = HsRecordBinds Unused Id TypecheckedPat
type TypecheckedHsModule = HsModule Unused Id TypecheckedPat
+type TypecheckedForeignDecl = ForeignDecl Id
\end{code}
\begin{code}
returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
\end{code}
+%************************************************************************
+%* *
+\subsection[BackSubst-Foreign]{Foreign exports}
+%* *
+%************************************************************************
+
+\begin{code}
+zonkForeignExports :: [TcForeignExportDecl s] -> NF_TcM s [TypecheckedForeignDecl]
+zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
+
+zonkForeignExport :: TcForeignExportDecl s -> NF_TcM s (TypecheckedForeignDecl)
+zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
+ zonkIdOcc i `thenNF_Tc` \ i' ->
+ returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
+
+\end{code}
import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_deriv )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
import RnHsSyn ( RenamedHsModule )
-import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, zonkTopBinds )
+import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, zonkTopBinds,
+ TypecheckedForeignDecl, zonkForeignExports
+ )
import TcMonad
import Inst ( Inst, emptyLIE, plusLIE )
import TcDefaults ( tcDefaults )
import TcEnv ( TcIdOcc(..), tcExtendGlobalValEnv, tcExtendTyConEnv,
getEnv_TyCons, getEnv_Classes, tcLookupLocalValue,
- tcLookupTyCon, initEnv )
+ tcLookupTyCon, initEnv, tcSetGlobalValEnv )
import TcExpr ( tcId )
+import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo )
type TcResults
= (TypecheckedMonoBinds,
[TyCon], [Class],
- Bag InstInfo, -- Instance declaration information
+ Bag InstInfo, -- Instance declaration information
+ [TypecheckedForeignDecl], -- foreign import & exports.
TcDDumpDeriv)
type TcDDumpDeriv = SDoc
dumpIfSet opt_D_dump_tc "Typechecked"
(case maybe_result of
- Just (binds, _, _, _, _) -> ppr binds
- Nothing -> text "Typecheck failed") >>
+ Just (binds, _, _, _, ds, _) -> ppr binds $$ ppr ds
+ Nothing -> text "Typecheck failed") >>
dumpIfSet opt_D_dump_deriv "Derived instances"
(case maybe_result of
- Just (_, _, _, _, dump_deriv) -> dump_deriv
- Nothing -> empty) >>
+ Just (_, _, _, _, _, dump_deriv) -> dump_deriv
+ Nothing -> empty) >>
return (if isEmptyBag errs then
maybe_result
tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
tcExtendGlobalValEnv sig_ids $
+ -- foreign import declarations next.
+ tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
+ tcExtendGlobalValEnv fo_ids $
-- Value declarations next.
-- We also typecheck any extra binds that came out of the "deriving" process
) `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
tcSetEnv final_env $
+ -- foreign export declarations next.
+ tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
-- Second pass over class and instance declarations,
-- to compile the bindings themselves.
tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
-
-
-- Check that "main" has the right signature
tcCheckMainSig mod_name `thenTc_`
-- during the generalisation step.)
-- trace "tc9" $
let
- lie_alldecls = lie_valdecls `plusLIE` lie_instdecls `plusLIE` lie_clasdecls
+ lie_alldecls = lie_valdecls `plusLIE`
+ lie_instdecls `plusLIE`
+ lie_clasdecls `plusLIE`
+ lie_fodecls
in
tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
val_binds `AndMonoBinds`
inst_binds `AndMonoBinds`
cls_binds `AndMonoBinds`
- const_inst_binds
+ const_inst_binds `AndMonoBinds`
+ foe_binds
in
- zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
+ zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
+ tcSetGlobalValEnv really_final_env $
+ zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
returnTc (really_final_env,
- (all_binds', local_tycons, local_classes, inst_info, ddump_deriv))
+ (all_binds',local_tycons, local_classes,
+ inst_info, foi_decls ++ foe_decls', ddump_deriv))
-- End of outer fix loop
) `thenTc` \ (final_env, stuff) ->
projects / ghc-hetmet.git / commitdiff