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

-}


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}

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

import GHC.Prelude

import GHC.Hs

import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Expr
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Tc.Instance.Family

import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk

import GHC.Types.ForeignCall
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc

import GHC.Builtin.Names
import GHC.Builtin.Types.Prim( isArrowTyCon )

import GHC.Driver.Session
import GHC.Driver.Backend

import GHC.Utils.Error
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Platform

import GHC.Data.Bag
import GHC.Driver.Hooks
import qualified GHC.LanguageExtensions as LangExt

import Control.Monad ( zipWithM )
import Control.Monad.Trans.Writer.CPS
  ( WriterT, runWriterT, tell )
import Control.Monad.Trans.Class
  ( lift )
import Data.Maybe (isJust)
import GHC.Types.RepType (tyConPrimRep)
import GHC.Builtin.Types (unitTyCon)

-- Defines a binding
isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport (forall p a. UnXRec p => XRec p a -> a
unXRec @name -> ForeignImport {}) = Bool
True
isForeignImport LForeignDecl name
_                        = Bool
False

-- Exports a binding
isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport (forall p a. UnXRec p => XRec p a -> a
unXRec @name -> ForeignExport {}) = Bool
True
isForeignExport LForeignDecl 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 parameterized 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 (Reduction, Bag GlobalRdrElt)
normaliseFfiType :: Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType Type
ty
    = do FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
         FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType' FamInstEnvs
fam_envs Type
ty

normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType' FamInstEnvs
env Type
ty0 = WriterT
  (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
-> TcM (Reduction, Bag GlobalRdrElt)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT (WriterT
   (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
 -> TcM (Reduction, Bag GlobalRdrElt))
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
-> TcM (Reduction, Bag GlobalRdrElt)
forall a b. (a -> b) -> a -> b
$ Role
-> RecTcChecker
-> Type
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
Representational RecTcChecker
initRecTc Type
ty0
  where
    go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction
    go :: Role
-> RecTcChecker
-> Type
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts Type
ty
      | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty     -- Expand synonyms
      = Role
-> RecTcChecker
-> Type
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
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]
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go_tc_app Role
role RecTcChecker
rec_nts TyCon
tc [Type]
tys

      | ([ForAllTyBinder]
bndrs, Type
inner_ty) <- Type -> ([ForAllTyBinder], Type)
splitForAllForAllTyBinders Type
ty
      , Bool -> Bool
not ([ForAllTyBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ForAllTyBinder]
bndrs)
      = do Reduction
redn <- Role
-> RecTcChecker
-> Type
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts Type
inner_ty
           Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a.
a -> WriterT (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduction
 -> WriterT
      (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction)
-> Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a b. (a -> b) -> a -> b
$ [ForAllTyBinder] -> Reduction -> Reduction
mkHomoForAllRedn [ForAllTyBinder]
bndrs Reduction
redn

      | Bool
otherwise -- see Note [Don't recur in normaliseFfiType']
      = Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a.
a -> WriterT (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduction
 -> WriterT
      (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction)
-> Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a b. (a -> b) -> a -> b
$ Role -> Type -> Reduction
mkReflRedn Role
role Type
ty

    go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]
              -> WriterT (Bag GlobalRdrElt) TcM Reduction
    go_tc_app :: Role
-> RecTcChecker
-> TyCon
-> [Type]
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go_tc_app Role
role RecTcChecker
rec_nts TyCon
tc [Type]
tys
        | TyCon -> Bool
isArrowTyCon TyCon
tc  -- Recurse through arrows, or at least the top
        = WriterT
  (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
children_only    -- level arrows.  Remember, the default case is
                           -- "don't recurse" (see last eqn for go_tc_app)

        | Unique
tc_key Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
ioTyConKey, Unique
funPtrTyConKey]
        -- We don't want to look through the IO newtype, even if it is
        -- in scope, so we have a special case for it:
        = WriterT
  (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
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 and products] in GHC.Core.TyCon.RecWalk
                   -- 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 <- IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) GlobalRdrEnv
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT (Bag GlobalRdrElt) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
 -> WriterT
      (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) GlobalRdrEnv)
-> IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ IOEnv (Env TcGblEnv TcLclEnv) GlobalRdrEnv
getGlobalRdrEnv
             ; case GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI GlobalRdrEnv
rdr_env TyCon
tc of
                 Maybe GlobalRdrElt
Nothing  -> WriterT
  (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
nothing
                 Just GlobalRdrElt
gre ->
                   do { Reduction
redn <- Role
-> RecTcChecker
-> Type
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts' Type
nt_rhs
                      ; Bag GlobalRdrElt
-> WriterT (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell (GlobalRdrElt -> Bag GlobalRdrElt
forall a. a -> Bag a
unitBag GlobalRdrElt
gre)
                      ; Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a.
a -> WriterT (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduction
 -> WriterT
      (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction)
-> Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a b. (a -> b) -> a -> b
$ Coercion
nt_co Coercion -> Reduction -> Reduction
`mkTransRedn` Reduction
redn } }

        | TyCon -> Bool
isFamilyTyCon TyCon
tc              -- Expand open tycons
        , Reduction Coercion
co Type
ty <- FamInstEnvs -> Role -> TyCon -> [Type] -> Reduction
normaliseTcApp FamInstEnvs
env Role
role TyCon
tc [Type]
tys
        , Bool -> Bool
not (Coercion -> Bool
isReflexiveCo Coercion
co)
        = do Reduction
redn <- Role
-> RecTcChecker
-> Type
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
role RecTcChecker
rec_nts Type
ty
             Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a.
a -> WriterT (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduction
 -> WriterT
      (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction)
-> Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a b. (a -> b) -> a -> b
$ Coercion
co Coercion -> Reduction -> Reduction
`mkTransRedn` Reduction
redn

        | Bool
otherwise
        = WriterT
  (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
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 :: WriterT
  (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
children_only
            = do { Reductions
args <- [Reduction] -> Reductions
unzipRedns ([Reduction] -> Reductions)
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) [Reduction]
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reductions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            (Type
 -> Role
 -> WriterT
      (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction)
-> [Type]
-> [Role]
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) [Reduction]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM ( \ Type
ty Role
r -> Role
-> RecTcChecker
-> Type
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
go Role
r RecTcChecker
rec_nts Type
ty )
                                     [Type]
tys (Role -> TyCon -> [Role]
tyConRoleListX Role
role TyCon
tc)
                 ; Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a.
a -> WriterT (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduction
 -> WriterT
      (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction)
-> Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a b. (a -> b) -> a -> b
$ Role -> TyCon -> Reductions -> Reduction
mkTyConAppRedn Role
role TyCon
tc Reductions
args }
          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 :: WriterT
  (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
nothing = Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a.
a -> WriterT (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduction
 -> WriterT
      (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction)
-> Reduction
-> WriterT
     (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
forall a b. (a -> b) -> a -> b
$ Role -> Type -> Reduction
mkReflRedn Role
role Type
ty

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
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
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' is 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 ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports [LForeignDecl GhcRn]
decls = do
    Hooks
hooks <- IOEnv (Env TcGblEnv TcLclEnv) Hooks
forall (m :: * -> *). HasHooks m => m Hooks
getHooks
    case Hooks
-> Maybe
     ([LForeignDecl GhcRn]
      -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignImportsHook Hooks
hooks of
        Maybe
  ([LForeignDecl GhcRn]
   -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
Nothing -> [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' [LForeignDecl GhcRn]
decls
        Just [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
h  -> [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
h [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 ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' [LForeignDecl GhcRn]
decls
  = do { ([Id]
ids, [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
decls, [Bag GlobalRdrElt]
gres) <- (GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Id, GenLocated SrcSpanAnnA (ForeignDecl GhcTc), Bag GlobalRdrElt))
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([Id], [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)],
      [Bag GlobalRdrElt])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M LForeignDecl GhcRn
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Id, GenLocated SrcSpanAnnA (ForeignDecl GhcTc), Bag GlobalRdrElt)
tcFImport ([GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      ([Id], [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)],
       [Bag GlobalRdrElt]))
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([Id], [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)],
      [Bag GlobalRdrElt])
forall a b. (a -> b) -> a -> b
$
                               (GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LForeignDecl GhcRn -> Bool
GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> Bool
forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport [LForeignDecl GhcRn]
[GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
decls
       ; ([Id], [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)],
 Bag GlobalRdrElt)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([Id], [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)],
      Bag GlobalRdrElt)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
ids, [GenLocated SrcSpanAnnA (ForeignDecl 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
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport (L SrcSpanAnnA
dloc fo :: ForeignDecl GhcRn
fo@(ForeignImport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = L SrcSpanAnnN
nloc Name
nm, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcRn
hs_ty
                                    , fd_fi :: forall pass. ForeignDecl pass -> ForeignImport pass
fd_fi = ForeignImport GhcRn
imp_decl }))
  = SrcSpanAnnA
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
dloc (TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
 -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt))
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall a b. (a -> b) -> a -> b
$ SDoc
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (ForeignDecl GhcRn -> SDoc
foreignDeclCtxt ForeignDecl GhcRn
fo)  (TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
 -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt))
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (Id, 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
nm) LHsSigType GhcRn
hs_ty
       ; (Reduction Coercion
norm_co Type
norm_sig_ty, Bag GlobalRdrElt
gres) <- Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType Type
sig_ty
       ; let
             -- Drop the foralls before inspecting the
             -- structure of the foreign type.
             -- Use splitFunTys, which splits (=>) as well as (->)
             -- so that for  foreign import foo :: Eq a => a -> blah
             -- we get "unacceptable argument Eq a" rather than
             --        "unacceptable result Eq a => a -> blah"
             -- Not a big deal.  We could make a better error message specially
             -- for overloaded functions, but doesn't seem worth it
             ([Scaled Type]
arg_tys, Type
res_ty) = Type -> ([Scaled Type], Type)
splitFunTys (Type -> Type
dropForAlls Type
norm_sig_ty)

             id :: Id
id = HasDebugCallStack => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId Name
nm Type
ManyTy 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.Zonk.Type.zonkForeignExports ignores it).

       ; ForeignImport GhcTc
imp_decl' <- [Scaled Type]
-> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc)
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty ForeignImport GhcRn
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 { fd_name :: LIdP GhcTc
fd_name = SrcSpanAnnN -> Id -> GenLocated SrcSpanAnnN Id
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nloc Id
id
                                     , fd_sig_ty :: LHsSigType GhcTc
fd_sig_ty = LHsSigType GhcTc
GenLocated SrcSpanAnnA (HsSigType GhcTc)
forall a. HasCallStack => a
undefined
                                     , fd_i_ext :: XForeignImport GhcTc
fd_i_ext = Coercion -> Coercion
mkSymCo Coercion
norm_co
                                     , fd_fi :: ForeignImport GhcTc
fd_fi = ForeignImport GhcTc
imp_decl' }
       ; (Id, GenLocated SrcSpanAnnA (ForeignDecl GhcTc), Bag GlobalRdrElt)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Id, GenLocated SrcSpanAnnA (ForeignDecl GhcTc), Bag GlobalRdrElt)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
id, SrcSpanAnnA
-> ForeignDecl GhcTc -> GenLocated SrcSpanAnnA (ForeignDecl GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
dloc ForeignDecl GhcTc
fi_decl, Bag GlobalRdrElt
gres) }
tcFImport LForeignDecl GhcRn
d = String
-> SDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Id, GenLocated SrcSpanAnnA (ForeignDecl GhcTc), Bag GlobalRdrElt)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcFImport" (GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LForeignDecl GhcRn
GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
d)

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

tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc)

tcCheckFIType :: [Scaled Type]
-> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc)
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty idecl :: ForeignImport GhcRn
idecl@(CImport XCImport GhcRn
src (L SrcSpan
lc CCallConv
cconv) XRec GhcRn Safety
safety Maybe Header
mh l :: CImportSpec
l@(CLabel CLabelString
_))
  -- Foreign import label
  = do Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
       -- NB check res_ty not sig_ty!
       --    In case sig_ty is (forall a. ForeignPtr a)
       Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check (Type -> Validity' IllegalForeignTypeReason
isFFILabelTy ([Scaled Type] -> Type -> Type
HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
arg_tys Type
res_ty))
             (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType Maybe ArgOrResult
forall a. Maybe a
Nothing)
       CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
       ForeignImport GhcTc -> TcM (ForeignImport GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCImport GhcTc
-> XRec GhcTc CCallConv
-> XRec GhcTc Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport GhcTc
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
XCImport GhcTc
src (SrcSpan -> CCallConv -> GenLocated SrcSpan CCallConv
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') XRec GhcRn Safety
XRec GhcTc Safety
safety Maybe Header
mh CImportSpec
l)

tcCheckFIType [Scaled Type]
arg_tys Type
res_ty idecl :: ForeignImport GhcRn
idecl@(CImport XCImport GhcRn
src (L SrcSpan
lc CCallConv
cconv) XRec GhcRn Safety
safety Maybe Header
mh CImportSpec
CWrapper) = 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.
    Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
    CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
    case [Scaled Type]
arg_tys of
        [Scaled Type
arg1_mult Type
arg1_ty] -> do
                        Type -> TcM ()
checkNoLinearFFI Type
arg1_mult
                        (Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity' IllegalForeignTypeReason
isFFIExternalTy [Scaled Type]
arg1_tys
                        Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
nonIOok  Bool
checkSafe Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy Type
res1_ty
                        Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
mustBeIO Bool
checkSafe (Type -> Type -> Validity' IllegalForeignTypeReason
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]
_ -> TcRnMessage -> TcM ()
addErrTc (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType Maybe ArgOrResult
forall a. Maybe a
Nothing IllegalForeignTypeReason
OneArgExpected)
    ForeignImport GhcTc -> TcM (ForeignImport GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCImport GhcTc
-> XRec GhcTc CCallConv
-> XRec GhcTc Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport GhcTc
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
XCImport GhcTc
src (SrcSpan -> CCallConv -> GenLocated SrcSpan CCallConv
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') XRec GhcRn Safety
XRec GhcTc Safety
safety Maybe Header
mh CImportSpec
CWrapper)

tcCheckFIType [Scaled Type]
arg_tys Type
res_ty idecl :: ForeignImport GhcRn
idecl@(CImport XCImport GhcRn
src (L SrcSpan
lc CCallConv
cconv) (L SrcSpan
ls Safety
safety) Maybe Header
mh
                                            (CFunction CCallTarget
target))
  | CCallTarget -> Bool
isDynamicTarget CCallTarget
target = do -- Foreign import dynamic
      Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
      CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
      case [Scaled Type]
arg_tys of           -- The first arg must be Ptr or FunPtr
        []                ->
          TcRnMessage -> TcM ()
addErrTc (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType Maybe ArgOrResult
forall a. Maybe a
Nothing IllegalForeignTypeReason
AtLeastOneArgExpected)
        (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
HasDebugCallStack => [Scaled Type] -> Type -> Type
mkScaledFunTys [Scaled Type]
arg_tys Type
res_ty
          Type -> TcM ()
checkNoLinearFFI Type
arg1_mult
          Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check (Type -> Type -> Validity' IllegalForeignTypeReason
isFFIDynTy Type
curried_res_ty Type
arg1_ty)
                (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Arg))
          (Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
isFFIArgumentTy DynFlags
dflags Safety
safety) [Scaled Type]
arg_tys
          Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy DynFlags
dflags) Type
res_ty
      ForeignImport GhcTc -> TcM (ForeignImport GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport GhcTc -> TcM (ForeignImport GhcTc))
-> ForeignImport GhcTc -> TcM (ForeignImport GhcTc)
forall a b. (a -> b) -> a -> b
$ XCImport GhcTc
-> XRec GhcTc CCallConv
-> XRec GhcTc Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport GhcTc
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
XCImport GhcTc
src (SrcSpan -> CCallConv -> GenLocated SrcSpan CCallConv
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') (SrcSpan -> Safety -> GenLocated SrcSpan Safety
forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target)
  | 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 -> TcRnMessage -> TcM ()
checkTc (Extension -> DynFlags -> Bool
xopt Extension
LangExt.GHCForeignImportPrim DynFlags
dflags)
              (ForeignImport GhcRn -> TcRnMessage
TcRnForeignImportPrimExtNotSet ForeignImport GhcRn
idecl)
      Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
      ForeignImport GhcRn -> CCallTarget -> TcM ()
checkCTarget ForeignImport GhcRn
idecl CCallTarget
target
      Bool -> TcRnMessage -> TcM ()
checkTc (Safety -> Bool
playSafe Safety
safety)
              (ForeignImport GhcRn -> TcRnMessage
TcRnForeignImportPrimSafeAnn ForeignImport GhcRn
idecl)
      (Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimArgumentTy DynFlags
dflags) [Scaled Type]
arg_tys
      -- prim import result is more liberal, allows (#,,#)
      Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimResultTy DynFlags
dflags) Type
res_ty
      ForeignImport GhcTc -> TcM (ForeignImport GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCImport GhcTc
-> XRec GhcTc CCallConv
-> XRec GhcTc Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport GhcTc
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
XCImport GhcTc
src (SrcSpan -> CCallConv -> GenLocated SrcSpan CCallConv
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv) (SrcSpan -> Safety -> GenLocated SrcSpan Safety
forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target))
  | CCallConv
cconv CCallConv -> CCallConv -> Bool
forall a. Eq a => a -> a -> Bool
== CCallConv
JavaScriptCallConv = do
      CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
      Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
      -- leave the rest to the JS backend (at least for now)
      ForeignImport GhcTc -> TcM (ForeignImport GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCImport GhcTc
-> XRec GhcTc CCallConv
-> XRec GhcTc Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport GhcTc
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
XCImport GhcTc
src (SrcSpan -> CCallConv -> GenLocated SrcSpan CCallConv
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') (SrcSpan -> Safety -> GenLocated SrcSpan Safety
forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target))
  | Bool
otherwise = do              -- Normal foreign import
      Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
      CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) CCallConv
cconv
      ForeignImport GhcRn -> CCallTarget -> TcM ()
checkCTarget ForeignImport GhcRn
idecl CCallTarget
target
      DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      (Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
isFFIArgumentTy DynFlags
dflags Safety
safety) [Scaled Type]
arg_tys
      Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy DynFlags
dflags) Type
res_ty
      ForeignImport GhcRn -> [Type] -> Type -> TcM ()
checkMissingAmpersand ForeignImport GhcRn
idecl ((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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Scaled Type]
arg_tys) ->
              TcRnMessage -> TcM ()
addErrTc (ForeignImport GhcRn -> TcRnMessage
TcRnForeignFunctionImportAsValue ForeignImport GhcRn
idecl)
          CCallTarget
_ -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ForeignImport GhcTc -> TcM (ForeignImport GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignImport GhcTc -> TcM (ForeignImport GhcTc))
-> ForeignImport GhcTc -> TcM (ForeignImport GhcTc)
forall a b. (a -> b) -> a -> b
$ XCImport GhcTc
-> XRec GhcTc CCallConv
-> XRec GhcTc Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport GhcTc
forall pass.
XCImport pass
-> XRec pass CCallConv
-> XRec pass Safety
-> Maybe Header
-> CImportSpec
-> ForeignImport pass
CImport XCImport GhcRn
XCImport GhcTc
src (SrcSpan -> CCallConv -> GenLocated SrcSpan CCallConv
forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') (SrcSpan -> Safety -> GenLocated SrcSpan Safety
forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target)

-- This makes a convenient place to check
-- that the C identifier is valid for C
checkCTarget :: ForeignImport GhcRn -> CCallTarget -> TcM ()
checkCTarget :: ForeignImport GhcRn -> CCallTarget -> TcM ()
checkCTarget ForeignImport GhcRn
idecl (StaticTarget SourceText
_ CLabelString
str Maybe Unit
_ Bool
_) = do
    Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignImport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. b -> Either a b
Right ForeignImport GhcRn
idecl) Backend -> Validity' ExpectedBackends
backendValidityOfCImport
    Bool -> TcRnMessage -> TcM ()
checkTc (CLabelString -> Bool
isCLabelString CLabelString
str) (CLabelString -> TcRnMessage
TcRnInvalidCIdentifier CLabelString
str)

checkCTarget ForeignImport GhcRn
_ CCallTarget
DynamicTarget = String -> TcM ()
forall a. HasCallStack => String -> a
panic String
"checkCTarget DynamicTarget"

checkMissingAmpersand :: ForeignImport GhcRn -> [Type] -> Type -> TcM ()
checkMissingAmpersand :: ForeignImport GhcRn -> [Type] -> Type -> TcM ()
checkMissingAmpersand ForeignImport GhcRn
idecl [Type]
arg_tys Type
res_ty
  | [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
arg_tys Bool -> Bool -> Bool
&& Type -> Bool
isFunPtrTy Type
res_ty
  = TcRnMessage -> TcM ()
addDiagnosticTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ ForeignImport GhcRn -> TcRnMessage
TcRnFunPtrImportWithoutAmpersand ForeignImport GhcRn
idecl
  | Bool
otherwise
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 = do
    Hooks
hooks <- IOEnv (Env TcGblEnv TcLclEnv) Hooks
forall (m :: * -> *). HasHooks m => m Hooks
getHooks
    case Hooks
-> Maybe
     ([LForeignDecl GhcRn]
      -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignExportsHook Hooks
hooks of
        Maybe
  ([LForeignDecl GhcRn]
   -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
Nothing -> [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports' [LForeignDecl GhcRn]
decls
        Just [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
h  -> [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
h [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
  = ((Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
  [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
 -> GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
       [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt))
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
    [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
-> GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
forall {ann}.
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
 Bag GlobalRdrElt)
-> GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
      Bag GlobalRdrElt)
combine (LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds, [], Bag GlobalRdrElt
forall a. Bag a
emptyBag) ((GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LForeignDecl GhcRn -> Bool
GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> Bool
forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport [LForeignDecl GhcRn]
[GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
decls)
  where
   combine :: (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
 Bag GlobalRdrElt)
-> GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
      Bag GlobalRdrElt)
combine (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds, [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)]
fs, Bag GlobalRdrElt
gres1) (L SrcSpanAnn' ann
loc ForeignDecl GhcRn
fe) = do
       (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b, ForeignDecl GhcTc
f, Bag GlobalRdrElt
gres2) <- SrcSpanAnn' ann
-> TcRn
     (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), ForeignDecl GhcTc,
      Bag GlobalRdrElt)
-> TcRn
     (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), ForeignDecl GhcTc,
      Bag GlobalRdrElt)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' ann
loc (ForeignDecl GhcRn
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport ForeignDecl GhcRn
fe)
       (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
 Bag GlobalRdrElt)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
      Bag GlobalRdrElt)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a -> Bag a
`consBag` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds, SrcSpanAnn' ann
-> ForeignDecl GhcTc
-> GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' ann
loc ForeignDecl GhcTc
f GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)
-> [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)]
-> [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)]
forall a. a -> [a] -> [a]
: [GenLocated (SrcSpanAnn' ann) (ForeignDecl 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
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport fo :: ForeignDecl GhcRn
fo@(ForeignExport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = L SrcSpanAnnN
loc Name
nm, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcRn
hs_ty, fd_fe :: forall pass. ForeignDecl pass -> ForeignExport pass
fd_fe = ForeignExport GhcRn
spec })
  = SDoc
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (ForeignDecl GhcRn -> SDoc
foreignDeclCtxt ForeignDecl GhcRn
fo) (TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
 -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt))
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
-> TcM (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
nm) LHsSigType GhcRn
hs_ty
    GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (IdP GhcRn -> LHsExpr GhcRn
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcRn
Name
nm) Type
sig_ty

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

    ForeignExport GhcTc
spec' <- Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)
tcCheckFEType Type
norm_sig_ty ForeignExport GhcRn
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.
    Id
id  <- Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM Id
mkStableIdFromName Name
nm Type
sig_ty (SrcSpanAnnN -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc) OccName -> OccName
mkForeignExportOcc
    (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), ForeignDecl GhcTc,
 Bag GlobalRdrElt)
-> TcRn
     (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), ForeignDecl GhcTc,
      Bag GlobalRdrElt)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
mkVarBind IdP GhcTc
Id
id LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
           , ForeignExport { fd_name :: LIdP GhcTc
fd_name = SrcSpanAnnN -> Id -> GenLocated SrcSpanAnnN Id
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Id
id
                           , fd_sig_ty :: LHsSigType GhcTc
fd_sig_ty = LHsSigType GhcTc
GenLocated SrcSpanAnnA (HsSigType GhcTc)
forall a. HasCallStack => a
undefined
                           , fd_e_ext :: XForeignExport GhcTc
fd_e_ext = XForeignExport GhcTc
Coercion
norm_co
                           , fd_fe :: ForeignExport GhcTc
fd_fe = ForeignExport GhcTc
spec' }
           , Bag GlobalRdrElt
gres)
tcFExport ForeignDecl GhcRn
d = String
-> SDoc
-> TcRn
     (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), ForeignDecl GhcTc,
      Bag GlobalRdrElt)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcFExport" (ForeignDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr ForeignDecl GhcRn
d)

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

tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)
tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)
tcCheckFEType Type
sig_ty edecl :: ForeignExport GhcRn
edecl@(CExport XCExport GhcRn
src (L SrcSpan
l (CExportStatic SourceText
esrc CLabelString
str CCallConv
cconv))) = do
    Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg (ForeignExport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. a -> Either a b
Left ForeignExport GhcRn
edecl) Backend -> Validity' ExpectedBackends
backendValidityOfCExport
    Bool -> TcRnMessage -> TcM ()
checkTc (CLabelString -> Bool
isCLabelString CLabelString
str) (CLabelString -> TcRnMessage
TcRnInvalidCIdentifier CLabelString
str)
    CCallConv
cconv' <- Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv (ForeignExport GhcRn
-> Either (ForeignExport GhcRn) (ForeignImport GhcRn)
forall a b. a -> Either a b
Left ForeignExport GhcRn
edecl) CCallConv
cconv
    (Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity' IllegalForeignTypeReason
isFFIExternalTy [Scaled Type]
arg_tys
    Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
nonIOok Bool
noCheckSafe Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy Type
res_ty
    ForeignExport GhcTc -> TcM (ForeignExport GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XCExport GhcTc -> XRec GhcTc CExportSpec -> ForeignExport GhcTc
forall pass.
XCExport pass -> XRec pass CExportSpec -> ForeignExport pass
CExport XCExport GhcRn
XCExport GhcTc
src (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')))
  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' IllegalForeignTypeReason) -> [Scaled Type] -> TcM ()
checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason)
-> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity' IllegalForeignTypeReason
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 a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                          Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check (Type -> Validity' IllegalForeignTypeReason
pred Type
ty) (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Arg))

checkNoLinearFFI :: Mult -> TcM ()  -- No linear types in FFI (#18472)
checkNoLinearFFI :: Type -> TcM ()
checkNoLinearFFI Type
ManyTy = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkNoLinearFFI Type
_      = TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Arg)
                                   IllegalForeignTypeReason
LinearTypesNotAllowed

------------ 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' IllegalForeignTypeReason) -> Type -> TcM ()
checkForeignRes :: Bool
-> Bool
-> (Type -> Validity' IllegalForeignTypeReason)
-> Type
-> TcM ()
checkForeignRes Bool
non_io_result_ok Bool
check_safe Type -> Validity' IllegalForeignTypeReason
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' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check (Type -> Validity' IllegalForeignTypeReason
pred_res_ty Type
res_ty)
           (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Result))

  -- We disallow nested foralls in foreign types
  -- (at least, for the time being). See #16702.
  | Type -> Bool
isForAllTy Type
ty
  = TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
UnexpectedNestedForall

  -- Case for non-IO result type with FFI Import
  | Bool -> Bool
not Bool
non_io_result_ok
  = TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
IOResultExpected

  | Bool
otherwise
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; case Type -> Validity' IllegalForeignTypeReason
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 IllegalForeignTypeReason
msg -> TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
msg

           -- handle safe infer fail
           Validity' IllegalForeignTypeReason
_ | Bool
check_safe Bool -> Bool -> Bool
&& DynFlags -> Bool
safeInferOn DynFlags
dflags
               -> Messages TcRnMessage -> TcM ()
recordUnsafeInfer Messages TcRnMessage
forall e. Messages e
emptyMessages

           -- handle safe language typecheck fail
           Validity' IllegalForeignTypeReason
_ | Bool
check_safe Bool -> Bool -> Bool
&& DynFlags -> Bool
safeLanguageOn DynFlags
dflags
               -> TcRnMessage -> TcM ()
addErrTc (Maybe ArgOrResult -> IllegalForeignTypeReason -> TcRnMessage
TcRnIllegalForeignType (ArgOrResult -> Maybe ArgOrResult
forall a. a -> Maybe a
Just ArgOrResult
Result) IllegalForeignTypeReason
SafeHaskellMustBeInIO)

           -- success! non-IO return is fine
           Validity' IllegalForeignTypeReason
_ -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () }

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

checkCg :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
        -> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl Backend -> Validity' ExpectedBackends
check = do
    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let bcknd :: Backend
bcknd = DynFlags -> Backend
backend DynFlags
dflags
    case Backend -> Validity' ExpectedBackends
check Backend
bcknd of
      Validity' ExpectedBackends
IsValid -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      NotValid ExpectedBackends
expectedBcknds ->
        TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> Backend -> ExpectedBackends -> TcRnMessage
TcRnIllegalForeignDeclBackend Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl Backend
bcknd ExpectedBackends
expectedBcknds

-- Calling conventions

checkCConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
           -> CCallConv -> TcM CCallConv
checkCConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> CCallConv -> TcM CCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
_ CCallConv
CCallConv    = CCallConv -> TcM CCallConv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
_ CCallConv
CApiConv     = CCallConv -> TcM CCallConv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CApiConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
StdCallConv
      else do -- This is a warning, not an error. see #3336
              let msg :: TcRnMessage
msg = Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> UnsupportedCallConvention -> TcRnMessage
TcRnUnsupportedCallConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl UnsupportedCallConvention
StdCallConvUnsupported
              TcRnMessage -> TcM ()
addDiagnosticTc TcRnMessage
msg
              CCallConv -> TcM CCallConv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl CCallConv
PrimCallConv = do
  TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> UnsupportedCallConvention -> TcRnMessage
TcRnUnsupportedCallConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl UnsupportedCallConvention
PrimCallConvUnsupported
  CCallConv -> TcM CCallConv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
PrimCallConv
checkCConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl 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 a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
JavaScriptCallConv
      else do
        TcRnMessage -> TcM ()
addErrTc (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-> UnsupportedCallConvention -> TcRnMessage
TcRnUnsupportedCallConv Either (ForeignExport GhcRn) (ForeignImport GhcRn)
decl UnsupportedCallConvention
JavaScriptCallConvUnsupported
        CCallConv -> TcM CCallConv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
JavaScriptCallConv

-- Warnings

check :: Validity' IllegalForeignTypeReason
      -> (IllegalForeignTypeReason -> TcRnMessage)
      -> TcM ()
check :: Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage) -> TcM ()
check Validity' IllegalForeignTypeReason
IsValid IllegalForeignTypeReason -> TcRnMessage
_                   = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check (NotValid IllegalForeignTypeReason
reason) IllegalForeignTypeReason -> TcRnMessage
mkMessage = TcRnMessage -> TcM ()
addErrTc (IllegalForeignTypeReason -> TcRnMessage
mkMessage IllegalForeignTypeReason
reason)

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


{- Predicates on Types used in this module -}

-- | Reason why a type in an FFI signature is invalid

isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
-- Checks for valid argument type for a 'foreign import'
isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
isFFIArgumentTy DynFlags
dflags Safety
safety Type
ty
   = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags
-> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalOutgoingTyCon DynFlags
dflags Safety
safety) Type
ty

isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason
-- Types that are allowed as arguments of a 'foreign export'
isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExternalTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEArgTyCon Type
ty

isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIImportResultTy DynFlags
dflags Type
ty
  = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIResultTyCon DynFlags
dflags) Type
ty

isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason
isFFIExportResultTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEResultTyCon Type
ty

isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason
-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of
-- either, and the wrapped function type must be equal to the given type.
-- We assume that all types have been run through normaliseFfiType, so we don't
-- need to worry about expanding newtypes here.
isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason
isFFIDynTy Type
expected Type
ty
    -- Note [Foreign import dynamic]
    -- In the example below, expected would be 'CInt -> IO ()', while ty would
    -- be 'FunPtr (CDouble -> IO ())'.
    | Just (TyCon
tc, [Type
ty']) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
    , TyCon -> Unique
tyConUnique TyCon
tc Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
ptrTyConKey, Unique
funPtrTyConKey]
    , Type -> Type -> Bool
eqType Type
ty' Type
expected
    = Validity' IllegalForeignTypeReason
forall a. Validity' a
IsValid
    | Bool
otherwise
    = IllegalForeignTypeReason -> Validity' IllegalForeignTypeReason
forall a. a -> Validity' a
NotValid (Type -> Type -> IllegalForeignTypeReason
ForeignDynNotPtr Type
expected Type
ty)

isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason
-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either.
isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason
isFFILabelTy Type
ty = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
forall {a}.
Uniquable a =>
a -> Validity' TypeCannotBeMarshaledReason
ok Type
ty
  where
    ok :: a -> Validity' TypeCannotBeMarshaledReason
ok a
tc | a
tc a -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funPtrTyConKey Bool -> Bool -> Bool
|| a
tc a -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ptrTyConKey
          = Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
          | Bool
otherwise
          = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
ForeignLabelNotAPtr

-- | Check validity for a type of the form @Any :: k@.
--
-- This function returns:
--
--  - @Just IsValid@ for @Any :: Type@ and @Any :: UnliftedType@,
--  - @Just (NotValid ..)@ for @Any :: k@ if @k@ is not a kind of boxed types,
--  - @Nothing@ if the type is not @Any@.
checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
  | Just Type
ki <- Type -> Maybe Type
anyTy_maybe Type
ty
  = Validity' IllegalForeignTypeReason
-> Maybe (Validity' IllegalForeignTypeReason)
forall a. a -> Maybe a
Just (Validity' IllegalForeignTypeReason
 -> Maybe (Validity' IllegalForeignTypeReason))
-> Validity' IllegalForeignTypeReason
-> Maybe (Validity' IllegalForeignTypeReason)
forall a b. (a -> b) -> a -> b
$
      if Maybe Levity -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Levity -> Bool) -> Maybe Levity -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Levity
kindBoxedRepLevity_maybe Type
ki
      then Validity' IllegalForeignTypeReason
forall a. Validity' a
IsValid
      -- NB: don't allow things like @Any :: TYPE IntRep@, as per #21305.
      else IllegalForeignTypeReason -> Validity' IllegalForeignTypeReason
forall a. a -> Validity' a
NotValid (Type -> TypeCannotBeMarshaledReason -> IllegalForeignTypeReason
TypeCannotBeMarshaled Type
ty TypeCannotBeMarshaledReason
NotBoxedKindAny)
  | Bool
otherwise
  = Maybe (Validity' IllegalForeignTypeReason)
forall a. Maybe a
Nothing

isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
-- Checks for valid argument type for a 'foreign import prim'
-- Currently they must all be simple unlifted types, or Any (at kind Type or UnliftedType),
-- which can be used to pass the address to a Haskell object on the heap to
-- the foreign function.
isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimArgumentTy DynFlags
dflags Type
ty
  | Just Validity' IllegalForeignTypeReason
validity <- Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
  = Validity' IllegalForeignTypeReason
validity
  | Bool
otherwise
  = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimArgTyCon DynFlags
dflags) Type
ty

isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
-- Checks for valid result type for a 'foreign import prim' Currently
-- it must be an unlifted type, including unboxed tuples, unboxed
-- sums, or the well-known type Any (at kind Type or UnliftedType).
isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
isFFIPrimResultTy DynFlags
dflags Type
ty
  | Just Validity' IllegalForeignTypeReason
validity <- Type -> Maybe (Validity' IllegalForeignTypeReason)
checkAnyTy Type
ty
  = Validity' IllegalForeignTypeReason
validity
  | Bool
otherwise
  = (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon (DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimResultTyCon DynFlags
dflags) Type
ty

isFunPtrTy :: Type -> Bool
isFunPtrTy :: Type -> Bool
isFunPtrTy Type
ty
  | Just (TyCon
tc, [Type
_]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  = TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funPtrTyConKey
  | Bool
otherwise
  = Bool
False

-- normaliseFfiType gets run before checkRepTyCon, so we don't
-- need to worry about looking through newtypes or type functions
-- here; that's already been taken care of.
checkRepTyCon
  :: (TyCon -> Validity' TypeCannotBeMarshaledReason)
  -> Type
  -> Validity' IllegalForeignTypeReason
checkRepTyCon :: (TyCon -> Validity' TypeCannotBeMarshaledReason)
-> Type -> Validity' IllegalForeignTypeReason
checkRepTyCon TyCon -> Validity' TypeCannotBeMarshaledReason
check_tc Type
ty
  = (TypeCannotBeMarshaledReason -> IllegalForeignTypeReason)
-> Validity' TypeCannotBeMarshaledReason
-> Validity' IllegalForeignTypeReason
forall a b. (a -> b) -> Validity' a -> Validity' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type -> TypeCannotBeMarshaledReason -> IllegalForeignTypeReason
TypeCannotBeMarshaled Type
ty) (Validity' TypeCannotBeMarshaledReason
 -> Validity' IllegalForeignTypeReason)
-> Validity' TypeCannotBeMarshaledReason
-> Validity' IllegalForeignTypeReason
forall a b. (a -> b) -> a -> b
$ case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty of
      Just (TyCon
tc, [Type]
tys)
        | TyCon -> Bool
isNewTyCon TyCon
tc -> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid (TyCon -> [Type] -> TypeCannotBeMarshaledReason
mk_nt_reason TyCon
tc [Type]
tys)
        | Bool
otherwise     -> TyCon -> Validity' TypeCannotBeMarshaledReason
check_tc TyCon
tc
      Maybe (TyCon, [Type])
Nothing -> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotADataType
  where
    mk_nt_reason :: TyCon -> [Type] -> TypeCannotBeMarshaledReason
mk_nt_reason TyCon
tc [Type]
tys = TyCon -> [Type] -> TypeCannotBeMarshaledReason
NewtypeDataConNotInScope TyCon
tc [Type]
tys

{-
Note [Foreign import dynamic]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign
type.  Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'.

We use isFFIDynTy to check whether a signature is well-formed. For example,
given a (illegal) declaration like:

foreign import ccall "dynamic"
  foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO ()

isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried
result type 'CInt -> IO ()', and return False, as they are not equal.


----------------------------------------------
These chaps do the work; they are not exported
----------------------------------------------
-}

legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEArgTyCon TyCon
tc
  -- It's illegal to make foreign exports that take unboxed
  -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
  = TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc

legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIResultTyCon DynFlags
dflags TyCon
tc
  | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon         = Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
  | Bool
otherwise               = DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon DynFlags
dflags TyCon
tc

legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
legalFEResultTyCon TyCon
tc
  | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
unitTyCon         = Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
  | Bool
otherwise               = TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc

legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason
-- Checks validity of types going from Haskell -> external world
legalOutgoingTyCon :: DynFlags
-> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalOutgoingTyCon DynFlags
dflags Safety
_ TyCon
tc
  = DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon DynFlags
dflags TyCon
tc

-- Check for marshalability of a primitive type.
-- We exclude lifted types such as RealWorld and TYPE.
-- They can technically appear in types, e.g.
-- f :: RealWorld -> TYPE LiftedRep -> RealWorld
-- f x _ = x
-- but there are no values of type RealWorld or TYPE LiftedRep,
-- so it doesn't make sense to use them in FFI.
marshalablePrimTyCon :: TyCon -> Bool
marshalablePrimTyCon :: TyCon -> Bool
marshalablePrimTyCon TyCon
tc = TyCon -> Bool
isPrimTyCon TyCon
tc Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isLiftedTypeKind (TyCon -> Type
tyConResKind TyCon
tc))

marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon DynFlags
dflags TyCon
tc
  | TyCon -> Bool
marshalablePrimTyCon TyCon
tc
  , Bool -> Bool
not ([PrimRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HasDebugCallStack => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc)) -- Note [Marshalling void]
  = DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
  | Bool
otherwise
  = TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc

boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon TyCon
tc
   | TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tc Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Unique
intTyConKey, Unique
int8TyConKey, Unique
int16TyConKey
                         , Unique
int32TyConKey, Unique
int64TyConKey
                         , Unique
wordTyConKey, Unique
word8TyConKey, Unique
word16TyConKey
                         , Unique
word32TyConKey, Unique
word64TyConKey
                         , Unique
floatTyConKey, Unique
doubleTyConKey
                         , Unique
ptrTyConKey, Unique
funPtrTyConKey
                         , Unique
charTyConKey
                         , Unique
stablePtrTyConKey
                         , Unique
boolTyConKey
                         ]
  = Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid

  | Bool
otherwise = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotABoxedMarshalableTyCon

legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
-- Check args of 'foreign import prim', only allow simple unlifted types.
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimArgTyCon DynFlags
dflags TyCon
tc
  | TyCon -> Bool
marshalablePrimTyCon TyCon
tc
  = DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
  | Bool
otherwise
  = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
NotSimpleUnliftedType

legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
-- Check result type of 'foreign import prim'. Allow simple unlifted
-- types and also unboxed tuple and sum result types.
legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
legalFIPrimResultTyCon DynFlags
dflags TyCon
tc
  | TyCon -> Bool
marshalablePrimTyCon TyCon
tc
  , Bool -> Bool
not ([PrimRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (HasDebugCallStack => TyCon -> [PrimRep]
TyCon -> [PrimRep]
tyConPrimRep TyCon
tc))   -- Note [Marshalling void]
  = DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags

  | TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc Bool -> Bool -> Bool
|| TyCon -> Bool
isUnboxedSumTyCon TyCon
tc
  = DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags

  | Bool
otherwise
  = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid (TypeCannotBeMarshaledReason
 -> Validity' TypeCannotBeMarshaledReason)
-> TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a b. (a -> b) -> a -> b
$ TypeCannotBeMarshaledReason
NotSimpleUnliftedType

validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason
validIfUnliftedFFITypes DynFlags
dflags
  | Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedFFITypes DynFlags
dflags =  Validity' TypeCannotBeMarshaledReason
forall a. Validity' a
IsValid
  | Bool
otherwise = TypeCannotBeMarshaledReason
-> Validity' TypeCannotBeMarshaledReason
forall a. a -> Validity' a
NotValid TypeCannotBeMarshaledReason
UnliftedFFITypesNeeded

{-
Note [Marshalling void]
~~~~~~~~~~~~~~~~~~~~~~~
We don't treat State# (whose PrimRep is VoidRep) as marshalable.
In turn that means you can't write
        foreign import foo :: Int -> State# RealWorld

Reason: the back end falls over with panic "primRepHint:VoidRep";
        and there is no compelling reason to permit it
-}