[project @ 2000-10-17 12:48:34 by sewardj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcForeign.lhs

diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 883103d..c8d61d2 100644 (file)
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -21,42 +21,41 @@ module TcForeign
 
 import HsSyn           ( HsDecl(..), ForeignDecl(..), HsExpr(..),
                          ExtName(Dynamic), isDynamicExtName, MonoBinds(..),
-                         OutPat(..), ForKind(..)
+                         ForKind(..)
                        )
 import RnHsSyn         ( RenamedHsDecl, RenamedForeignDecl )
 
 import TcMonad
 import TcEnv           ( newLocalId )
-import TcType          ( tcSplitRhoTy, zonkTcTypeToType )
-import TcMonoType      ( tcHsSigType, tcHsBoxedSigType )
+import TcMonoType      ( tcHsBoxedSigType )
 import TcHsSyn         ( TcMonoBinds, TypecheckedForeignDecl,
                          TcForeignExportDecl )
-import TcExpr          ( tcId, tcPolyExpr )                    
+import TcExpr          ( tcPolyExpr )                  
 import Inst            ( emptyLIE, LIE, plusLIE )
 
 import ErrUtils                ( Message )
-import Id              ( Id, idName, mkVanillaId )
+import Id              ( Id, mkVanillaId )
 import Name            ( nameOccName )
 import Type            ( splitFunTys
                        , splitTyConApp_maybe
                        , splitForAllTys
                        )
 import TysWiredIn      ( isFFIArgumentTy, isFFIResultTy, 
-                         isFFIExternalTy, isAddrTy,
-                         isFFIDynResultTy, isFFILabelTy
+                         isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
+                         isFFILabelTy
                        )
 import Type             ( Type )
-import Unique
+import PrelNames       ( hasKey, ioTyConKey )
 import Outputable
 
 \end{code}
 
 \begin{code}
-tcForeignImports :: [RenamedHsDecl] -> TcM s ([Id], [TypecheckedForeignDecl])
+tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
 tcForeignImports decls = 
    mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
 
-tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE, TcMonoBinds, [TcForeignExportDecl])
+tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
 tcForeignExports decls = 
    foldlTc combine (emptyLIE, EmptyMonoBinds, [])
                   [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
@@ -81,7 +80,7 @@ isForeignExport _                                   = False
 \end{code}
 
 \begin{code}
-tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
+tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
 tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
    tcAddSrcLoc src_loc              $
    tcAddErrCtxt (foreignDeclCtxt fo) $
@@ -115,7 +114,7 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_
    tcAddSrcLoc src_loc              $
    tcAddErrCtxt (foreignDeclCtxt fo) $
 
-   tcHsSigType hs_ty                `thenTc` \ ty ->
+   tcHsBoxedSigType hs_ty                   `thenTc` \ ty ->
     -- Check that the type has the right shape
     -- and that the argument and result types are acceptable.
    let
@@ -129,7 +128,7 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_
        let i = (mkVanillaId nm ty) in
        returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
 
-tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl)
+tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
 tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc              $
    tcAddErrCtxt (foreignDeclCtxt fo) $
@@ -161,26 +160,28 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
 
 
 \begin{code}
-checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM s ()
+checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM ()
 checkForeignImport is_dynamic is_safe 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 is_safe)) xs   `thenTc_`
+       getDOptsTc                                              `thenTc` \ dflags ->
+        check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
+        mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) xs    `thenTc_`
        checkForeignRes True {-NonIO ok-} isFFIResultTy res
  | otherwise =
-     mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args     `thenTc_`
+     getDOptsTc                                                           `thenTc` \ dflags ->
+     mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) args `thenTc_`
      checkForeignRes True {-NonIO ok-} isFFIResultTy res
 
-checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()
+checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM ()
 checkForeignExport is_dynamic ty args res
  | is_dynamic = 
     -- * the first (and only!) arg has got to be a function type
     --   and it must return IO t
-    -- * result type is an Addr or IO Addr
+    -- * result type is IO Addr
    case args of
      [arg]  ->
        case splitFunTys arg of
@@ -193,13 +194,13 @@ checkForeignExport is_dynamic ty args res
      mapTc (checkForeignArg isFFIExternalTy) args              `thenTc_`
      checkForeignRes True {-NonIO ok-} isFFIResultTy res
  
-checkForeignArg :: (Type -> Bool) -> Type -> TcM s ()
+checkForeignArg :: (Type -> Bool) -> Type -> TcM ()
 checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
 
 -- Check that the type has the form 
 --    (IO t) or (t) , and that t satisfies the given predicate.
 --
-checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM s ()
+checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
 checkForeignRes non_io_result_ok pred_res_ty ty =
  case (splitTyConApp_maybe ty) of
     Just (io, [res_ty]) 
@@ -213,7 +214,7 @@ checkForeignRes non_io_result_ok pred_res_ty ty =
 Warnings
 
 \begin{code}
-check :: Bool -> Message -> TcM s ()
+check :: Bool -> Message -> TcM ()
 check True _      = returnTc ()
 check _    the_err = addErrTc the_err `thenNF_Tc_` returnTc ()