{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1998

-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}

-- | Typechecking @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.
module GHC.Tc.Gen.Foreign
        ( tcForeignImports
        , tcForeignExports

        -- Low-level exports for hooks
        , isForeignImport, isForeignExport
        , tcFImport, tcFExport
        , tcForeignImports'
        , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
        , normaliseFfiType
        , nonIOok, mustBeIO
        , checkSafe, noCheckSafe
        , tcForeignExports'
        , tcCheckFEType
        ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Hs

import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Expr
import GHC.Tc.Utils.Env

import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Types.ForeignCall
import GHC.Utils.Error
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Tc.Utils.TcType
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Utils.Outputable as Outputable
import GHC.Platform
import GHC.Types.SrcLoc
import GHC.Data.Bag
import GHC.Driver.Hooks
import qualified GHC.LanguageExtensions as LangExt

import Control.Monad

-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
isForeignImport :: forall name. LForeignDecl name -> Bool
isForeignImport (L SrcSpan
_ (ForeignImport {})) = Bool
True
isForeignImport GenLocated SrcSpan (ForeignDecl name)
_                        = Bool
False

-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
isForeignExport :: forall name. LForeignDecl name -> Bool
isForeignExport (L SrcSpan
_ (ForeignExport {})) = Bool
True
isForeignExport GenLocated SrcSpan (ForeignDecl name)
_                        = Bool
False

{-
Note [Don't recur in normaliseFfiType']
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
normaliseFfiType' is the workhorse for normalising a type used in a foreign
declaration. If we have

newtype Age = MkAge Int

we want to see that Age -> IO () is the same as Int -> IO (). But, we don't
need to recur on any type parameters, because no paramaterized types (with
interesting parameters) are marshalable! The full list of marshalable types
is in the body of boxedMarshalableTyCon in GHC.Tc.Utils.TcType. The only members of that
list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled
the same way regardless of type parameter. So, no need to recur into
parameters.

Similarly, we don't need to look in AppTy's, because nothing headed by
an AppTy will be marshalable.
-}

-- normaliseFfiType takes the type from an FFI declaration, and
-- evaluates any type synonyms, type functions, and newtypes. However,
-- we are only allowed to look through newtypes if the constructor is
-- in scope.  We return a bag of all the newtype constructors thus found.
-- Always returns a Representational coercion
normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType Type
ty
    = do FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
         FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType' FamInstEnvs
fam_envs Type
ty

normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType' FamInstEnvs
env Type
ty0 = Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
Representational RecTcChecker
initRecTc Type
ty0
  where
    go :: Role -> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
    go :: Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
role RecTcChecker
rec_nts Type
ty
      | Just Type
ty' <- Type -> Maybe Type
tcView Type
ty     -- Expand synonyms
      = Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
role RecTcChecker
rec_nts Type
ty'

      | Just (TyCon
tc, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
      = Role
-> RecTcChecker
-> TyCon
-> [Type]
-> TcM (Coercion, Type, Bag GlobalRdrElt)
go_tc_app Role
role RecTcChecker
rec_nts TyCon
tc [Type]
tys

      | ([TyCoVarBinder]
bndrs, Type
inner_ty) <- Type -> ([TyCoVarBinder], Type)
splitForAllVarBndrs Type
ty
      , Bool -> Bool
not ([TyCoVarBinder] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVarBinder]
bndrs)
      = do (Coercion
coi, Type
nty1, Bag GlobalRdrElt
gres1) <- Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
role RecTcChecker
rec_nts Type
inner_ty
           (Coercion, Type, Bag GlobalRdrElt)
-> TcM (Coercion, Type, Bag GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [TyCoVar] -> Coercion -> Coercion
mkHomoForAllCos ([TyCoVarBinder] -> [TyCoVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyCoVarBinder]
bndrs) Coercion
coi
                  , [TyCoVarBinder] -> Type -> Type
mkForAllTys [TyCoVarBinder]
bndrs Type
nty1, Bag GlobalRdrElt
gres1 )

      | Bool
otherwise -- see Note [Don't recur in normaliseFfiType']
      = (Coercion, Type, Bag GlobalRdrElt)
-> TcM (Coercion, Type, Bag GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Type -> Coercion
mkReflCo Role
role Type
ty, Type
ty, Bag GlobalRdrElt
forall a. Bag a
emptyBag)

    go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]
              -> TcM (Coercion, Type, Bag GlobalRdrElt)
    go_tc_app :: Role
-> RecTcChecker
-> TyCon
-> [Type]
-> TcM (Coercion, Type, Bag GlobalRdrElt)
go_tc_app Role
role RecTcChecker
rec_nts TyCon
tc [Type]
tys
        -- We don't want to look through the IO newtype, even if it is
        -- in scope, so we have a special case for it:
        | Unique
tc_key Unique -> [Unique] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
ioTyConKey, Unique
funPtrTyConKey, Unique
funTyConKey]
        = TcM (Coercion, Type, Bag GlobalRdrElt)
children_only

        | TyCon -> Bool
isNewTyCon TyCon
tc         -- Expand newtypes
        , Just RecTcChecker
rec_nts' <- RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_nts TyCon
tc
                   -- See Note [Expanding newtypes] in GHC.Core.TyCon
                   -- We can't just use isRecursiveTyCon; sometimes recursion is ok:
                   --     newtype T = T (Ptr T)
                   --   Here, we don't reject the type for being recursive.
                   -- If this is a recursive newtype then it will normally
                   -- be rejected later as not being a valid FFI type.
        = do { GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
             ; case GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI GlobalRdrEnv
rdr_env TyCon
tc of
                 Maybe GlobalRdrElt
Nothing  -> TcM (Coercion, Type, Bag GlobalRdrElt)
nothing
                 Just GlobalRdrElt
gre -> do { (Coercion
co', Type
ty', Bag GlobalRdrElt
gres) <- Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
role RecTcChecker
rec_nts' Type
nt_rhs
                                ; (Coercion, Type, Bag GlobalRdrElt)
-> TcM (Coercion, Type, Bag GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion -> Coercion
mkTransCo Coercion
nt_co Coercion
co', Type
ty', GlobalRdrElt
gre GlobalRdrElt -> Bag GlobalRdrElt -> Bag GlobalRdrElt
forall a. a -> Bag a -> Bag a
`consBag` Bag GlobalRdrElt
gres) } }

        | TyCon -> Bool
isFamilyTyCon TyCon
tc              -- Expand open tycons
        , (Coercion
co, Type
ty) <- FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type)
normaliseTcApp FamInstEnvs
env Role
role TyCon
tc [Type]
tys
        , Bool -> Bool
not (Coercion -> Bool
isReflexiveCo Coercion
co)
        = do (Coercion
co', Type
ty', Bag GlobalRdrElt
gres) <- Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
role RecTcChecker
rec_nts Type
ty
             (Coercion, Type, Bag GlobalRdrElt)
-> TcM (Coercion, Type, Bag GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion -> Coercion
mkTransCo Coercion
co Coercion
co', Type
ty', Bag GlobalRdrElt
gres)

        | Bool
otherwise
        = TcM (Coercion, Type, Bag GlobalRdrElt)
nothing -- see Note [Don't recur in normaliseFfiType']
        where
          tc_key :: Unique
tc_key = TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc
          children_only :: TcM (Coercion, Type, Bag GlobalRdrElt)
children_only
            = do [(Coercion, Type, Bag GlobalRdrElt)]
xs <- (Type -> Role -> TcM (Coercion, Type, Bag GlobalRdrElt))
-> [Type]
-> [Role]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [(Coercion, Type, Bag GlobalRdrElt)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Type
ty Role
r -> Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
r RecTcChecker
rec_nts Type
ty) [Type]
tys (Role -> TyCon -> [Role]
tyConRolesX Role
role TyCon
tc)
                 let ([Coercion]
cos, [Type]
tys', [Bag GlobalRdrElt]
gres) = [(Coercion, Type, Bag GlobalRdrElt)]
-> ([Coercion], [Type], [Bag GlobalRdrElt])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(Coercion, Type, Bag GlobalRdrElt)]
xs
                 (Coercion, Type, Bag GlobalRdrElt)
-> TcM (Coercion, Type, Bag GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
role TyCon
tc [Coercion]
cos
                        , TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tys', [Bag GlobalRdrElt] -> Bag GlobalRdrElt
forall a. [Bag a] -> Bag a
unionManyBags [Bag GlobalRdrElt]
gres)
          nt_co :: Coercion
nt_co  = Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
role (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
tc) [Type]
tys []
          nt_rhs :: Type
nt_rhs = TyCon -> [Type] -> Type
newTyConInstRhs TyCon
tc [Type]
tys

          ty :: Type
ty      = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tys
          nothing :: TcM (Coercion, Type, Bag GlobalRdrElt)
nothing = (Coercion, Type, Bag GlobalRdrElt)
-> TcM (Coercion, Type, Bag GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Type -> Coercion
mkReflCo Role
role Type
ty, Type
ty, Bag GlobalRdrElt
forall a. Bag a
emptyBag)

checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI GlobalRdrEnv
rdr_env TyCon
tc
  | Just DataCon
con <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
  , Just GlobalRdrElt
gre <- GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env (DataCon -> Name
dataConName DataCon
con)
  = GlobalRdrElt -> Maybe GlobalRdrElt
forall a. a -> Maybe a
Just GlobalRdrElt
gre    -- See Note [Newtype constructor usage in foreign declarations]
  | Bool
otherwise
  = Maybe GlobalRdrElt
forall a. Maybe a
Nothing

{-
Note [Newtype constructor usage in foreign declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC automatically "unwraps" newtype constructors in foreign import/export
declarations.  In effect that means that a newtype data constructor is
used even though it is not mentioned expclitly in the source, so we don't
want to report it as "defined but not used" or "imported but not used".
eg     newtype D = MkD Int
       foreign import foo :: D -> IO ()
Here 'MkD' us used.  See #7408.

GHC also expands type functions during this process, so it's not enough
just to look at the free variables of the declaration.
eg     type instance F Bool = D
       foreign import bar :: F Bool -> IO ()
Here again 'MkD' is used.

So we really have wait until the type checker to decide what is used.
That's why tcForeignImports and tecForeignExports return a (Bag GRE)
for the newtype constructors they see. Then GHC.Tc.Module can add them
to the module's usages.


************************************************************************
*                                                                      *
\subsection{Imports}
*                                                                      *
************************************************************************
-}

tcForeignImports :: [LForeignDecl GhcRn]
                 -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports :: [LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports [LForeignDecl GhcRn]
decls
  = (Hooks
 -> Maybe
      ([LForeignDecl GhcRn]
       -> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)))
-> ([LForeignDecl GhcRn]
    -> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([LForeignDecl GhcRn]
      -> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt))
forall (f :: * -> *) a.
(Functor f, HasDynFlags f) =>
(Hooks -> Maybe a) -> a -> f a
getHooked Hooks
-> Maybe
     ([LForeignDecl GhcRn]
      -> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignImportsHook [LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' IOEnv
  (Env TcGblEnv TcLclEnv)
  ([LForeignDecl GhcRn]
   -> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> (([LForeignDecl GhcRn]
     -> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt))
    -> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (([LForeignDecl GhcRn]
 -> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> [LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
forall a b. (a -> b) -> a -> b
$ [LForeignDecl GhcRn]
decls)

tcForeignImports' :: [LForeignDecl GhcRn]
                  -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
-- For the (Bag GlobalRdrElt) result,
-- see Note [Newtype constructor usage in foreign declarations]
tcForeignImports' :: [LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' [LForeignDecl GhcRn]
decls
  = do { ([TyCoVar]
ids, [LForeignDecl GhcTc]
decls, [Bag GlobalRdrElt]
gres) <- (LForeignDecl GhcRn
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt))
-> [LForeignDecl GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TyCoVar], [LForeignDecl GhcTc], [Bag GlobalRdrElt])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M LForeignDecl GhcRn
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport ([LForeignDecl GhcRn]
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      ([TyCoVar], [LForeignDecl GhcTc], [Bag GlobalRdrElt]))
-> [LForeignDecl GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TyCoVar], [LForeignDecl GhcTc], [Bag GlobalRdrElt])
forall a b. (a -> b) -> a -> b
$
                               (LForeignDecl GhcRn -> Bool)
-> [LForeignDecl GhcRn] -> [LForeignDecl GhcRn]
forall a. (a -> Bool) -> [a] -> [a]
filter LForeignDecl GhcRn -> Bool
forall name. LForeignDecl name -> Bool
isForeignImport [LForeignDecl GhcRn]
decls
       ; ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyCoVar]
ids, [LForeignDecl GhcTc]
decls, [Bag GlobalRdrElt] -> Bag GlobalRdrElt
forall a. [Bag a] -> Bag a
unionManyBags [Bag GlobalRdrElt]
gres) }

tcFImport :: LForeignDecl GhcRn
          -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport :: LForeignDecl GhcRn
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport (L SrcSpan
dloc fo :: ForeignDecl GhcRn
fo@(ForeignImport { fd_name :: forall pass. ForeignDecl pass -> Located (IdP pass)
fd_name = L SrcSpan
nloc IdP GhcRn
nm, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcRn
hs_ty
                                    , fd_fi :: forall pass. ForeignDecl pass -> ForeignImport
fd_fi = ForeignImport
imp_decl }))
  = SrcSpan
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
dloc (IOEnv
   (Env TcGblEnv TcLclEnv)
   (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall a b. (a -> b) -> a -> b
$ MsgDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (ForeignDecl GhcRn -> MsgDoc
foreignDeclCtxt ForeignDecl GhcRn
fo)  (IOEnv
   (Env TcGblEnv TcLclEnv)
   (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall a b. (a -> b) -> a -> b
$
    do { Type
sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType (Name -> UserTypeCtxt
ForSigCtxt Name
IdP GhcRn
nm) LHsSigType GhcRn
hs_ty
       ; (Coercion
norm_co, Type
norm_sig_ty, Bag GlobalRdrElt
gres) <- Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType Type
sig_ty
       ; let
           -- Drop the foralls before inspecting the
           -- structure of the foreign type.
             ([Scaled Type]
arg_tys, Type
res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys (Type -> Type
dropForAlls Type
norm_sig_ty)
             id :: TyCoVar
id                = HasDebugCallStack => Name -> Type -> Type -> TyCoVar
Name -> Type -> Type -> TyCoVar
mkLocalId Name
IdP GhcRn
nm Type
Many Type
sig_ty
                 -- Use a LocalId to obey the invariant that locally-defined
                 -- things are LocalIds.  However, it does not need zonking,
                 -- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it).

       ; ForeignImport
imp_decl' <- [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty ForeignImport
imp_decl
          -- Can't use sig_ty here because sig_ty :: Type and
          -- we need HsType Id hence the undefined
       ; let fi_decl :: ForeignDecl GhcTc
fi_decl = ForeignImport :: forall pass.
XForeignImport pass
-> Located (IdP pass)
-> LHsSigType pass
-> ForeignImport
-> ForeignDecl pass
ForeignImport { fd_name :: Located (IdP GhcTc)
fd_name = SrcSpan -> TyCoVar -> GenLocated SrcSpan TyCoVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
nloc TyCoVar
id
                                     , fd_sig_ty :: LHsSigType GhcTc
fd_sig_ty = LHsSigType GhcTc
forall a. HasCallStack => a
undefined
                                     , fd_i_ext :: XForeignImport GhcTc
fd_i_ext = Coercion -> Coercion
mkSymCo Coercion
norm_co
                                     , fd_fi :: ForeignImport
fd_fi = ForeignImport
imp_decl' }
       ; (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCoVar
id, SrcSpan -> ForeignDecl GhcTc -> LForeignDecl GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
dloc ForeignDecl GhcTc
fi_decl, Bag GlobalRdrElt
gres) }
tcFImport LForeignDecl GhcRn
d = String
-> MsgDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"tcFImport" (LForeignDecl GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LForeignDecl GhcRn
d)

-- ------------ Checking types for foreign import ----------------------

tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport

tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty (CImport (L SrcSpan
lc CCallConv
cconv) Located Safety
safety Maybe Header
mh l :: CImportSpec
l@(CLabel CLabelString
_) Located SourceText
src)
  -- Foreign import label
  = do (HscTarget -> Validity) -> TcM ()
checkCg HscTarget -> Validity
checkCOrAsmOrLlvmOrInterp
       -- NB check res_ty not sig_ty!
       --    In case sig_ty is (forall a. ForeignPtr a)
       Validity -> (MsgDoc -> MsgDoc) -> TcM ()
check (Type -> Validity
isFFILabelTy ([Scaled Type] -> Type -> Type
mkVisFunTys [Scaled Type]
arg_tys Type
res_ty)) (MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
Outputable.empty)
       CCallConv
cconv' <- CCallConv -> TcM CCallConv
checkCConv CCallConv
cconv
       ForeignImport -> TcM ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (SrcSpan -> CCallConv -> GenLocated SrcSpan CCallConv
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') Located Safety
safety Maybe Header
mh CImportSpec
l Located SourceText
src)

tcCheckFIType [Scaled Type]
arg_tys Type
res_ty (CImport (L SrcSpan
lc CCallConv
cconv) Located Safety
safety Maybe Header
mh CImportSpec
CWrapper Located SourceText
src) = do
        -- Foreign wrapper (former f.e.d.)
        -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
        -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.
        -- The use of the latter form is DEPRECATED, though.
    (HscTarget -> Validity) -> TcM ()
checkCg HscTarget -> Validity
checkCOrAsmOrLlvmOrInterp
    CCallConv
cconv' <- CCallConv -> TcM CCallConv
checkCConv CCallConv
cconv
    case [Scaled Type]
arg_tys of
        [Scaled Type
arg1_mult Type
arg1_ty] -> do
                        Type -> TcM ()
checkNoLinearFFI Type
arg1_mult
                        (Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity
isFFIExternalTy [Scaled Type]
arg1_tys
                        Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
nonIOok  Bool
checkSafe Type -> Validity
isFFIExportResultTy Type
res1_ty
                        Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
mustBeIO Bool
checkSafe (Type -> Type -> Validity
isFFIDynTy Type
arg1_ty) Type
res_ty
                  where
                     ([Scaled Type]
arg1_tys, Type
res1_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
arg1_ty
        [Scaled Type]
_ -> MsgDoc -> TcM ()
addErrTc (MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
Outputable.empty (String -> MsgDoc
text String
"One argument expected"))
    ForeignImport -> TcM ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (SrcSpan -> CCallConv -> GenLocated SrcSpan CCallConv
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') Located Safety
safety Maybe Header
mh CImportSpec
CWrapper Located SourceText
src)

tcCheckFIType [Scaled Type]
arg_tys Type
res_ty idecl :: ForeignImport
idecl@(CImport (L SrcSpan
lc CCallConv
cconv) (L SrcSpan
ls Safety
safety) Maybe Header
mh
                                            (CFunction CCallTarget
target) Located SourceText
src)
  | CCallTarget -> Bool
isDynamicTarget CCallTarget
target = do -- Foreign import dynamic
      (HscTarget -> Validity) -> TcM ()
checkCg HscTarget -> Validity
checkCOrAsmOrLlvmOrInterp
      CCallConv
cconv' <- CCallConv -> TcM CCallConv
checkCConv CCallConv
cconv
      case [Scaled Type]
arg_tys of           -- The first arg must be Ptr or FunPtr
        []                ->
          MsgDoc -> TcM ()
addErrTc (MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
Outputable.empty (String -> MsgDoc
text String
"At least one argument expected"))
        (Scaled Type
arg1_mult Type
arg1_ty:[Scaled Type]
arg_tys) -> do
          DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
          let curried_res_ty :: Type
curried_res_ty = [Scaled Type] -> Type -> Type
mkVisFunTys [Scaled Type]
arg_tys Type
res_ty
          Type -> TcM ()
checkNoLinearFFI Type
arg1_mult
          Validity -> (MsgDoc -> MsgDoc) -> TcM ()
check (Type -> Type -> Validity
isFFIDynTy Type
curried_res_ty Type
arg1_ty)
                (MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
argument)
          (Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Safety -> Type -> Validity
isFFIArgumentTy DynFlags
dflags Safety
safety) [Scaled Type]
arg_tys
          Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity
isFFIImportResultTy DynFlags
dflags) Type
res_ty
      ForeignImport -> TcM ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport -> TcM ForeignImport)
-> ForeignImport -> TcM ForeignImport
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (SrcSpan -> CCallConv -> GenLocated SrcSpan CCallConv
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') (SrcSpan -> Safety -> Located Safety
forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target) Located SourceText
src
  | CCallConv
cconv CCallConv -> CCallConv -> Bool
forall a. Eq a => a -> a -> Bool
== CCallConv
PrimCallConv = do
      DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      Bool -> MsgDoc -> TcM ()
checkTc (Extension -> DynFlags -> Bool
xopt Extension
LangExt.GHCForeignImportPrim DynFlags
dflags)
              (String -> MsgDoc
text String
"Use GHCForeignImportPrim to allow `foreign import prim'.")
      (HscTarget -> Validity) -> TcM ()
checkCg HscTarget -> Validity
checkCOrAsmOrLlvmOrInterp
      CCallTarget -> TcM ()
checkCTarget CCallTarget
target
      Bool -> MsgDoc -> TcM ()
checkTc (Safety -> Bool
playSafe Safety
safety)
              (String -> MsgDoc
text String
"The safe/unsafe annotation should not be used with `foreign import prim'.")
      (Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Type -> Validity
isFFIPrimArgumentTy DynFlags
dflags) [Scaled Type]
arg_tys
      -- prim import result is more liberal, allows (#,,#)
      Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity
isFFIPrimResultTy DynFlags
dflags) Type
res_ty
      ForeignImport -> TcM ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignImport
idecl
  | Bool
otherwise = do              -- Normal foreign import
      (HscTarget -> Validity) -> TcM ()
checkCg HscTarget -> Validity
checkCOrAsmOrLlvmOrInterp
      CCallConv
cconv' <- CCallConv -> TcM CCallConv
checkCConv CCallConv
cconv
      CCallTarget -> TcM ()
checkCTarget CCallTarget
target
      DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      (Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Safety -> Type -> Validity
isFFIArgumentTy DynFlags
dflags Safety
safety) [Scaled Type]
arg_tys
      Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity
isFFIImportResultTy DynFlags
dflags) Type
res_ty
      DynFlags -> [Type] -> Type -> TcM ()
checkMissingAmpersand DynFlags
dflags ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) Type
res_ty
      case CCallTarget
target of
          StaticTarget SourceText
_ CLabelString
_ Maybe Unit
_ Bool
False
           | Bool -> Bool
not ([Scaled Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Scaled Type]
arg_tys) ->
              MsgDoc -> TcM ()
addErrTc (String -> MsgDoc
text String
"`value' imports cannot have function types")
          CCallTarget
_ -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ForeignImport -> TcM ForeignImport
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport -> TcM ForeignImport)
-> ForeignImport -> TcM ForeignImport
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (SrcSpan -> CCallConv -> GenLocated SrcSpan CCallConv
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') (SrcSpan -> Safety -> Located Safety
forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target) Located SourceText
src


-- This makes a convenient place to check
-- that the C identifier is valid for C
checkCTarget :: CCallTarget -> TcM ()
checkCTarget :: CCallTarget -> TcM ()
checkCTarget (StaticTarget SourceText
_ CLabelString
str Maybe Unit
_ Bool
_) = do
    (HscTarget -> Validity) -> TcM ()
checkCg HscTarget -> Validity
checkCOrAsmOrLlvmOrInterp
    Bool -> MsgDoc -> TcM ()
checkTc (CLabelString -> Bool
isCLabelString CLabelString
str) (CLabelString -> MsgDoc
badCName CLabelString
str)

checkCTarget CCallTarget
DynamicTarget = String -> TcM ()
forall a. String -> a
panic String
"checkCTarget DynamicTarget"


checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
checkMissingAmpersand DynFlags
dflags [Type]
arg_tys Type
res_ty
  | [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
arg_tys Bool -> Bool -> Bool
&& Type -> Bool
isFunPtrTy Type
res_ty Bool -> Bool -> Bool
&&
    WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnDodgyForeignImports DynFlags
dflags
  = WarnReason -> MsgDoc -> TcM ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDodgyForeignImports)
        (String -> MsgDoc
text String
"possible missing & in foreign import of FunPtr")
  | Bool
otherwise
  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-
************************************************************************
*                                                                      *
\subsection{Exports}
*                                                                      *
************************************************************************
-}

tcForeignExports :: [LForeignDecl GhcRn]
             -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports [LForeignDecl GhcRn]
decls =
  (Hooks
 -> Maybe
      ([LForeignDecl GhcRn]
       -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)))
-> ([LForeignDecl GhcRn]
    -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([LForeignDecl GhcRn]
      -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
forall (f :: * -> *) a.
(Functor f, HasDynFlags f) =>
(Hooks -> Maybe a) -> a -> f a
getHooked Hooks
-> Maybe
     ([LForeignDecl GhcRn]
      -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignExportsHook [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports' IOEnv
  (Env TcGblEnv TcLclEnv)
  ([LForeignDecl GhcRn]
   -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> (([LForeignDecl GhcRn]
     -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
    -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (([LForeignDecl GhcRn]
 -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
forall a b. (a -> b) -> a -> b
$ [LForeignDecl GhcRn]
decls)

tcForeignExports' :: [LForeignDecl GhcRn]
             -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
-- For the (Bag GlobalRdrElt) result,
-- see Note [Newtype constructor usage in foreign declarations]
tcForeignExports' :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports' [LForeignDecl GhcRn]
decls
  = ((LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
 -> LForeignDecl GhcRn
 -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
-> [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
-> LForeignDecl GhcRn
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
combine (LHsBinds GhcTc
forall idL idR. LHsBindsLR idL idR
emptyLHsBinds, [], Bag GlobalRdrElt
forall a. Bag a
emptyBag) ((LForeignDecl GhcRn -> Bool)
-> [LForeignDecl GhcRn] -> [LForeignDecl GhcRn]
forall a. (a -> Bool) -> [a] -> [a]
filter LForeignDecl GhcRn -> Bool
forall name. LForeignDecl name -> Bool
isForeignExport [LForeignDecl GhcRn]
decls)
  where
   combine :: (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
-> LForeignDecl GhcRn
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
combine (LHsBinds GhcTc
binds, [LForeignDecl GhcTc]
fs, Bag GlobalRdrElt
gres1) (L SrcSpan
loc ForeignDecl GhcRn
fe) = do
       (LHsBind GhcTc
b, ForeignDecl GhcTc
f, Bag GlobalRdrElt
gres2) <- SrcSpan
-> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (ForeignDecl GhcRn
-> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport ForeignDecl GhcRn
fe)
       (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBind GhcTc
b LHsBind GhcTc -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. a -> Bag a -> Bag a
`consBag` LHsBinds GhcTc
binds, SrcSpan -> ForeignDecl GhcTc -> LForeignDecl GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ForeignDecl GhcTc
f LForeignDecl GhcTc -> [LForeignDecl GhcTc] -> [LForeignDecl GhcTc]
forall a. a -> [a] -> [a]
: [LForeignDecl GhcTc]
fs, Bag GlobalRdrElt
gres1 Bag GlobalRdrElt -> Bag GlobalRdrElt -> Bag GlobalRdrElt
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag GlobalRdrElt
gres2)

tcFExport :: ForeignDecl GhcRn
          -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport :: ForeignDecl GhcRn
-> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport fo :: ForeignDecl GhcRn
fo@(ForeignExport { fd_name :: forall pass. ForeignDecl pass -> Located (IdP pass)
fd_name = L SrcSpan
loc IdP GhcRn
nm, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcRn
hs_ty, fd_fe :: forall pass. ForeignDecl pass -> ForeignExport
fd_fe = ForeignExport
spec })
  = MsgDoc
-> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (ForeignDecl GhcRn -> MsgDoc
foreignDeclCtxt ForeignDecl GhcRn
fo) (TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
 -> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt))
-> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
forall a b. (a -> b) -> a -> b
$ do

    Type
sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType (Name -> UserTypeCtxt
ForSigCtxt Name
IdP GhcRn
nm) LHsSigType GhcRn
hs_ty
    LHsExpr GhcTc
rhs <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (IdP GhcRn -> LHsExpr GhcRn
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar IdP GhcRn
nm) Type
sig_ty

    (Coercion
norm_co, Type
norm_sig_ty, Bag GlobalRdrElt
gres) <- Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType Type
sig_ty

    ForeignExport
spec' <- Type -> ForeignExport -> TcM ForeignExport
tcCheckFEType Type
norm_sig_ty ForeignExport
spec

           -- 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).


    -- We need to give a name to the new top-level binding that
    -- is *stable* (i.e. the compiler won't change it later),
    -- because this name will be referred to by the C code stub.
    TyCoVar
id  <- Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TyCoVar
mkStableIdFromName Name
IdP GhcRn
nm Type
sig_ty SrcSpan
loc OccName -> OccName
mkForeignExportOcc
    (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return ( IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind TyCoVar
IdP GhcTc
id LHsExpr GhcTc
rhs
           , ForeignExport :: forall pass.
XForeignExport pass
-> Located (IdP pass)
-> LHsSigType pass
-> ForeignExport
-> ForeignDecl pass
ForeignExport { fd_name :: Located (IdP GhcTc)
fd_name = SrcSpan -> TyCoVar -> GenLocated SrcSpan TyCoVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc TyCoVar
id
                           , fd_sig_ty :: LHsSigType GhcTc
fd_sig_ty = LHsSigType GhcTc
forall a. HasCallStack => a
undefined
                           , fd_e_ext :: XForeignExport GhcTc
fd_e_ext = Coercion
XForeignExport GhcTc
norm_co, fd_fe :: ForeignExport
fd_fe = ForeignExport
spec' }
           , Bag GlobalRdrElt
gres)
tcFExport ForeignDecl GhcRn
d = String
-> MsgDoc
-> TcRn (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"tcFExport" (ForeignDecl GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ForeignDecl GhcRn
d)

-- ------------ Checking argument types for foreign export ----------------------

tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
tcCheckFEType Type
sig_ty (CExport (L SrcSpan
l (CExportStatic SourceText
esrc CLabelString
str CCallConv
cconv)) Located SourceText
src) = do
    (HscTarget -> Validity) -> TcM ()
checkCg HscTarget -> Validity
checkCOrAsmOrLlvm
    Bool -> MsgDoc -> TcM ()
checkTc (CLabelString -> Bool
isCLabelString CLabelString
str) (CLabelString -> MsgDoc
badCName CLabelString
str)
    CCallConv
cconv' <- CCallConv -> TcM CCallConv
checkCConv CCallConv
cconv
    (Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity
isFFIExternalTy [Scaled Type]
arg_tys
    Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
nonIOok Bool
noCheckSafe Type -> Validity
isFFIExportResultTy Type
res_ty
    ForeignExport -> TcM ForeignExport
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan CExportSpec
-> Located SourceText -> ForeignExport
CExport (SrcSpan -> CExportSpec -> GenLocated SrcSpan CExportSpec
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (SourceText -> CLabelString -> CCallConv -> CExportSpec
CExportStatic SourceText
esrc CLabelString
str CCallConv
cconv')) Located SourceText
src)
  where
      -- Drop the foralls before inspecting
      -- the structure of the foreign type.
    ([Scaled Type]
arg_tys, Type
res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys (Type -> Type
dropForAlls Type
sig_ty)

{-
************************************************************************
*                                                                      *
\subsection{Miscellaneous}
*                                                                      *
************************************************************************
-}

------------ Checking argument types for foreign import ----------------------
checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity
pred [Scaled Type]
tys = (Scaled Type -> TcM ()) -> [Scaled Type] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Scaled Type -> TcM ()
go [Scaled Type]
tys
  where
    go :: Scaled Type -> TcM ()
go (Scaled Type
mult Type
ty) = Type -> TcM ()
checkNoLinearFFI Type
mult TcM () -> TcM () -> TcM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                          Validity -> (MsgDoc -> MsgDoc) -> TcM ()
check (Type -> Validity
pred Type
ty) (MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
argument)

checkNoLinearFFI :: Mult -> TcM ()  -- No linear types in FFI (#18472)
checkNoLinearFFI :: Type -> TcM ()
checkNoLinearFFI Type
Many = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkNoLinearFFI Type
_    = MsgDoc -> TcM ()
addErrTc (MsgDoc -> TcM ()) -> MsgDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
argument
                                   (String -> MsgDoc
text String
"Linear types are not supported in FFI declarations, see #18472")

------------ Checking result types for foreign calls ----------------------
-- | Check that the type has the form
--    (IO t) or (t) , and that t satisfies the given predicate.
-- When calling this function, any newtype wrappers (should) have been
-- already dealt with by normaliseFfiType.
--
-- We also check that the Safe Haskell condition of FFI imports having
-- results in the IO monad holds.
--
checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
non_io_result_ok Bool
check_safe Type -> Validity
pred_res_ty Type
ty
  | Just (TyCon
_, Type
res_ty) <- Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
ty
  =     -- Got an IO result type, that's always fine!
     Validity -> (MsgDoc -> MsgDoc) -> TcM ()
check (Type -> Validity
pred_res_ty Type
res_ty) (MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
result)

  -- We disallow nested foralls in foreign types
  -- (at least, for the time being). See #16702.
  | Type -> Bool
tcIsForAllTy Type
ty
  = MsgDoc -> TcM ()
addErrTc (MsgDoc -> TcM ()) -> MsgDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
result (String -> MsgDoc
text String
"Unexpected nested forall")

  -- Case for non-IO result type with FFI Import
  | Bool -> Bool
not Bool
non_io_result_ok
  = MsgDoc -> TcM ()
addErrTc (MsgDoc -> TcM ()) -> MsgDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
result (String -> MsgDoc
text String
"IO result type expected")

  | Bool
otherwise
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; case Type -> Validity
pred_res_ty Type
ty of
                -- Handle normal typecheck fail, we want to handle this first and
                -- only report safe haskell errors if the normal type check is OK.
           NotValid MsgDoc
msg -> MsgDoc -> TcM ()
addErrTc (MsgDoc -> TcM ()) -> MsgDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
result MsgDoc
msg

           -- handle safe infer fail
           Validity
_ | Bool
check_safe Bool -> Bool -> Bool
&& DynFlags -> Bool
safeInferOn DynFlags
dflags
               -> WarningMessages -> TcM ()
recordUnsafeInfer WarningMessages
forall a. Bag a
emptyBag

           -- handle safe language typecheck fail
           Validity
_ | Bool
check_safe Bool -> Bool -> Bool
&& DynFlags -> Bool
safeLanguageOn DynFlags
dflags
               -> MsgDoc -> TcM ()
addErrTc (MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
result MsgDoc
safeHsErr)

           -- success! non-IO return is fine
           Validity
_ -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
  where
    safeHsErr :: MsgDoc
safeHsErr =
      String -> MsgDoc
text String
"Safe Haskell is on, all FFI imports must be in the IO monad"

nonIOok, mustBeIO :: Bool
nonIOok :: Bool
nonIOok  = Bool
True
mustBeIO :: Bool
mustBeIO = Bool
False

checkSafe, noCheckSafe :: Bool
checkSafe :: Bool
checkSafe   = Bool
True
noCheckSafe :: Bool
noCheckSafe = Bool
False

-- Checking a supported backend is in use

checkCOrAsmOrLlvm :: HscTarget -> Validity
checkCOrAsmOrLlvm :: HscTarget -> Validity
checkCOrAsmOrLlvm HscTarget
HscC    = Validity
IsValid
checkCOrAsmOrLlvm HscTarget
HscAsm  = Validity
IsValid
checkCOrAsmOrLlvm HscTarget
HscLlvm = Validity
IsValid
checkCOrAsmOrLlvm HscTarget
_
  = MsgDoc -> Validity
NotValid (String -> MsgDoc
text String
"requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")

checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity
checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity
checkCOrAsmOrLlvmOrInterp HscTarget
HscC           = Validity
IsValid
checkCOrAsmOrLlvmOrInterp HscTarget
HscAsm         = Validity
IsValid
checkCOrAsmOrLlvmOrInterp HscTarget
HscLlvm        = Validity
IsValid
checkCOrAsmOrLlvmOrInterp HscTarget
HscInterpreted = Validity
IsValid
checkCOrAsmOrLlvmOrInterp HscTarget
_
  = MsgDoc -> Validity
NotValid (String -> MsgDoc
text String
"requires interpreted, unregisterised, llvm or native code generation")

checkCg :: (HscTarget -> Validity) -> TcM ()
checkCg :: (HscTarget -> Validity) -> TcM ()
checkCg HscTarget -> Validity
check = do
    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let target :: HscTarget
target = DynFlags -> HscTarget
hscTarget DynFlags
dflags
    case HscTarget
target of
      HscTarget
HscNothing -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      HscTarget
_ ->
        case HscTarget -> Validity
check HscTarget
target of
          Validity
IsValid      -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          NotValid MsgDoc
err -> MsgDoc -> TcM ()
addErrTc (String -> MsgDoc
text String
"Illegal foreign declaration:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
err)

-- Calling conventions

checkCConv :: CCallConv -> TcM CCallConv
checkCConv :: CCallConv -> TcM CCallConv
checkCConv CCallConv
CCallConv    = CCallConv -> TcM CCallConv
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CCallConv
checkCConv CCallConv
CApiConv     = CCallConv -> TcM CCallConv
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CApiConv
checkCConv CCallConv
StdCallConv  = do DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                             let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
                             if Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchX86
                                 then CCallConv -> TcM CCallConv
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
StdCallConv
                                 else do -- This is a warning, not an error. see #3336
                                         Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnsupportedCallingConventions DynFlags
dflags) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
                                             WarnReason -> MsgDoc -> TcM ()
addWarnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnsupportedCallingConventions)
                                                 (String -> MsgDoc
text String
"the 'stdcall' calling convention is unsupported on this platform," MsgDoc -> MsgDoc -> MsgDoc
$$ String -> MsgDoc
text String
"treating as ccall")
                                         CCallConv -> TcM CCallConv
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CCallConv
checkCConv CCallConv
PrimCallConv = do MsgDoc -> TcM ()
addErrTc (String -> MsgDoc
text String
"The `prim' calling convention can only be used with `foreign import'")
                             CCallConv -> TcM CCallConv
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
PrimCallConv
checkCConv CCallConv
JavaScriptCallConv = do DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                                   if Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchJavaScript
                                       then CCallConv -> TcM CCallConv
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
JavaScriptCallConv
                                       else do MsgDoc -> TcM ()
addErrTc (String -> MsgDoc
text String
"The `javascript' calling convention is unsupported on this platform")
                                               CCallConv -> TcM CCallConv
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
JavaScriptCallConv

-- Warnings

check :: Validity -> (MsgDoc -> MsgDoc) -> TcM ()
check :: Validity -> (MsgDoc -> MsgDoc) -> TcM ()
check Validity
IsValid MsgDoc -> MsgDoc
_             = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check (NotValid MsgDoc
doc) MsgDoc -> MsgDoc
err_fn = MsgDoc -> TcM ()
addErrTc (MsgDoc -> MsgDoc
err_fn MsgDoc
doc)

illegalForeignTyErr :: SDoc -> SDoc -> SDoc
illegalForeignTyErr :: MsgDoc -> MsgDoc -> MsgDoc
illegalForeignTyErr MsgDoc
arg_or_res MsgDoc
extra
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang MsgDoc
msg Int
2 MsgDoc
extra
  where
    msg :: MsgDoc
msg = [MsgDoc] -> MsgDoc
hsep [ String -> MsgDoc
text String
"Unacceptable", MsgDoc
arg_or_res
               , String -> MsgDoc
text String
"type in foreign declaration:"]

-- Used for 'arg_or_res' argument to illegalForeignTyErr
argument, result :: SDoc
argument :: MsgDoc
argument = String -> MsgDoc
text String
"argument"
result :: MsgDoc
result   = String -> MsgDoc
text String
"result"

badCName :: CLabelString -> MsgDoc
badCName :: CLabelString -> MsgDoc
badCName CLabelString
target
  = [MsgDoc] -> MsgDoc
sep [MsgDoc -> MsgDoc
quotes (CLabelString -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr CLabelString
target) MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"is not a valid C identifier"]

foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
foreignDeclCtxt :: ForeignDecl GhcRn -> MsgDoc
foreignDeclCtxt ForeignDecl GhcRn
fo
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"When checking declaration:")
       Int
2 (ForeignDecl GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ForeignDecl GhcRn
fo)