TcForeign.lhs 9.84 KB
Newer Older
sof's avatar
sof committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
%
% (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(..),
23
			  MonoBinds(..), FoImport(..), FoExport(..)
sof's avatar
sof committed
24 25 26 27
			)
import RnHsSyn		( RenamedHsDecl, RenamedForeignDecl )

import TcMonad
28
import TcEnv		( newLocalId )
29
import TcMonoType	( tcHsLiftedSigType )
sof's avatar
sof committed
30
import TcHsSyn		( TcMonoBinds, TypecheckedForeignDecl,
sof's avatar
sof committed
31
			  TcForeignExportDecl )
32
import TcExpr		( tcPolyExpr )			
sof's avatar
sof committed
33 34 35
import Inst		( emptyLIE, LIE, plusLIE )

import ErrUtils		( Message )
36
import Id		( Id, mkLocalId )
sof's avatar
sof committed
37
import Name		( nameOccName )
38 39
import TysWiredIn	( isFFIArgumentTy, isFFIImportResultTy, 
			  isFFIExportResultTy,
40 41
			  isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
			  isFFILabelTy
sof's avatar
sof committed
42
			)
43
import TcType		( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys )
44
import ForeignCall	( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget )
45
import CStrings		( CLabelString, isCLabelString )
46
import PrelNames	( hasKey, ioTyConKey )
47
import CmdLineOpts	( dopt_HscLang, HscLang(..) )
sof's avatar
sof committed
48 49 50 51
import Outputable

\end{code}

52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
\begin{code}
-- Defines a binding
isForeignImport :: ForeignDecl name -> Bool
isForeignImport (ForeignImport _ _ _ _) = True
isForeignImport _			= False

-- Exports a binding
isForeignExport :: ForeignDecl name -> Bool
isForeignExport (ForeignExport _ _ _ _) = True
isForeignExport _	  	        = False
\end{code}

%************************************************************************
%*									*
\subsection{Imports}
%*									*
%************************************************************************

sof's avatar
sof committed
70
\begin{code}
71
tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
sof's avatar
sof committed
72 73 74
tcForeignImports decls = 
   mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]

75 76 77 78 79 80 81 82
tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc)
 = tcAddSrcLoc src_loc			$
   tcAddErrCtxt (foreignDeclCtxt fo)	$
   tcHsLiftedSigType hs_ty		`thenTc`	\ sig_ty ->
   let 
      -- drop the foralls before inspecting the structure
      -- of the foreign type.
83 84
	(_, t_ty)	  = tcSplitForAllTys sig_ty
	(arg_tys, res_ty) = tcSplitFunTys t_ty
85 86 87 88 89 90 91 92 93 94
	id		  = mkLocalId nm sig_ty
   in
   tcCheckFIType sig_ty arg_tys res_ty imp_decl		`thenNF_Tc_` 
   returnTc (id, ForeignImport id undefined imp_decl src_loc)
\end{code}


------------ Checking types for foreign import ----------------------
\begin{code}
tcCheckFIType _ _ _ (DNImport _)
95
  = checkCg checkDotNet
96 97

tcCheckFIType sig_ty arg_tys res_ty (LblImport _)
98 99
  = checkCg checkCOrAsm		`thenNF_Tc_`
    check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
100 101 102 103 104

tcCheckFIType sig_ty arg_tys res_ty (CDynImport _)
  = 	-- Foreign export dynamic
   	-- The first (and only!) arg has got to be a function type
	-- and it must return IO t; result type is IO Addr
105
    checkCg checkCOrAsm		`thenNF_Tc_`
106 107 108 109 110
    case arg_tys of
	[arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys			`thenNF_Tc_`
		     checkForeignRes nonIOok  isFFIExportResultTy res1_ty	`thenNF_Tc_`
		     checkForeignRes mustBeIO isFFIDynResultTy	  res_ty
		  where
111
		     (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
112 113 114 115
        other -> addErrTc (illegalForeignTyErr empty sig_ty)

tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety))
  | isDynamicTarget target	-- Foreign import dynamic
116
  = checkCg checkCOrAsmOrInterp		`thenNF_Tc_`
117
    case arg_tys of		-- The first arg must be Addr
118 119 120 121 122 123 124 125
      []     		-> check False (illegalForeignTyErr empty sig_ty)
      (arg1_ty:arg_tys) -> getDOptsTc							`thenNF_Tc` \ dflags ->
			   check (isFFIDynArgumentTy arg1_ty)
				 (illegalForeignTyErr argument arg1_ty)			`thenNF_Tc_`
			   checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys	`thenNF_Tc_`
			   checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty

  | otherwise 		-- Normal foreign import
126
  = checkCg (if isCasmTarget target
127
	     then checkC else checkCOrAsmOrDotNetOrInterp)	`thenNF_Tc_`
128
    checkCTarget target						`thenNF_Tc_`
129
    getDOptsTc							`thenNF_Tc` \ dflags ->
130 131 132 133 134
    checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys	`thenNF_Tc_`
    checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty

-- This makes a convenient place to check
-- that the C identifier is valid for C
135
checkCTarget (StaticTarget str) 
136
  = checkCg checkCOrAsmOrDotNetOrInterp	 	`thenNF_Tc_`
137 138 139 140
    check (isCLabelString str) (badCName str)

checkCTarget (CasmTarget _)
  = checkCg checkC
141 142 143 144 145 146 147 148 149 150
\end{code}


%************************************************************************
%*									*
\subsection{Exports}
%*									*
%************************************************************************

\begin{code}
151
tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
sof's avatar
sof committed
152 153 154 155 156 157 158 159
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)

160
tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
161 162 163
tcFExport fo@(ForeignExport nm hs_ty spec src_loc) =
   tcAddSrcLoc src_loc			$
   tcAddErrCtxt (foreignDeclCtxt fo)	$
sof's avatar
sof committed
164

165
   tcHsLiftedSigType hs_ty	       `thenTc`	\ sig_ty ->
166 167 168
   tcPolyExpr (HsVar nm) sig_ty		`thenTc`    \ (rhs, lie, _, _, _) ->

   tcCheckFEType sig_ty spec		`thenTc_`
sof's avatar
sof committed
169 170 171 172 173

	  -- 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).
174 175 176 177 178 179 180 181
   newLocalId (nameOccName nm) sig_ty src_loc	`thenNF_Tc` \ id ->
   let
	bind  = VarMonoBind id rhs
   in
   returnTc (lie, bind, ForeignExport id undefined spec src_loc)
\end{code}

------------ Checking argument types for foreign export ----------------------
sof's avatar
sof committed
182

183 184 185 186 187 188 189 190
\begin{code}
tcCheckFEType sig_ty (CExport (CExportStatic str _))
  = check (isCLabelString str) (badCName str)		`thenNF_Tc_`
    checkForeignArgs isFFIExternalTy arg_tys  	        `thenNF_Tc_`
    checkForeignRes nonIOok isFFIExportResultTy res_ty
  where
      -- Drop the foralls before inspecting n
      -- the structure of the foreign type.
191 192
    (_, t_ty) = tcSplitForAllTys sig_ty
    (arg_tys, res_ty) = tcSplitFunTys t_ty
sof's avatar
sof committed
193 194 195
\end{code}


196 197 198 199 200 201 202

%************************************************************************
%*									*
\subsection{Miscellaneous}
%*									*
%************************************************************************

sof's avatar
sof committed
203
\begin{code}
204 205 206 207 208 209
------------ Checking argument types for foreign import ----------------------
checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM ()
checkForeignArgs pred tys
  = mapNF_Tc go tys	`thenNF_Tc_` returnNF_Tc ()
  where
    go ty = check (pred ty) (illegalForeignTyErr argument ty)
sof's avatar
sof committed
210

211 212

------------ Checking result types for foreign calls ----------------------
sof's avatar
sof committed
213
-- Check that the type has the form 
214
--    (IO t) or (t) , and that t satisfies the given predicate.
sof's avatar
sof committed
215
--
216 217 218 219 220
checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM ()

nonIOok  = True
mustBeIO = False

221 222 223
checkForeignRes non_io_result_ok pred_res_ty ty
 = case tcSplitTyConApp_maybe ty of
      Just (io, [res_ty]) 
224
        | io `hasKey` ioTyConKey && pred_res_ty res_ty 
225
	-> returnNF_Tc ()
226
      _   
227
        -> check (non_io_result_ok && pred_res_ty ty) 
228
		 (illegalForeignTyErr result ty)
sof's avatar
sof committed
229 230
\end{code}

231 232 233 234 235 236 237 238 239
\begin{code} 
checkDotNet HscILX = Nothing
checkDotNet other  = Just (text "requires .NET code generation (-filx)")

checkC HscC  = Nothing
checkC other = Just (text "requires C code generation (-fvia-C)")
			   
checkCOrAsm HscC   = Nothing
checkCOrAsm HscAsm = Nothing
240 241 242 243 244 245 246 247
checkCOrAsm other  
   = Just (text "requires via-C or native code generation (-fvia-C)")

checkCOrAsmOrInterp HscC           = Nothing
checkCOrAsmOrInterp HscAsm         = Nothing
checkCOrAsmOrInterp HscInterpreted = Nothing
checkCOrAsmOrInterp other  
   = Just (text "requires interpreted, C or native code generation")
248

249 250 251
checkCOrAsmOrDotNet HscC   = Nothing
checkCOrAsmOrDotNet HscAsm = Nothing
checkCOrAsmOrDotNet HscILX = Nothing
252 253
checkCOrAsmOrDotNet other  
   = Just (text "requires C, native or .NET ILX code generation")
254

255 256 257 258 259 260 261
checkCOrAsmOrDotNetOrInterp HscC           = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm         = Nothing
checkCOrAsmOrDotNetOrInterp HscILX         = Nothing
checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrDotNetOrInterp other  
   = Just (text "requires interpreted, C, native or .NET ILX code generation")

262 263 264 265 266 267 268
checkCg check
 = getDOptsTc		`thenNF_Tc` \ dflags ->
   case check (dopt_HscLang dflags) of
	Nothing  -> returnNF_Tc ()
	Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
\end{code} 
			   
sof's avatar
sof committed
269 270 271
Warnings

\begin{code}
272
check :: Bool -> Message -> NF_TcM ()
273
check True _	   = returnTc ()
274
check _    the_err = addErrTc the_err
275

276
illegalForeignTyErr arg_or_res ty
277 278
  = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, 
                ptext SLIT("type in foreign declaration:")])
279
	 4 (hsep [ppr ty])
sof's avatar
sof committed
280

281 282 283 284 285
-- Used for 'arg_or_res' argument to illegalForeignTyErr
argument = text "argument"
result   = text "result"

badCName :: CLabelString -> Message
286 287
badCName target 
   = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")]
288 289 290

foreignDeclCtxt fo
  = hang (ptext SLIT("When checking declaration:"))
291
         4 (ppr fo)
sof's avatar
sof committed
292
\end{code}