    {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

    -- | Handling of JavaScript foreign imports/exports
    module GHC.HsToCore.Foreign.JavaScript
      ( dsJsImport
      , dsJsFExport
      , dsJsFExportDynamic
      )
    where

    import GHC.Prelude

    import GHC.Platform

    import GHC.Hs

    import GHC.HsToCore.Monad
    import GHC.HsToCore.Foreign.Call
    import GHC.HsToCore.Foreign.Prim
    import GHC.HsToCore.Foreign.Utils
    import GHC.HsToCore.Utils

    import GHC.Core
    import GHC.Core.Make
    import GHC.Core.Utils
    import GHC.Core.DataCon
    import GHC.Core.Unfold.Make
    import GHC.Core.Type
    import GHC.Core.TyCon
    import GHC.Core.Coercion
    import GHC.Core.Multiplicity

    import GHC.Types.Id
    import GHC.Types.Id.Make
    import GHC.Types.Literal
    import GHC.Types.ForeignStubs
    import GHC.Types.SourceText
    import GHC.Types.Name
    import GHC.Types.RepType
    import GHC.Types.ForeignCall
    import GHC.Types.Basic
    import GHC.Types.Unique

    import GHC.Unit.Module

    import GHC.Tc.Utils.TcType

    import GHC.Cmm.Expr
    import GHC.Cmm.Utils

    import GHC.JS.Ppr

    import GHC.Driver.DynFlags
    import GHC.Driver.Config

    import GHC.Builtin.Types
    import GHC.Builtin.Types.Prim
    import GHC.Builtin.Names

    import GHC.Data.FastString
    import GHC.Data.Maybe

    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Utils.Encoding

    dsJsFExport
      :: Id                 -- Either the exported Id,
                            -- or the foreign-export-dynamic constructor
      -> Coercion           -- Coercion between the Haskell type callable
                            -- from C, and its representation type
      -> CLabelString       -- The name to export to C land
      -> CCallConv
      -> Bool               -- True => foreign export dynamic
                            --         so invoke IO action that's hanging off
                            --         the first argument's stable pointer
      -> DsM ( CHeader      -- contents of Module_stub.h
             , CStub        -- contents of Module_stub.c
             , String       -- string describing type to pass to createAdj.
             , Int          -- size of args to stub function
             )

    dsJsFExport :: Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String, Arity)
    dsJsFExport Id
    fn_id Coercion
    co CLabelString
    ext_name CCallConv
    cconv Bool
    isDyn = do
        let
           ty :: Type
    ty                              = Coercion -> Type
    coercionRKind Coercion
    co
           ([Id]
    _tvs,Type
    sans_foralls)             = Type -> ([Id], Type)
    tcSplitForAllTyVars Type
    ty
           ([Scaled Type]
    fe_arg_tys', Type
    orig_res_ty)      = Type -> ([Scaled Type], Type)
    tcSplitFunTys Type
    sans_foralls
           -- We must use tcSplits here, because we want to see
           -- the (IO t) in the corner of the type!
           fe_arg_tys :: [Scaled Type]
    fe_arg_tys | Bool
    isDyn     = [Scaled Type] -> [Scaled Type]
    forall a. HasCallStack => [a] -> [a]
    tail [Scaled Type]
    fe_arg_tys'
                      | Bool
    otherwise = [Scaled Type]
    fe_arg_tys'

           -- Look at the result type of the exported function, orig_res_ty
           -- If it's IO t, return         (t, True)
           -- If it's plain t, return      (t, False)
           (Type
    res_ty, Bool
    is_IO_res_ty) = case Type -> Maybe (TyCon, Type)
    tcSplitIOType_maybe Type
    orig_res_ty of
                                    -- The function already returns IO t
                                    Just (TyCon
    _ioTyCon, Type
    res_ty) -> (Type
    res_ty, Bool
    True)
                                    -- The function returns t
                                    Maybe (TyCon, Type)
    Nothing                 -> (Type
    orig_res_ty, Bool
    False)
        platform <- DynFlags -> Platform
    targetPlatform (DynFlags -> Platform)
    -> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    -> IOEnv (Env DsGblEnv DsLclEnv) Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        return $
          mkFExportJSBits platform ext_name
                         (if isDyn then Nothing else Just fn_id)
                         (map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv

    mkFExportJSBits
      :: Platform
      -> FastString
      -> Maybe Id      -- Just==static, Nothing==dynamic
      -> [Type]
      -> Type
      -> Bool          -- True <=> returns an IO type
      -> CCallConv
      -> (CHeader,
          CStub,
          String,      -- the argument reps
          Int          -- total size of arguments
         )
    mkFExportJSBits :: Platform
    -> CLabelString
    -> Maybe Id
    -> [Type]
    -> Type
    -> Bool
    -> CCallConv
    -> (CHeader, CStub, String, Arity)
    mkFExportJSBits Platform
    platform CLabelString
    c_nm Maybe Id
    maybe_target [Type]
    arg_htys Type
    res_hty Bool
    is_IO_res_ty CCallConv
    _cconv
     = (CHeader
    header_bits, CStub
    js_bits, String
    type_string,
        [Arity] -> Arity
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum [ Width -> Arity
    widthInBytes (CmmType -> Width
    typeWidth CmmType
    rep) | (SDoc
    _,SDoc
    _,Type
    _,CmmType
    rep) <- [(SDoc, SDoc, Type, CmmType)]
    arg_info] -- all the args
             -- NB. the calculation here isn't strictly speaking correct.
             -- We have a primitive Haskell type (eg. Int#, Double#), and
             -- we want to know the size, when passed on the C stack, of
             -- the associated C type (eg. HsInt, HsDouble).  We don't have
             -- this information to hand, but we know what GHC's conventions
             -- are for passing around the primitive Haskell types, so we
             -- use that instead.  I hope the two coincide --SDM
        )
     where
      -- list the arguments to the JS function
      arg_info :: [(SDoc,           -- arg name
                    SDoc,           -- C type
                    Type,           -- Haskell type
                    CmmType)]       -- the CmmType
      arg_info :: [(SDoc, SDoc, Type, CmmType)]
    arg_info  = [ let stg_type :: SDoc
    stg_type = Type -> SDoc
    showStgType Type
    ty in
                    (Arity -> SDoc -> SDoc
    forall {doc} {a} {p}. (IsLine doc, Show a) => a -> p -> doc
    arg_cname Arity
    n SDoc
    stg_type,
                     SDoc
    stg_type,
                     Type
    ty,
                     Platform -> Type -> CmmType
    typeCmmType Platform
    platform (Type -> Type
    getPrimTyOf Type
    ty))
                  | (Type
    ty,Arity
    n) <- [Type] -> [Arity] -> [(Type, Arity)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Type]
    arg_htys [Arity
    1::Int ..] ]

      arg_cname :: a -> p -> doc
    arg_cname a
    n p
    _stg_ty = String -> doc
    forall doc. IsLine doc => String -> doc
    text (Char
    'a'Char -> String -> String
    forall a. a -> [a] -> [a]
    :a -> String
    forall a. Show a => a -> String
    show a
    n)

      type_string :: String
    type_string = Platform -> Type -> Char
    primTyDescChar Platform
    platform Type
    res_hty Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    arg_type_string

      arg_type_string :: String
    arg_type_string = [Platform -> Type -> Char
    primTyDescChar Platform
    platform Type
    ty | (SDoc
    _,SDoc
    _,Type
    ty,CmmType
    _) <- [(SDoc, SDoc, Type, CmmType)]
    arg_info]

      -- stuff to do with the return type of the JS function
      res_hty_is_unit :: Bool
    res_hty_is_unit = Type
    res_hty Type -> Type -> Bool
    `eqType` Type
    unitTy     -- Look through any newtypes

      unboxResType :: SDoc
    unboxResType | Bool
    res_hty_is_unit = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "h$rts_getUnit"
                   | Bool
    otherwise       = Type -> SDoc
    unpackHObj Type
    res_hty

      header_bits :: CHeader
    header_bits = CHeader -> (Id -> CHeader) -> Maybe Id -> CHeader
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe CHeader
    forall a. Monoid a => a
    mempty Id -> CHeader
    forall {a}. Uniquable a => a -> CHeader
    idTag Maybe Id
    maybe_target
      idTag :: a -> CHeader
    idTag a
    i = let (Char
    tag, Word64
    u) = Unique -> (Char, Word64)
    unpkUnique (a -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique a
    i)
                in  SDoc -> CHeader
    CHeader (Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    tag SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Word64 -> SDoc
    forall doc. IsLine doc => Word64 -> doc
    word64 Word64
    u)

      normal_args :: [SDoc]
    normal_args = ((SDoc, SDoc, Type, CmmType) -> SDoc)
    -> [(SDoc, SDoc, Type, CmmType)] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(SDoc
    nm,SDoc
    _ty,Type
    _,CmmType
    _) -> SDoc
    nm) [(SDoc, SDoc, Type, CmmType)]
    arg_info
      all_args :: [SDoc]
    all_args
        | Maybe Id -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe Id
    maybe_target = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "stableptr_offset" SDoc -> [SDoc] -> [SDoc]
    forall a. a -> [a] -> [a]
    : [SDoc]
    normal_args
        | Bool
    otherwise              = [SDoc]
    normal_args

      fun_args :: SDoc
    fun_args
        | [(SDoc, SDoc, Type, CmmType)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(SDoc, SDoc, Type, CmmType)]
    arg_info = SDoc
    forall doc. IsOutput doc => doc
    empty -- text "void"
        | Bool
    otherwise     = [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    forall doc. IsLine doc => doc -> [doc] -> [doc]
    punctuate SDoc
    forall doc. IsLine doc => doc
    comma [SDoc]
    all_args

      fun_proto :: SDoc
    fun_proto
          = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "function" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>
            (if Maybe Id -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe Id
    maybe_target
             then String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "h$" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    ftext CLabelString
    c_nm
             else CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    ftext CLabelString
    c_nm) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
            SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens SDoc
    fun_args

      fun_export :: SDoc
    fun_export
         = case Maybe Id
    maybe_target of
              Just Id
    hs_fn | Just Module
    m <- Name -> Maybe Module
    nameModule_maybe (Id -> Name
    forall a. NamedThing a => a -> Name
    getName Id
    hs_fn) ->
                String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "h$foreignExport" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
                            SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (
                              CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    ftext CLabelString
    c_nm SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    comma SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
                              CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    strlit (UnitId -> CLabelString
    unitIdFS (Module -> UnitId
    moduleUnitId Module
    m)) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    comma SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
                              CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    strlit (ModuleName -> CLabelString
    moduleNameFS (Module -> ModuleName
    forall unit. GenModule unit -> ModuleName
    moduleName Module
    m)) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    comma SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
                              CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    strlit CLabelString
    c_nm SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    comma SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
                              CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    strlit (String -> CLabelString
    mkFastString String
    type_string)
                            ) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    semi
              Maybe Id
    _ -> SDoc
    forall doc. IsOutput doc => doc
    empty

      strlit :: CLabelString -> doc
    strlit CLabelString
    xs = CLabelString -> doc
    forall doc. IsLine doc => CLabelString -> doc
    pprStringLit CLabelString
    xs

      -- the target which will form the root of what we ask rts_evalIO to run
      the_cfun :: SDoc
    the_cfun
         = case Maybe Id
    maybe_target of
              Maybe Id
    Nothing    -> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "h$deRefStablePtr(stableptr_offset)"
              Just Id
    hs_fn -> Id -> SDoc
    idClosureText Id
    hs_fn

      -- the expression we give to rts_eval
      expr_to_run :: SDoc
      expr_to_run :: SDoc
    expr_to_run
         = (SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc)
    -> SDoc -> [(SDoc, SDoc, Type, CmmType)] -> SDoc
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc
    forall {b} {d}. SDoc -> (SDoc, b, Type, d) -> SDoc
    appArg SDoc
    the_cfun [(SDoc, SDoc, Type, CmmType)]
    arg_info
           where
              appArg :: SDoc -> (SDoc, b, Type, d) -> SDoc
    appArg SDoc
    acc (SDoc
    arg_cname, b
    _, Type
    arg_hty, d
    _)
                 = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "h$rts_apply"
                   SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (SDoc
    acc SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    comma SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Type -> SDoc
    mkHObj Type
    arg_hty SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens SDoc
    arg_cname)

      -- finally, the whole darn thing
      js_bits :: CStub
    js_bits = CStub { getCStub :: SDoc
    getCStub        = SDoc
    js_sdoc
                      , getInitializers :: [CLabel]
    getInitializers = [CLabel]
    forall a. Monoid a => a
    mempty
                      , getFinalizers :: [CLabel]
    getFinalizers   = [CLabel]
    forall a. Monoid a => a
    mempty
                      }
           where js_sdoc :: SDoc
    js_sdoc = SDoc
    forall doc. IsLine doc => doc
    space
                   SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ SDoc
    fun_proto
                   SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat
                     [ SDoc
    forall doc. IsLine doc => doc
    lbrace
                     ,   String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "return"
                         SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "h$rts_eval_sync"
                         SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens ((if Bool
    is_IO_res_ty
                                     then SDoc
    expr_to_run
                                     else String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "h$rts_toIO" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens SDoc
    expr_to_run)
                                    SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    comma SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    unboxResType)
                         SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    semi
                     , SDoc
    forall doc. IsLine doc => doc
    rbrace
                     ]
                   SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ SDoc
    fun_export

    idClosureText :: Id -> SDoc
    idClosureText :: Id -> SDoc
    idClosureText Id
    i
      | Id -> Bool
    isExportedId Id
    i
      , Name
    name <- Id -> Name
    forall a. NamedThing a => a -> Name
    getName Id
    i
      , Just Module
    m <- Name -> Maybe Module
    nameModule_maybe Name
    name
      = let str :: String
    str = SDocContext -> SDoc -> String
    renderWithContext SDocContext
    defaultSDocContext (Module -> Name -> SDoc
    pprFullName Module
    m (Name -> Name
    localiseName Name
    name))
        in String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "h$" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (String -> String
    zEncodeString String
    str)
      | Bool
    otherwise
      = String -> SDoc
    forall a. HasCallStack => String -> a
    panic String
    "idClosureText: unknown module"

    -- | Desugaring of JavaScript foreign imports
    dsJsImport
      :: Id
      -> Coercion
      -> CImportSpec
      -> CCallConv
      -> Safety
      -> Maybe Header
      -> DsM ([Binding], CHeader, CStub)
    dsJsImport :: Id
    -> Coercion
    -> CImportSpec
    -> CCallConv
    -> Safety
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsJsImport Id
    id Coercion
    co (CLabel CLabelString
    cid) CCallConv
    cconv Safety
    _ Maybe Header
    _ = do
       let ty :: Type
    ty = Coercion -> Type
    coercionLKind Coercion
    co
           fod :: FunctionOrData
    fod = case Type -> Maybe TyCon
    tyConAppTyCon_maybe (Type -> Type
    dropForAlls Type
    ty) of
                 Just TyCon
    tycon
                  | TyCon -> Unique
    tyConUnique TyCon
    tycon Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    funPtrTyConKey ->
                     FunctionOrData
    IsFunction
                 Maybe TyCon
    _ -> FunctionOrData
    IsData
       (_resTy, foRhs) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    jsResultWrapper Type
    ty
    --   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
       let rhs = CoreExpr -> CoreExpr
    foRhs (Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
    LitLabel CLabelString
    cid Maybe Arity
    stdcall_info FunctionOrData
    fod))
           rhs' = CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast CoreExpr
    rhs Coercion
    co
           stdcall_info = CCallConv -> Type -> Maybe Arity
    fun_type_arg_stdcall_info CCallConv
    cconv Type
    ty

       return ([(id, rhs')], mempty, mempty)

    dsJsImport Id
    id Coercion
    co (CFunction CCallTarget
    target) cconv :: CCallConv
    cconv@CCallConv
    PrimCallConv Safety
    safety Maybe Header
    _
      = Id -> Coercion -> ForeignCall -> DsM ([Binding], CHeader, CStub)
    dsPrimCall Id
    id Coercion
    co (CCallSpec -> ForeignCall
    CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
    CCallSpec CCallTarget
    target CCallConv
    cconv Safety
    safety))
    dsJsImport Id
    id Coercion
    co (CFunction CCallTarget
    target) CCallConv
    cconv Safety
    safety Maybe Header
    mHeader
      = Id
    -> Coercion
    -> ForeignCall
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsJsCall Id
    id Coercion
    co (CCallSpec -> ForeignCall
    CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
    CCallSpec CCallTarget
    target CCallConv
    cconv Safety
    safety)) Maybe Header
    mHeader
    dsJsImport Id
    id Coercion
    co CImportSpec
    CWrapper CCallConv
    cconv Safety
    _ Maybe Header
    _
      = Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
    dsJsFExportDynamic Id
    id Coercion
    co CCallConv
    cconv

    -- fixme work in progress
    -- FIXME (Sylvain 2022-03): possibility of code sharing with dsFExportDynamic?
    -- Lot of duplication
    dsJsFExportDynamic :: Id
                     -> Coercion
                     -> CCallConv
                     -> DsM ([Binding], CHeader, CStub)
    dsJsFExportDynamic :: Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
    dsJsFExportDynamic Id
    id Coercion
    co0 CCallConv
    cconv = do
        let
          ty :: Type
    ty                            = Coercion -> Type
    coercionLKind Coercion
    co0
          ([Id]
    tvs,Type
    sans_foralls)            = Type -> ([Id], Type)
    tcSplitForAllTyVars Type
    ty
          ([Scaled Type
    arg_mult Type
    arg_ty], Type
    fn_res_ty)  = Type -> ([Scaled Type], Type)
    tcSplitFunTys Type
    sans_foralls
          (TyCon
    io_tc, Type
    res_ty)               = String -> Maybe (TyCon, Type) -> (TyCon, Type)
    forall a. HasCallStack => String -> Maybe a -> a
    expectJust String
    "dsJsFExportDynamic: IO type expected"
                                            -- Must have an IO type; hence Just
                                            (Maybe (TyCon, Type) -> (TyCon, Type))
    -> Maybe (TyCon, Type) -> (TyCon, Type)
    forall a b. (a -> b) -> a -> b
    $ Type -> Maybe (TyCon, Type)
    tcSplitIOType_maybe Type
    fn_res_ty
        mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
    forall (m :: * -> *). HasModule m => m Module
    getModule
        platform <- targetPlatform <$> getDynFlags
        let fe_nm = String -> CLabelString
    mkFastString (String -> CLabelString) -> String -> CLabelString
    forall a b. (a -> b) -> a -> b
    $ String -> String
    zEncodeString
                (String
    "h$" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Module -> String
    moduleStableString Module
    mod String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "$" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Id -> String
    toJsName Id
    id)
            -- Construct the label based on the passed id, don't use names
            -- depending on Unique. See #13807 and Note [Unique Determinism].
        cback <- newSysLocalDs arg_mult arg_ty
        newStablePtrId <- dsLookupGlobalId newStablePtrName
        stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
        let
            stable_ptr_ty = TyCon -> [Type] -> Type
    mkTyConApp TyCon
    stable_ptr_tycon [Type
    arg_ty]
            export_ty     = HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    stable_ptr_ty Type
    arg_ty
        bindIOId <- dsLookupGlobalId bindIOName
        stbl_value <- newSysLocalDs ManyTy stable_ptr_ty
        (h_code, c_code, typestring, args_size) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True
        let
             {-
              The arguments to the external function which will
              create a little bit of (template) code on the fly
              for allowing the (stable pointed) Haskell closure
              to be entered using an external calling convention
              (stdcall, ccall).
             -}
            adj_args      = [ Platform -> Integer -> CoreExpr
    forall b. Platform -> Integer -> Expr b
    mkIntLit Platform
    platform (Arity -> Integer
    forall a. Integral a => a -> Integer
    toInteger (CCallConv -> Arity
    ccallConvToInt CCallConv
    cconv))
                            , Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    stbl_value
                            , Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
    LitLabel CLabelString
    fe_nm Maybe Arity
    mb_sz_args FunctionOrData
    IsFunction)
                            , Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit (String -> Literal
    mkLitString String
    typestring)
                            ]
              -- name of external entry point providing these services.
              -- (probably in the RTS.)
            adjustor   = String -> CLabelString
    fsLit String
    "createAdjustor"

              -- Determine the number of bytes of arguments to the stub function,
              -- so that we can attach the '@N' suffix to its label if it is a
              -- stdcall on Windows.
            mb_sz_args = case CCallConv
    cconv of
                            CCallConv
    StdCallConv -> Arity -> Maybe Arity
    forall a. a -> Maybe a
    Just Arity
    args_size
                            CCallConv
    _           -> Maybe Arity
    forall a. Maybe a
    Nothing

        ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
            -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback

        let io_app = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    tvs                  (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                     Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    cback                   (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                     CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    bindIOId)
                            [ Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    stable_ptr_ty
                            , Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    res_ty
                            , CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    newStablePtrId) [ Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    arg_ty, Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    cback ]
                            , Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    stbl_value CoreExpr
    ccall_adj
                            ]

            fed = (Id
    id Id -> Activation -> Id
    `setInlineActivation` Activation
    NeverActive, CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast CoreExpr
    io_app Coercion
    co0)
                   -- Never inline the f.e.d. function, because the litlit
                   -- might not be in scope in other modules.

        return ([fed], h_code, c_code)

    toJsName :: Id -> String
    toJsName :: Id -> String
    toJsName Id
    i = SDocContext -> SDoc -> String
    renderWithContext SDocContext
    defaultSDocContext (SDoc -> SDoc
    pprCode (Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Name
    idName Id
    i)))

    dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header
            -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
    dsJsCall :: Id
    -> Coercion
    -> ForeignCall
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsJsCall Id
    fn_id Coercion
    co (CCall (CCallSpec CCallTarget
    target CCallConv
    cconv Safety
    safety)) Maybe Header
    _mDeclHeader = do
        let
            ty :: Type
    ty                   = Coercion -> Type
    coercionLKind Coercion
    co
            ([TyVarBinder]
    tv_bndrs, Type
    rho)      = Type -> ([TyVarBinder], Type)
    tcSplitForAllTyVarBinders Type
    ty
            ([Scaled Type]
    arg_tys, Type
    io_res_ty) = Type -> ([Scaled Type], Type)
    tcSplitFunTys Type
    rho

        args <- [Scaled Type] -> DsM [Id]
    newSysLocalsDs [Scaled Type]
    arg_tys  -- no FFI levity-polymorphism
        (val_args, arg_wrappers) <- mapAndUnzipM unboxJsArg (map Var args)

        let
            work_arg_ids  = [Id
    v | Var Id
    v <- [CoreExpr]
    val_args] -- All guaranteed to be vars

        (ccall_result_ty, res_wrapper) <- boxJsResult io_res_ty

        ccall_uniq <- newUnique
        work_uniq  <- newUnique

        simpl_opts <- initSimpleOpts <$> getDynFlags

        let
            -- Build the worker
            fcall         = CCallSpec -> ForeignCall
    CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
    CCallSpec CCallTarget
    target CCallConv
    cconv Safety
    safety)
            worker_ty     = [TyVarBinder] -> Type -> Type
    mkForAllTys [TyVarBinder]
    tv_bndrs ([Type] -> Type -> Type
    mkVisFunTysMany ((Id -> Type) -> [Id] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> Type
    idType [Id]
    work_arg_ids) Type
    ccall_result_ty)
            tvs           = (TyVarBinder -> Id) -> [TyVarBinder] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBinder -> Id
    forall tv argf. VarBndr tv argf -> tv
    binderVar [TyVarBinder]
    tv_bndrs
            the_ccall_app = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
    mkFCall Unique
    ccall_uniq ForeignCall
    fcall [CoreExpr]
    val_args Type
    ccall_result_ty
            work_rhs      = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    tvs ([Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    work_arg_ids CoreExpr
    the_ccall_app)
            work_id       = CLabelString -> Unique -> Type -> Type -> Id
    mkSysLocal (String -> CLabelString
    fsLit String
    "$wccall") Unique
    work_uniq Type
    ManyTy Type
    worker_ty

            -- Build the wrapper
            work_app     = CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (CoreExpr -> [Id] -> CoreExpr
    forall b. Expr b -> [Id] -> Expr b
    mkVarApps (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    work_id) [Id]
    tvs) [CoreExpr]
    val_args
            wrapper_body = ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
    -> CoreExpr -> [CoreExpr -> CoreExpr] -> CoreExpr
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    ($) (CoreExpr -> CoreExpr
    res_wrapper CoreExpr
    work_app) [CoreExpr -> CoreExpr]
    arg_wrappers
            wrap_rhs     = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams ([Id]
    tvs [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id]
    args) CoreExpr
    wrapper_body
            wrap_rhs'    = CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast CoreExpr
    wrap_rhs Coercion
    co
            fn_id_w_inl  = Id
    fn_id
                           Id -> Unfolding -> Id
    `setIdUnfolding`
                           SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding
    mkInlineUnfoldingWithArity SimpleOpts
    simpl_opts UnfoldingSource
    VanillaSrc
                                                      ([Id] -> Arity
    forall a. [a] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length [Id]
    args)  CoreExpr
    wrap_rhs'

        return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, mempty)

    mkHObj :: Type -> SDoc
    mkHObj :: Type -> SDoc
    mkHObj Type
    t = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "h$rts_mk" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Type -> SDoc
    showFFIType Type
    t

    unpackHObj :: Type -> SDoc
    unpackHObj :: Type -> SDoc
    unpackHObj Type
    t = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "h$rts_get" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Type -> SDoc
    showFFIType Type
    t

    showStgType :: Type -> SDoc
    showStgType :: Type -> SDoc
    showStgType Type
    t = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Hs" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Type -> SDoc
    showFFIType Type
    t

    showFFIType :: Type -> SDoc
    showFFIType :: Type -> SDoc
    showFFIType Type
    t = CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    ftext (OccName -> CLabelString
    occNameFS (TyCon -> OccName
    forall a. NamedThing a => a -> OccName
    getOccName (Type -> TyCon
    typeTyCon Type
    t)))

    typeTyCon :: Type -> TyCon
    typeTyCon :: Type -> TyCon
    typeTyCon Type
    ty
      -- UnaryRep rep_ty <- repType ty
      | Just (TyCon
    tc, [Type]
    _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe (Type -> Type
    unwrapType Type
    ty) -- rep_ty
      = TyCon
    tc
      | Bool
    otherwise
      = String -> SDoc -> TyCon
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "typeTyCon" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)

    {-
      We unbox arguments for JS calls a bit different from native code:
        - Bool is marshalled to true/false, not 0/1
        - All int types are narrowed, since JS floats have a greater range than Int32
     -}

    unboxJsArg :: CoreExpr                  -- The supplied argument
               -> DsM (CoreExpr,              -- To pass as the actual argument
                       CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
                      )
    unboxJsArg :: CoreExpr
    -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
    unboxJsArg CoreExpr
    arg
      -- Primtive types: nothing to unbox
      | Type -> Bool
    isPrimitiveType Type
    arg_ty
      = (CoreExpr, CoreExpr -> CoreExpr)
    -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr
    arg, \CoreExpr
    body -> CoreExpr
    body)

      -- Recursive newtypes
      | Just (Coercion
    co, Type
    _rep_ty) <- Type -> Maybe (Coercion, Type)
    topNormaliseNewType_maybe Type
    arg_ty
      = CoreExpr
    -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
    unboxJsArg (HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
    CoreExpr -> Coercion -> CoreExpr
    mkCast CoreExpr
    arg Coercion
    co)

      -- Booleans, do not convert to 0/1, only force them
      | Just TyCon
    tc <- Type -> Maybe TyCon
    tyConAppTyCon_maybe Type
    arg_ty,
        TyCon
    tc TyCon -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    boolTyConKey
      = (CoreExpr, CoreExpr -> CoreExpr)
    -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr
    arg,
                  \ CoreExpr
    body -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
    mkWildCase CoreExpr
    arg (Type -> Scaled Type
    forall a. a -> Scaled a
    unrestricted Type
    boolTy) (HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    DEFAULT [] CoreExpr
    body])

      | Just TyCon
    tc <- Type -> Maybe TyCon
    tyConAppTyCon_maybe Type
    arg_ty,
        TyCon
    tc TyCon -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    anyTyConKey
      = (CoreExpr, CoreExpr -> CoreExpr)
    -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreExpr
    arg,
                  \ CoreExpr
    body -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
    mkWildCase CoreExpr
    arg (Type -> Scaled Type
    forall a. a -> Scaled a
    unrestricted Type
    arg_ty) (HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    DEFAULT [] CoreExpr
    body])
      -- Data types with a single constructor, which has a single, primitive-typed arg
      -- This deals with Int, Float etc; also Ptr, ForeignPtr
      | Bool
    is_product_type Bool -> Bool -> Bool
    && Arity
    data_con_arity Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    1
        = do case_bndr <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy Type
    arg_ty
             prim_arg <- newSysLocalDs ManyTy (scaledThing data_con_arg_ty1)
             return (Var prim_arg,
                   \ CoreExpr
    body -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case CoreExpr
    arg Id
    case_bndr (HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt DataCon
    data_con) [Id
    prim_arg] CoreExpr
    body]
                  )

      -- Byte-arrays, both mutable and otherwise; hack warning
      -- We're looking for values of type ByteArray, MutableByteArray
      --    data ByteArray          ix = ByteArray        ix ix ByteArray#
      --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
      | Bool
    is_product_type Bool -> Bool -> Bool
    &&
        Arity
    data_con_arity Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    3 Bool -> Bool -> Bool
    &&
        Maybe TyCon -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe TyCon
    maybe_arg3_tycon Bool -> Bool -> Bool
    &&
        (TyCon
    arg3_tycon TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    ==  TyCon
    byteArrayPrimTyCon Bool -> Bool -> Bool
    ||
         TyCon
    arg3_tycon TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    ==  TyCon
    mutableByteArrayPrimTyCon)
      = do case_bndr <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy Type
    arg_ty
           vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
           return (Var arr_cts_var,
                   \ CoreExpr
    body -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case CoreExpr
    arg Id
    case_bndr (HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt DataCon
    data_con) [Id]
    vars CoreExpr
    body]
                  )

      | Bool
    otherwise
      = do l <- DsM SrcSpan
    getSrcSpanDs
           pprPanic "unboxJsArg: " (ppr l <+> ppr arg_ty)
      where
        arg_ty :: Type
    arg_ty                                      = HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    arg
        maybe_product_type :: Maybe (TyCon, [Type], DataCon, [Scaled Type])
    maybe_product_type                          = Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
    splitDataProductType_maybe Type
    arg_ty
        is_product_type :: Bool
    is_product_type                             = Maybe (TyCon, [Type], DataCon, [Scaled Type]) -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe (TyCon, [Type], DataCon, [Scaled Type])
    maybe_product_type
        Just (TyCon
    _, [Type]
    _, DataCon
    data_con, [Scaled Type]
    data_con_arg_tys)     = Maybe (TyCon, [Type], DataCon, [Scaled Type])
    maybe_product_type
        data_con_arity :: Arity
    data_con_arity                              = DataCon -> Arity
    dataConSourceArity DataCon
    data_con
        (Scaled Type
    data_con_arg_ty1 : [Scaled Type]
    _)                      = [Scaled Type]
    data_con_arg_tys

        (Scaled Type
    _ : Scaled Type
    _ : Scaled Type
    data_con_arg_ty3 : [Scaled Type]
    _) = [Scaled Type]
    data_con_arg_tys
        maybe_arg3_tycon :: Maybe TyCon
    maybe_arg3_tycon               = Type -> Maybe TyCon
    tyConAppTyCon_maybe (Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing Scaled Type
    data_con_arg_ty3)
        Just TyCon
    arg3_tycon                = Maybe TyCon
    maybe_arg3_tycon

    -- Takes the result of the user-level ccall:
    --      either (IO t),
    --      or maybe just t for an side-effect-free call
    -- Returns a wrapper for the primitive ccall itself, along with the
    -- type of the result of the primitive ccall.  This result type
    -- will be of the form
    --      State# RealWorld -> (# State# RealWorld, t' #)
    -- where t' is the unwrapped form of t.  If t is simply (), then
    -- the result type will be
    --      State# RealWorld -> (# State# RealWorld #)
    boxJsResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
    boxJsResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
    boxJsResult Type
    result_ty
      | Just (TyCon
    io_tycon, Type
    io_res_ty) <- Type -> Maybe (TyCon, Type)
    tcSplitIOType_maybe Type
    result_ty
            -- isIOType_maybe handles the case where the type is a
            -- simple wrapping of IO.  E.g.
            --      newtype Wrap a = W (IO a)
            -- No coercion necessary because its a non-recursive newtype
            -- (If we wanted to handle a *recursive* newtype too, we'd need
            -- another case, and a coercion.)
            -- The result is IO t, so wrap the result in an IO constructor
      = do  { res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    jsResultWrapper Type
    io_res_ty
            ; let return_result CoreExpr
    state CoreExpr
    ans
                    = [CoreExpr] -> CoreExpr
    mkCoreUnboxedTuple [CoreExpr
    state, CoreExpr
    ans]

            ; (ccall_res_ty, the_alt) <- mk_alt return_result res

            ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
            ; let io_data_con = [DataCon] -> DataCon
    forall a. HasCallStack => [a] -> a
    head (TyCon -> [DataCon]
    tyConDataCons TyCon
    io_tycon)
                  toIOCon     = DataCon -> Id
    dataConWrapId DataCon
    io_data_con

                  wrap CoreExpr
    the_call =
                                  CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    toIOCon)
                                         [ Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    io_res_ty,
                                           Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    state_id (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                                           CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
    mkWildCase (CoreExpr -> CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b -> Expr b
    App CoreExpr
    the_call (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    state_id))
                                                 (Type -> Scaled Type
    forall a. a -> Scaled a
    unrestricted Type
    ccall_res_ty)
                                                 (CoreAlt -> Type
    coreAltType CoreAlt
    the_alt)
                                                 [CoreAlt
    the_alt]
                                         ]

            ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) }

    boxJsResult Type
    result_ty
      = do -- It isn't IO, so do unsafePerformIO
           -- It's not conveniently available, so we inline it
           res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    jsResultWrapper Type
    result_ty
           (ccall_res_ty, the_alt) <- mk_alt return_result res
           let
               wrap = \ CoreExpr
    the_call -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
    mkWildCase (CoreExpr -> CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b -> Expr b
    App CoreExpr
    the_call (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    realWorldPrimId))
                                               (Type -> Scaled Type
    forall a. a -> Scaled a
    unrestricted Type
    ccall_res_ty)
                                               (CoreAlt -> Type
    coreAltType CoreAlt
    the_alt)
                                               [CoreAlt
    the_alt]
           return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
      where
        return_result :: p -> p -> p
    return_result p
    _ p
    ans = p
    ans

    mk_alt :: (Expr Var -> Expr Var -> Expr Var)
           -> (Maybe Type, Expr Var -> Expr Var)
           -> DsM (Type, CoreAlt)
    mk_alt :: (CoreExpr -> CoreExpr -> CoreExpr)
    -> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreAlt)
    mk_alt CoreExpr -> CoreExpr -> CoreExpr
    return_result (Maybe Type
    Nothing, CoreExpr -> CoreExpr
    wrap_result)
      = do -- The ccall returns ()
           state_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy Type
    realWorldStatePrimTy
           let
                 the_rhs = CoreExpr -> CoreExpr -> CoreExpr
    return_result (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    state_id)
                                         (CoreExpr -> CoreExpr
    wrap_result (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ String -> CoreExpr
    forall a. HasCallStack => String -> a
    panic String
    "jsBoxResult")
                 ccall_res_ty = Boxity -> [Type] -> Type
    mkTupleTy Boxity
    Unboxed [Type
    realWorldStatePrimTy]
                 the_alt      = AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt (Boxity -> Arity -> DataCon
    tupleDataCon Boxity
    Unboxed Arity
    1)) [Id
    state_id] CoreExpr
    the_rhs
           return (ccall_res_ty, the_alt)

    mk_alt CoreExpr -> CoreExpr -> CoreExpr
    return_result (Just Type
    prim_res_ty, CoreExpr -> CoreExpr
    wrap_result)
                    -- The ccall returns a non-() value
      | Type -> Bool
    isUnboxedTupleType Type
    prim_res_ty = do
        let
            Just [Type]
    ls = ([Type] -> [Type]) -> Maybe [Type] -> Maybe [Type]
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [Type] -> [Type]
    dropRuntimeRepArgs (Type -> Maybe [Type]
    tyConAppArgs_maybe Type
    prim_res_ty)
            arity :: Arity
    arity = Arity
    1 Arity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    + [Type] -> Arity
    forall a. [a] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length [Type]
    ls
        args_ids <- (Type -> DsM Id) -> [Type] -> DsM [Id]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy) [Type]
    ls
        state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
        let
            result_tup = [CoreExpr] -> CoreExpr
    mkCoreUnboxedTuple ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> CoreExpr
    forall b. Id -> Expr b
    Var [Id]
    args_ids)
            the_rhs = CoreExpr -> CoreExpr -> CoreExpr
    return_result (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    state_id)
                                    (CoreExpr -> CoreExpr
    wrap_result CoreExpr
    result_tup)
            ccall_res_ty = Boxity -> [Type] -> Type
    mkTupleTy Boxity
    Unboxed (Type
    realWorldStatePrimTy Type -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    : [Type]
    ls)
            the_alt      = AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt (Boxity -> Arity -> DataCon
    tupleDataCon Boxity
    Unboxed Arity
    arity))
                               (Id
    state_id Id -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    : [Id]
    args_ids)
                              CoreExpr
    the_rhs
        return (ccall_res_ty, the_alt)

      | Bool
    otherwise = do
        result_id <- Type -> Type -> DsM Id
    newSysLocalDs Type
    ManyTy Type
    prim_res_ty
        state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
        let
            the_rhs = CoreExpr -> CoreExpr -> CoreExpr
    return_result (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    state_id)
                                    (CoreExpr -> CoreExpr
    wrap_result (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    result_id))
            ccall_res_ty = Boxity -> [Type] -> Type
    mkTupleTy Boxity
    Unboxed [Type
    realWorldStatePrimTy, Type
    prim_res_ty]
            the_alt      = AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt (Boxity -> Arity -> DataCon
    tupleDataCon Boxity
    Unboxed Arity
    2)) [Id
    state_id, Id
    result_id] CoreExpr
    the_rhs
        return (ccall_res_ty, the_alt)

    fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
    fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Arity
    fun_type_arg_stdcall_info CCallConv
    _other_conv Type
    _ = Maybe Arity
    forall a. Maybe a
    Nothing

    jsResultWrapper
      :: Type
      -> DsM ( Maybe Type           -- Type of the expected result, if any
             , CoreExpr -> CoreExpr -- Wrapper for the result
             )
    -- resultWrapper deals with the result *value*
    -- E.g. foreign import foo :: Int -> IO T
    -- Then resultWrapper deals with marshalling the 'T' part
    jsResultWrapper :: Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    jsResultWrapper Type
    result_ty
      -- Base case 1a: unboxed tuples
      | Just (TyCon
    tc, [Type]
    args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    splitTyConApp_maybe Type
    result_ty
      , TyCon -> Bool
    isUnboxedTupleTyCon TyCon
    tc {- && False -} = do
        let args' :: [Type]
    args' = [Type] -> [Type]
    dropRuntimeRepArgs [Type]
    args
        (tys, wrappers) <- [(Maybe Type, CoreExpr -> CoreExpr)]
    -> ([Maybe Type], [CoreExpr -> CoreExpr])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Maybe Type, CoreExpr -> CoreExpr)]
     -> ([Maybe Type], [CoreExpr -> CoreExpr]))
    -> IOEnv
         (Env DsGblEnv DsLclEnv) [(Maybe Type, CoreExpr -> CoreExpr)]
    -> IOEnv
         (Env DsGblEnv DsLclEnv) ([Maybe Type], [CoreExpr -> CoreExpr])
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Type -> DsM (Maybe Type, CoreExpr -> CoreExpr))
    -> [Type]
    -> IOEnv
         (Env DsGblEnv DsLclEnv) [(Maybe Type, CoreExpr -> CoreExpr)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    jsResultWrapper [Type]
    args'
        matched <- mapM (mapM (newSysLocalDs ManyTy)) tys
        let tys'    = [Maybe Type] -> [Type]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe Type]
    tys
            -- arity   = length args'
            -- resCon  = tupleDataCon Unboxed (length args)
            err     = String -> a
    forall a. HasCallStack => String -> a
    panic String
    "jsResultWrapper: used Id with result type Nothing"
            resWrap :: CoreExpr
            resWrap = [CoreExpr] -> CoreExpr
    mkCoreUnboxedTuple (((CoreExpr -> CoreExpr) -> Maybe Id -> CoreExpr)
    -> [CoreExpr -> CoreExpr] -> [Maybe Id] -> [CoreExpr]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\CoreExpr -> CoreExpr
    w -> CoreExpr -> CoreExpr
    w (CoreExpr -> CoreExpr)
    -> (Maybe Id -> CoreExpr) -> Maybe Id -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> CoreExpr
    forall b. Id -> Expr b
    Var (Id -> CoreExpr) -> (Maybe Id -> Id) -> Maybe Id -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> Maybe Id -> Id
    forall a. a -> Maybe a -> a
    fromMaybe Id
    forall {a}. a
    err) [CoreExpr -> CoreExpr]
    wrappers [Maybe Id]
    matched)
        return $
          if null tys'
            then (Nothing, \CoreExpr
    _ -> CoreExpr
    resWrap)
            else let innerArity = [Type] -> Arity
    forall a. [a] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length [Type]
    tys'
                     innerTy    = Boxity -> [Type] -> Type
    mkTupleTy Boxity
    Unboxed [Type]
    tys'
                     innerCon   = Boxity -> Arity -> DataCon
    tupleDataCon Boxity
    Unboxed Arity
    innerArity
                     inner :: CoreExpr -> CoreExpr
                     inner CoreExpr
    e    = CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
    mkWildCase CoreExpr
    e (Type -> Scaled Type
    forall a. a -> Scaled a
    unrestricted Type
    innerTy) Type
    result_ty
                                             [AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt DataCon
    innerCon)
                                                  ([Maybe Id] -> [Id]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe Id]
    matched)
                                                  CoreExpr
    resWrap
                                             ]
                 in (Just innerTy, inner)

      -- Base case 1b: primitive types
      | Type -> Bool
    isPrimitiveType Type
    result_ty
      = (Maybe Type, CoreExpr -> CoreExpr)
    -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Maybe Type
    forall a. a -> Maybe a
    Just Type
    result_ty, \CoreExpr
    e -> CoreExpr
    e)
      -- Base case 1c: boxed tuples
      -- fixme: levity args?
      | Just (TyCon
    tc, [Type]
    args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    splitTyConApp_maybe Type
    result_ty
      , TyCon -> Bool
    isBoxedTupleTyCon TyCon
    tc = do
          let args' :: [Type]
    args'   = [Type] -> [Type]
    dropRuntimeRepArgs [Type]
    args
              innerTy :: Type
    innerTy = Boxity -> [Type] -> Type
    mkTupleTy Boxity
    Unboxed [Type]
    args'
          (inner_res, w) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    jsResultWrapper Type
    innerTy
          matched <- mapM (newSysLocalDs ManyTy) args'
          let inner CoreExpr
    e = CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
    mkWildCase (CoreExpr -> CoreExpr
    w CoreExpr
    e) (Type -> Scaled Type
    forall a. a -> Scaled a
    unrestricted Type
    innerTy) Type
    result_ty
                                   [ AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt (Boxity -> Arity -> DataCon
    tupleDataCon Boxity
    Unboxed ([Type] -> Arity
    forall a. [a] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length [Type]
    args')))
                                         [Id]
    matched
                                         ([CoreExpr] -> CoreExpr
    mkCoreTup ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> CoreExpr
    forall b. Id -> Expr b
    Var [Id]
    matched))
                                    -- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched)
                                   ]
          return (inner_res, inner)

      -- Base case 2: the unit type ()
      | Just (TyCon
    tc,[Type]
    _) <- Maybe (TyCon, [Type])
    maybe_tc_app, TyCon
    tc TyCon -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    unitTyConKey
      = (Maybe Type, CoreExpr -> CoreExpr)
    -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe Type
    forall a. Maybe a
    Nothing, \CoreExpr
    _ -> Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    unitDataConId)

      -- Base case 3: the boolean type
      | Just (TyCon
    tc,[Type]
    _) <- Maybe (TyCon, [Type])
    maybe_tc_app, TyCon
    tc TyCon -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    boolTyConKey = do
    --    result_id <- newSysLocalDs boolTy
        ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
    forall gbl lcl. TcRnIf gbl lcl Unique
    newUnique
        let forceBool CoreExpr
    e = Unique -> CLabelString -> [CoreExpr] -> Type -> CoreExpr
    mkJsCall Unique
    ccall_uniq (String -> CLabelString
    fsLit String
    "((x) => { return !(!x); })") [CoreExpr
    e] Type
    boolTy
        return
         (Just intPrimTy, \CoreExpr
    e -> CoreExpr -> CoreExpr
    forceBool CoreExpr
    e)

      -- Base case 4: the any type
      |  Just (TyCon
    tc,[Type]
    _) <- Maybe (TyCon, [Type])
    maybe_tc_app, TyCon
    tc TyCon -> Unique -> Bool
    forall a. Uniquable a => a -> Unique -> Bool
    `hasKey` Unique
    anyTyConKey
      = (Maybe Type, CoreExpr -> CoreExpr)
    -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Type -> Maybe Type
    forall a. a -> Maybe a
    Just Type
    result_ty, \CoreExpr
    e -> CoreExpr
    e)

      -- Newtypes
      | Just (Coercion
    co, Type
    rep_ty) <- Type -> Maybe (Coercion, Type)
    topNormaliseNewType_maybe Type
    result_ty
      = do (maybe_ty, wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    jsResultWrapper Type
    rep_ty
           return (maybe_ty, \CoreExpr
    e -> CoreExpr -> Coercion -> CoreExpr
    mkCastDs (CoreExpr -> CoreExpr
    wrapper CoreExpr
    e) (Coercion -> Coercion
    mkSymCo Coercion
    co))

      -- The type might contain foralls (eg. for dummy type arguments,
      -- referring to 'Ptr a' is legal).
      | Just (Id
    tyvar, Type
    rest) <- Type -> Maybe (Id, Type)
    splitForAllTyCoVar_maybe Type
    result_ty
      = do (maybe_ty, wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    jsResultWrapper Type
    rest
           return (maybe_ty, \CoreExpr
    e -> Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    tyvar (CoreExpr -> CoreExpr
    wrapper CoreExpr
    e))

      -- Data types with a single constructor, which has a single arg
      -- This includes types like Ptr and ForeignPtr
      | Just (TyCon
    _tycon, [Type]
    tycon_arg_tys, DataCon
    data_con, [Scaled Type]
    data_con_arg_tys) <- Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
    splitDataProductType_maybe Type
    result_ty,
        DataCon -> Arity
    dataConSourceArity DataCon
    data_con Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    1
      = do let (Scaled Type
    unwrapped_res_ty : [Scaled Type]
    _) = [Scaled Type]
    data_con_arg_tys
           (maybe_ty, wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    jsResultWrapper (Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing Scaled Type
    unwrapped_res_ty)
           return
             (maybe_ty, \CoreExpr
    e -> CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (Id -> CoreExpr
    forall b. Id -> Expr b
    Var (DataCon -> Id
    dataConWrapId DataCon
    data_con))
                                     ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> CoreExpr
    forall b. Type -> Expr b
    Type [Type]
    tycon_arg_tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
    forall a. [a] -> [a] -> [a]
    ++ [CoreExpr -> CoreExpr
    wrapper CoreExpr
    e]))

      | Bool
    otherwise
      = String -> SDoc -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "jsResultWrapper" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    result_ty)
      where
        maybe_tc_app :: Maybe (TyCon, [Type])
    maybe_tc_app = HasDebugCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    splitTyConApp_maybe Type
    result_ty

    -- low-level primitive JavaScript call:
    mkJsCall :: Unique -> FastString -> [CoreExpr] -> Type -> CoreExpr
    mkJsCall :: Unique -> CLabelString -> [CoreExpr] -> Type -> CoreExpr
    mkJsCall Unique
    u CLabelString
    tgt [CoreExpr]
    args Type
    t = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
    mkFCall Unique
    u ForeignCall
    ccall [CoreExpr]
    args Type
    t
      where
        ccall :: ForeignCall
    ccall = CCallSpec -> ForeignCall
    CCall (CCallSpec -> ForeignCall) -> CCallSpec -> ForeignCall
    forall a b. (a -> b) -> a -> b
    $ CCallTarget -> CCallConv -> Safety -> CCallSpec
    CCallSpec
                  (SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
    StaticTarget SourceText
    NoSourceText CLabelString
    tgt (Unit -> Maybe Unit
    forall a. a -> Maybe a
    Just Unit
    primUnit) Bool
    True)
                  CCallConv
    JavaScriptCallConv
                  Safety
    PlayRisky