never executed always true always false
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1998
4
5 -}
6
7
8 {-# LANGUAGE TypeFamilies #-}
9 {-# LANGUAGE TypeApplications #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 {-# LANGUAGE RankNTypes #-}
12 {-# LANGUAGE ViewPatterns #-}
13
14 -- | Typechecking @foreign@ declarations
15 --
16 -- A foreign declaration is used to either give an externally
17 -- implemented function a Haskell type (and calling interface) or
18 -- give a Haskell function an external calling interface. Either way,
19 -- the range of argument and result types these functions can accommodate
20 -- is restricted to what the outside world understands (read C), and this
21 -- module checks to see if a foreign declaration has got a legal type.
22 module GHC.Tc.Gen.Foreign
23 ( tcForeignImports
24 , tcForeignExports
25
26 -- Low-level exports for hooks
27 , isForeignImport, isForeignExport
28 , tcFImport, tcFExport
29 , tcForeignImports'
30 , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
31 , normaliseFfiType
32 , nonIOok, mustBeIO
33 , checkSafe, noCheckSafe
34 , tcForeignExports'
35 , tcCheckFEType
36 ) where
37
38 import GHC.Prelude
39
40 import GHC.Hs
41
42 import GHC.Tc.Errors.Types
43 import GHC.Tc.Utils.Monad
44 import GHC.Tc.Gen.HsType
45 import GHC.Tc.Gen.Expr
46 import GHC.Tc.Utils.Env
47
48 import GHC.Tc.Instance.Family
49 import GHC.Core.FamInstEnv
50 import GHC.Core.Coercion
51 import GHC.Core.Reduction
52 import GHC.Core.Type
53 import GHC.Core.Multiplicity
54 import GHC.Types.ForeignCall
55 import GHC.Utils.Error
56 import GHC.Types.Id
57 import GHC.Types.Name
58 import GHC.Types.Name.Reader
59 import GHC.Core.DataCon
60 import GHC.Core.TyCon
61 import GHC.Core.TyCon.RecWalk
62 import GHC.Tc.Utils.TcType
63 import GHC.Builtin.Names
64 import GHC.Driver.Session
65 import GHC.Driver.Backend
66 import GHC.Utils.Outputable as Outputable
67 import GHC.Utils.Panic
68 import GHC.Platform
69 import GHC.Types.SrcLoc
70 import GHC.Data.Bag
71 import GHC.Driver.Hooks
72 import qualified GHC.LanguageExtensions as LangExt
73
74 import Control.Monad ( zipWithM )
75 import Control.Monad.Trans.Writer.CPS
76 ( WriterT, runWriterT, tell )
77 import Control.Monad.Trans.Class
78 ( lift )
79
80 -- Defines a binding
81 isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
82 isForeignImport (unXRec @name -> ForeignImport {}) = True
83 isForeignImport _ = False
84
85 -- Exports a binding
86 isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
87 isForeignExport (unXRec @name -> ForeignExport {}) = True
88 isForeignExport _ = False
89
90 {-
91 Note [Don't recur in normaliseFfiType']
92 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
93 normaliseFfiType' is the workhorse for normalising a type used in a foreign
94 declaration. If we have
95
96 newtype Age = MkAge Int
97
98 we want to see that Age -> IO () is the same as Int -> IO (). But, we don't
99 need to recur on any type parameters, because no paramaterized types (with
100 interesting parameters) are marshalable! The full list of marshalable types
101 is in the body of boxedMarshalableTyCon in GHC.Tc.Utils.TcType. The only members of that
102 list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled
103 the same way regardless of type parameter. So, no need to recur into
104 parameters.
105
106 Similarly, we don't need to look in AppTy's, because nothing headed by
107 an AppTy will be marshalable.
108 -}
109
110 -- normaliseFfiType takes the type from an FFI declaration, and
111 -- evaluates any type synonyms, type functions, and newtypes. However,
112 -- we are only allowed to look through newtypes if the constructor is
113 -- in scope. We return a bag of all the newtype constructors thus found.
114 -- Always returns a Representational coercion
115 normaliseFfiType :: Type -> TcM (Reduction, Bag GlobalRdrElt)
116 normaliseFfiType ty
117 = do fam_envs <- tcGetFamInstEnvs
118 normaliseFfiType' fam_envs ty
119
120 normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
121 normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0
122 where
123 go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction
124 go role rec_nts ty
125 | Just ty' <- tcView ty -- Expand synonyms
126 = go role rec_nts ty'
127
128 | Just (tc, tys) <- splitTyConApp_maybe ty
129 = go_tc_app role rec_nts tc tys
130
131 | (bndrs, inner_ty) <- splitForAllTyCoVarBinders ty
132 , not (null bndrs)
133 = do redn <- go role rec_nts inner_ty
134 return $ mkHomoForAllRedn bndrs redn
135
136 | otherwise -- see Note [Don't recur in normaliseFfiType']
137 = return $ mkReflRedn role ty
138
139 go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]
140 -> WriterT (Bag GlobalRdrElt) TcM Reduction
141 go_tc_app role rec_nts tc tys
142 -- We don't want to look through the IO newtype, even if it is
143 -- in scope, so we have a special case for it:
144 | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey]
145 = children_only
146
147 | isNewTyCon tc -- Expand newtypes
148 , Just rec_nts' <- checkRecTc rec_nts tc
149 -- See Note [Expanding newtypes] in GHC.Core.TyCon
150 -- We can't just use isRecursiveTyCon; sometimes recursion is ok:
151 -- newtype T = T (Ptr T)
152 -- Here, we don't reject the type for being recursive.
153 -- If this is a recursive newtype then it will normally
154 -- be rejected later as not being a valid FFI type.
155 = do { rdr_env <- lift $ getGlobalRdrEnv
156 ; case checkNewtypeFFI rdr_env tc of
157 Nothing -> nothing
158 Just gre ->
159 do { redn <- go role rec_nts' nt_rhs
160 ; tell (unitBag gre)
161 ; return $ nt_co `mkTransRedn` redn } }
162
163 | isFamilyTyCon tc -- Expand open tycons
164 , Reduction co ty <- normaliseTcApp env role tc tys
165 , not (isReflexiveCo co)
166 = do redn <- go role rec_nts ty
167 return $ co `mkTransRedn` redn
168
169 | otherwise
170 = nothing -- see Note [Don't recur in normaliseFfiType']
171 where
172 tc_key = getUnique tc
173 children_only
174 = do { args <- unzipRedns <$>
175 zipWithM ( \ ty r -> go r rec_nts ty )
176 tys (tyConRolesX role tc)
177 ; return $ mkTyConAppRedn role tc args }
178 nt_co = mkUnbranchedAxInstCo role (newTyConCo tc) tys []
179 nt_rhs = newTyConInstRhs tc tys
180
181 ty = mkTyConApp tc tys
182 nothing = return $ mkReflRedn role ty
183
184 checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
185 checkNewtypeFFI rdr_env tc
186 | Just con <- tyConSingleDataCon_maybe tc
187 , Just gre <- lookupGRE_Name rdr_env (dataConName con)
188 = Just gre -- See Note [Newtype constructor usage in foreign declarations]
189 | otherwise
190 = Nothing
191
192 {-
193 Note [Newtype constructor usage in foreign declarations]
194 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
195 GHC automatically "unwraps" newtype constructors in foreign import/export
196 declarations. In effect that means that a newtype data constructor is
197 used even though it is not mentioned expclitly in the source, so we don't
198 want to report it as "defined but not used" or "imported but not used".
199 eg newtype D = MkD Int
200 foreign import foo :: D -> IO ()
201 Here 'MkD' us used. See #7408.
202
203 GHC also expands type functions during this process, so it's not enough
204 just to look at the free variables of the declaration.
205 eg type instance F Bool = D
206 foreign import bar :: F Bool -> IO ()
207 Here again 'MkD' is used.
208
209 So we really have wait until the type checker to decide what is used.
210 That's why tcForeignImports and tecForeignExports return a (Bag GRE)
211 for the newtype constructors they see. Then GHC.Tc.Module can add them
212 to the module's usages.
213
214
215 ************************************************************************
216 * *
217 \subsection{Imports}
218 * *
219 ************************************************************************
220 -}
221
222 tcForeignImports :: [LForeignDecl GhcRn]
223 -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
224 tcForeignImports decls = do
225 hooks <- getHooks
226 case tcForeignImportsHook hooks of
227 Nothing -> tcForeignImports' decls
228 Just h -> h decls
229
230 tcForeignImports' :: [LForeignDecl GhcRn]
231 -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
232 -- For the (Bag GlobalRdrElt) result,
233 -- see Note [Newtype constructor usage in foreign declarations]
234 tcForeignImports' decls
235 = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $
236 filter isForeignImport decls
237 ; return (ids, decls, unionManyBags gres) }
238
239 tcFImport :: LForeignDecl GhcRn
240 -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
241 tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
242 , fd_fi = imp_decl }))
243 = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo) $
244 do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
245 ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
246 ; let
247 -- Drop the foralls before inspecting the
248 -- structure of the foreign type.
249 (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty)
250 id = mkLocalId nm Many sig_ty
251 -- Use a LocalId to obey the invariant that locally-defined
252 -- things are LocalIds. However, it does not need zonking,
253 -- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it).
254
255 ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
256 -- Can't use sig_ty here because sig_ty :: Type and
257 -- we need HsType Id hence the undefined
258 ; let fi_decl = ForeignImport { fd_name = L nloc id
259 , fd_sig_ty = undefined
260 , fd_i_ext = mkSymCo norm_co
261 , fd_fi = imp_decl' }
262 ; return (id, L dloc fi_decl, gres) }
263 tcFImport d = pprPanic "tcFImport" (ppr d)
264
265 -- ------------ Checking types for foreign import ----------------------
266
267 tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
268
269 tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)
270 -- Foreign import label
271 = do checkCg checkCOrAsmOrLlvmOrInterp
272 -- NB check res_ty not sig_ty!
273 -- In case sig_ty is (forall a. ForeignPtr a)
274 check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
275 cconv' <- checkCConv cconv
276 return (CImport (L lc cconv') safety mh l src)
277
278 tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do
279 -- Foreign wrapper (former f.e.d.)
280 -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
281 -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too.
282 -- The use of the latter form is DEPRECATED, though.
283 checkCg checkCOrAsmOrLlvmOrInterp
284 cconv' <- checkCConv cconv
285 case arg_tys of
286 [Scaled arg1_mult arg1_ty] -> do
287 checkNoLinearFFI arg1_mult
288 checkForeignArgs isFFIExternalTy arg1_tys
289 checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty
290 checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
291 where
292 (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
293 _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected"))
294 return (CImport (L lc cconv') safety mh CWrapper src)
295
296 tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
297 (CFunction target) src)
298 | isDynamicTarget target = do -- Foreign import dynamic
299 checkCg checkCOrAsmOrLlvmOrInterp
300 cconv' <- checkCConv cconv
301 case arg_tys of -- The first arg must be Ptr or FunPtr
302 [] ->
303 addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))
304 (Scaled arg1_mult arg1_ty:arg_tys) -> do
305 dflags <- getDynFlags
306 let curried_res_ty = mkVisFunTys arg_tys res_ty
307 checkNoLinearFFI arg1_mult
308 check (isFFIDynTy curried_res_ty arg1_ty)
309 (illegalForeignTyErr argument)
310 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
311 checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
312 return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
313 | cconv == PrimCallConv = do
314 dflags <- getDynFlags
315 checkTc (xopt LangExt.GHCForeignImportPrim dflags)
316 (TcRnUnknownMessage $ mkPlainError noHints $
317 text "Use GHCForeignImportPrim to allow `foreign import prim'.")
318 checkCg checkCOrAsmOrLlvmOrInterp
319 checkCTarget target
320 checkTc (playSafe safety)
321 (TcRnUnknownMessage $ mkPlainError noHints $
322 text "The safe/unsafe annotation should not be used with `foreign import prim'.")
323 checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
324 -- prim import result is more liberal, allows (#,,#)
325 checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
326 return idecl
327 | otherwise = do -- Normal foreign import
328 checkCg checkCOrAsmOrLlvmOrInterp
329 cconv' <- checkCConv cconv
330 checkCTarget target
331 dflags <- getDynFlags
332 checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
333 checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
334 checkMissingAmpersand (map scaledThing arg_tys) res_ty
335 case target of
336 StaticTarget _ _ _ False
337 | not (null arg_tys) ->
338 addErrTc (TcRnUnknownMessage $ mkPlainError noHints $
339 text "`value' imports cannot have function types")
340 _ -> return ()
341 return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
342
343
344 -- This makes a convenient place to check
345 -- that the C identifier is valid for C
346 checkCTarget :: CCallTarget -> TcM ()
347 checkCTarget (StaticTarget _ str _ _) = do
348 checkCg checkCOrAsmOrLlvmOrInterp
349 checkTc (isCLabelString str) (badCName str)
350
351 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
352
353
354 checkMissingAmpersand :: [Type] -> Type -> TcM ()
355 checkMissingAmpersand arg_tys res_ty
356 | null arg_tys && isFunPtrTy res_ty
357 = addDiagnosticTc $ TcRnUnknownMessage $
358 mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyForeignImports) noHints
359 (text "possible missing & in foreign import of FunPtr")
360 | otherwise
361 = return ()
362
363 {-
364 ************************************************************************
365 * *
366 \subsection{Exports}
367 * *
368 ************************************************************************
369 -}
370
371 tcForeignExports :: [LForeignDecl GhcRn]
372 -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
373 tcForeignExports decls = do
374 hooks <- getHooks
375 case tcForeignExportsHook hooks of
376 Nothing -> tcForeignExports' decls
377 Just h -> h decls
378
379 tcForeignExports' :: [LForeignDecl GhcRn]
380 -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
381 -- For the (Bag GlobalRdrElt) result,
382 -- see Note [Newtype constructor usage in foreign declarations]
383 tcForeignExports' decls
384 = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
385 where
386 combine (binds, fs, gres1) (L loc fe) = do
387 (b, f, gres2) <- setSrcSpanA loc (tcFExport fe)
388 return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
389
390 tcFExport :: ForeignDecl GhcRn
391 -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
392 tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec })
393 = addErrCtxt (foreignDeclCtxt fo) $ do
394
395 sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
396 rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty
397
398 (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
399
400 spec' <- tcCheckFEType norm_sig_ty spec
401
402 -- we're exporting a function, but at a type possibly more
403 -- constrained than its declared/inferred type. Hence the need
404 -- to create a local binding which will call the exported function
405 -- at a particular type (and, maybe, overloading).
406
407
408 -- We need to give a name to the new top-level binding that
409 -- is *stable* (i.e. the compiler won't change it later),
410 -- because this name will be referred to by the C code stub.
411 id <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc
412 return ( mkVarBind id rhs
413 , ForeignExport { fd_name = L loc id
414 , fd_sig_ty = undefined
415 , fd_e_ext = norm_co
416 , fd_fe = spec' }
417 , gres)
418 tcFExport d = pprPanic "tcFExport" (ppr d)
419
420 -- ------------ Checking argument types for foreign export ----------------------
421
422 tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
423 tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do
424 checkCg checkCOrAsmOrLlvm
425 checkTc (isCLabelString str) (badCName str)
426 cconv' <- checkCConv cconv
427 checkForeignArgs isFFIExternalTy arg_tys
428 checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
429 return (CExport (L l (CExportStatic esrc str cconv')) src)
430 where
431 -- Drop the foralls before inspecting
432 -- the structure of the foreign type.
433 (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty)
434
435 {-
436 ************************************************************************
437 * *
438 \subsection{Miscellaneous}
439 * *
440 ************************************************************************
441 -}
442
443 ------------ Checking argument types for foreign import ----------------------
444 checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM ()
445 checkForeignArgs pred tys = mapM_ go tys
446 where
447 go (Scaled mult ty) = checkNoLinearFFI mult >>
448 check (pred ty) (illegalForeignTyErr argument)
449
450 checkNoLinearFFI :: Mult -> TcM () -- No linear types in FFI (#18472)
451 checkNoLinearFFI Many = return ()
452 checkNoLinearFFI _ = addErrTc $ illegalForeignTyErr argument
453 (text "Linear types are not supported in FFI declarations, see #18472")
454
455 ------------ Checking result types for foreign calls ----------------------
456 -- | Check that the type has the form
457 -- (IO t) or (t) , and that t satisfies the given predicate.
458 -- When calling this function, any newtype wrappers (should) have been
459 -- already dealt with by normaliseFfiType.
460 --
461 -- We also check that the Safe Haskell condition of FFI imports having
462 -- results in the IO monad holds.
463 --
464 checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
465 checkForeignRes non_io_result_ok check_safe pred_res_ty ty
466 | Just (_, res_ty) <- tcSplitIOType_maybe ty
467 = -- Got an IO result type, that's always fine!
468 check (pred_res_ty res_ty) (illegalForeignTyErr result)
469
470 -- We disallow nested foralls in foreign types
471 -- (at least, for the time being). See #16702.
472 | tcIsForAllTy ty
473 = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall")
474
475 -- Case for non-IO result type with FFI Import
476 | not non_io_result_ok
477 = addErrTc $ illegalForeignTyErr result (text "IO result type expected")
478
479 | otherwise
480 = do { dflags <- getDynFlags
481 ; case pred_res_ty ty of
482 -- Handle normal typecheck fail, we want to handle this first and
483 -- only report safe haskell errors if the normal type check is OK.
484 NotValid msg -> addErrTc $ illegalForeignTyErr result msg
485
486 -- handle safe infer fail
487 _ | check_safe && safeInferOn dflags
488 -> recordUnsafeInfer emptyMessages
489
490 -- handle safe language typecheck fail
491 _ | check_safe && safeLanguageOn dflags
492 -> addErrTc (illegalForeignTyErr result safeHsErr)
493
494 -- success! non-IO return is fine
495 _ -> return () }
496 where
497 safeHsErr =
498 text "Safe Haskell is on, all FFI imports must be in the IO monad"
499
500 nonIOok, mustBeIO :: Bool
501 nonIOok = True
502 mustBeIO = False
503
504 checkSafe, noCheckSafe :: Bool
505 checkSafe = True
506 noCheckSafe = False
507
508 -- | Checking a supported backend is in use
509 checkCOrAsmOrLlvm :: Backend -> Validity
510 checkCOrAsmOrLlvm ViaC = IsValid
511 checkCOrAsmOrLlvm NCG = IsValid
512 checkCOrAsmOrLlvm LLVM = IsValid
513 checkCOrAsmOrLlvm _
514 = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
515
516 -- | Checking a supported backend is in use
517 checkCOrAsmOrLlvmOrInterp :: Backend -> Validity
518 checkCOrAsmOrLlvmOrInterp ViaC = IsValid
519 checkCOrAsmOrLlvmOrInterp NCG = IsValid
520 checkCOrAsmOrLlvmOrInterp LLVM = IsValid
521 checkCOrAsmOrLlvmOrInterp Interpreter = IsValid
522 checkCOrAsmOrLlvmOrInterp _
523 = NotValid (text "requires interpreted, unregisterised, llvm or native code generation")
524
525 checkCg :: (Backend -> Validity) -> TcM ()
526 checkCg check = do
527 dflags <- getDynFlags
528 let bcknd = backend dflags
529 case bcknd of
530 NoBackend -> return ()
531 _ ->
532 case check bcknd of
533 IsValid -> return ()
534 NotValid err ->
535 addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal foreign declaration:" <+> err)
536
537 -- Calling conventions
538
539 checkCConv :: CCallConv -> TcM CCallConv
540 checkCConv CCallConv = return CCallConv
541 checkCConv CApiConv = return CApiConv
542 checkCConv StdCallConv = do dflags <- getDynFlags
543 let platform = targetPlatform dflags
544 if platformArch platform == ArchX86
545 then return StdCallConv
546 else do -- This is a warning, not an error. see #3336
547 let msg = TcRnUnknownMessage $
548 mkPlainDiagnostic (WarningWithFlag Opt_WarnUnsupportedCallingConventions)
549 noHints
550 (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
551 addDiagnosticTc msg
552 return CCallConv
553 checkCConv PrimCallConv = do
554 addErrTc $ TcRnUnknownMessage $ mkPlainError noHints
555 (text "The `prim' calling convention can only be used with `foreign import'")
556 return PrimCallConv
557 checkCConv JavaScriptCallConv = do dflags <- getDynFlags
558 if platformArch (targetPlatform dflags) == ArchJavaScript
559 then return JavaScriptCallConv
560 else do
561 addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $
562 (text "The `javascript' calling convention is unsupported on this platform")
563 return JavaScriptCallConv
564
565 -- Warnings
566
567 check :: Validity -> (SDoc -> TcRnMessage) -> TcM ()
568 check IsValid _ = return ()
569 check (NotValid doc) err_fn = addErrTc (err_fn doc)
570
571 illegalForeignTyErr :: SDoc -> SDoc -> TcRnMessage
572 illegalForeignTyErr arg_or_res extra
573 = TcRnUnknownMessage $ mkPlainError noHints $ hang msg 2 extra
574 where
575 msg = hsep [ text "Unacceptable", arg_or_res
576 , text "type in foreign declaration:"]
577
578 -- Used for 'arg_or_res' argument to illegalForeignTyErr
579 argument, result :: SDoc
580 argument = text "argument"
581 result = text "result"
582
583 badCName :: CLabelString -> TcRnMessage
584 badCName target
585 = TcRnUnknownMessage $ mkPlainError noHints $
586 sep [quotes (ppr target) <+> text "is not a valid C identifier"]
587
588 foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
589 foreignDeclCtxt fo
590 = hang (text "When checking declaration:")
591 2 (ppr fo)