{-# 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)
parseFFIPattern :: Bool
-> Bool
-> Bool
-> 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
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
-> Bool
-> String
-> Type
-> [JExpr]
-> [StgArg]
-> G JStat
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
parseFFIPattern' :: Maybe JExpr
-> Bool
-> String
-> Type
-> [JExpr]
-> [StgArg]
-> 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)
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
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])
|
(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'
| 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
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
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, [])
| 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
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
""
resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident,JExpr)]
resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident, JExpr)]
resultPlaceholders Bool
True Type
_ [JExpr]
_ = []
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)]
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
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>"