Implememt -fdefer-type-errors (Trac #5624)
[ghc.git] / compiler / typecheck / TcForeign.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1998
4 %
5 \section[TcForeign]{Typechecking \tr{foreign} declarations}
6
7 A foreign declaration is used to either give an externally
8 implemented function a Haskell type (and calling interface) or
9 give a Haskell function an external calling interface. Either way,
10 the range of argument and result types these functions can accommodate
11 is restricted to what the outside world understands (read C), and this
12 module checks to see if a foreign declaration has got a legal type.
13
14 \begin{code}
15 module TcForeign
16         (
17           tcForeignImports
18         , tcForeignExports
19         ) where
20
21 #include "HsVersions.h"
22
23 import HsSyn
24
25 import TcRnMonad
26 import TcHsType
27 import TcExpr
28 import TcEnv
29 import RnEnv
30
31 import FamInst
32 import FamInstEnv
33 import Coercion      
34 import Type
35 import TypeRep
36 import ForeignCall
37 import ErrUtils
38 import Id
39 import Name
40 import RdrName
41 import DataCon
42 import TyCon
43 import TcType
44 import PrelNames
45 import DynFlags
46 import Outputable
47 import Platform
48 import SrcLoc
49 import Bag
50 import FastString
51
52 import Control.Monad
53 \end{code}
54
55 \begin{code}
56 -- Defines a binding
57 isForeignImport :: LForeignDecl name -> Bool
58 isForeignImport (L _ (ForeignImport _ _ _ _)) = True
59 isForeignImport _                             = False
60
61 -- Exports a binding
62 isForeignExport :: LForeignDecl name -> Bool
63 isForeignExport (L _ (ForeignExport _ _ _ _)) = True
64 isForeignExport _                             = False
65 \end{code}
66
67 \begin{code}
68 -- normaliseFfiType takes the type from an FFI declaration, and
69 -- evaluates any type synonyms, type functions, and newtypes. However,
70 -- we are only allowed to look through newtypes if the constructor is
71 -- in scope.
72 normaliseFfiType :: Type -> TcM (Coercion, Type)
73 normaliseFfiType ty
74     = do fam_envs <- tcGetFamInstEnvs
75          normaliseFfiType' fam_envs ty
76
77 normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type)
78 normaliseFfiType' env ty0 = go [] ty0
79   where
80     go :: [TyCon] -> Type -> TcM (Coercion, Type)
81     go rec_nts ty | Just ty' <- coreView ty     -- Expand synonyms
82         = go rec_nts ty'
83
84     go rec_nts ty@(TyConApp tc tys)
85         -- We don't want to look through the IO newtype, even if it is
86         -- in scope, so we have a special case for it:
87         | tc_key `elem` [ioTyConKey, funPtrTyConKey]
88         = children_only
89
90         | isNewTyCon tc         -- Expand newtypes
91         -- We can't just use isRecursiveTyCon here, as we need to allow
92         -- some recursive types as described below
93         = if tc `elem` rec_nts  -- See Note [Expanding newtypes] in Type.lhs
94           then -- If this is a recursive newtype then it will normally
95                -- be rejected later as not being a valid FFI type.
96                -- Sometimes recursion is OK though, e.g. with
97                --     newtype T = T (Ptr T)
98                -- we don't reject the type for being recursive.
99                return (Refl ty, ty)
100           else do newtypeOK <- do env <- getGblEnv
101                                   case tyConSingleDataCon_maybe tc of
102                                       Just dataCon ->
103                                           case lookupGRE_Name (tcg_rdr_env env) $ dataConName dataCon of
104                                               [gre] ->
105                                                   do -- If we look through a newtype constructor, then we need it to be in scope.
106                                                      -- But if this is the only use if that import then we'll get an unused import
107                                                      -- warning, so we need to mark a valid RdrName for it as used.
108                                                      case gre_prov gre of
109                                                          Imported (is : _) ->
110                                                              do let modName = is_as (is_decl is)
111                                                                     occName = nameOccName (dataConName dataCon)
112                                                                     rdrName = mkRdrQual modName occName
113                                                                 addUsedRdrNames [rdrName]
114                                                          Imported [] ->
115                                                              panic "normaliseFfiType': Imported []"
116                                                          LocalDef ->
117                                                              return ()
118                                                      return True
119                                               [] ->
120                                                   return False
121                                               _ ->
122                                                   panic "normaliseFfiType': Got more GREs than expected"
123                                       _ ->
124                                           return False
125                   when (not newtypeOK) $
126                      -- later: stop_here
127                     addWarnTc (ptext (sLit "newtype") <+> quotes (ppr tc) <+>
128                                ptext (sLit "is used in an FFI declaration,") $$
129                                ptext (sLit "but its constructor is not in scope.") $$
130                                ptext (sLit "This will become an error in GHC 7.6.1."))
131
132                   let nt_co = mkAxInstCo (newTyConCo tc) tys
133                   add_co nt_co rec_nts' nt_rhs
134
135         | isFamilyTyCon tc              -- Expand open tycons
136         , (co, ty) <- normaliseTcApp env tc tys
137         , not (isReflCo co)
138         = add_co co rec_nts ty
139
140         | otherwise
141         = return (mkReflCo ty, ty)
142             -- If we have reached an ordinary (non-newtype) type constructor,
143             -- we are done.  Note that we don't need to normalise the arguments,
144             -- because whether an FFI type is legal or not depends only on
145             -- the top-level type constructor (e.g. "Ptr a" is valid for all a).
146         where
147           tc_key = getUnique tc
148           children_only = do xs <- mapM (go rec_nts) tys
149                              let (cos, tys') = unzip xs
150                              return (mkTyConAppCo tc cos, mkTyConApp tc tys')
151           nt_rhs = newTyConInstRhs tc tys
152           rec_nts' | isRecursiveTyCon tc = tc:rec_nts
153                    | otherwise           = rec_nts
154
155     go rec_nts (AppTy ty1 ty2)
156       = do (coi1, nty1) <- go rec_nts ty1
157            (coi2, nty2) <- go rec_nts ty2
158            return (mkAppCo coi1 coi2, mkAppTy nty1 nty2)
159
160     go rec_nts (FunTy ty1 ty2)
161       = do (coi1,nty1) <- go rec_nts ty1
162            (coi2,nty2) <- go rec_nts ty2
163            return (mkFunCo coi1 coi2, mkFunTy nty1 nty2)
164
165     go rec_nts (ForAllTy tyvar ty1)
166       = do (coi,nty1) <- go rec_nts ty1
167            return (mkForAllCo tyvar coi, ForAllTy tyvar nty1)
168
169     go _ ty@(TyVarTy _)
170       = return (Refl ty, ty)
171
172     add_co co rec_nts ty
173         = do (co', ty') <- go rec_nts ty
174              return (mkTransCo co co', ty')
175 \end{code}
176
177 %************************************************************************
178 %*                                                                      *
179 \subsection{Imports}
180 %*                                                                      *
181 %************************************************************************
182
183 \begin{code}
184 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
185 tcForeignImports decls
186   = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
187
188 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
189 tcFImport fo@(ForeignImport (L loc nm) hs_ty _ imp_decl)
190   = addErrCtxt (foreignDeclCtxt fo)  $
191     do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
192        ; (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty
193        ; let
194            -- Drop the foralls before inspecting the
195            -- structure of the foreign type.
196              (_, t_ty)         = tcSplitForAllTys norm_sig_ty
197              (arg_tys, res_ty) = tcSplitFunTys t_ty
198              id                = mkLocalId nm sig_ty
199                  -- Use a LocalId to obey the invariant that locally-defined
200                  -- things are LocalIds.  However, it does not need zonking,
201                  -- (so TcHsSyn.zonkForeignExports ignores it).
202
203        ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
204           -- Can't use sig_ty here because sig_ty :: Type and
205           -- we need HsType Id hence the undefined
206        ; return (id, ForeignImport (L loc id) undefined (mkSymCo norm_co) imp_decl') }
207 tcFImport d = pprPanic "tcFImport" (ppr d)
208 \end{code}
209
210
211 ------------ Checking types for foreign import ----------------------
212 \begin{code}
213 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
214
215 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _))
216   = ASSERT( null arg_tys )
217     do { checkCg checkCOrAsmOrLlvmOrInterp
218        ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
219        ; return idecl }      -- NB check res_ty not sig_ty!
220                              --    In case sig_ty is (forall a. ForeignPtr a)
221
222 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do
223         -- Foreign wrapper (former f.e.d.)
224         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
225         -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
226         -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
227         -- is DEPRECATED, though.
228     checkCg checkCOrAsmOrLlvmOrInterp
229     checkCConv cconv
230     case arg_tys of
231         [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
232                         checkForeignRes nonIOok  checkSafe isFFIExportResultTy res1_ty
233                         checkForeignRes mustBeIO checkSafe isFFIDynResultTy    res_ty
234                                  -- ToDo: Why are res1_ty and res_ty not equal?
235                   where
236                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
237         _ -> addErrTc (illegalForeignTyErr empty sig_ty)
238     return idecl
239
240 tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target))
241   | isDynamicTarget target = do -- Foreign import dynamic
242       checkCg checkCOrAsmOrLlvmOrInterp
243       checkCConv cconv
244       case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
245         []                -> do
246           check False (illegalForeignTyErr empty sig_ty)
247           return idecl
248         (arg1_ty:arg_tys) -> do
249           dflags <- getDOpts
250           check (isFFIDynArgumentTy arg1_ty)
251                 (illegalForeignTyErr argument arg1_ty)
252           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
253           checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
254           return idecl
255   | cconv == PrimCallConv = do
256       dflags <- getDOpts
257       check (xopt Opt_GHCForeignImportPrim dflags)
258             (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
259       checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
260       checkCTarget target
261       check (playSafe safety)
262             (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
263       checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
264       -- prim import result is more liberal, allows (#,,#)
265       checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
266       return idecl
267   | otherwise = do              -- Normal foreign import
268       checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
269       checkCConv cconv
270       checkCTarget target
271       dflags <- getDOpts
272       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
273       checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
274       checkMissingAmpersand dflags arg_tys res_ty
275       return idecl
276
277
278 -- This makes a convenient place to check
279 -- that the C identifier is valid for C
280 checkCTarget :: CCallTarget -> TcM ()
281 checkCTarget (StaticTarget str _) = do
282     checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
283     check (isCLabelString str) (badCName str)
284
285 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
286
287
288 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
289 checkMissingAmpersand dflags arg_tys res_ty
290   | null arg_tys && isFunPtrTy res_ty &&
291     wopt Opt_WarnDodgyForeignImports dflags
292   = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
293   | otherwise
294   = return ()
295 \end{code}
296
297 %************************************************************************
298 %*                                                                      *
299 \subsection{Exports}
300 %*                                                                      *
301 %************************************************************************
302
303 \begin{code}
304 tcForeignExports :: [LForeignDecl Name]
305                  -> TcM (LHsBinds TcId, [LForeignDecl TcId])
306 tcForeignExports decls
307   = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
308   where
309    combine (binds, fs) fe = do
310        (b, f) <- wrapLocSndM tcFExport fe
311        return (b `consBag` binds, f:fs)
312
313 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
314 tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec)
315   = addErrCtxt (foreignDeclCtxt fo) $ do
316
317     sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
318     rhs <- tcPolyExpr (nlHsVar nm) sig_ty
319
320     (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty
321
322     tcCheckFEType norm_sig_ty spec
323
324            -- we're exporting a function, but at a type possibly more
325            -- constrained than its declared/inferred type. Hence the need
326            -- to create a local binding which will call the exported function
327            -- at a particular type (and, maybe, overloading).
328
329
330     -- We need to give a name to the new top-level binding that
331     -- is *stable* (i.e. the compiler won't change it later),
332     -- because this name will be referred to by the C code stub.
333     id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
334     return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec)
335 tcFExport d = pprPanic "tcFExport" (ppr d)
336 \end{code}
337
338 ------------ Checking argument types for foreign export ----------------------
339
340 \begin{code}
341 tcCheckFEType :: Type -> ForeignExport -> TcM ()
342 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
343     checkCg checkCOrAsmOrLlvm
344     check (isCLabelString str) (badCName str)
345     checkCConv cconv
346     checkForeignArgs isFFIExternalTy arg_tys
347     checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
348   where
349       -- Drop the foralls before inspecting n
350       -- the structure of the foreign type.
351     (_, t_ty) = tcSplitForAllTys sig_ty
352     (arg_tys, res_ty) = tcSplitFunTys t_ty
353 \end{code}
354
355
356
357 %************************************************************************
358 %*                                                                      *
359 \subsection{Miscellaneous}
360 %*                                                                      *
361 %************************************************************************
362
363 \begin{code}
364 ------------ Checking argument types for foreign import ----------------------
365 checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
366 checkForeignArgs pred tys = mapM_ go tys
367   where go ty = check (pred ty) (illegalForeignTyErr argument ty)
368
369 ------------ Checking result types for foreign calls ----------------------
370 -- | Check that the type has the form
371 --    (IO t) or (t) , and that t satisfies the given predicate.
372 -- When calling this function, any newtype wrappers (should) have been
373 -- already dealt with by normaliseFfiType.
374 -- 
375 -- We also check that the Safe Haskell condition of FFI imports having
376 -- results in the IO monad holds.
377 --
378 checkForeignRes :: Bool -> Bool -> (Type -> Bool) -> Type -> TcM ()
379 checkForeignRes non_io_result_ok check_safe pred_res_ty ty
380   = case tcSplitIOType_maybe ty of
381         -- Got an IO result type, that's always fine!
382         Just (_, res_ty) | pred_res_ty res_ty -> return ()
383
384         -- Case for non-IO result type with FFI Import
385         _ -> do
386             dflags <- getDOpts
387             case (pred_res_ty ty && non_io_result_ok) of
388                 -- handle normal typecheck fail, we want to handle this first and
389                 -- only report safe haskell errors if the normal type check is OK.
390                 False -> addErrTc $ illegalForeignTyErr result ty
391
392                 -- handle safe infer fail
393                 _ | check_safe && safeInferOn dflags
394                     -> recordUnsafeInfer
395
396                 -- handle safe language typecheck fail
397                 _ | check_safe && safeLanguageOn dflags
398                     -> addErrTc $ illegalForeignTyErr result ty $+$ safeHsErr
399
400                 -- sucess! non-IO return is fine
401                 _ -> return ()
402
403   where 
404     safeHsErr = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad"
405
406 nonIOok, mustBeIO :: Bool
407 nonIOok  = True
408 mustBeIO = False
409
410 checkSafe, noCheckSafe :: Bool
411 checkSafe   = True
412 noCheckSafe = False
413 \end{code}
414
415 Checking a supported backend is in use
416
417 \begin{code}
418 checkCOrAsmOrLlvm :: HscTarget -> Maybe SDoc
419 checkCOrAsmOrLlvm HscC    = Nothing
420 checkCOrAsmOrLlvm HscAsm  = Nothing
421 checkCOrAsmOrLlvm HscLlvm = Nothing
422 checkCOrAsmOrLlvm _
423   = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
424
425 checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
426 checkCOrAsmOrLlvmOrInterp HscC           = Nothing
427 checkCOrAsmOrLlvmOrInterp HscAsm         = Nothing
428 checkCOrAsmOrLlvmOrInterp HscLlvm        = Nothing
429 checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
430 checkCOrAsmOrLlvmOrInterp _
431   = Just (text "requires interpreted, C, Llvm or native code generation")
432
433 checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
434 checkCOrAsmOrLlvmOrDotNetOrInterp HscC           = Nothing
435 checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm         = Nothing
436 checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm        = Nothing
437 checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
438 checkCOrAsmOrLlvmOrDotNetOrInterp _
439   = Just (text "requires interpreted, C, Llvm or native code generation")
440
441 checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
442 checkCg check = do
443     dflags <- getDOpts
444     let target = hscTarget dflags
445     case target of
446       HscNothing -> return ()
447       _ ->
448         case check target of
449           Nothing  -> return ()
450           Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
451 \end{code}
452
453 Calling conventions
454
455 \begin{code}
456 checkCConv :: CCallConv -> TcM ()
457 checkCConv CCallConv    = return ()
458 checkCConv CApiConv     = return ()
459 checkCConv StdCallConv  = do dflags <- getDOpts
460                              let platform = targetPlatform dflags
461                              unless (platformArch platform == ArchX86) $
462                                  -- This is a warning, not an error. see #3336
463                                  addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
464 checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
465 checkCConv CmmCallConv  = panic "checkCConv CmmCallConv"
466 \end{code}
467
468 Warnings
469
470 \begin{code}
471 check :: Bool -> MsgDoc -> TcM ()
472 check True _       = return ()
473 check _    the_err = addErrTc the_err
474
475 illegalForeignTyErr :: SDoc -> Type -> SDoc
476 illegalForeignTyErr arg_or_res ty
477   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
478                 ptext (sLit "type in foreign declaration:")])
479        2 (hsep [ppr ty])
480
481 -- Used for 'arg_or_res' argument to illegalForeignTyErr
482 argument, result :: SDoc
483 argument = text "argument"
484 result   = text "result"
485
486 badCName :: CLabelString -> MsgDoc
487 badCName target
488   = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
489
490 foreignDeclCtxt :: ForeignDecl Name -> SDoc
491 foreignDeclCtxt fo
492   = hang (ptext (sLit "When checking declaration:"))
493        2 (ppr fo)
494 \end{code}