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

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

import GHC.Prelude

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

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

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

import GHC.Stg.Syntax

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

import GHC.Core.Type hiding (typeSize)

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

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

genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStgStat, ExprResult)
genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStgStat, ExprResult)
genPrimCall ExprCtx
ctx (PrimCall CLabelString
lbl Unit
_) [StgArg]
args Type
t = do
  j <- Bool
-> Bool
-> Bool
-> String
-> Type
-> [JStgExpr]
-> [StgArg]
-> G JStgStat
parseFFIPattern Bool
False Bool
False Bool
False (CLabelString -> String
unpackFS CLabelString
hdStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ CLabelString -> String
unpackFS CLabelString
lbl) Type
t ((TypedExpr -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypedExpr -> [JStgExpr]
typex_expr ([TypedExpr] -> [JStgExpr]) -> [TypedExpr] -> [JStgExpr]
forall a b. (a -> b) -> a -> b
$ ExprCtx -> [TypedExpr]
ctxTarget ExprCtx
ctx) [StgArg]
args
  return (j, ExprInline)

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

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

  return type examples
  1. $r                      unary return
  2. $r1, $r2                binary return
  3. $r1, $r2, $r3_1, $r3_2  unboxed tuple return
 -}
parseFFIPattern :: Bool  -- ^ catch exception and convert them to haskell exceptions
                -> Bool  -- ^ async (only valid with javascript calling conv)
                -> Bool  -- ^ using javascript calling convention
                -> String
                -> Type
                -> [JStgExpr]
                -> [StgArg]
                -> G JStgStat
parseFFIPattern :: Bool
-> Bool
-> Bool
-> String
-> Type
-> [JStgExpr]
-> [StgArg]
-> G JStgStat
parseFFIPattern Bool
catchExcep Bool
async Bool
jscc String
pat Type
t [JStgExpr]
es [StgArg]
as
  | Bool
catchExcep = do
      c <- Bool
-> Bool -> String -> Type -> [JStgExpr] -> [StgArg] -> G JStgStat
parseFFIPatternA Bool
async Bool
jscc String
pat Type
t [JStgExpr]
es [StgArg]
as
      -- Generate:
      --  try {
      --    `c`;
      --  } catch(except) {
      --    return h$throwJSException(except);
      --  }
      return (TryStat c exceptStr (ReturnStat (ApplExpr hdThrowJSException [except])) mempty)
  | Bool
otherwise  = Bool
-> Bool -> String -> Type -> [JStgExpr] -> [StgArg] -> G JStgStat
parseFFIPatternA Bool
async Bool
jscc String
pat Type
t [JStgExpr]
es [StgArg]
as

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

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

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

    traceCall :: StgToJSConfig -> [[JStgExpr]] -> JStgStat
traceCall StgToJSConfig
cs [[JStgExpr]]
as
        | StgToJSConfig -> Bool
csTraceForeign StgToJSConfig
cs = JStgExpr -> [JStgExpr] -> JStgStat
ApplStat JStgExpr
hdTraceForeign [String -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr String
pat, [[JStgExpr]] -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr [[JStgExpr]]
as]
        | Bool
otherwise         = JStgStat
forall a. Monoid a => a
mempty

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

genForeignCall :: HasDebugCallStack
               => ExprCtx
               -> ForeignCall
               -> Type
               -> [JStgExpr]
               -> [StgArg]
               -> G (JStgStat, ExprResult)
genForeignCall :: HasDebugCallStack =>
ExprCtx
-> ForeignCall
-> Type
-> [JStgExpr]
-> [StgArg]
-> G (JStgStat, ExprResult)
genForeignCall ExprCtx
_ctx
               (CCall (CCallSpec (StaticTarget SourceText
_ CLabelString
tgt Maybe Unit
Nothing Bool
True)
                                   CCallConv
JavaScriptCallConv
                                   Safety
PlayRisky))
               Type
_t
               [JStgExpr
obj]
               [StgArg]
args
  | CLabelString
tgt CLabelString -> CLabelString -> Bool
forall a. Eq a => a -> a -> Bool
== CLabelString
hdBuildObjectStr
  , Just [(CLabelString, StgArg)]
pairs <- [StgArg] -> Maybe [(CLabelString, StgArg)]
getObjectKeyValuePairs [StgArg]
args = do
      pairs' <- ((CLabelString, StgArg)
 -> StateT GenState IO (CLabelString, JStgExpr))
-> [(CLabelString, StgArg)]
-> StateT GenState IO [(CLabelString, JStgExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(CLabelString
k,StgArg
v) -> HasDebugCallStack => StgArg -> StateT GenState IO [JStgExpr]
StgArg -> StateT GenState IO [JStgExpr]
genArg StgArg
v StateT GenState IO [JStgExpr]
-> ([JStgExpr] -> StateT GenState IO (CLabelString, JStgExpr))
-> StateT GenState IO (CLabelString, JStgExpr)
forall a b.
StateT GenState IO a
-> (a -> StateT GenState IO b) -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[JStgExpr]
vs -> (CLabelString, JStgExpr)
-> StateT GenState IO (CLabelString, JStgExpr)
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CLabelString
k, [JStgExpr] -> JStgExpr
forall a. HasCallStack => [a] -> a
head [JStgExpr]
vs)) [(CLabelString, StgArg)]
pairs
      return ( (|=) obj (ValExpr (JHash $ listToUniqMap pairs'))
             , ExprInline
             )

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

    lbl :: CLabelString
lbl | (StaticTarget SourceText
_ CLabelString
clbl Maybe Unit
_mpkg Bool
_isFunPtr) <- CCallTarget
ccTarget
            = let clbl' :: String
clbl'    = CLabelString -> String
unpackFS CLabelString
clbl
                  hDollarS :: String
hDollarS = CLabelString -> String
unpackFS CLabelString
hdStr
              in  if | Bool
isJsCc -> CLabelString
clbl
                     | String
wrapperPrefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
clbl' ->
                         String -> CLabelString
mkFastString (String
hDollarS 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 -> CLabelString
mkFastString (String -> CLabelString) -> String -> CLabelString
forall a b. (a -> b) -> a -> b
$ String
hDollarS String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
clbl'
        | Bool
otherwise = CLabelString
hdCallDynamicStr

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

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

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

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

    wrapperPrefix :: String
wrapperPrefix = CLabelString -> String
unpackFS CLabelString
wrapperColonStr

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

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

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

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