    {-
    (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.Utils.Unique
    import GHC.Platform

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

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

    -- 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 fam_envs <- TcM FamInstEnvs
    tcGetFamInstEnvs
             normaliseFfiType' fam_envs 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 redn <- Role
    -> RecTcChecker
    -> Type
    -> WriterT
         (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
    go Role
    role RecTcChecker
    rec_nts Type
    inner_ty
               return $ mkHomoForAllRedn bndrs 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 { 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 checkNewtypeFFI rdr_env tc of
                     Maybe GlobalRdrElt
    Nothing  -> WriterT
      (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
    nothing
                     Just GlobalRdrElt
    gre ->
                       do { redn <- Role
    -> RecTcChecker
    -> Type
    -> WriterT
         (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
    go Role
    role RecTcChecker
    rec_nts' Type
    nt_rhs
                          ; tell (unitBag gre)
                          ; return $ nt_co `mkTransRedn` 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 redn <- Role
    -> RecTcChecker
    -> Type
    -> WriterT
         (Bag GlobalRdrElt) (IOEnv (Env TcGblEnv TcLclEnv)) Reduction
    go Role
    role RecTcChecker
    rec_nts Type
    ty
                 return $ co `mkTransRedn` 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 { 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)
                     ; return $ mkTyConAppRedn role tc 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 <- IOEnv (Env TcGblEnv TcLclEnv) Hooks
    forall (m :: * -> *). HasHooks m => m Hooks
    getHooks
        case tcForeignImportsHook 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 { (ids, decls, 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
           ; return (ids, decls, unionManyBags 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. EpAnn 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
    $ ErrCtxtMsg
    -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
    -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
    forall a. ErrCtxtMsg -> TcM a -> TcM a
    addErrCtxt (ForeignDecl GhcRn -> ErrCtxtMsg
    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 { sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
    tcHsSigType (Name -> UserTypeCtxt
    ForSigCtxt Name
    nm) LHsSigType GhcRn
    hs_ty
           ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType 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
                 (arg_tys, res_ty) = splitFunTys (dropForAlls norm_sig_ty)

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

           ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
              -- Can't use sig_ty here because sig_ty :: Type and
              -- we need HsType Id hence the undefined
           ; let 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' }
           ; return (id, L dloc fi_decl, 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 EpaLocation
    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)
           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
           return (CImport src (L lc cconv') safety mh l)

    tcCheckFIType [Scaled Type]
    arg_tys Type
    res_ty idecl :: ForeignImport GhcRn
    idecl@(CImport XCImport GhcRn
    src (L EpaLocation
    lc CCallConv
    cconv) XRec GhcRn Safety
    safety Maybe Header
    mh CImportSpec
    CWrapper) = do
            -- Foreign wrapper (former foreign export dynamic)
            -- 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
        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 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)
        return (CImport src (L lc cconv') safety mh CWrapper)

    tcCheckFIType [Scaled Type]
    arg_tys Type
    res_ty idecl :: ForeignImport GhcRn
    idecl@(CImport XCImport GhcRn
    src (L EpaLocation
    lc CCallConv
    cconv) (L EpaLocation
    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
          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 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
              dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
              let curried_res_ty = [Scaled Type] -> Type -> Type
    HasDebugCallStack => [Scaled Type] -> Type -> Type
    mkScaledFunTys [Scaled Type]
    arg_tys Type
    res_ty
              checkNoLinearFFI arg1_mult
              check (isFFIDynTy curried_res_ty arg1_ty)
                    (TcRnIllegalForeignType (Just Arg))
              checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
              checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
          return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target)
      | CCallConv
    cconv CCallConv -> CCallConv -> Bool
    forall a. Eq a => a -> a -> Bool
    == CCallConv
    PrimCallConv = do
          dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
          checkTc (xopt LangExt.GHCForeignImportPrim dflags)
                  (TcRnForeignImportPrimExtNotSet idecl)
          checkCg (Right idecl) backendValidityOfCImport
          checkCTarget idecl target
          checkTc (playSafe safety)
                  (TcRnForeignImportPrimSafeAnn idecl)
          checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
          -- prim import result is more liberal, allows (#,,#)
          checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
          return (CImport src (L lc cconv) (L ls safety) mh (CFunction target))
      | CCallConv
    cconv CCallConv -> CCallConv -> Bool
    forall a. Eq a => a -> a -> Bool
    == CCallConv
    JavaScriptCallConv = do
          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
          checkCg (Right idecl) backendValidityOfCImport
          -- leave the rest to the JS backend (at least for now)
          return (CImport src (L lc cconv') (L ls safety) mh (CFunction 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
          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
          checkCTarget idecl target
          dflags <- getDynFlags
          checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
          checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
          checkMissingAmpersand idecl target (map scaledThing arg_tys) res_ty
          case 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 ()
          return $ CImport src (L lc cconv') (L ls safety) mh (CFunction 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 -> CCallTarget -> [Type] -> Type -> TcM ()
    checkMissingAmpersand :: ForeignImport GhcRn -> CCallTarget -> [Type] -> Type -> TcM ()
    checkMissingAmpersand ForeignImport GhcRn
    _ (StaticTarget SourceText
    _ CLabelString
    _ Maybe Unit
    _ Bool
    False) [Type]
    _ Type
    _ = () -> TcM ()
    forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    checkMissingAmpersand ForeignImport GhcRn
    idecl CCallTarget
    _ [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 <- IOEnv (Env TcGblEnv TcLclEnv) Hooks
    forall (m :: * -> *). HasHooks m => m Hooks
    getHooks
        case tcForeignExportsHook 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
      = (([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
      [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
     -> GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
     -> IOEnv
          (Env TcGblEnv TcLclEnv)
          ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
           [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt))
    -> ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
        [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
    -> [GenLocated SrcSpanAnnA (ForeignDecl GhcRn)]
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([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 ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
     [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
    -> GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
          [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)], Bag GlobalRdrElt)
    forall {ann}.
    ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
     [GenLocated (EpAnn ann) (ForeignDecl GhcTc)], Bag GlobalRdrElt)
    -> GenLocated (EpAnn ann) (ForeignDecl GhcRn)
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
          [GenLocated (EpAnn ann) (ForeignDecl GhcTc)], Bag GlobalRdrElt)
    combine (LHsBinds GhcTc
    [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 :: ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
     [GenLocated (EpAnn ann) (ForeignDecl GhcTc)], Bag GlobalRdrElt)
    -> GenLocated (EpAnn ann) (ForeignDecl GhcRn)
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)],
          [GenLocated (EpAnn ann) (ForeignDecl GhcTc)], Bag GlobalRdrElt)
    combine ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
    binds, [GenLocated (EpAnn ann) (ForeignDecl GhcTc)]
    fs, Bag GlobalRdrElt
    gres1) (L EpAnn ann
    loc ForeignDecl GhcRn
    fe) = do
           (b, f, gres2) <- EpAnn ann
    -> TcRn
         (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), ForeignDecl GhcTc,
          Bag GlobalRdrElt)
    -> TcRn
         (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc), ForeignDecl GhcTc,
          Bag GlobalRdrElt)
    forall ann a. EpAnn ann -> TcRn a -> TcRn a
    setSrcSpanA EpAnn ann
    loc (ForeignDecl GhcRn
    -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
    tcFExport ForeignDecl GhcRn
    fe)
           return (b : binds, L loc f : fs, gres1 `unionBags` 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 })
      = ErrCtxtMsg
    -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
    -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
    forall a. ErrCtxtMsg -> TcM a -> TcM a
    addErrCtxt (ForeignDecl GhcRn -> ErrCtxtMsg
    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

        sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
    tcHsSigType (Name -> UserTypeCtxt
    ForSigCtxt Name
    nm) LHsSigType GhcRn
    hs_ty
        rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty

        (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty

        spec' <- tcCheckFEType norm_sig_ty 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  <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc
        return ( mkVarBind id rhs
               , ForeignExport { fd_name = L loc id
                               , fd_sig_ty = undefined
                               , fd_e_ext = norm_co
                               , fd_fe = spec' }
               , 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 EpaLocation
    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 -> TcM () -> TcM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (CCallConv
    cconv CCallConv -> CCallConv -> Bool
    forall a. Eq a => a -> a -> Bool
    /= CCallConv
    JavaScriptCallConv) (TcM () -> TcM ()) -> TcM () -> TcM ()
    forall a b. (a -> b) -> a -> b
    $ Bool -> TcRnMessage -> TcM ()
    checkTc (CLabelString -> Bool
    isCLabelString CLabelString
    str) (CLabelString -> TcRnMessage
    TcRnInvalidCIdentifier CLabelString
    str)
        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
        checkForeignArgs isFFIExternalTy arg_tys
        checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
        return (CExport src (L l (CExportStatic esrc str 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
    mult Type
    ty)]
      -- If there is a single argument allow:
      --    foo :: (# #) -> T
      | Type -> Bool
    isUnboxedTupleType Type
    ty
      , PrimOrVoidRep
    VoidRep <- HasDebugCallStack => Type -> PrimOrVoidRep
    Type -> PrimOrVoidRep
    typePrimRep1 Type
    ty
      = do
        Type -> TcM ()
    checkNoLinearFFI Type
    mult
        dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        case (validIfUnliftedFFITypes dflags) of
          Validity' TypeCannotBeMarshaledReason
    IsValid -> Type -> TcM ()
    checkNoLinearFFI Type
    mult
          NotValid TypeCannotBeMarshaledReason
    needs_uffi -> 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)
              (Type -> TypeCannotBeMarshaledReason -> IllegalForeignTypeReason
    TypeCannotBeMarshaled Type
    ty TypeCannotBeMarshaledReason
    needs_uffi)
      -- = check (validIfUnliftedFFITypes dflags) (TypeCannotBeMarshaled (Just Arg)) >> checkNoLinearFFI mult
    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 { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
           ; case pred_res_ty 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
        dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        let bcknd = DynFlags -> Backend
    backend DynFlags
    dflags
        case check 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
                  -- 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
      dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      if platformArch (targetPlatform dflags) `elem` [ ArchJavaScript, ArchWasm32 ]
          then return JavaScriptCallConv
          else do
            addErrTc $ TcRnUnsupportedCallConv decl JavaScriptCallConvUnsupported
            return 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)

    {- 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]
        , HasCallStack => Type -> Type -> Bool
    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
      = 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] -> Bool
    forall a. Uniquable a => a -> [Unique] -> Bool
    anyOfUnique TyCon
    tc [ 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
                        , Unique
    jsvalTyConKey
                        ]
      = 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
      = 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