{-# 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$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FastString -> String
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 -> 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"
      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 -> 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' (JExpr -> Maybe JExpr
forall a. a -> Maybe a
Just (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Ident
cb)) Bool
True String
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
(() :: Constraint) => [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 String
pat Type
t [JExpr]
es [StgArg]
as =
  Maybe JExpr
-> Bool -> String -> Type -> [JExpr] -> [StgArg] -> G JStat
parseFFIPattern' Maybe JExpr
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
&& [JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
tgt Int -> Int -> Bool
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 = UniqFM Ident JExpr -> [(Ident, JExpr)] -> UniqFM Ident JExpr
forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM UniqFM Ident JExpr
forall key elt. UniqFM key elt
emptyUFM ([(Ident, JExpr)]
rp [(Ident, JExpr)] -> [(Ident, JExpr)] -> [(Ident, JExpr)]
forall a. [a] -> [a] -> [a]
++ [(Ident, JExpr)]
ap)
          if [JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
tgt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
            then 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
statPre JStat -> JStat -> JStat
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 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
statPre JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> ((Ident -> JExpr) -> JStat -> JStat
mapStatIdent (UniqFM Ident JExpr -> Ident -> JExpr
replaceIdent UniqFM Ident JExpr
env) (JExpr -> JStat
forall a. ToStat a => a -> JStat
toStat JExpr
expr))
        Right JExpr
_ -> String -> G JStat
p (String -> G JStat) -> String -> G JStat
forall a b. (a -> b) -> a -> b
$ String
"invalid expression FFI pattern. Expression FFI patterns can only be used for synchronous FFI " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String
" imports with result size 0 or 1.\n" String -> String -> String
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 (String -> String
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 = UniqFM Ident JExpr -> [(Ident, JExpr)] -> UniqFM Ident JExpr
forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM UniqFM Ident JExpr
forall key elt. UniqFM key elt
emptyUFM ([(Ident, JExpr)]
rp [(Ident, JExpr)] -> [(Ident, JExpr)] -> [(Ident, JExpr)]
forall a. [a] -> [a] -> [a]
++ [(Ident, JExpr)]
ap [(Ident, JExpr)] -> [(Ident, JExpr)] -> [(Ident, JExpr)]
forall a. [a] -> [a] -> [a]
++ [(Ident, JExpr)]
cp)
            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
statPre JStat -> JStat -> JStat
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 = Maybe JExpr -> Bool
forall a. Maybe a -> Bool
isJust Maybe JExpr
callback
    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 :: String -> G JStat
mkApply String
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
$ String -> FastString
mkFastString String
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
    p :: String -> G JStat
p String
e = String -> G JStat
forall a. HasCallStack => String -> a
error (String
"Parse error in FFI pattern: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
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 = JExpr -> Maybe JExpr -> JExpr
forall a. a -> Maybe a -> a
fromMaybe JExpr
err (UniqFM Ident JExpr -> Ident -> Maybe JExpr
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 = String -> SDoc -> JExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"parseFFIPattern': invalid placeholder, check function type"
                  ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
pat, FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
i', [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args, Type -> SDoc
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") [String -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr String
pat, [[JExpr]] -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr [[JExpr]]
as]
        | Bool
otherwise         = JStat
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 ([((), String)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ReadP () -> ReadS ()
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 (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"0123456789" :: String))
    parser :: ReadP ()
parser = ReadP () -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (String -> ReadP String
P.string String
"$r" ReadP String -> ReadP () -> ReadP ()
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
P.eof) ReadP () -> ReadP () -> ReadP ()
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
             ReadP () -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (String -> ReadP String
P.string String
"$c" ReadP String -> ReadP () -> ReadP ()
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
P.eof) ReadP () -> ReadP () -> ReadP ()
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
      Char
_ <- Char -> ReadP Char
P.char Char
'$'
      ReadP Char -> ReadP ()
forall a. ReadP a -> ReadP ()
P.optional (Char -> ReadP Char
P.char Char
'r')
      String
_ <- ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
P.many1 ReadP Char
digit
      ReadP String -> ReadP ()
forall a. ReadP a -> ReadP ()
P.optional (Char -> ReadP Char
P.char Char
'_' ReadP Char -> ReadP String -> ReadP String
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP Char -> ReadP String
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 -> 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
<$> (() :: Constraint) => 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  = (() :: Constraint) => Type -> TyCon
Type -> TyCon
tyConAppTyCon (Type -> Type
unwrapType Type
arg_ty)
     arg_ty :: Type
arg_ty = StgArg -> Type
stgArgType StgArg
a
     r :: VarType
r      = (() :: Constraint) => Type -> VarType
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) <- [(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
isJavaScriptCc) [StgArg]
args
  let idents :: [[JExpr]]
idents = ([JExpr] -> Bool) -> [[JExpr]] -> [[JExpr]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([JExpr] -> Bool) -> [JExpr] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[JExpr]]
idents0
  (JStat, [(Ident, JExpr)]) -> G (JStat, [(Ident, JExpr)])
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((JStat, [(Ident, JExpr)]) -> G (JStat, [(Ident, JExpr)]))
-> (JStat, [(Ident, JExpr)]) -> G (JStat, [(Ident, JExpr)])
forall a b. (a -> b) -> a -> b
$ ([JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat]
stats, [[(Ident, JExpr)]] -> [(Ident, JExpr)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    (([JExpr] -> Int -> [(Ident, JExpr)])
-> [[JExpr]] -> [Int] -> [[(Ident, JExpr)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[JExpr]
is Int
n -> Bool -> String -> [JExpr] -> [(Ident, JExpr)]
mkPlaceholder Bool
True (String
"$"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
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 (FastString -> Ident) -> (String -> FastString) -> String -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ String
prefix, JExpr
x)]
             xs :: [JExpr]
xs@(JExpr
x:[JExpr]
_) -> (FastString -> Ident
TxtI (FastString -> Ident) -> (String -> FastString) -> String -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ String
prefix, JExpr
x) (Ident, JExpr) -> [(Ident, JExpr)] -> [(Ident, JExpr)]
forall a. a -> [a] -> [a]
:
                (JExpr -> Int -> (Ident, JExpr))
-> [JExpr] -> [Int] -> [(Ident, JExpr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\JExpr
x Int
m -> (FastString -> Ident
TxtI (FastString -> Ident) -> (String -> FastString) -> String -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
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 (() :: Constraint) => Type -> [VarType]
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 = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0) ((VarType -> Int) -> [VarType] -> [Int]
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" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n]]
          f a
n a
k = [String
"$r" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sn, String
"$r" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_1"] [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: (a -> [String]) -> [a] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> [String
"$r" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x]) [a
2..a
k]
            where sn :: String
sn = a -> String
forall a. Show a => a -> String
show a
n
          phs :: [[[String]]]
phs   = (Int -> Int -> [[String]]) -> [Int] -> [Int] -> [[[String]]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
size Int
n -> Int -> Int -> [[String]]
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]
_   -> [[(Ident, JExpr)]] -> [(Ident, JExpr)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Ident, JExpr)]] -> [(Ident, JExpr)])
-> [[(Ident, JExpr)]] -> [(Ident, JExpr)]
forall a b. (a -> b) -> a -> b
$ ([String] -> JExpr -> [(Ident, JExpr)])
-> [[String]] -> [JExpr] -> [[(Ident, JExpr)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[String]
phs' JExpr
r -> (String -> (Ident, JExpr)) -> [String] -> [(Ident, JExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
i -> (FastString -> Ident
TxtI (String -> FastString
mkFastString String
i), JExpr
r)) [String]
phs') ([[[String]]] -> [[String]]
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",[JExpr] -> JExpr
forall a. HasCallStack => [a] -> a
head [JExpr]
rs)] -- single
    mkUnary Int
n = [(FastString -> Ident
TxtI FastString
"$r",[JExpr] -> JExpr
forall a. HasCallStack => [a] -> a
head [JExpr]
rs),(FastString -> Ident
TxtI FastString
"$r1", [JExpr] -> JExpr
forall a. HasCallStack => [a] -> a
head [JExpr]
rs)] [(Ident, JExpr)] -> [(Ident, JExpr)] -> [(Ident, JExpr)]
forall a. [a] -> [a] -> [a]
++
       (Int -> JExpr -> (Ident, JExpr))
-> [Int] -> [JExpr] -> [(Ident, JExpr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n JExpr
r -> (FastString -> Ident
TxtI (FastString -> Ident) -> (String -> FastString) -> String -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ String
"$r" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n, JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
r)) [Int
2..Int
n] ([JExpr] -> [JExpr]
forall a. HasCallStack => [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 =  String -> Either String JExpr
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 = String -> Either String JStat
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 = Maybe FastString -> a -> a
forall a. JMacro a => Maybe FastString -> a -> a
jsSaturate (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (FastString -> Maybe FastString)
-> (String -> FastString) -> String -> Maybe FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> Maybe FastString) -> String -> Maybe FastString
forall a b. (a -> b) -> a -> b
$ String
"ghcjs_ffi_sat_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
u)

genForeignCall :: HasDebugCallStack
               => ExprCtx
               -> ForeignCall
               -> Type
               -> [JExpr]
               -> [StgArg]
               -> G (JStat, ExprResult)
genForeignCall :: (() :: Constraint) =>
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
== String -> FastString
fsLit String
"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) -> (() :: Constraint) => 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) (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) (JStat -> (JStat, ExprResult)) -> G JStat -> G (JStat, 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 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 = 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 :: 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)(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) =
      String -> FastString
mkFastString (SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc))
  | Bool
otherwise = FastString
"<unknown>"