{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}

module GHC.StgToJS.FFI
  ( genPrimCall
  , genForeignCall
  , saturateFFI
  )
where

import GHC.Prelude

import GHC.JS.Unsat.Syntax
import GHC.JS.Make
import GHC.JS.Transform
import qualified GHC.JS.Syntax as Sat

import GHC.StgToJS.Arg
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Monad
import GHC.StgToJS.Types
import GHC.StgToJS.Literal
import GHC.StgToJS.Regs
import GHC.StgToJS.Utils
import GHC.StgToJS.Ids

import GHC.Types.RepType
import GHC.Types.ForeignCall
import GHC.Types.Unique.Map

import GHC.Stg.Syntax

import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim

import GHC.Core.Type hiding (typeSize)

import GHC.Utils.Misc
import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr)
import GHC.Data.FastString

import Data.Char
import Data.Monoid
import qualified Data.List as L

genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult)
genPrimCall ExprCtx
ctx (PrimCall FastString
lbl Unit
_) [StgArg]
args Type
t = do
  JStat
j <- Bool
-> Bool -> Bool -> [Char] -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern Bool
False Bool
False Bool
False ([Char]
"h$" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FastString -> [Char]
unpackFS FastString
lbl) Type
t ((TypedExpr -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr ([TypedExpr] -> [JExpr]) -> [TypedExpr] -> [JExpr]
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [StgArg]
args
  (JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
j, Maybe [JExpr] -> ExprResult
ExprInline Maybe [JExpr]
forall a. Maybe a
Nothing)

-- | generate the actual call
{-
  parse FFI patterns:
   "&value         -> value
  1. "function"      -> ret = function(...)
  2. "$r = $1.f($2)  -> r1 = a1.f(a2)

  arguments, $1, $2, $3 unary arguments
     $1_1, $1_2, for a binary argument

  return type examples
  1. $r                      unary return
  2. $r1, $r2                binary return
  3. $r1, $r2, $r3_1, $r3_2  unboxed tuple return
 -}
parseFFIPattern :: Bool  -- ^ catch exception and convert them to haskell exceptions
                -> Bool  -- ^ async (only valid with javascript calling conv)
                -> Bool  -- ^ using javascript calling convention
                -> String
                -> Type
                -> [JExpr]
                -> [StgArg]
                -> G JStat
parseFFIPattern :: Bool
-> Bool -> Bool -> [Char] -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern Bool
catchExcep Bool
async Bool
jscc [Char]
pat Type
t [JExpr]
es [StgArg]
as
  | Bool
catchExcep = do
      JStat
c <- Bool -> Bool -> [Char] -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPatternA Bool
async Bool
jscc [Char]
pat Type
t [JExpr]
es [StgArg]
as
      -- Generate:
      --  try {
      --    `c`;
      --  } catch(except) {
      --    return h$throwJSException(except);
      --  }
      let ex :: Ident
ex = FastString -> Ident
TxtI FastString
"except"
      JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> Ident -> JStat -> JStat -> JStat
TryStat JStat
c Ident
ex (JExpr -> JStat
ReturnStat (JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$throwJSException") [Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
ex])) JStat
forall a. Monoid a => a
mempty)
  | Bool
otherwise  = Bool -> Bool -> [Char] -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPatternA Bool
async Bool
jscc [Char]
pat Type
t [JExpr]
es [StgArg]
as

parseFFIPatternA :: Bool  -- ^ async
                 -> Bool  -- ^ using JavaScript calling conv
                 -> String
                 -> Type
                 -> [JExpr]
                 -> [StgArg]
                 -> G JStat
-- async calls get an extra callback argument
-- call it with the result
parseFFIPatternA :: Bool -> Bool -> [Char] -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPatternA Bool
True Bool
True [Char]
pat Type
t [JExpr]
es [StgArg]
as  = do
  Ident
cb <- G Ident
freshIdent
  Ident
x  <- G Ident
freshIdent
  Ident
d  <- G Ident
freshIdent
  JStat
stat <- Maybe JExpr
-> Bool -> [Char] -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern' (JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
cb)) Bool
True [Char]
pat Type
t [JExpr]
es [StgArg]
as
  JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
    [ Ident
x  Ident -> JExpr -> JStat
||= (JVal -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr ([(FastString, JExpr)] -> JVal
jhFromList [(FastString
"mv", JExpr
null_)]))
    , Ident
cb Ident -> JExpr -> JStat
||= JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$mkForeignCallback") [Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
x]
    , JStat
stat
    , JExpr -> JStat -> JStat -> JStat
IfStat (JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
StrictEqOp (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
x JExpr -> FastString -> JExpr
.^ FastString
"mv") JExpr
null_)
          ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
            [ Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
x JExpr -> FastString -> JExpr
.^ FastString
"mv" JExpr -> JExpr -> JStat
|= JUOp -> JExpr -> JExpr
UOpExpr JUOp
NewOp (JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$MVar") [])
            , JExpr
sp JExpr -> JExpr -> JStat
|= JExpr -> JExpr -> JExpr
Add JExpr
sp JExpr
one_
            , (JExpr -> JExpr -> JExpr
IdxExpr JExpr
stack JExpr
sp) JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$unboxFFIResult"
            , JExpr -> JStat
ReturnStat (JExpr -> JStat) -> JExpr -> JStat
forall a b. (a -> b) -> a -> b
$ JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$takeMVar") [Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
x JExpr -> FastString -> JExpr
.^ FastString
"mv"]
            ])
          ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
            [ Ident
d Ident -> JExpr -> JStat
||= Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
x JExpr -> FastString -> JExpr
.^ FastString
"mv"
            , JExpr -> JStat
copyResult (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
d)
            ])
    ]
    where nrst :: Int
nrst = Type -> Int
typeSize Type
t
          copyResult :: JExpr -> JStat
copyResult JExpr
d = [JExpr] -> [JExpr] -> JStat
HasDebugCallStack => [JExpr] -> [JExpr] -> JStat
assignAllEqual [JExpr]
es ((Int -> JExpr) -> [Int] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map (JExpr -> JExpr -> JExpr
IdxExpr JExpr
d (JExpr -> JExpr) -> (Int -> JExpr) -> Int -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr) [Int
0..Int
nrstInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1])
parseFFIPatternA Bool
_async Bool
javascriptCc [Char]
pat Type
t [JExpr]
es [StgArg]
as =
  Maybe JExpr
-> Bool -> [Char] -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern' Maybe JExpr
forall a. Maybe a
Nothing Bool
javascriptCc [Char]
pat Type
t [JExpr]
es [StgArg]
as

-- parseFFIPatternA _ _ _ _ _ _ = error "parseFFIPattern: non-JavaScript pattern must be synchronous"

parseFFIPattern' :: Maybe JExpr -- ^ Nothing for sync, Just callback for async
                 -> Bool        -- ^ javascript calling convention used
                 -> String      -- ^ pattern called
                 -> Type        -- ^ return type
                 -> [JExpr]     -- ^ expressions to return in (may be more than necessary)
                 -> [StgArg]    -- ^ arguments
                 -> G JStat
parseFFIPattern' :: Maybe JExpr
-> Bool -> [Char] -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern' Maybe JExpr
callback Bool
javascriptCc [Char]
pat Type
t [JExpr]
ret [StgArg]
args
  | Bool -> Bool
not Bool
javascriptCc = [Char] -> G JStat
mkApply [Char]
pat
  | Bool
otherwise = [Char] -> G JStat
mkApply [Char]
pat
  where
    tgt :: [JExpr]
tgt = Int -> [JExpr] -> [JExpr]
forall a. Int -> [a] -> [a]
take (Type -> Int
typeSize Type
t) [JExpr]
ret
    -- automatic apply, build call and result copy
    mkApply :: [Char] -> G JStat
mkApply [Char]
f
      | Just JExpr
cb <- Maybe JExpr
callback = do
         ([JStat]
stats, [[JExpr]]
as) <- [(JStat, [JExpr])] -> ([JStat], [[JExpr]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(JStat, [JExpr])] -> ([JStat], [[JExpr]]))
-> StateT GenState IO [(JStat, [JExpr])]
-> StateT GenState IO ([JStat], [[JExpr]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> StateT GenState IO (JStat, [JExpr]))
-> [StgArg] -> StateT GenState IO [(JStat, [JExpr])]
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 (Bool -> StgArg -> StateT GenState IO (JStat, [JExpr])
genFFIArg Bool
javascriptCc) [StgArg]
args
         StgToJSConfig
cs <- G StgToJSConfig
getSettings
         JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> [[JExpr]] -> JStat
traceCall StgToJSConfig
cs [[JExpr]]
as JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat]
stats JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> [JExpr] -> JStat
ApplStat JExpr
f' ([[JExpr]] -> [JExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JExpr]]
as[JExpr] -> [JExpr] -> [JExpr]
forall a. [a] -> [a] -> [a]
++[JExpr
cb])
      | {-ts@-}
        (JExpr
t:[JExpr]
ts') <- [JExpr]
tgt = do
         ([JStat]
stats, [[JExpr]]
as) <- [(JStat, [JExpr])] -> ([JStat], [[JExpr]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(JStat, [JExpr])] -> ([JStat], [[JExpr]]))
-> StateT GenState IO [(JStat, [JExpr])]
-> StateT GenState IO ([JStat], [[JExpr]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> StateT GenState IO (JStat, [JExpr]))
-> [StgArg] -> StateT GenState IO [(JStat, [JExpr])]
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 (Bool -> StgArg -> StateT GenState IO (JStat, [JExpr])
genFFIArg Bool
javascriptCc) [StgArg]
args
         StgToJSConfig
cs <- G StgToJSConfig
getSettings
         JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> [[JExpr]] -> JStat
traceCall StgToJSConfig
cs [[JExpr]]
as
                JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat]
stats
                JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> (JExpr
t JExpr -> JExpr -> JStat
|= JExpr -> [JExpr] -> JExpr
ApplExpr JExpr
f' ([[JExpr]] -> [JExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JExpr]]
as) )
                JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JExpr] -> JStat
forall {a}. ToJExpr a => [a] -> JStat
copyResult [JExpr]
ts'
           -- _ -> error "mkApply: empty list"
      | Bool
otherwise = do
         ([JStat]
stats, [[JExpr]]
as) <- [(JStat, [JExpr])] -> ([JStat], [[JExpr]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(JStat, [JExpr])] -> ([JStat], [[JExpr]]))
-> StateT GenState IO [(JStat, [JExpr])]
-> StateT GenState IO ([JStat], [[JExpr]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StgArg -> StateT GenState IO (JStat, [JExpr]))
-> [StgArg] -> StateT GenState IO [(JStat, [JExpr])]
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 (Bool -> StgArg -> StateT GenState IO (JStat, [JExpr])
genFFIArg Bool
javascriptCc) [StgArg]
args
         StgToJSConfig
cs <- G StgToJSConfig
getSettings
         JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> [[JExpr]] -> JStat
traceCall StgToJSConfig
cs [[JExpr]]
as JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat]
stats JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JExpr -> [JExpr] -> JStat
ApplStat JExpr
f' ([[JExpr]] -> [JExpr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JExpr]]
as)
        where f' :: JExpr
f' = Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (FastString -> Ident
TxtI (FastString -> Ident) -> FastString -> Ident
forall a b. (a -> b) -> a -> b
$ [Char] -> FastString
mkFastString [Char]
f)
    copyResult :: [a] -> JStat
copyResult [a]
rs = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> [JStat] -> JStat
forall a b. (a -> b) -> a -> b
$ (StgRet -> a -> JStat) -> [StgRet] -> [a] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\StgRet
t a
r -> a -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr a
r JExpr -> JExpr -> JStat
|= StgRet -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StgRet
t) (StgRet -> [StgRet]
forall a. Enum a => a -> [a]
enumFrom StgRet
Ret1) [a]
rs

    traceCall :: StgToJSConfig -> [[JExpr]] -> JStat
traceCall StgToJSConfig
cs [[JExpr]]
as
        | StgToJSConfig -> Bool
csTraceForeign StgToJSConfig
cs = JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$traceForeign") [[Char] -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [Char]
pat, [[JExpr]] -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [[JExpr]]
as]
        | Bool
otherwise         = JStat
forall a. Monoid a => a
mempty

-- generate arg to be passed to FFI call, with marshalling JStat to be run
-- before the call
genFFIArg :: Bool -> StgArg -> G (JStat, [JExpr])
genFFIArg :: Bool -> StgArg -> StateT GenState IO (JStat, [JExpr])
genFFIArg Bool
_isJavaScriptCc (StgLitArg Literal
l) = (JStat
forall a. Monoid a => a
mempty,) ([JExpr] -> (JStat, [JExpr]))
-> StateT GenState IO [JExpr]
-> StateT GenState IO (JStat, [JExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Literal -> StateT GenState IO [JExpr]
Literal -> StateT GenState IO [JExpr]
genLit Literal
l
genFFIArg Bool
isJavaScriptCc a :: StgArg
a@(StgVarArg Id
i)
    | Bool -> Bool
not Bool
isJavaScriptCc Bool -> Bool -> Bool
&&
      (TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon) =
        (\JExpr
x -> (JStat
forall a. Monoid a => a
mempty,[JExpr
x, JExpr
zero_])) (JExpr -> (JStat, [JExpr]))
-> StateT GenState IO JExpr -> StateT GenState IO (JStat, [JExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO JExpr
varForId Id
i
    | VarType -> Bool
isVoid VarType
r                  = (JStat, [JExpr]) -> StateT GenState IO (JStat, [JExpr])
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
forall a. Monoid a => a
mempty, [])
--    | Just x <- marshalFFIArg a = x
    | VarType -> Bool
isMultiVar VarType
r              = (JStat
forall a. Monoid a => a
mempty,) ([JExpr] -> (JStat, [JExpr]))
-> StateT GenState IO [JExpr]
-> StateT GenState IO (JStat, [JExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> StateT GenState IO JExpr)
-> [Int] -> StateT GenState IO [JExpr]
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 (Id -> Int -> StateT GenState IO JExpr
varForIdN Id
i) [Int
1..VarType -> Int
varSize VarType
r]
    | Bool
otherwise                 = (\JExpr
x -> (JStat
forall a. Monoid a => a
mempty,[JExpr
x])) (JExpr -> (JStat, [JExpr]))
-> StateT GenState IO JExpr -> StateT GenState IO (JStat, [JExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO JExpr
varForId Id
i
   where
     tycon :: TyCon
tycon  = HasDebugCallStack => Type -> TyCon
Type -> TyCon
tyConAppTyCon (Type -> Type
unwrapType Type
arg_ty)
     arg_ty :: Type
arg_ty = StgArg -> Type
stgArgType StgArg
a
     r :: VarType
r      = HasDebugCallStack => Type -> VarType
Type -> VarType
uTypeVt Type
arg_ty

saturateFFI :: Int -> JStat -> Sat.JStat
saturateFFI :: Int -> JStat -> JStat
saturateFFI Int
u = Maybe FastString -> JStat -> JStat
satJStat (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (FastString -> Maybe FastString)
-> ([Char] -> FastString) -> [Char] -> Maybe FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString ([Char] -> Maybe FastString) -> [Char] -> Maybe FastString
forall a b. (a -> b) -> a -> b
$ [Char]
"ghcjs_ffi_sat_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
u)

genForeignCall :: HasDebugCallStack
               => ExprCtx
               -> ForeignCall
               -> Type
               -> [JExpr]
               -> [StgArg]
               -> G (JStat, ExprResult)
genForeignCall :: HasDebugCallStack =>
ExprCtx
-> ForeignCall
-> Type
-> [JExpr]
-> [StgArg]
-> G (JStat, ExprResult)
genForeignCall ExprCtx
_ctx
               (CCall (CCallSpec (StaticTarget SourceText
_ FastString
tgt Maybe Unit
Nothing Bool
True)
                                   CCallConv
JavaScriptCallConv
                                   Safety
PlayRisky))
               Type
_t
               [JExpr
obj]
               [StgArg]
args
  | FastString
tgt FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> FastString
fsLit [Char]
"h$buildObject"
  , Just [(FastString, StgArg)]
pairs <- [StgArg] -> Maybe [(FastString, StgArg)]
getObjectKeyValuePairs [StgArg]
args = do
      [(FastString, JExpr)]
pairs' <- ((FastString, StgArg) -> StateT GenState IO (FastString, JExpr))
-> [(FastString, StgArg)]
-> StateT GenState IO [(FastString, JExpr)]
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 (\(FastString
k,StgArg
v) -> HasDebugCallStack => StgArg -> StateT GenState IO [JExpr]
StgArg -> StateT GenState IO [JExpr]
genArg StgArg
v StateT GenState IO [JExpr]
-> ([JExpr] -> StateT GenState IO (FastString, JExpr))
-> StateT GenState IO (FastString, JExpr)
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[JExpr]
vs -> (FastString, JExpr) -> StateT GenState IO (FastString, JExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString
k, [JExpr] -> JExpr
forall a. HasCallStack => [a] -> a
head [JExpr]
vs)) [(FastString, StgArg)]
pairs
      (JStat, ExprResult) -> G (JStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( JExpr -> JExpr -> JStat
(|=) JExpr
obj (JVal -> JExpr
ValExpr (UniqMap FastString JExpr -> JVal
JHash (UniqMap FastString JExpr -> JVal)
-> UniqMap FastString JExpr -> JVal
forall a b. (a -> b) -> a -> b
$ [(FastString, JExpr)] -> UniqMap FastString JExpr
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap [(FastString, JExpr)]
pairs'))
             , Maybe [JExpr] -> ExprResult
ExprInline Maybe [JExpr]
forall a. Maybe a
Nothing
             )

genForeignCall ExprCtx
ctx (CCall (CCallSpec CCallTarget
ccTarget CCallConv
cconv Safety
safety)) Type
t [JExpr]
tgt [StgArg]
args = do
  Maybe RealSrcSpan
-> FastString
-> Safety
-> CCallConv
-> [FastString]
-> FastString
-> G ()
emitForeign (ExprCtx -> Maybe RealSrcSpan
ctxSrcSpan ExprCtx
ctx) ([Char] -> FastString
mkFastString [Char]
lbl) Safety
safety CCallConv
cconv ((StgArg -> FastString) -> [StgArg] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> FastString
showArgType [StgArg]
args) (Type -> FastString
showType Type
t)
  (,ExprResult
exprResult) (JStat -> (JStat, ExprResult)) -> G JStat -> G (JStat, ExprResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Bool -> Bool -> [Char] -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern Bool
catchExcep Bool
async Bool
isJsCc [Char]
lbl Type
t [JExpr]
tgt' [StgArg]
args
  where
    isJsCc :: Bool
isJsCc = CCallConv
cconv CCallConv -> CCallConv -> Bool
forall a. Eq a => a -> a -> Bool
== CCallConv
JavaScriptCallConv

    lbl :: [Char]
lbl | (StaticTarget SourceText
_ FastString
clbl Maybe Unit
_mpkg Bool
_isFunPtr) <- CCallTarget
ccTarget
            = let clbl' :: [Char]
clbl' = FastString -> [Char]
unpackFS FastString
clbl
              in  if | Bool
isJsCc -> [Char]
clbl'
                     | [Char]
wrapperPrefix [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` [Char]
clbl' ->
                         ([Char]
"h$" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
2 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isDigit ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
wrapperPrefix) [Char]
clbl'))
                     | Bool
otherwise -> [Char]
"h$" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
clbl'
        | Bool
otherwise = [Char]
"h$callDynamic"

    exprResult :: ExprResult
exprResult | Bool
async     = ExprResult
ExprCont
               | Bool
otherwise = Maybe [JExpr] -> ExprResult
ExprInline Maybe [JExpr]
forall a. Maybe a
Nothing

    catchExcep :: Bool
catchExcep = (CCallConv
cconv CCallConv -> CCallConv -> Bool
forall a. Eq a => a -> a -> Bool
== CCallConv
JavaScriptCallConv) Bool -> Bool -> Bool
&&
                 Safety -> Bool
playSafe Safety
safety Bool -> Bool -> Bool
|| Safety -> Bool
playInterruptible Safety
safety

    async :: Bool
async | Bool
isJsCc    = Safety -> Bool
playInterruptible Safety
safety
          | Bool
otherwise = Safety -> Bool
playInterruptible Safety
safety Bool -> Bool -> Bool
|| Safety -> Bool
playSafe Safety
safety

    tgt' :: [JExpr]
tgt'  | Bool
async     = Int -> [JExpr] -> [JExpr]
forall a. Int -> [a] -> [a]
take ([JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
tgt) [JExpr]
jsRegsFromR1
          | Bool
otherwise = [JExpr]
tgt

    wrapperPrefix :: [Char]
wrapperPrefix = [Char]
"ghczuwrapperZC"

getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)]
getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)]
getObjectKeyValuePairs [] = [(FastString, StgArg)] -> Maybe [(FastString, StgArg)]
forall a. a -> Maybe a
Just []
getObjectKeyValuePairs (StgArg
k:StgArg
v:[StgArg]
xs)
  | Just FastString
t <- StgArg -> Maybe FastString
argJSStringLitUnfolding StgArg
k =
      ([(FastString, StgArg)] -> [(FastString, StgArg)])
-> Maybe [(FastString, StgArg)] -> Maybe [(FastString, StgArg)]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FastString
t,StgArg
v)(FastString, StgArg)
-> [(FastString, StgArg)] -> [(FastString, StgArg)]
forall a. a -> [a] -> [a]
:) ([StgArg] -> Maybe [(FastString, StgArg)]
getObjectKeyValuePairs [StgArg]
xs)
getObjectKeyValuePairs [StgArg]
_ = Maybe [(FastString, StgArg)]
forall a. Maybe a
Nothing

argJSStringLitUnfolding :: StgArg -> Maybe FastString
argJSStringLitUnfolding :: StgArg -> Maybe FastString
argJSStringLitUnfolding (StgVarArg Id
_v) = Maybe FastString
forall a. Maybe a
Nothing -- fixme
argJSStringLitUnfolding StgArg
_              = Maybe FastString
forall a. Maybe a
Nothing

showArgType :: StgArg -> FastString
showArgType :: StgArg -> FastString
showArgType StgArg
a = Type -> FastString
showType (StgArg -> Type
stgArgType StgArg
a)

showType :: Type -> FastString
showType :: Type -> FastString
showType Type
t
  | Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
unwrapType Type
t) =
      [Char] -> FastString
mkFastString (SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc))
  | Bool
otherwise = FastString
"<unknown>"