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

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

import GHC.Prelude

import GHC.JS.Syntax
import GHC.JS.Make
import GHC.JS.Transform

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.CoreUtils
import GHC.StgToJS.Ids

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

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.Panic
import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr, vcat, text)
import GHC.Data.FastString

import Data.Char
import Data.Monoid
import Data.Maybe
import qualified Data.List as L
import Control.Monad
import Control.Applicative
import qualified Text.ParserCombinators.ReadP as P

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 -> String -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern Bool
False Bool
False Bool
False (String
"h$" forall a. [a] -> [a] -> [a]
++ FastString -> String
unpackFS FastString
lbl) Type
t (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JExpr]
typex_expr forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [StgArg]
args
  forall (m :: * -> *) a. Monad m => a -> m a
return (JStat
j, Maybe [JExpr] -> ExprResult
ExprInline 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 -> String -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern Bool
catchExcep Bool
async Bool
jscc String
pat Type
t [JExpr]
es [StgArg]
as
  | Bool
catchExcep = do
      JStat
c <- Bool -> Bool -> String -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPatternA Bool
async Bool
jscc String
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"
      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") [forall a. ToJExpr a => a -> JExpr
toJExpr Ident
ex])) forall a. Monoid a => a
mempty)
  | Bool
otherwise  = Bool -> Bool -> String -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPatternA Bool
async Bool
jscc String
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 -> String -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPatternA Bool
True Bool
True String
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 -> String -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern' (forall a. a -> Maybe a
Just (forall a. ToJExpr a => a -> JExpr
toJExpr Ident
cb)) Bool
True String
pat Type
t [JExpr]
es [StgArg]
as
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
    [ Ident
x  Ident -> JExpr -> JStat
||= (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") [forall a. ToJExpr a => a -> JExpr
toJExpr Ident
x]
    , JStat
stat
    , JExpr -> JStat -> JStat -> JStat
IfStat (JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
StrictEqOp (forall a. ToJExpr a => a -> JExpr
toJExpr Ident
x JExpr -> FastString -> JExpr
.^ FastString
"mv") JExpr
null_)
          (forall a. Monoid a => [a] -> a
mconcat
            [ 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 forall a b. (a -> b) -> a -> b
$ JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$takeMVar") [forall a. ToJExpr a => a -> JExpr
toJExpr Ident
x JExpr -> FastString -> JExpr
.^ FastString
"mv"]
            ])
          (forall a. Monoid a => [a] -> a
mconcat
            [ Ident
d Ident -> JExpr -> JStat
||= forall a. ToJExpr a => a -> JExpr
toJExpr Ident
x JExpr -> FastString -> JExpr
.^ FastString
"mv"
            , JExpr -> JStat
copyResult (forall a. ToJExpr a => a -> JExpr
toJExpr Ident
d)
            ])
    ]
    where nrst :: Int
nrst = Type -> Int
typeSize Type
t
          copyResult :: JExpr -> JStat
copyResult JExpr
d = HasDebugCallStack => [JExpr] -> [JExpr] -> JStat
assignAllEqual [JExpr]
es (forall a b. (a -> b) -> [a] -> [b]
map (JExpr -> JExpr -> JExpr
IdxExpr JExpr
d forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJExpr a => a -> JExpr
toJExpr) [Int
0..Int
nrstforall a. Num a => a -> a -> a
-Int
1])
parseFFIPatternA Bool
_async Bool
javascriptCc String
pat Type
t [JExpr]
es [StgArg]
as =
  Maybe JExpr
-> Bool -> String -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern' forall a. Maybe a
Nothing Bool
javascriptCc String
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 -> String -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern' Maybe JExpr
callback Bool
javascriptCc String
pat Type
t [JExpr]
ret [StgArg]
args
  | Bool -> Bool
not Bool
javascriptCc = String -> G JStat
mkApply String
pat
  | Bool
otherwise =
   if Bool
True
     then String -> G JStat
mkApply String
pat
     else do
      Int
u <- G Int
freshUnique
      case String -> Int -> Either String JExpr
parseFfiJME String
pat Int
u of
        Right (ValExpr (JVar (TxtI FastString
_ident))) -> String -> G JStat
mkApply String
pat
        Right JExpr
expr | Bool -> Bool
not Bool
async Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
tgt forall a. Ord a => a -> a -> Bool
< Int
2 -> do
          (JStat
statPre, [(Ident, JExpr)]
ap) <- Bool -> [StgArg] -> G (JStat, [(Ident, JExpr)])
argPlaceholders Bool
javascriptCc [StgArg]
args
          let rp :: [(Ident, JExpr)]
rp  = Bool -> Type -> [JExpr] -> [(Ident, JExpr)]
resultPlaceholders Bool
async Type
t [JExpr]
ret
              env :: UniqFM Ident JExpr
env = forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM forall key elt. UniqFM key elt
emptyUFM ([(Ident, JExpr)]
rp forall a. [a] -> [a] -> [a]
++ [(Ident, JExpr)]
ap)
          if forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
tgt forall a. Eq a => a -> a -> Bool
== Int
1
            then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ JStat
statPre forall a. Semigroup a => a -> a -> a
<> ((Ident -> JExpr) -> JStat -> JStat
mapStatIdent (UniqFM Ident JExpr -> Ident -> JExpr
replaceIdent UniqFM Ident JExpr
env) (FastString -> JExpr
var FastString
"$r" JExpr -> JExpr -> JStat
|= JExpr
expr))
            else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ JStat
statPre forall a. Semigroup a => a -> a -> a
<> ((Ident -> JExpr) -> JStat -> JStat
mapStatIdent (UniqFM Ident JExpr -> Ident -> JExpr
replaceIdent UniqFM Ident JExpr
env) (forall a. ToStat a => a -> JStat
toStat JExpr
expr))
        Right JExpr
_ -> String -> G JStat
p forall a b. (a -> b) -> a -> b
$ String
"invalid expression FFI pattern. Expression FFI patterns can only be used for synchronous FFI " forall a. [a] -> [a] -> [a]
++
                       String
" imports with result size 0 or 1.\n" forall a. [a] -> [a] -> [a]
++ String
pat
        Left String
_ -> case String -> Int -> Either String JStat
parseFfiJM String
pat Int
u of
          Left String
err -> String -> G JStat
p (forall a. Show a => a -> String
show String
err)
          Right JStat
stat -> do
            let rp :: [(Ident, JExpr)]
rp = Bool -> Type -> [JExpr] -> [(Ident, JExpr)]
resultPlaceholders Bool
async Type
t [JExpr]
ret
            let cp :: [(Ident, JExpr)]
cp = Maybe JExpr -> [(Ident, JExpr)]
callbackPlaceholders Maybe JExpr
callback
            (JStat
statPre, [(Ident, JExpr)]
ap) <- Bool -> [StgArg] -> G (JStat, [(Ident, JExpr)])
argPlaceholders Bool
javascriptCc [StgArg]
args
            let env :: UniqFM Ident JExpr
env = forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM forall key elt. UniqFM key elt
emptyUFM ([(Ident, JExpr)]
rp forall a. [a] -> [a] -> [a]
++ [(Ident, JExpr)]
ap forall a. [a] -> [a] -> [a]
++ [(Ident, JExpr)]
cp)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ JStat
statPre forall a. Semigroup a => a -> a -> a
<> ((Ident -> JExpr) -> JStat -> JStat
mapStatIdent (UniqFM Ident JExpr -> Ident -> JExpr
replaceIdent UniqFM Ident JExpr
env) JStat
stat) -- fixme trace?
  where
    async :: Bool
async = forall a. Maybe a -> Bool
isJust Maybe JExpr
callback
    tgt :: [JExpr]
tgt = forall a. Int -> [a] -> [a]
take (Type -> Int
typeSize Type
t) [JExpr]
ret
    -- automatic apply, build call and result copy
    mkApply :: String -> G JStat
mkApply String
f
      | Just JExpr
cb <- Maybe JExpr
callback = do
         ([JStat]
stats, [[JExpr]]
as) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> StgArg -> G (JStat, [JExpr])
genFFIArg Bool
javascriptCc) [StgArg]
args
         StgToJSConfig
cs <- G StgToJSConfig
getSettings
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> [[JExpr]] -> JStat
traceCall StgToJSConfig
cs [[JExpr]]
as forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [JStat]
stats forall a. Semigroup a => a -> a -> a
<> JExpr -> [JExpr] -> JStat
ApplStat JExpr
f' (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JExpr]]
asforall a. [a] -> [a] -> [a]
++[JExpr
cb])
      | {-ts@-}
        (JExpr
t:[JExpr]
ts') <- [JExpr]
tgt = do
         ([JStat]
stats, [[JExpr]]
as) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> StgArg -> G (JStat, [JExpr])
genFFIArg Bool
javascriptCc) [StgArg]
args
         StgToJSConfig
cs <- G StgToJSConfig
getSettings
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> [[JExpr]] -> JStat
traceCall StgToJSConfig
cs [[JExpr]]
as
                forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [JStat]
stats
                forall a. Semigroup a => a -> a -> a
<> (JExpr
t JExpr -> JExpr -> JStat
|= JExpr -> [JExpr] -> JExpr
ApplExpr JExpr
f' (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JExpr]]
as) )
                forall a. Semigroup a => a -> a -> a
<> forall {a}. ToJExpr a => [a] -> JStat
copyResult [JExpr]
ts'
           -- _ -> error "mkApply: empty list"
      | Bool
otherwise = do
         ([JStat]
stats, [[JExpr]]
as) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> StgArg -> G (JStat, [JExpr])
genFFIArg Bool
javascriptCc) [StgArg]
args
         StgToJSConfig
cs <- G StgToJSConfig
getSettings
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ StgToJSConfig -> [[JExpr]] -> JStat
traceCall StgToJSConfig
cs [[JExpr]]
as forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [JStat]
stats forall a. Semigroup a => a -> a -> a
<> JExpr -> [JExpr] -> JStat
ApplStat JExpr
f' (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[JExpr]]
as)
        where f' :: JExpr
f' = forall a. ToJExpr a => a -> JExpr
toJExpr (FastString -> Ident
TxtI forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString String
f)
    copyResult :: [a] -> JStat
copyResult [a]
rs = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\StgRet
t a
r -> forall a. ToJExpr a => a -> JExpr
toJExpr a
r JExpr -> JExpr -> JStat
|= forall a. ToJExpr a => a -> JExpr
toJExpr StgRet
t) (forall a. Enum a => a -> [a]
enumFrom StgRet
Ret1) [a]
rs
    p :: String -> G JStat
p String
e = forall a. HasCallStack => String -> a
error (String
"Parse error in FFI pattern: " forall a. [a] -> [a] -> [a]
++ String
pat forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
e)

    replaceIdent :: UniqFM Ident JExpr -> Ident -> JExpr
    replaceIdent :: UniqFM Ident JExpr -> Ident -> JExpr
replaceIdent UniqFM Ident JExpr
env Ident
i
      | Ident -> Bool
isFFIPlaceholder Ident
i = forall a. a -> Maybe a -> a
fromMaybe JExpr
err (forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Ident JExpr
env Ident
i)
      | Bool
otherwise = JVal -> JExpr
ValExpr (Ident -> JVal
JVar Ident
i)
        where
          (TxtI FastString
i') = Ident
i
          err :: JExpr
err = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"parseFFIPattern': invalid placeholder, check function type"
                  (forall doc. IsDoc doc => [doc] -> doc
vcat [forall doc. IsLine doc => String -> doc
text String
pat, forall a. Outputable a => a -> SDoc
ppr FastString
i', forall a. Outputable a => a -> SDoc
ppr [StgArg]
args, forall a. Outputable a => a -> SDoc
ppr Type
t])
    traceCall :: StgToJSConfig -> [[JExpr]] -> JStat
traceCall StgToJSConfig
cs [[JExpr]]
as
        | StgToJSConfig -> Bool
csTraceForeign StgToJSConfig
cs = JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$traceForeign") [forall a. ToJExpr a => a -> JExpr
toJExpr String
pat, forall a. ToJExpr a => a -> JExpr
toJExpr [[JExpr]]
as]
        | Bool
otherwise         = forall a. Monoid a => a
mempty

-- ident is $N, $N_R, $rN, $rN_R or $r or $c
isFFIPlaceholder :: Ident -> Bool
isFFIPlaceholder :: Ident -> Bool
isFFIPlaceholder (TxtI FastString
x) = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. ReadP a -> ReadS a
P.readP_to_S ReadP ()
parser (FastString -> String
unpackFS FastString
x)))
  where
    digit :: ReadP Char
digit = (Char -> Bool) -> ReadP Char
P.satisfy (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"0123456789" :: String))
    parser :: ReadP ()
parser = forall (f :: * -> *) a. Functor f => f a -> f ()
void (String -> ReadP String
P.string String
"$r" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
P.eof) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
             forall (f :: * -> *) a. Functor f => f a -> f ()
void (String -> ReadP String
P.string String
"$c" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
P.eof) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
      Char
_ <- Char -> ReadP Char
P.char Char
'$'
      forall a. ReadP a -> ReadP ()
P.optional (Char -> ReadP Char
P.char Char
'r')
      String
_ <- forall a. ReadP a -> ReadP [a]
P.many1 ReadP Char
digit
      forall a. ReadP a -> ReadP ()
P.optional (Char -> ReadP Char
P.char Char
'_' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. ReadP a -> ReadP [a]
P.many1 ReadP Char
digit)
      ReadP ()
P.eof

-- 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 -> G (JStat, [JExpr])
genFFIArg Bool
_isJavaScriptCc (StgLitArg Literal
l) = (forall a. Monoid a => a
mempty,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Literal -> G [JExpr]
genLit Literal
l
genFFIArg Bool
isJavaScriptCc a :: StgArg
a@(StgVarArg Id
i)
    | Bool -> Bool
not Bool
isJavaScriptCc Bool -> Bool -> Bool
&&
      (TyCon
tycon forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
|| TyCon
tycon forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon) =
        (\JExpr
x -> (forall a. Monoid a => a
mempty,[JExpr
x, JExpr
zero_])) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G JExpr
varForId Id
i
    | VarType -> Bool
isVoid VarType
r                  = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, [])
--    | Just x <- marshalFFIArg a = x
    | VarType -> Bool
isMultiVar VarType
r              = (forall a. Monoid a => a
mempty,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id -> Int -> G JExpr
varForIdN Id
i) [Int
1..VarType -> Int
varSize VarType
r]
    | Bool
otherwise                 = (\JExpr
x -> (forall a. Monoid a => a
mempty,[JExpr
x])) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G JExpr
varForId Id
i
   where
     tycon :: TyCon
tycon  = HasDebugCallStack => 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
uTypeVt Type
arg_ty

-- $1, $2, $3 for single, $1_1, $1_2 etc for dual
-- void args not counted
argPlaceholders :: Bool -> [StgArg] -> G (JStat, [(Ident,JExpr)])
argPlaceholders :: Bool -> [StgArg] -> G (JStat, [(Ident, JExpr)])
argPlaceholders Bool
isJavaScriptCc [StgArg]
args = do
  ([JStat]
stats, [[JExpr]]
idents0) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> StgArg -> G (JStat, [JExpr])
genFFIArg Bool
isJavaScriptCc) [StgArg]
args
  let idents :: [[JExpr]]
idents = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[JExpr]]
idents0
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. Monoid a => [a] -> a
mconcat [JStat]
stats, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[JExpr]
is Int
n -> Bool -> String -> [JExpr] -> [(Ident, JExpr)]
mkPlaceholder Bool
True (String
"$"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
n) [JExpr]
is) [[JExpr]]
idents [(Int
1::Int)..]))

mkPlaceholder :: Bool -> String -> [JExpr] -> [(Ident, JExpr)]
mkPlaceholder :: Bool -> String -> [JExpr] -> [(Ident, JExpr)]
mkPlaceholder Bool
undersc String
prefix [JExpr]
aids =
      case [JExpr]
aids of
             []       -> []
             [JExpr
x]      -> [(FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ String
prefix, JExpr
x)]
             xs :: [JExpr]
xs@(JExpr
x:[JExpr]
_) -> (FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ String
prefix, JExpr
x) forall a. a -> [a] -> [a]
:
                forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\JExpr
x Int
m -> (FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ String
prefix forall a. [a] -> [a] -> [a]
++ String
u forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
m,JExpr
x)) [JExpr]
xs [(Int
1::Int)..]
   where u :: String
u = if Bool
undersc then String
"_" else String
""

-- $r for single, $r1,$r2 for dual
-- $r1, $r2, etc for ubx tup, void args not counted
resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident,JExpr)] -- ident, replacement
resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident, JExpr)]
resultPlaceholders Bool
True Type
_ [JExpr]
_ = [] -- async has no direct resuls, use callback
resultPlaceholders Bool
False Type
t [JExpr]
rs =
  case HasDebugCallStack => Type -> [VarType]
typeVt (Type -> Type
unwrapType Type
t) of
    [VarType
t'] -> Int -> [(Ident, JExpr)]
mkUnary (VarType -> Int
varSize VarType
t')
    [VarType]
uts ->
      let sizes :: [Int]
sizes = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
>Int
0) (forall a b. (a -> b) -> [a] -> [b]
map VarType -> Int
varSize [VarType]
uts)
          f :: a -> a -> [[String]]
f a
_ a
0 = []
          f a
n a
1 = [[String
"$r" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n]]
          f a
n a
k = [String
"$r" forall a. [a] -> [a] -> [a]
++ String
sn, String
"$r" forall a. [a] -> [a] -> [a]
++ String
sn forall a. [a] -> [a] -> [a]
++ String
"_1"] forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> [String
"$r" forall a. [a] -> [a] -> [a]
++ String
sn forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x]) [a
2..a
k]
            where sn :: String
sn = forall a. Show a => a -> String
show a
n
          phs :: [[[String]]]
phs   = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
size Int
n -> forall {a} {a}.
(Eq a, Num a, Show a, Show a, Enum a) =>
a -> a -> [[String]]
f Int
n Int
size) [Int]
sizes [(Int
1::Int)..]
      in case [Int]
sizes of
           [Int
n] -> Int -> [(Ident, JExpr)]
mkUnary Int
n
           [Int]
_   -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[String]
phs' JExpr
r -> forall a b. (a -> b) -> [a] -> [b]
map (\String
i -> (FastString -> Ident
TxtI (String -> FastString
mkFastString String
i), JExpr
r)) [String]
phs') (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[String]]]
phs) [JExpr]
rs
  where
    mkUnary :: Int -> [(Ident, JExpr)]
mkUnary Int
0 = []
    mkUnary Int
1 = [(FastString -> Ident
TxtI FastString
"$r",forall a. [a] -> a
head [JExpr]
rs)] -- single
    mkUnary Int
n = [(FastString -> Ident
TxtI FastString
"$r",forall a. [a] -> a
head [JExpr]
rs),(FastString -> Ident
TxtI FastString
"$r1", forall a. [a] -> a
head [JExpr]
rs)] forall a. [a] -> [a] -> [a]
++
       forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n JExpr
r -> (FastString -> Ident
TxtI forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ String
"$r" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n, forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
r)) [Int
2..Int
n] (forall a. [a] -> [a]
tail [JExpr]
rs)

callbackPlaceholders :: Maybe JExpr -> [(Ident,JExpr)]
callbackPlaceholders :: Maybe JExpr -> [(Ident, JExpr)]
callbackPlaceholders Maybe JExpr
Nothing  = []
callbackPlaceholders (Just JExpr
e) = [((FastString -> Ident
TxtI FastString
"$c"), JExpr
e)]

parseFfiJME :: String -> Int -> Either String JExpr
parseFfiJME :: String -> Int -> Either String JExpr
parseFfiJME String
_xs Int
_u =  forall a b. a -> Either a b
Left String
"parseFfiJME not yet implemented"

parseFfiJM :: String -> Int -> Either String JStat
parseFfiJM :: String -> Int -> Either String JStat
parseFfiJM String
_xs Int
_u = forall a b. a -> Either a b
Left String
"parseFfiJM not yet implemented"

saturateFFI :: JMacro a => Int -> a -> a
saturateFFI :: forall a. JMacro a => Int -> a -> a
saturateFFI Int
u = forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ String
"ghcjs_ffi_sat_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
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 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, JExpr)]
pairs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(FastString
k,StgArg
v) -> HasDebugCallStack => StgArg -> G [JExpr]
genArg StgArg
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[JExpr]
vs -> forall (m :: * -> *) a. Monad m => a -> m a
return (FastString
k, forall a. [a] -> a
head [JExpr]
vs)) [(FastString, StgArg)]
pairs
      forall (m :: * -> *) a. Monad m => a -> m a
return ( JExpr -> JExpr -> JStat
(|=) JExpr
obj (JVal -> JExpr
ValExpr (UniqMap FastString JExpr -> JVal
JHash forall a b. (a -> b) -> a -> b
$ forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap [(FastString, JExpr)]
pairs'))
             , Maybe [JExpr] -> ExprResult
ExprInline 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) (String -> FastString
mkFastString String
lbl) Safety
safety CCallConv
cconv (forall a b. (a -> b) -> [a] -> [b]
map StgArg -> FastString
showArgType [StgArg]
args) (Type -> FastString
showType Type
t)
  (,ExprResult
exprResult) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Bool -> Bool -> String -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern Bool
catchExcep Bool
async Bool
isJsCc String
lbl Type
t [JExpr]
tgt' [StgArg]
args
  where
    isJsCc :: Bool
isJsCc = CCallConv
cconv 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 forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
clbl' ->
                         (String
"h$" forall a. [a] -> [a] -> [a]
++ (forall a. Int -> [a] -> [a]
drop Int
2 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isDigit forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
wrapperPrefix) String
clbl'))
                     | Bool
otherwise -> String
"h$" forall a. [a] -> [a] -> [a]
++ String
clbl'
        | Bool
otherwise = String
"h$callDynamic"

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

    catchExcep :: Bool
catchExcep = (CCallConv
cconv 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     = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
tgt) [JExpr]
jsRegsFromR1
          | Bool
otherwise = [JExpr]
tgt

    wrapperPrefix :: String
wrapperPrefix = String
"ghczuwrapperZC"

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

argJSStringLitUnfolding :: StgArg -> Maybe FastString
argJSStringLitUnfolding :: StgArg -> Maybe FastString
argJSStringLitUnfolding (StgVarArg Id
_v) = forall a. Maybe a
Nothing -- fixme
argJSStringLitUnfolding StgArg
_              = 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 (forall a. Outputable a => a -> SDoc
ppr TyCon
tc))
  | Bool
otherwise = FastString
"<unknown>"