ghc/compiler/typecheck/TcForeign.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1998
   3 %
   4 \section[TcForeign]{Typechecking \tr{foreign} declarations}
   5
   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.
  12
  13 \begin{code}
  14 module TcForeign
  15         (
  16           tcForeignImports
  17         , tcForeignExports
  18         ) where
  19
  20 #include "HsVersions.h"
  21
  22 import HsSyn            ( HsDecl(..), ForeignDecl(..), HsExpr(..),
  23                           MonoBinds(..), FoImport(..), FoExport(..)
  24                         )
  25 import RnHsSyn          ( RenamedHsDecl, RenamedForeignDecl )
  26
  27 import TcMonad
  28 import TcEnv            ( newLocalId )
  29 import TcMonoType       ( tcHsLiftedSigType )
  30 import TcHsSyn          ( TcMonoBinds, TypecheckedForeignDecl,
  31                           TcForeignExportDecl )
  32 import TcExpr           ( tcPolyExpr )
  33 import Inst             ( emptyLIE, LIE, plusLIE )
  34
  35 import ErrUtils         ( Message )
  36 import Id               ( Id, mkLocalId )
  37 import Name             ( nameOccName )
  38 import Type             ( splitFunTys
  39                         , splitTyConApp_maybe
  40                         , splitForAllTys
  41                         )
  42 import TysWiredIn       ( isFFIArgumentTy, isFFIImportResultTy,
  43                           isFFIExportResultTy,
  44                           isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
  45                           isFFILabelTy
  46                         )
  47 import Type             ( Type )
  48 import ForeignCall      ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget )
  49 import CStrings         ( CLabelString, isCLabelString )
  50 import PrelNames        ( hasKey, ioTyConKey )
  51 import Outputable
  52
  53 \end{code}
  54
  55 \begin{code}
  56 -- Defines a binding
  57 isForeignImport :: ForeignDecl name -> Bool
  58 isForeignImport (ForeignImport _ _ _ _) = True
  59 isForeignImport _                       = False
  60
  61 -- Exports a binding
  62 isForeignExport :: ForeignDecl name -> Bool
  63 isForeignExport (ForeignExport _ _ _ _) = True
  64 isForeignExport _                       = False
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 \subsection{Imports}
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 \begin{code}
  74 tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
  75 tcForeignImports decls =
  76    mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
  77
  78 tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
  79 tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc)
  80  = tcAddSrcLoc src_loc                  $
  81    tcAddErrCtxt (foreignDeclCtxt fo)    $
  82    tcHsLiftedSigType hs_ty              `thenTc`        \ sig_ty ->
  83    let
  84       -- drop the foralls before inspecting the structure
  85       -- of the foreign type.
  86         (_, t_ty)         = splitForAllTys sig_ty
  87         (arg_tys, res_ty) = splitFunTys t_ty
  88         id                = mkLocalId nm sig_ty
  89    in
  90    tcCheckFIType sig_ty arg_tys res_ty imp_decl         `thenNF_Tc_`
  91    returnTc (id, ForeignImport id undefined imp_decl src_loc)
  92 \end{code}
  93
  94
  95 ------------ Checking types for foreign import ----------------------
  96 \begin{code}
  97 tcCheckFIType _ _ _ (DNImport _)
  98   = returnNF_Tc ()      -- No error checking yet
  99
 100 tcCheckFIType sig_ty arg_tys res_ty (LblImport _)
 101   = check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
 102
 103 tcCheckFIType sig_ty arg_tys res_ty (CDynImport _)
 104   =     -- Foreign export dynamic
 105         -- The first (and only!) arg has got to be a function type
 106         -- and it must return IO t; result type is IO Addr
 107     case arg_tys of
 108         [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys                  `thenNF_Tc_`
 109                      checkForeignRes nonIOok  isFFIExportResultTy res1_ty       `thenNF_Tc_`
 110                      checkForeignRes mustBeIO isFFIDynResultTy    res_ty
 111                   where
 112                      (arg1_tys, res1_ty) = splitFunTys arg1_ty
 113         other -> addErrTc (illegalForeignTyErr empty sig_ty)
 114
 115 tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety))
 116   | isDynamicTarget target      -- Foreign import dynamic
 117   = case arg_tys of             -- The first arg must be Addr
 118       []                -> check False (illegalForeignTyErr empty sig_ty)
 119       (arg1_ty:arg_tys) -> getDOptsTc                                                   `thenNF_Tc` \ dflags ->
 120                            check (isFFIDynArgumentTy arg1_ty)
 121                                  (illegalForeignTyErr argument arg1_ty)                 `thenNF_Tc_`
 122                            checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys     `thenNF_Tc_`
 123                            checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 124
 125   | otherwise           -- Normal foreign import
 126   = getDOptsTc                                                  `thenNF_Tc` \ dflags ->
 127     checkCTarget target                                         `thenNF_Tc_`
 128     checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys    `thenNF_Tc_`
 129     checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
 130
 131 -- This makes a convenient place to check
 132 -- that the C identifier is valid for C
 133 checkCTarget (StaticTarget str) | not (isCLabelString str) = addErrTc (badCName str)
 134 checkCTarget other                                         = returnNF_Tc ()
 135 \end{code}
 136
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection{Exports}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144 \begin{code}
 145 tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
 146 tcForeignExports decls =
 147    foldlTc combine (emptyLIE, EmptyMonoBinds, [])
 148                    [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
 149   where
 150    combine (lie, binds, fs) fe =
 151        tcFExport fe `thenTc ` \ (a_lie, b, f) ->
 152        returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
 153
 154 tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
 155 tcFExport fo@(ForeignExport nm hs_ty spec src_loc) =
 156    tcAddSrcLoc src_loc                  $
 157    tcAddErrCtxt (foreignDeclCtxt fo)    $
 158
 159    tcHsLiftedSigType hs_ty             `thenTc` \ sig_ty ->
 160    tcPolyExpr (HsVar nm) sig_ty         `thenTc`    \ (rhs, lie, _, _, _) ->
 161
 162    tcCheckFEType sig_ty spec            `thenTc_`
 163
 164           -- we're exporting a function, but at a type possibly more constrained
 165           -- than its declared/inferred type. Hence the need
 166           -- to create a local binding which will call the exported function
 167           -- at a particular type (and, maybe, overloading).
 168    newLocalId (nameOccName nm) sig_ty src_loc   `thenNF_Tc` \ id ->
 169    let
 170         bind  = VarMonoBind id rhs
 171    in
 172    returnTc (lie, bind, ForeignExport id undefined spec src_loc)
 173 \end{code}
 174
 175 ------------ Checking argument types for foreign export ----------------------
 176
 177 \begin{code}
 178 tcCheckFEType sig_ty (CExport (CExportStatic str _))
 179   = check (isCLabelString str) (badCName str)           `thenNF_Tc_`
 180     checkForeignArgs isFFIExternalTy arg_tys            `thenNF_Tc_`
 181     checkForeignRes nonIOok isFFIExportResultTy res_ty
 182   where
 183       -- Drop the foralls before inspecting n
 184       -- the structure of the foreign type.
 185     (_, t_ty) = splitForAllTys sig_ty
 186     (arg_tys, res_ty) = splitFunTys t_ty
 187 \end{code}
 188
 189
 190
 191 %************************************************************************
 192 %*                                                                      *
 193 \subsection{Miscellaneous}
 194 %*                                                                      *
 195 %************************************************************************
 196
 197 \begin{code}
 198 ------------ Checking argument types for foreign import ----------------------
 199 checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM ()
 200 checkForeignArgs pred tys
 201   = mapNF_Tc go tys     `thenNF_Tc_` returnNF_Tc ()
 202   where
 203     go ty = check (pred ty) (illegalForeignTyErr argument ty)
 204
 205
 206 ------------ Checking result types for foreign calls ----------------------
 207 -- Check that the type has the form
 208 --    (IO t) or (t) , and that t satisfies the given predicate.
 209 --
 210 checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM ()
 211
 212 nonIOok  = True
 213 mustBeIO = False
 214
 215 checkForeignRes non_io_result_ok pred_res_ty ty =
 216  case (splitTyConApp_maybe ty) of
 217     Just (io, [res_ty])
 218         | io `hasKey` ioTyConKey && pred_res_ty res_ty
 219         -> returnNF_Tc ()
 220     _
 221         -> check (non_io_result_ok && pred_res_ty ty)
 222                  (illegalForeignTyErr result ty)
 223 \end{code}
 224
 225 Warnings
 226
 227 \begin{code}
 228 check :: Bool -> Message -> NF_TcM ()
 229 check True _       = returnTc ()
 230 check _    the_err = addErrTc the_err
 231
 232 illegalForeignTyErr arg_or_res ty
 233   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")])
 234          4 (hsep [ppr ty])
 235
 236 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 237 argument = text "argument"
 238 result   = text "result"
 239
 240 badCName :: CLabelString -> Message
 241 badCName target = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
 242
 243 foreignDeclCtxt fo
 244   = hang (ptext SLIT("When checking declaration:"))
 245      4   (ppr fo)
 246 \end{code}