303391fcddd15a63d161be1f4110c6ece2170d11
[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 {-# LANGUAGE CPP #-}
16
17 module TcForeign
18         ( tcForeignImports
19         , tcForeignExports
20
21         -- Low-level exports for hooks
22         , isForeignImport, isForeignExport
23         , tcFImport, tcFExport
24         , tcForeignImports'
25         , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
26         , normaliseFfiType
27         , nonIOok, mustBeIO
28         , checkSafe, noCheckSafe
29         , tcForeignExports'
30         , tcCheckFEType
31         ) where
32
33 #include "HsVersions.h"
34
35 import HsSyn
36
37 import TcRnMonad
38 import TcHsType
39 import TcExpr
40 import TcEnv
41
42 import FamInst
43 import FamInstEnv
44 import Coercion
45 import Type
46 import TypeRep
47 import ForeignCall
48 import ErrUtils
49 import Id
50 import Name
51 import RdrName
52 import DataCon
53 import TyCon
54 import TcType
55 import PrelNames
56 import DynFlags
57 import Outputable
58 import Platform
59 import SrcLoc
60 import Bag
61 import FastString
62 import Hooks
63
64 import Control.Monad
65 \end{code}
66
67 \begin{code}
68 -- Defines a binding
69 isForeignImport :: LForeignDecl name -> Bool
70 isForeignImport (L _ (ForeignImport _ _ _ _)) = True
71 isForeignImport _                             = False
72
73 -- Exports a binding
74 isForeignExport :: LForeignDecl name -> Bool
75 isForeignExport (L _ (ForeignExport _ _ _ _)) = True
76 isForeignExport _                             = False
77 \end{code}
78
79 Note [Don't recur in normaliseFfiType']
80 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
81 normaliseFfiType' is the workhorse for normalising a type used in a foreign
82 declaration. If we have
83
84 newtype Age = MkAge Int
85
86 we want to see that Age -> IO () is the same as Int -> IO (). But, we don't
87 need to recur on any type parameters, because no paramaterized types (with
88 interesting parameters) are marshalable! The full list of marshalable types
89 is in the body of boxedMarshalableTyCon in TcType. The only members of that
90 list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled
91 the same way regardless of type parameter. So, no need to recur into
92 parameters.
93
94 Similarly, we don't need to look in AppTy's, because nothing headed by
95 an AppTy will be marshalable.
96
97 Note [FFI type roles]
98 ~~~~~~~~~~~~~~~~~~~~~
99 The 'go' helper function within normaliseFfiType' always produces
100 representational coercions. But, in the "children_only" case, we need to
101 use these coercions in a TyConAppCo. Accordingly, the roles on the coercions
102 must be twiddled to match the expectation of the enclosing TyCon. However,
103 we cannot easily go from an R coercion to an N one, so we forbid N roles
104 on FFI type constructors. Currently, only two such type constructors exist:
105 IO and FunPtr. Thus, this is not an onerous burden.
106
107 If we ever want to lift this restriction, we would need to make 'go' take
108 the target role as a parameter. This wouldn't be hard, but it's a complication
109 not yet necessary and so is not yet implemented.
110
111 \begin{code}
112 -- normaliseFfiType takes the type from an FFI declaration, and
113 -- evaluates any type synonyms, type functions, and newtypes. However,
114 -- we are only allowed to look through newtypes if the constructor is
115 -- in scope.  We return a bag of all the newtype constructors thus found.
116 -- Always returns a Representational coercion
117 normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
118 normaliseFfiType ty
119     = do fam_envs <- tcGetFamInstEnvs
120          normaliseFfiType' fam_envs ty
121
122 normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
123 normaliseFfiType' env ty0 = go initRecTc ty0
124   where
125     go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
126     go rec_nts ty | Just ty' <- coreView ty     -- Expand synonyms
127         = go rec_nts ty'
128
129     go rec_nts ty@(TyConApp tc tys)
130         -- We don't want to look through the IO newtype, even if it is
131         -- in scope, so we have a special case for it:
132         | tc_key `elem` [ioTyConKey, funPtrTyConKey]
133                   -- These *must not* have nominal roles on their parameters!
134                   -- See Note [FFI type roles]
135         = children_only
136
137         | isNewTyCon tc         -- Expand newtypes
138         , Just rec_nts' <- checkRecTc rec_nts tc
139                    -- See Note [Expanding newtypes] in TyCon.lhs
140                    -- We can't just use isRecursiveTyCon; sometimes recursion is ok:
141                    --     newtype T = T (Ptr T)
142                    --   Here, we don't reject the type for being recursive.
143                    -- If this is a recursive newtype then it will normally
144                    -- be rejected later as not being a valid FFI type.
145         = do { rdr_env <- getGlobalRdrEnv 
146              ; case checkNewtypeFFI rdr_env tc of
147                  Nothing  -> nothing
148                  Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs
149                                 ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }
150
151         | isFamilyTyCon tc              -- Expand open tycons
152         , (co, ty) <- normaliseTcApp env Representational tc tys
153         , not (isReflCo co)
154         = do (co', ty', gres) <- go rec_nts ty
155              return (mkTransCo co co', ty', gres)  
156
157         | otherwise
158         = nothing -- see Note [Don't recur in normaliseFfiType']
159         where
160           tc_key = getUnique tc
161           children_only
162             = do xs <- mapM (go rec_nts) tys
163                  let (cos, tys', gres) = unzip3 xs
164                         -- the (repeat Representational) is because 'go' always
165                         -- returns R coercions
166                      cos' = zipWith3 downgradeRole (tyConRoles tc)
167                                      (repeat Representational) cos
168                  return ( mkTyConAppCo Representational tc cos'
169                         , mkTyConApp tc tys', unionManyBags gres)
170           nt_co  = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys
171           nt_rhs = newTyConInstRhs tc tys
172           nothing = return (Refl Representational ty, ty, emptyBag)
173
174     go rec_nts (FunTy ty1 ty2)
175       = do (coi1,nty1,gres1) <- go rec_nts ty1
176            (coi2,nty2,gres2) <- go rec_nts ty2
177            return (mkFunCo Representational coi1 coi2, mkFunTy nty1 nty2, gres1 `unionBags` gres2)
178
179     go rec_nts (ForAllTy tyvar ty1)
180       = do (coi,nty1,gres1) <- go rec_nts ty1
181            return (mkForAllCo tyvar coi, ForAllTy tyvar nty1, gres1)
182
183     go _ ty@(TyVarTy {}) = return (Refl Representational ty, ty, emptyBag)
184     go _ ty@(LitTy {})   = return (Refl Representational ty, ty, emptyBag)
185     go _ ty@(AppTy {})   = return (Refl Representational ty, ty, emptyBag)
186          -- See Note [Don't recur in normaliseFfiType']
187
188 checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
189 checkNewtypeFFI rdr_env tc 
190   | Just con <- tyConSingleDataCon_maybe tc
191   , [gre] <- lookupGRE_Name rdr_env (dataConName con)
192   = Just gre    -- See Note [Newtype constructor usage in foreign declarations]
193   | otherwise
194   = Nothing
195 \end{code}
196
197 Note [Newtype constructor usage in foreign declarations]
198 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
199 GHC automatically "unwraps" newtype constructors in foreign import/export
200 declarations.  In effect that means that a newtype data constructor is 
201 used even though it is not mentioned expclitly in the source, so we don't
202 want to report it as "defined but not used" or "imported but not used".
203 eg     newtype D = MkD Int
204        foreign import foo :: D -> IO ()
205 Here 'MkD' us used.  See Trac #7408.
206
207 GHC also expands type functions during this process, so it's not enough
208 just to look at the free variables of the declaration.  
209 eg     type instance F Bool = D
210        foreign import bar :: F Bool -> IO ()
211 Here again 'MkD' is used.
212
213 So we really have wait until the type checker to decide what is used.
214 That's why tcForeignImports and tecForeignExports return a (Bag GRE)
215 for the newtype constructors they see. Then TcRnDriver can add them 
216 to the module's usages.
217
218
219 %************************************************************************
220 %*                                                                      *
221 \subsection{Imports}
222 %*                                                                      *
223 %************************************************************************
224
225 \begin{code}
226 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)
227 tcForeignImports decls
228   = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)
229
230 tcForeignImports' :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)
231 -- For the (Bag GlobalRdrElt) result, 
232 -- see Note [Newtype constructor usage in foreign declarations]
233 tcForeignImports' decls
234   = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $
235                                filter isForeignImport decls
236        ; return (ids, decls, unionManyBags gres) }
237
238 tcFImport :: LForeignDecl Name -> TcM (Id, LForeignDecl Id, Bag GlobalRdrElt)
239 tcFImport (L dloc fo@(ForeignImport (L nloc nm) hs_ty _ imp_decl))
240   = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo)  $
241     do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
242        ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
243        ; let
244            -- Drop the foralls before inspecting the
245            -- structure of the foreign type.
246              (_, t_ty)         = tcSplitForAllTys norm_sig_ty
247              (arg_tys, res_ty) = tcSplitFunTys t_ty
248              id                = mkLocalId nm sig_ty
249                  -- Use a LocalId to obey the invariant that locally-defined
250                  -- things are LocalIds.  However, it does not need zonking,
251                  -- (so TcHsSyn.zonkForeignExports ignores it).
252
253        ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
254           -- Can't use sig_ty here because sig_ty :: Type and
255           -- we need HsType Id hence the undefined
256        ; let fi_decl = ForeignImport (L nloc id) undefined (mkSymCo norm_co) imp_decl'
257        ; return (id, L dloc fi_decl, gres) }
258 tcFImport d = pprPanic "tcFImport" (ppr d)
259 \end{code}
260
261
262 ------------ Checking types for foreign import ----------------------
263 \begin{code}
264 tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport
265
266 tcCheckFIType arg_tys res_ty (CImport cconv safety mh l@(CLabel _))
267   -- Foreign import label
268   = do checkCg checkCOrAsmOrLlvmOrInterp
269        -- NB check res_ty not sig_ty!
270        --    In case sig_ty is (forall a. ForeignPtr a)
271        check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr empty)
272        cconv' <- checkCConv cconv
273        return (CImport cconv' safety mh l)
274
275 tcCheckFIType arg_tys res_ty (CImport cconv safety mh CWrapper) = do
276         -- Foreign wrapper (former f.e.d.)
277         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
278         -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.
279         -- The use of the latter form is DEPRECATED, though.
280     checkCg checkCOrAsmOrLlvmOrInterp
281     cconv' <- checkCConv cconv
282     case arg_tys of
283         [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
284                         checkForeignRes nonIOok  checkSafe isFFIExportResultTy res1_ty
285                         checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
286                   where
287                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
288         _ -> addErrTc (illegalForeignTyErr empty (ptext (sLit "One argument expected")))
289     return (CImport cconv' safety mh CWrapper)
290
291 tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target))
292   | isDynamicTarget target = do -- Foreign import dynamic
293       checkCg checkCOrAsmOrLlvmOrInterp
294       cconv' <- checkCConv cconv
295       case arg_tys of           -- The first arg must be Ptr or FunPtr
296         []                -> 
297           addErrTc (illegalForeignTyErr empty (ptext (sLit "At least one argument expected")))
298         (arg1_ty:arg_tys) -> do
299           dflags <- getDynFlags
300           let curried_res_ty = foldr FunTy res_ty arg_tys
301           check (isFFIDynTy curried_res_ty arg1_ty)
302                 (illegalForeignTyErr argument)
303           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
304           checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
305       return $ CImport cconv' safety mh (CFunction target)
306   | cconv == PrimCallConv = do
307       dflags <- getDynFlags
308       checkTc (xopt Opt_GHCForeignImportPrim dflags)
309               (text "Use GHCForeignImportPrim to allow `foreign import prim'.")
310       checkCg checkCOrAsmOrLlvmOrInterp
311       checkCTarget target
312       checkTc (playSafe safety)
313               (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
314       checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
315       -- prim import result is more liberal, allows (#,,#)
316       checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
317       return idecl
318   | otherwise = do              -- Normal foreign import
319       checkCg checkCOrAsmOrLlvmOrInterp
320       cconv' <- checkCConv cconv
321       checkCTarget target
322       dflags <- getDynFlags
323       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
324       checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
325       checkMissingAmpersand dflags arg_tys res_ty
326       case target of
327           StaticTarget _ _ False
328            | not (null arg_tys) ->
329               addErrTc (text "`value' imports cannot have function types")
330           _ -> return ()
331       return $ CImport cconv' safety mh (CFunction target)
332
333
334 -- This makes a convenient place to check
335 -- that the C identifier is valid for C
336 checkCTarget :: CCallTarget -> TcM ()
337 checkCTarget (StaticTarget str _ _) = do
338     checkCg checkCOrAsmOrLlvmOrInterp
339     checkTc (isCLabelString str) (badCName str)
340
341 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
342
343
344 checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
345 checkMissingAmpersand dflags arg_tys res_ty
346   | null arg_tys && isFunPtrTy res_ty &&
347     wopt Opt_WarnDodgyForeignImports dflags
348   = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
349   | otherwise
350   = return ()
351 \end{code}
352
353 %************************************************************************
354 %*                                                                      *
355 \subsection{Exports}
356 %*                                                                      *
357 %************************************************************************
358
359 \begin{code}
360 tcForeignExports :: [LForeignDecl Name]
361                  -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)
362 tcForeignExports decls =
363   getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls)
364
365 tcForeignExports' :: [LForeignDecl Name]
366                  -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)
367 -- For the (Bag GlobalRdrElt) result, 
368 -- see Note [Newtype constructor usage in foreign declarations]
369 tcForeignExports' decls
370   = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
371   where
372    combine (binds, fs, gres1) (L loc fe) = do
373        (b, f, gres2) <- setSrcSpan loc (tcFExport fe)
374        return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
375
376 tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id, Bag GlobalRdrElt)
377 tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec)
378   = addErrCtxt (foreignDeclCtxt fo) $ do
379
380     sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
381     rhs <- tcPolyExpr (nlHsVar nm) sig_ty
382
383     (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
384
385     spec' <- tcCheckFEType norm_sig_ty spec
386
387            -- we're exporting a function, but at a type possibly more
388            -- constrained than its declared/inferred type. Hence the need
389            -- to create a local binding which will call the exported function
390            -- at a particular type (and, maybe, overloading).
391
392
393     -- We need to give a name to the new top-level binding that
394     -- is *stable* (i.e. the compiler won't change it later),
395     -- because this name will be referred to by the C code stub.
396     id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
397     return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec', gres)
398 tcFExport d = pprPanic "tcFExport" (ppr d)
399 \end{code}
400
401 ------------ Checking argument types for foreign export ----------------------
402
403 \begin{code}
404 tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
405 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
406     checkCg checkCOrAsmOrLlvm
407     checkTc (isCLabelString str) (badCName str)
408     cconv' <- checkCConv cconv
409     checkForeignArgs isFFIExternalTy arg_tys
410     checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
411     return (CExport (CExportStatic str cconv'))
412   where
413       -- Drop the foralls before inspecting n
414       -- the structure of the foreign type.
415     (_, t_ty) = tcSplitForAllTys sig_ty
416     (arg_tys, res_ty) = tcSplitFunTys t_ty
417 \end{code}
418
419
420
421 %************************************************************************
422 %*                                                                      *
423 \subsection{Miscellaneous}
424 %*                                                                      *
425 %************************************************************************
426
427 \begin{code}
428 ------------ Checking argument types for foreign import ----------------------
429 checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM ()
430 checkForeignArgs pred tys = mapM_ go tys
431   where
432     go ty = check (pred ty) (illegalForeignTyErr argument)
433
434 ------------ Checking result types for foreign calls ----------------------
435 -- | Check that the type has the form
436 --    (IO t) or (t) , and that t satisfies the given predicate.
437 -- When calling this function, any newtype wrappers (should) have been
438 -- already dealt with by normaliseFfiType.
439 -- 
440 -- We also check that the Safe Haskell condition of FFI imports having
441 -- results in the IO monad holds.
442 --
443 checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
444 checkForeignRes non_io_result_ok check_safe pred_res_ty ty
445   | Just (_, res_ty) <- tcSplitIOType_maybe ty
446   =     -- Got an IO result type, that's always fine!
447      check (pred_res_ty res_ty) (illegalForeignTyErr result)
448
449   -- Case for non-IO result type with FFI Import
450   | not non_io_result_ok
451   = addErrTc $ illegalForeignTyErr result (ptext (sLit "IO result type expected"))
452
453   | otherwise
454   = do { dflags <- getDynFlags
455        ; case pred_res_ty ty of
456                 -- Handle normal typecheck fail, we want to handle this first and
457                 -- only report safe haskell errors if the normal type check is OK.
458            NotValid msg -> addErrTc $ illegalForeignTyErr result msg
459
460            -- handle safe infer fail
461            _ | check_safe && safeInferOn dflags
462                -> recordUnsafeInfer
463
464            -- handle safe language typecheck fail
465            _ | check_safe && safeLanguageOn dflags
466                -> addErrTc (illegalForeignTyErr result safeHsErr)
467
468            -- sucess! non-IO return is fine
469            _ -> return () }
470   where
471     safeHsErr = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad"
472
473 nonIOok, mustBeIO :: Bool
474 nonIOok  = True
475 mustBeIO = False
476
477 checkSafe, noCheckSafe :: Bool
478 checkSafe   = True
479 noCheckSafe = False
480 \end{code}
481
482 Checking a supported backend is in use
483
484 \begin{code}
485 checkCOrAsmOrLlvm :: HscTarget -> Validity
486 checkCOrAsmOrLlvm HscC    = IsValid
487 checkCOrAsmOrLlvm HscAsm  = IsValid
488 checkCOrAsmOrLlvm HscLlvm = IsValid
489 checkCOrAsmOrLlvm _
490   = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
491
492 checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity
493 checkCOrAsmOrLlvmOrInterp HscC           = IsValid
494 checkCOrAsmOrLlvmOrInterp HscAsm         = IsValid
495 checkCOrAsmOrLlvmOrInterp HscLlvm        = IsValid
496 checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid
497 checkCOrAsmOrLlvmOrInterp _
498   = NotValid (text "requires interpreted, unregisterised, llvm or native code generation")
499
500 checkCg :: (HscTarget -> Validity) -> TcM ()
501 checkCg check = do
502     dflags <- getDynFlags
503     let target = hscTarget dflags
504     case target of
505       HscNothing -> return ()
506       _ ->
507         case check target of
508           IsValid      -> return ()
509           NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err)
510 \end{code}
511
512 Calling conventions
513
514 \begin{code}
515 checkCConv :: CCallConv -> TcM CCallConv
516 checkCConv CCallConv    = return CCallConv
517 checkCConv CApiConv     = return CApiConv
518 checkCConv StdCallConv  = do dflags <- getDynFlags
519                              let platform = targetPlatform dflags
520                              if platformArch platform == ArchX86
521                                  then return StdCallConv
522                                  else do -- This is a warning, not an error. see #3336
523                                          when (wopt Opt_WarnUnsupportedCallingConventions dflags) $
524                                              addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
525                                          return CCallConv
526 checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
527                              return PrimCallConv
528 checkCConv JavaScriptCallConv = do dflags <- getDynFlags
529                                    if platformArch (targetPlatform dflags) == ArchJavaScript
530                                        then return JavaScriptCallConv
531                                        else do addErrTc (text "The `javascript' calling convention is unsupported on this platform")
532                                                return JavaScriptCallConv
533 \end{code}
534
535 Warnings
536
537 \begin{code}
538 check :: Validity -> (MsgDoc -> MsgDoc) -> TcM ()
539 check IsValid _             = return ()
540 check (NotValid doc) err_fn = addErrTc (err_fn doc)
541
542 illegalForeignTyErr :: SDoc -> SDoc -> SDoc
543 illegalForeignTyErr arg_or_res extra
544   = hang msg 2 extra
545   where
546     msg = hsep [ ptext (sLit "Unacceptable"), arg_or_res
547                , ptext (sLit "type in foreign declaration:")]
548
549 -- Used for 'arg_or_res' argument to illegalForeignTyErr
550 argument, result :: SDoc
551 argument = text "argument"
552 result   = text "result"
553
554 badCName :: CLabelString -> MsgDoc
555 badCName target
556   = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
557
558 foreignDeclCtxt :: ForeignDecl Name -> SDoc
559 foreignDeclCtxt fo
560   = hang (ptext (sLit "When checking declaration:"))
561        2 (ppr fo)
562 \end{code}