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                           ExtName(..), isDynamic, MonoBinds(..),
  24                           OutPat(..)
  25                         )
  26 import RnHsSyn          ( RenamedHsDecl, RenamedForeignDecl )
  27
  28 import TcMonad
  29 import TcEnv            ( tcLookupClassByKey, newLocalId, tcLookupGlobalValue )
  30 import TcType           ( tcInstTcType, tcInstSigType, tcSplitRhoTy, zonkTcTypeToType )
  31 import TcMonoType       ( tcHsType )
  32 import TcHsSyn          ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl, TcIdOcc(..),
  33                           TcForeignExportDecl )
  34 import TcExpr           ( tcId, tcPolyExpr )
  35 import Inst             ( emptyLIE, LIE, plusLIE )
  36 import CoreSyn
  37
  38 import ErrUtils         ( Message )
  39 import Id               ( Id, idName )
  40 import Name             ( nameOccName )
  41 import MkId             ( mkUserId )
  42 import Type             ( isUnpointedType
  43                         , splitFunTys
  44                         , splitTyConApp_maybe
  45                         , splitForAllTys
  46                         , splitRhoTy
  47                         , isForAllTy
  48                         , mkForAllTys
  49                         )
  50 import TyVar            ( emptyTyVarEnv )
  51
  52
  53 import TysWiredIn       ( isFFIArgumentTy, isFFIResultTy,
  54                           isFFIExternalTy, isAddrTy
  55                         )
  56 import Type             ( Type )
  57 import Unique
  58 import Unify            ( unifyTauTy )
  59 import Outputable
  60 import Util
  61 import CmdLineOpts      ( opt_GlasgowExts )
  62 import Maybes           ( maybeToBool )
  63
  64 \end{code}
  65
  66 \begin{code}
  67 tcForeignImports :: [RenamedHsDecl] -> TcM s ([Id], [TypecheckedForeignDecl])
  68 tcForeignImports decls =
  69    mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
  70
  71 tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE s, TcMonoBinds s, [TcForeignExportDecl s])
  72 tcForeignExports decls =
  73    foldlTc combine (emptyLIE, EmptyMonoBinds, [])
  74                    [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
  75   where
  76    combine (lie, binds, fs) fe =
  77        tcFExport fe `thenTc ` \ (a_lie, b, f) ->
  78        returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
  79
  80 -- defines a binding
  81 isForeignImport :: ForeignDecl name -> Bool
  82 isForeignImport (ForeignDecl _ (Just _) _ _ _ _)      = True
  83 isForeignImport (ForeignDecl _ Nothing _ Dynamic _ _) = True
  84 isForeignImport _                                     = False
  85
  86 -- exports a binding
  87 isForeignExport :: ForeignDecl name -> Bool
  88 isForeignExport (ForeignDecl _ Nothing _ ext_nm _ _) = not (isDynamic ext_nm)
  89 isForeignExport _                                    = False
  90
  91 \end{code}
  92
  93 \begin{code}
  94 tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
  95 tcFImport fo@(ForeignDecl nm Nothing hs_ty Dynamic cconv src_loc) =
  96    tcAddSrcLoc src_loc               $
  97    tcAddErrCtxt (foreignDeclCtxt fo) $
  98    tcHsType hs_ty                   `thenTc`    \ sig_ty ->
  99    let
 100       -- drop the foralls before inspecting the structure
 101       -- of the foreign type.
 102     (_, t_ty) = splitForAllTys sig_ty
 103    in
 104    case splitFunTys t_ty of
 105      (arg_tys, res_ty) ->
 106         checkForeignExport True t_ty arg_tys res_ty `thenTc_`
 107         let i = (mkUserId nm sig_ty) in
 108         returnTc (i, (ForeignDecl i Nothing undefined Dynamic cconv src_loc))
 109
 110 tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
 111    tcAddSrcLoc src_loc               $
 112    tcAddErrCtxt (foreignDeclCtxt fo) $
 113
 114    tcHsType hs_ty                    `thenTc` \ ty ->
 115     -- Check that the type has the right shape
 116     -- and that the argument and result types are acceptable.
 117    let
 118       -- drop the foralls before inspecting the structure
 119       -- of the foreign type.
 120     (_, t_ty) = splitForAllTys ty
 121    in
 122    case splitFunTys t_ty of
 123      (arg_tys, res_ty) ->
 124         checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_`
 125         let i = (mkUserId nm ty) in
 126         returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
 127
 128 tcFExport :: RenamedForeignDecl -> TcM s (LIE s, TcMonoBinds s, TcForeignExportDecl s)
 129 tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
 130    tcAddSrcLoc src_loc               $
 131    tcAddErrCtxt (foreignDeclCtxt fo) $
 132
 133    tcHsType hs_ty                   `thenTc`    \ sig_ty ->
 134    tcInstSigType sig_ty             `thenNF_Tc` \ sig_tc_ty ->
 135    tcPolyExpr (HsVar nm) sig_tc_ty  `thenTc`    \ (rhs, lie, _, _, _) ->
 136
 137    let
 138       -- drop the foralls before inspecting the structure
 139       -- of the foreign type.
 140     (_, t_ty) = splitForAllTys sig_ty
 141    in
 142    case splitFunTys t_ty of
 143      (arg_tys, res_ty) ->
 144         checkForeignExport False t_ty arg_tys res_ty `thenTc_`
 145           -- we're exporting a function, but at a type possibly more constrained
 146           -- than its declared/inferred type. Hence the need
 147           -- to create a local binding which will call the exported function
 148           -- at a particular type (and, maybe, overloading).
 149         newLocalId (nameOccName nm) sig_tc_ty   `thenNF_Tc` \ i ->
 150         let
 151             i2    = TcId i
 152             bind  = VarMonoBind i2 rhs
 153         in
 154         returnTc (lie, bind, ForeignDecl i2 imp_exp undefined ext_nm cconv src_loc)
 155         --                                          ^^^^^^^^^
 156         -- ToDo: fill the type field in with something sensible.
 157
 158 \end{code}
 159
 160
 161 \begin{code}
 162 checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s ()
 163 checkForeignImport is_dynamic ty args res
 164  | is_dynamic =
 165     -- * first arg has got to be an Addr
 166    case args of
 167      []     -> check False (illegalForeignTyErr True{-Arg-} ty)
 168      (x:xs) ->
 169         check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
 170         mapTc (checkForeignArg isFFIArgumentTy) xs              `thenTc_`
 171         checkForeignRes (isFFIResultTy) res
 172  | otherwise =
 173      mapTc (checkForeignArg isFFIArgumentTy) args               `thenTc_`
 174      checkForeignRes (isFFIResultTy) res
 175
 176 checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()
 177 checkForeignExport is_dynamic ty args res
 178  | is_dynamic =
 179     -- * the first (and only!) arg has got to be a function type
 180     -- * result type is an Addr
 181    case args of
 182      [arg]  ->
 183         case splitFunTys arg of
 184            (arg_tys, res_ty) ->
 185                 mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
 186                 checkForeignRes (isFFIResultTy) res_ty          `thenTc_`
 187                 checkForeignRes (isAddrTy) res
 188      _      -> check False (illegalForeignTyErr True{-Arg-} ty)
 189  | otherwise =
 190      mapTc (checkForeignArg isFFIExternalTy) args               `thenTc_`
 191      checkForeignRes (isFFIResultTy) res
 192
 193 check :: Bool -> Message -> TcM s ()
 194 check True _       = returnTc ()
 195 check _    the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
 196
 197 checkForeignArg :: (Type -> Bool) -> Type -> TcM s ()
 198 checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
 199
 200 -- Check that the type has the form
 201 --    (IO t) and that t satisfies the given predicate.
 202 --
 203 checkForeignRes :: (Type -> Bool) -> Type -> TcM s ()
 204 checkForeignRes pred_res_ty ty =
 205  case (splitTyConApp_maybe ty) of
 206     Just (io, [res_ty])
 207         | (uniqueOf io) == ioTyConKey &&
 208           pred_res_ty res_ty
 209         -> returnTc ()
 210     _   -> check False (illegalForeignTyErr False{-Res-} ty)
 211
 212 \end{code}
 213
 214 Warnings
 215
 216 \begin{code}
 217 illegalForeignTyErr isArg ty
 218   = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration")])
 219          4 (hsep [ ptext SLIT("type:"),  ppr ty])
 220   where
 221    arg_or_res
 222     | isArg     = ptext SLIT("argument")
 223     | otherwise = ptext SLIT("result")
 224
 225 foreignDeclCtxt fo =
 226  hang (ptext SLIT("When checking a foreign declaration:"))
 227   4   (ppr fo)
 228
 229 \end{code}