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

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

import GHC.Prelude

import GHC.JS.JStg.Syntax
import GHC.JS.Ident
import GHC.JS.Make

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 (JStgStat, ExprResult)
genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStgStat, ExprResult)
genPrimCall ExprCtx
ctx (PrimCall FastString
lbl Unit
_) [StgArg]
args Type
t = do
  JStgStat
j <- Bool
-> Bool
-> Bool
-> String
-> Type
-> [JStgExpr]
-> [StgArg]
-> G JStgStat
parseFFIPattern Bool
False Bool
False Bool
False (String
"h$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FastString -> String
unpackFS FastString
lbl) Type
t ((TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr ([TypedExpr] -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [StgArg]
args
  (JStgStat, ExprResult) -> G (JStgStat, ExprResult)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat
j, ExprResult
ExprInline)

-- | 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
                -> [JStgExpr]
                -> [StgArg]
                -> G JStgStat
parseFFIPattern :: Bool
-> Bool
-> Bool
-> String
-> Type
-> [JStgExpr]
-> [StgArg]
-> G JStgStat
parseFFIPattern Bool
catchExcep Bool
async Bool
jscc String
pat Type
t [JStgExpr]
es [StgArg]
as
  | Bool
catchExcep = do
      JStgStat
c <- Bool
-> Bool -> String -> Type -> [JStgExpr] -> [StgArg] -> G JStgStat
parseFFIPatternA Bool
async Bool
jscc String
pat Type
t [JStgExpr]
es [StgArg]
as
      -- Generate:
      --  try {
      --    `c`;
      --  } catch(except) {
      --    return h$throwJSException(except);
      --  }
      let ex :: Ident
ex = FastString -> Ident
global FastString
"except"
      JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> Ident -> JStgStat -> JStgStat -> JStgStat
TryStat JStgStat
c Ident
ex (JStgExpr -> JStgStat
ReturnStat (JStgExpr -> [JStgExpr] -> JStgExpr
ApplExpr (FastString -> JStgExpr
var FastString
"h$throwJSException") [Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Ident
ex])) JStgStat
forall a. Monoid a => a
mempty)
  | Bool
otherwise  = Bool
-> Bool -> String -> Type -> [JStgExpr] -> [StgArg] -> G JStgStat
parseFFIPatternA Bool
async Bool
jscc String
pat Type
t [JStgExpr]
es [StgArg]
as

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

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

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

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

-- generate arg to be passed to FFI call, with marshalling JStgStat to be run
-- before the call
genFFIArg :: Bool -> StgArg -> G (JStgStat, [JStgExpr])
genFFIArg :: Bool -> StgArg -> StateT GenState IO (JStgStat, [JStgExpr])
genFFIArg Bool
_isJavaScriptCc (StgLitArg Literal
l) = (JStgStat
forall a. Monoid a => a
mempty,) ([JStgExpr] -> (JStgStat, [JStgExpr]))
-> StateT GenState IO [JStgExpr]
-> StateT GenState IO (JStgStat, [JStgExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Literal -> StateT GenState IO [JStgExpr]
Literal -> StateT GenState IO [JStgExpr]
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) =
        (\JStgExpr
x -> (JStgStat
forall a. Monoid a => a
mempty,[JStgExpr
x, JStgExpr
zero_])) (JStgExpr -> (JStgStat, [JStgExpr]))
-> StateT GenState IO JStgExpr
-> StateT GenState IO (JStgStat, [JStgExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO JStgExpr
varForId Id
i
    | JSRep -> Bool
isVoid JSRep
r                  = (JStgStat, [JStgExpr]) -> StateT GenState IO (JStgStat, [JStgExpr])
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat
forall a. Monoid a => a
mempty, [])
--    | Just x <- marshalFFIArg a = x
    | JSRep -> Bool
isMultiVar JSRep
r              = (JStgStat
forall a. Monoid a => a
mempty,) ([JStgExpr] -> (JStgStat, [JStgExpr]))
-> StateT GenState IO [JStgExpr]
-> StateT GenState IO (JStgStat, [JStgExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> StateT GenState IO JStgExpr)
-> [Int] -> StateT GenState IO [JStgExpr]
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 JStgExpr
varForIdN Id
i) [Int
1..JSRep -> Int
varSize JSRep
r]
    | Bool
otherwise                 = (\JStgExpr
x -> (JStgStat
forall a. Monoid a => a
mempty,[JStgExpr
x])) (JStgExpr -> (JStgStat, [JStgExpr]))
-> StateT GenState IO JStgExpr
-> StateT GenState IO (JStgStat, [JStgExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> StateT GenState IO JStgExpr
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 :: JSRep
r      = HasDebugCallStack => Type -> JSRep
Type -> JSRep
unaryTypeJSRep Type
arg_ty

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

genForeignCall ExprCtx
ctx (CCall (CCallSpec CCallTarget
ccTarget CCallConv
cconv Safety
safety)) Type
t [JStgExpr]
tgt [StgArg]
args = do
  Maybe RealSrcSpan
-> FastString
-> Safety
-> CCallConv
-> [FastString]
-> FastString
-> G ()
emitForeign (ExprCtx -> Maybe RealSrcSpan
ctxSrcSpan ExprCtx
ctx) (String -> FastString
mkFastString String
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) (JStgStat -> (JStgStat, ExprResult))
-> G JStgStat -> G (JStgStat, ExprResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Bool
-> Bool
-> String
-> Type
-> [JStgExpr]
-> [StgArg]
-> G JStgStat
parseFFIPattern Bool
catchExcep Bool
async Bool
isJsCc String
lbl Type
t [JStgExpr]
tgt' [StgArg]
args
  where
    isJsCc :: Bool
isJsCc = CCallConv
cconv CCallConv -> CCallConv -> Bool
forall a. Eq a => a -> a -> Bool
== CCallConv
JavaScriptCallConv

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

    exprResult :: ExprResult
exprResult | Bool
async     = ExprResult
ExprCont
               | Bool
otherwise = ExprResult
ExprInline

    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' :: [JStgExpr]
tgt'  | Bool
async     = Int -> [JStgExpr] -> [JStgExpr]
forall a. Int -> [a] -> [a]
take ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
tgt) [JStgExpr]
jsRegsFromR1
          | Bool
otherwise = [JStgExpr]
tgt

    wrapperPrefix :: String
wrapperPrefix = String
"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):) ([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) =
      String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc))
  | Bool
otherwise = FastString
"<unknown>"