{-# LANGUAGE BangPatterns, QuasiQuotes, TemplateHaskell, OverloadedStrings, ScopedTypeVariables, FlexibleContexts #-}

{-|
Module      : Quickjs
Description : Haskell bindings to the [QuickJS](https://bellard.org/quickjs/) library
Copyright   : (c) Samuel Balco, 2020
License     : MIT
Maintainer  : goodlyrottenapple@gmail.com

This is a very basic wrapper for the [QuickJS](https://bellard.org/quickjs/) .

The current functionality includes evaluating JS code, calling a JS function in the global scope
and marshalling 'Value's to and from 'JSValue's.
-}
module Quickjs (JSValue, JSContextPtr, quickjs, quickjsMultithreaded, call, eval, eval_, withJSValue, fromJSValue_) where

import           Foreign
import           Foreign.C                   (CString, CInt, CDouble, CSize)
import           Data.ByteString             (ByteString, useAsCString, useAsCStringLen, packCString)
import           Data.Text.Encoding          (encodeUtf8)
import qualified Language.C.Inline           as C
import           Control.Monad.Catch         (MonadThrow(..), MonadCatch(..), MonadMask(..), finally)
import           Control.Monad               (when, forM_)
import           Control.Monad.Reader        (MonadReader, runReaderT, ask)
import           Control.Monad.Trans.Reader  (ReaderT)
import           Control.Monad.IO.Class      (MonadIO, liftIO)
import           Control.Monad.IO.Unlift     (MonadUnliftIO(..), UnliftIO(..), askUnliftIO)
import           Data.Aeson                  (Value(..), encode, toJSON)
import qualified Data.Aeson                  as Aeson
import           Data.Scientific             (fromFloatDigits, toRealFloat, toBoundedInteger, isInteger)
import           Data.Text                   (Text)
import           Data.Vector                 (fromList, imapM_)
import           Data.HashMap.Strict         (HashMap, empty, insert, toList)
import           Data.String.Conv            (toS)
import           Data.Time.Clock.POSIX       (posixSecondsToUTCTime)
import           Control.Concurrent          (rtsSupportsBoundThreads, runInBoundThread)

import           Quickjs.Types
import           Quickjs.Error


C.context quickjsCtx
C.include "quickjs.h"
C.include "quickjs-libc.h"


foreign import ccall "JS_NewRuntime"
  jsNewRuntime :: IO (Ptr JSRuntime)

foreign import ccall "JS_FreeRuntime"
  jsFreeRuntime :: Ptr JSRuntime -> IO ()



foreign import ccall "JS_NewContext"
  jsNewContext :: Ptr JSRuntime -> IO (Ptr JSContext)

foreign import ccall "JS_FreeContext"
  jsFreeContext :: Ptr JSContext -> IO ()



jsFreeValue :: JSContextPtr -> JSValue -> IO ()
jsFreeValue :: JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctx JSValue
val = JSValue -> (Ptr JSValue -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
val ((Ptr JSValue -> IO ()) -> IO ())
-> (Ptr JSValue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
v -> [C.block| void {
    if (JS_VALUE_HAS_REF_COUNT(*$(JSValue *v))) {
      JSRefCountHeader *p = (JSRefCountHeader *)JS_VALUE_GET_PTR(*$(JSValue *v));
      if (--p->ref_count <= 0) {
        __JS_FreeValue($(JSContext *ctx), *$(JSValue *v));
      }
    }
  } |]



type JSContextPtr = Ptr JSContext
type JSValueConstPtr = Ptr JSValueConst

jsIs_ :: (MonadIO m, Storable p, Eq n, Num n) => p -> (Ptr p -> IO n) -> m Bool
jsIs_ :: p -> (Ptr p -> IO n) -> m Bool
jsIs_ p
val Ptr p -> IO n
fun = do
  n
b <- IO n -> m n
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO n -> m n) -> IO n -> m n
forall a b. (a -> b) -> a -> b
$ p -> (Ptr p -> IO n) -> IO n
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with p
val Ptr p -> IO n
fun
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ n
b n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
1

-- jsIsNumber :: MonadIO m => JSValue -> m Bool
-- jsIsNumber val = jsIs_ val $ \valPtr -> [C.block| int { return JS_IsNumber(*$(JSValueConst *valPtr)); } |]

jsIsArray :: MonadIO m => JSContextPtr -> JSValue -> m Bool
jsIsArray :: JSContextPtr -> JSValue -> m Bool
jsIsArray JSContextPtr
ctxPtr JSValue
val = JSValue -> (Ptr JSValue -> IO CInt) -> m Bool
forall (m :: * -> *) p n.
(MonadIO m, Storable p, Eq n, Num n) =>
p -> (Ptr p -> IO n) -> m Bool
jsIs_ JSValue
val ((Ptr JSValue -> IO CInt) -> m Bool)
-> (Ptr JSValue -> IO CInt) -> m Bool
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
valPtr -> [C.block| int { return JS_IsArray($(JSContext *ctxPtr), *$(JSValueConst *valPtr)); } |]

jsIsDate :: MonadIO m => JSContextPtr -> JSValue -> m Bool
jsIsDate :: JSContextPtr -> JSValue -> m Bool
jsIsDate JSContextPtr
ctxPtr JSValue
val = do
  JSValue
globalObject <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
globalObjectPtr ->
      [C.block| void { *$(JSValue *globalObjectPtr) = JS_GetGlobalObject($(JSContext *ctxPtr)); } |]
  JSValue
dateConstructor <- JSContextPtr -> JSValue -> ByteString -> m JSValue
forall (m :: * -> *).
MonadIO m =>
JSContextPtr -> JSValue -> ByteString -> m JSValue
jsGetPropertyStr JSContextPtr
ctxPtr JSValue
globalObject ByteString
"Date"
  IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
    JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
globalObject
    CInt
res <- JSValue -> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
val ((Ptr JSValue -> IO CInt) -> IO CInt)
-> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
valPtr -> JSValue -> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
dateConstructor ((Ptr JSValue -> IO CInt) -> IO CInt)
-> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
dateCPtr -> 
      [C.block| int { return JS_IsInstanceOf($(JSContext *ctxPtr), *$(JSValueConst *valPtr), *$(JSValueConst *dateCPtr)); } |]
    JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
dateConstructor
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CInt
res CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> CInt
0


jsIsTryAll :: MonadThrow m =>
  JSValue -> [JSValue -> m Bool] -> [JSTypeEnum] -> JSTypeEnum -> m JSTypeEnum
jsIsTryAll :: JSValue
-> [JSValue -> m Bool]
-> [JSTypeEnum]
-> JSTypeEnum
-> m JSTypeEnum
jsIsTryAll JSValue
_ [] [JSTypeEnum]
_ JSTypeEnum
def = JSTypeEnum -> m JSTypeEnum
forall (m :: * -> *) a. Monad m => a -> m a
return JSTypeEnum
def
jsIsTryAll JSValue
jsval (JSValue -> m Bool
f:[JSValue -> m Bool]
funs)(JSTypeEnum
l:[JSTypeEnum]
lbls) JSTypeEnum
def = do
  Bool
b <- JSValue -> m Bool
f JSValue
jsval
  if Bool
b then JSTypeEnum -> m JSTypeEnum
forall (m :: * -> *) a. Monad m => a -> m a
return JSTypeEnum
l else JSValue
-> [JSValue -> m Bool]
-> [JSTypeEnum]
-> JSTypeEnum
-> m JSTypeEnum
forall (m :: * -> *).
MonadThrow m =>
JSValue
-> [JSValue -> m Bool]
-> [JSTypeEnum]
-> JSTypeEnum
-> m JSTypeEnum
jsIsTryAll JSValue
jsval [JSValue -> m Bool]
funs [JSTypeEnum]
lbls JSTypeEnum
def
jsIsTryAll JSValue
_ [JSValue -> m Bool]
_ [JSTypeEnum]
_ JSTypeEnum
_ = InternalError -> m JSTypeEnum
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InternalError -> m JSTypeEnum) -> InternalError -> m JSTypeEnum
forall a b. (a -> b) -> a -> b
$ Text -> InternalError
InternalError (Text -> InternalError) -> Text -> InternalError
forall a b. (a -> b) -> a -> b
$ Text
"jsIsTryAll_ unreachable case"


jsIs :: (MonadIO m, MonadThrow m) => JSContextPtr -> JSValue -> m JSTypeEnum
jsIs :: JSContextPtr -> JSValue -> m JSTypeEnum
jsIs JSContextPtr
ctx JSValue
jsval = case CLong -> Maybe JSTagEnum
forall ty cty. FromCType ty cty => cty -> Maybe ty
fromCType (CLong -> Maybe JSTagEnum) -> CLong -> Maybe JSTagEnum
forall a b. (a -> b) -> a -> b
$ JSValue -> CLong
tag JSValue
jsval of
  Just JSTagEnum
JSTagObject -> 
    JSValue
-> [JSValue -> m Bool]
-> [JSTypeEnum]
-> JSTypeEnum
-> m JSTypeEnum
forall (m :: * -> *).
MonadThrow m =>
JSValue
-> [JSValue -> m Bool]
-> [JSTypeEnum]
-> JSTypeEnum
-> m JSTypeEnum
jsIsTryAll JSValue
jsval [JSContextPtr -> JSValue -> m Bool
forall (m :: * -> *).
MonadIO m =>
JSContextPtr -> JSValue -> m Bool
jsIsArray JSContextPtr
ctx, JSContextPtr -> JSValue -> m Bool
forall (m :: * -> *).
MonadIO m =>
JSContextPtr -> JSValue -> m Bool
jsIsDate JSContextPtr
ctx] [JSTypeEnum
JSIsArray, JSTypeEnum
JSIsDate] (JSTagEnum -> JSTypeEnum
JSTypeFromTag JSTagEnum
JSTagObject)
  Just JSTagEnum
t | JSTagEnum
t JSTagEnum -> JSTagEnum -> Bool
forall a. Eq a => a -> a -> Bool
== JSTagEnum
JSTagBigDecimal Bool -> Bool -> Bool
|| 
           JSTagEnum
t JSTagEnum -> JSTagEnum -> Bool
forall a. Eq a => a -> a -> Bool
== JSTagEnum
JSTagBigInt Bool -> Bool -> Bool
||
           JSTagEnum
t JSTagEnum -> JSTagEnum -> Bool
forall a. Eq a => a -> a -> Bool
== JSTagEnum
JSTagBigFloat Bool -> Bool -> Bool
||
           JSTagEnum
t JSTagEnum -> JSTagEnum -> Bool
forall a. Eq a => a -> a -> Bool
== JSTagEnum
JSTagInt Bool -> Bool -> Bool
|| 
           JSTagEnum
t JSTagEnum -> JSTagEnum -> Bool
forall a. Eq a => a -> a -> Bool
== JSTagEnum
JSTagFloat64 -> JSTypeEnum -> m JSTypeEnum
forall (m :: * -> *) a. Monad m => a -> m a
return JSTypeEnum
JSIsNumber
         | Bool
otherwise -> JSTypeEnum -> m JSTypeEnum
forall (m :: * -> *) a. Monad m => a -> m a
return (JSTypeEnum -> m JSTypeEnum) -> JSTypeEnum -> m JSTypeEnum
forall a b. (a -> b) -> a -> b
$ JSTagEnum -> JSTypeEnum
JSTypeFromTag JSTagEnum
t
  Maybe JSTagEnum
Nothing -> UnknownJSTag -> m JSTypeEnum
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UnknownJSTag -> m JSTypeEnum) -> UnknownJSTag -> m JSTypeEnum
forall a b. (a -> b) -> a -> b
$ CLong -> UnknownJSTag
UnknownJSTag (JSValue -> CLong
tag JSValue
jsval)
 


jsNullValue :: JSValue
jsNullValue :: JSValue
jsNullValue = JSValue :: CDouble -> CLong -> JSValue
JSValue { u :: CDouble
u = CDouble
0, tag :: CLong
tag = JSTagEnum -> CLong
forall ty cty. ToCType ty cty => ty -> cty
toCType JSTagEnum
JSTagNull }

jsNewBool :: JSContextPtr -> Bool -> IO JSValue
jsNewBool :: JSContextPtr -> Bool -> IO JSValue
jsNewBool JSContextPtr
ctxPtr Bool
bool = do
  let b :: CInt
b = if Bool
bool then CInt
1 else CInt
0
  (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
ptr -> [C.block| void { *$(JSValue *ptr) = JS_NewBool($(JSContext *ctxPtr), $(int b)); } |]

jsNewFloat64 :: JSContextPtr -> CDouble -> IO JSValue
jsNewFloat64 :: JSContextPtr -> CDouble -> IO JSValue
jsNewFloat64 JSContextPtr
ctxPtr CDouble
num =
  (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
ptr -> [C.block| void { *$(JSValue *ptr) = JS_NewFloat64($(JSContext *ctxPtr), $(double num)); } |]

jsNewInt64 :: JSContextPtr -> Int64 -> IO JSValue
jsNewInt64 :: JSContextPtr -> Int64 -> IO JSValue
jsNewInt64 JSContextPtr
ctxPtr Int64
num = do
  (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
ptr -> [C.block| void { *$(JSValue *ptr) = JS_NewInt64($(JSContext *ctxPtr), $(int64_t num)); } |]

jsNewString :: JSContextPtr -> ByteString -> IO JSValue
jsNewString :: JSContextPtr -> ByteString -> IO JSValue
jsNewString JSContextPtr
ctxPtr ByteString
s = (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
ptr -> ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
useAsCStringLen ByteString
s ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cstringPtr, Int
cstringLen) -> do
  let len :: CSize
len = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cstringLen
  [C.block| void { *$(JSValue *ptr) = JS_NewStringLen($(JSContext *ctxPtr), $(const char *cstringPtr), $(size_t len)); } |]



checkIsException :: (MonadThrow m, MonadIO m) => Text -> JSContextPtr -> JSValue -> m ()
checkIsException :: Text -> JSContextPtr -> JSValue -> m ()
checkIsException Text
loc JSContextPtr
ctxPtr JSValue
val =
  case CLong -> Maybe JSTagEnum
forall ty cty. FromCType ty cty => cty -> Maybe ty
fromCType (CLong -> Maybe JSTagEnum) -> CLong -> Maybe JSTagEnum
forall a b. (a -> b) -> a -> b
$ JSValue -> CLong
tag JSValue
val of
    Just JSTagEnum
JSTagException -> do
      Text
err <- JSContextPtr -> m Text
forall (m :: * -> *). MonadIO m => JSContextPtr -> m Text
getErrorMessage JSContextPtr
ctxPtr 
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
val
      JSException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JSException -> m ()) -> JSException -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> JSException
JSException Text
loc Text
err
    Maybe JSTagEnum
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()



jsonToJSValue :: (MonadThrow m, MonadIO m) => JSContextPtr -> Value -> m JSValue
jsonToJSValue :: JSContextPtr -> Value -> m JSValue
jsonToJSValue JSContextPtr
_ Value
Null = JSValue -> m JSValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSValue
jsNullValue
jsonToJSValue JSContextPtr
ctx (Bool Bool
b) = IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> Bool -> IO JSValue
jsNewBool JSContextPtr
ctx Bool
b
jsonToJSValue JSContextPtr
ctx (Number Scientific
n) = 
  if Bool -> Bool
not (Scientific -> Bool
isInteger Scientific
n) then IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> CDouble -> IO JSValue
jsNewFloat64 JSContextPtr
ctx (Scientific -> CDouble
forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
n)
  else case Scientific -> Maybe Int64
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
n of
    Just Int64
i -> IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> Int64 -> IO JSValue
jsNewInt64 JSContextPtr
ctx Int64
i
    Maybe Int64
Nothing -> InternalError -> m JSValue
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InternalError -> m JSValue) -> InternalError -> m JSValue
forall a b. (a -> b) -> a -> b
$ Text -> InternalError
InternalError Text
"Value does not fit in Int64"
jsonToJSValue JSContextPtr
ctx (String Text
s) = IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> ByteString -> IO JSValue
jsNewString JSContextPtr
ctx (ByteString -> IO JSValue) -> ByteString -> IO JSValue
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. StringConv a b => a -> b
toS Text
s
jsonToJSValue JSContextPtr
ctxPtr (Array Array
xs) = do
  JSValue
arrVal <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
arrValPtr -> [C.block| void { *$(JSValueConst *arrValPtr) = JS_NewArray($(JSContext *ctxPtr)); } |])
  
  Text -> JSContextPtr -> JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Text -> JSContextPtr -> JSValue -> m ()
checkIsException Text
"jsonToJSValue/Array/1" JSContextPtr
ctxPtr JSValue
arrVal

  ((Int -> Value -> m ()) -> Array -> m ())
-> Array -> (Int -> Value -> m ()) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Value -> m ()) -> Array -> m ()
forall (m :: * -> *) a b.
Monad m =>
(Int -> a -> m b) -> Vector a -> m ()
imapM_ Array
xs ((Int -> Value -> m ()) -> m ()) -> (Int -> Value -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
index Value
value -> do 
    JSValue
val <- JSContextPtr -> Value -> m JSValue
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
JSContextPtr -> Value -> m JSValue
jsonToJSValue JSContextPtr
ctxPtr Value
value
    Text -> JSContextPtr -> JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Text -> JSContextPtr -> JSValue -> m ()
checkIsException Text
"jsonToJSValue/Array/2" JSContextPtr
ctxPtr JSValue
val

    let idx :: Word32
idx = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index
    CInt
code <- IO CInt -> m CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (JSValue -> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
arrVal ((Ptr JSValue -> IO CInt) -> IO CInt)
-> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
arrValPtr -> JSValue -> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
val ((Ptr JSValue -> IO CInt) -> IO CInt)
-> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
valPtr -> 
      [C.block| int { return JS_DefinePropertyValueUint32(
        $(JSContext *ctxPtr), 
        *$(JSValueConst *arrValPtr),
        $(uint32_t idx),
        *$(JSValueConst *valPtr),
        JS_PROP_C_W_E
      ); } |])
    () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    if (CInt
code CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0) then do
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
arrVal
      InternalError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InternalError -> m ()) -> InternalError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> InternalError
InternalError Text
"Could not append element to array"
    else () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  JSValue -> m JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
arrVal
jsonToJSValue JSContextPtr
ctxPtr (Object Object
o) = do
  JSValue
objVal <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
objValPtr -> 
    [C.block| void { *$(JSValueConst *objValPtr) = JS_NewObject($(JSContext *ctxPtr)); } |])

  Text -> JSContextPtr -> JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Text -> JSContextPtr -> JSValue -> m ()
checkIsException Text
"jsonToJSValue/Object/1" JSContextPtr
ctxPtr JSValue
objVal
  
  [(Text, Value)] -> ((Text, Value) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
toList Object
o) (((Text, Value) -> m ()) -> m ())
-> ((Text, Value) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Text
key,Value
value) -> do
    JSValue
val <- JSContextPtr -> Value -> m JSValue
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
JSContextPtr -> Value -> m JSValue
jsonToJSValue JSContextPtr
ctxPtr Value
value
    Text -> JSContextPtr -> JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Text -> JSContextPtr -> JSValue -> m ()
checkIsException Text
"jsonToJSValue/Object/2" JSContextPtr
ctxPtr JSValue
val

    CInt
code <- IO CInt -> m CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (JSValue -> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
objVal ((Ptr JSValue -> IO CInt) -> IO CInt)
-> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
objValPtr -> JSValue -> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
val ((Ptr JSValue -> IO CInt) -> IO CInt)
-> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
valPtr -> 
      ByteString -> (Ptr CChar -> IO CInt) -> IO CInt
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
useAsCString (Text -> ByteString
encodeUtf8 Text
key) ((Ptr CChar -> IO CInt) -> IO CInt)
-> (Ptr CChar -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
cstringPtr -> do
        [C.block| int { 
          return JS_DefinePropertyValueStr(
            $(JSContext *ctxPtr), 
            *$(JSValueConst *objValPtr),
            $(const char *cstringPtr),
            *$(JSValueConst *valPtr),
            JS_PROP_C_W_E
          ); 
        } |])

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
code CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
objVal
      InternalError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InternalError -> m ()) -> InternalError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> InternalError
InternalError Text
"Could not add add property to object"

  JSValue -> m JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
objVal


jsToBool :: (MonadThrow m, MonadIO m) => JSContextPtr -> JSValue -> m Bool
jsToBool :: JSContextPtr -> JSValue -> m Bool
jsToBool JSContextPtr
ctxPtr JSValue
val = do
    CInt
code <- IO CInt -> m CInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CInt -> m CInt) -> IO CInt -> m CInt
forall a b. (a -> b) -> a -> b
$ JSValue -> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
val ((Ptr JSValue -> IO CInt) -> IO CInt)
-> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
valPtr -> [C.block| int { return JS_ToBool($(JSContext *ctxPtr), *$(JSValueConst *valPtr)); } |]
    case CInt
code of
        -1 -> JSContextPtr -> m Text
forall (m :: * -> *). MonadIO m => JSContextPtr -> m Text
getErrorMessage JSContextPtr
ctxPtr m Text -> (Text -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSException -> m Bool
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JSException -> m Bool) -> (Text -> JSException) -> Text -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> JSException
JSException Text
"jsToBool"
        CInt
0 -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        CInt
_ -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

jsToInt64 :: (MonadThrow m, MonadIO m) => JSContextPtr -> JSValue -> m Int64
jsToInt64 :: JSContextPtr -> JSValue -> m Int64
jsToInt64 JSContextPtr
ctxPtr JSValue
val = do
  (Int64
res, CInt
code) <- IO (Int64, CInt) -> m (Int64, CInt)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int64, CInt) -> m (Int64, CInt))
-> IO (Int64, CInt) -> m (Int64, CInt)
forall a b. (a -> b) -> a -> b
$ (Ptr Int64 -> IO CInt) -> IO (Int64, CInt)
forall a b. Storable a => (Ptr a -> IO b) -> IO (a, b)
C.withPtr ((Ptr Int64 -> IO CInt) -> IO (Int64, CInt))
-> (Ptr Int64 -> IO CInt) -> IO (Int64, CInt)
forall a b. (a -> b) -> a -> b
$ \Ptr Int64
intPtr -> JSValue -> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
val ((Ptr JSValue -> IO CInt) -> IO CInt)
-> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
valPtr -> [C.block| int { return JS_ToInt64($(JSContext *ctxPtr), $(int64_t *intPtr), *$(JSValueConst *valPtr)); } |]
  if CInt
code CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 then Int64 -> m Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
res
  else JSContextPtr -> m Text
forall (m :: * -> *). MonadIO m => JSContextPtr -> m Text
getErrorMessage JSContextPtr
ctxPtr m Text -> (Text -> m Int64) -> m Int64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSException -> m Int64
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JSException -> m Int64)
-> (Text -> JSException) -> Text -> m Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> JSException
JSException Text
"jsToInt64"


jsToFloat64 :: (MonadThrow m, MonadIO m) => JSContextPtr -> JSValue -> m CDouble
jsToFloat64 :: JSContextPtr -> JSValue -> m CDouble
jsToFloat64 JSContextPtr
ctxPtr JSValue
val = do
  (CDouble
res, CInt
code) <- IO (CDouble, CInt) -> m (CDouble, CInt)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CDouble, CInt) -> m (CDouble, CInt))
-> IO (CDouble, CInt) -> m (CDouble, CInt)
forall a b. (a -> b) -> a -> b
$ (Ptr CDouble -> IO CInt) -> IO (CDouble, CInt)
forall a b. Storable a => (Ptr a -> IO b) -> IO (a, b)
C.withPtr ((Ptr CDouble -> IO CInt) -> IO (CDouble, CInt))
-> (Ptr CDouble -> IO CInt) -> IO (CDouble, CInt)
forall a b. (a -> b) -> a -> b
$ \Ptr CDouble
doublePtr -> JSValue -> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
val ((Ptr JSValue -> IO CInt) -> IO CInt)
-> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
valPtr -> [C.block| int { return JS_ToFloat64($(JSContext *ctxPtr), $(double *doublePtr), *$(JSValueConst *valPtr)); } |]
  if CInt
code CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 then CDouble -> m CDouble
forall (m :: * -> *) a. Monad m => a -> m a
return CDouble
res
  else JSContextPtr -> m Text
forall (m :: * -> *). MonadIO m => JSContextPtr -> m Text
getErrorMessage JSContextPtr
ctxPtr m Text -> (Text -> m CDouble) -> m CDouble
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= JSException -> m CDouble
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JSException -> m CDouble)
-> (Text -> JSException) -> Text -> m CDouble
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> JSException
JSException Text
"jsToFloat64"



jsToString :: MonadIO m => JSContextPtr -> JSValue -> m ByteString
jsToString :: JSContextPtr -> JSValue -> m ByteString
jsToString JSContextPtr
ctxPtr JSValue
val = IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
    Ptr CChar
cstring <- JSValue -> (Ptr JSValue -> IO (Ptr CChar)) -> IO (Ptr CChar)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
val ((Ptr JSValue -> IO (Ptr CChar)) -> IO (Ptr CChar))
-> (Ptr JSValue -> IO (Ptr CChar)) -> IO (Ptr CChar)
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
valPtr -> [C.block| const char * { return JS_ToCString($(JSContext *ctxPtr), *$(JSValueConst *valPtr)); } |]
    if Ptr CChar
cstring Ptr CChar -> Ptr CChar -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CChar
forall a. Ptr a
nullPtr then ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
    else do
      ByteString
string <- Ptr CChar -> IO ByteString
packCString Ptr CChar
cstring
      JSContextPtr -> Ptr CChar -> IO ()
jsFreeCString JSContextPtr
ctxPtr Ptr CChar
cstring
      ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
string


foreign import ccall "JS_FreeCString"
  jsFreeCString :: JSContextPtr -> CString -> IO ()


jsToJSON :: (MonadCatch m, MonadIO m) => JSContextPtr -> JSValue -> m Value
jsToJSON :: JSContextPtr -> JSValue -> m Value
jsToJSON JSContextPtr
ctx JSValue
jsval = do
  JSTypeEnum
ty <- JSContextPtr -> JSValue -> m JSTypeEnum
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
JSContextPtr -> JSValue -> m JSTypeEnum
jsIs JSContextPtr
ctx JSValue
jsval
  case JSTypeEnum
ty of
    JSTypeFromTag JSTagEnum
JSTagException -> do
      Text
err <- JSContextPtr -> m Text
forall (m :: * -> *). MonadIO m => JSContextPtr -> m Text
getErrorMessage JSContextPtr
ctx 
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctx JSValue
jsval
      JSException -> m Value
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JSException -> m Value) -> JSException -> m Value
forall a b. (a -> b) -> a -> b
$ Text -> Text -> JSException
JSException Text
"jsToJSON/JSTagException" Text
err
    JSTypeFromTag JSTagEnum
JSTagNull -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
    JSTypeFromTag JSTagEnum
JSTagUndefined -> Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
    JSTypeFromTag JSTagEnum
JSTagBool -> do
      Bool
b <- JSContextPtr -> JSValue -> m Bool
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
JSContextPtr -> JSValue -> m Bool
jsToBool JSContextPtr
ctx JSValue
jsval
      Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
Bool Bool
b
    JSTypeEnum
JSIsNumber -> do
      CDouble
n <- JSContextPtr -> JSValue -> m CDouble
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
JSContextPtr -> JSValue -> m CDouble
jsToFloat64 JSContextPtr
ctx JSValue
jsval
      Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ CDouble -> Scientific
forall a. RealFloat a => a -> Scientific
fromFloatDigits CDouble
n
    JSTypeFromTag JSTagEnum
JSTagString -> do
      ByteString
s <- JSContextPtr -> JSValue -> m ByteString
forall (m :: * -> *).
MonadIO m =>
JSContextPtr -> JSValue -> m ByteString
jsToString JSContextPtr
ctx JSValue
jsval
      Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
s
    JSTypeEnum
JSIsArray -> do
      Int64
len <- do
        JSValue
lenVal <- JSContextPtr -> JSValue -> ByteString -> m JSValue
forall (m :: * -> *).
MonadIO m =>
JSContextPtr -> JSValue -> ByteString -> m JSValue
jsGetPropertyStr JSContextPtr
ctx JSValue
jsval ByteString
"length" 
        Int64
len' <- JSContextPtr -> JSValue -> m Int64
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
JSContextPtr -> JSValue -> m Int64
jsToInt64 JSContextPtr
ctx JSValue
lenVal
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctx JSValue
lenVal
        Int64 -> m Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
len'
      [Value]
vs <- JSContextPtr -> JSValue -> Int -> Int -> m [Value]
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
JSContextPtr -> JSValue -> Int -> Int -> m [Value]
jsArrayToJSON JSContextPtr
ctx JSValue
jsval Int
0 (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len)
      Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
fromList [Value]
vs
    JSTypeEnum
JSIsDate -> do
      JSValue
getter <- JSContextPtr -> JSValue -> ByteString -> m JSValue
forall (m :: * -> *).
MonadIO m =>
JSContextPtr -> JSValue -> ByteString -> m JSValue
jsGetPropertyStr JSContextPtr
ctx JSValue
jsval ByteString
"getTime" 

      JSValue
timestampRaw <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
res -> JSValue -> (Ptr JSValue -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
getter ((Ptr JSValue -> IO ()) -> IO ())
-> (Ptr JSValue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
getterPtr -> JSValue -> (Ptr JSValue -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
jsval ((Ptr JSValue -> IO ()) -> IO ())
-> (Ptr JSValue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
jsvalPtr -> 
        [C.block| void { *$(JSValue *res) = JS_Call($(JSContext *ctx), *$(JSValueConst *getterPtr), *$(JSValueConst *jsvalPtr), 0, NULL); } |]

      CDouble
timestamp <- JSContextPtr -> JSValue -> m CDouble
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
JSContextPtr -> JSValue -> m CDouble
jsToFloat64 JSContextPtr
ctx JSValue
timestampRaw
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctx JSValue
getter
        JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctx JSValue
timestampRaw
      Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON (UTCTime -> Value) -> UTCTime -> Value
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ CDouble -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (CDouble -> POSIXTime) -> CDouble -> POSIXTime
forall a b. (a -> b) -> a -> b
$ CDouble
timestamp CDouble -> CDouble -> CDouble
forall a. Fractional a => a -> a -> a
/ CDouble
1000
    JSTypeFromTag JSTagEnum
JSTagObject -> do
      Object
o <- JSContextPtr -> JSValue -> m Object
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
JSContextPtr -> JSValue -> m Object
jsObjectToJSON JSContextPtr
ctx JSValue
jsval
      Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
o 
    JSTypeFromTag JSTagEnum
f -> UnsupportedTypeTag -> m Value
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UnsupportedTypeTag -> m Value) -> UnsupportedTypeTag -> m Value
forall a b. (a -> b) -> a -> b
$ JSTagEnum -> UnsupportedTypeTag
UnsupportedTypeTag JSTagEnum
f
    JSTypeEnum
JSIsError -> InternalError -> m Value
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InternalError -> m Value) -> InternalError -> m Value
forall a b. (a -> b) -> a -> b
$ Text -> InternalError
InternalError Text
"JSIsError unreachable"


jsArrayToJSON :: (MonadCatch m, MonadIO m) => JSContextPtr -> JSValue -> Int -> Int -> m [Value]
jsArrayToJSON :: JSContextPtr -> JSValue -> Int -> Int -> m [Value]
jsArrayToJSON JSContextPtr
ctxPtr JSValue
jsval Int
index Int
len = 
  if Int
index Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len then do
    Value
v <- do
      let idx :: Word32
idx = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index
      JSValue
val <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
ptr -> JSValue -> (Ptr JSValue -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
jsval ((Ptr JSValue -> IO ()) -> IO ())
-> (Ptr JSValue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
jsvalPtr -> 
        [C.block| void { *$(JSValue *ptr) = JS_GetPropertyUint32($(JSContext *ctxPtr), *$(JSValueConst *jsvalPtr), $(uint32_t idx)); } |]

      Text -> JSContextPtr -> JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Text -> JSContextPtr -> JSValue -> m ()
checkIsException Text
"jsArrayToJSON" JSContextPtr
ctxPtr JSValue
val
      Value
res <- JSContextPtr -> JSValue -> m Value
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
JSContextPtr -> JSValue -> m Value
jsToJSON JSContextPtr
ctxPtr JSValue
val
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
val
      Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
res

    [Value]
vs <- JSContextPtr -> JSValue -> Int -> Int -> m [Value]
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
JSContextPtr -> JSValue -> Int -> Int -> m [Value]
jsArrayToJSON JSContextPtr
ctxPtr JSValue
jsval (Int
indexInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
len
    [Value] -> m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Value] -> m [Value]) -> [Value] -> m [Value]
forall a b. (a -> b) -> a -> b
$ Value
vValue -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:[Value]
vs
  else [Value] -> m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return []






forLoop :: (Num a, Ord a, Monad m) => a -> (a -> m ()) -> m ()
forLoop :: a -> (a -> m ()) -> m ()
forLoop a
end a -> m ()
f = a -> m ()
go a
0
  where
    go :: a -> m ()
go !a
x | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
end   = a -> m ()
f a
x m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m ()
go (a
xa -> a -> a
forall a. Num a => a -> a -> a
+a
1)
          | Bool
otherwise = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()




jsObjectToJSON :: (MonadCatch m, MonadIO m) => JSContextPtr -> JSValue -> m (HashMap Text Value)
jsObjectToJSON :: JSContextPtr -> JSValue -> m Object
jsObjectToJSON JSContextPtr
ctxPtr JSValue
obj = do
    let flags :: CInt
flags = JSGPNMask -> CInt
unJSGPNMask (JSGPNMask -> CInt) -> JSGPNMask -> CInt
forall a b. (a -> b) -> a -> b
$ JSGPNMask
jsGPNStringMask JSGPNMask -> JSGPNMask -> JSGPNMask
forall a. Bits a => a -> a -> a
.|. JSGPNMask
jsGPNSymbolMask JSGPNMask -> JSGPNMask -> JSGPNMask
forall a. Bits a => a -> a -> a
.|. JSGPNMask
jsGPNEnumOnly
    Ptr (Ptr JSPropertyEnum)
properties <- IO (Ptr (Ptr JSPropertyEnum)) -> m (Ptr (Ptr JSPropertyEnum))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr (Ptr JSPropertyEnum)) -> m (Ptr (Ptr JSPropertyEnum)))
-> IO (Ptr (Ptr JSPropertyEnum)) -> m (Ptr (Ptr JSPropertyEnum))
forall a b. (a -> b) -> a -> b
$ IO (Ptr (Ptr JSPropertyEnum))
forall a. Storable a => IO (Ptr a)
malloc
    Int
plen <- JSContextPtr
-> JSValue -> Ptr (Ptr JSPropertyEnum) -> CInt -> m Int
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
JSContextPtr
-> JSValue -> Ptr (Ptr JSPropertyEnum) -> CInt -> m Int
jsGetOwnPropertyNames JSContextPtr
ctxPtr JSValue
obj Ptr (Ptr JSPropertyEnum)
properties CInt
flags 
      m Int -> (SomeJSRuntimeException -> m Int) -> m Int
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeJSRuntimeException
e::SomeJSRuntimeException) -> do
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Ptr (Ptr JSPropertyEnum) -> IO ()
forall a. Ptr a -> IO ()
free Ptr (Ptr JSPropertyEnum)
properties
        SomeJSRuntimeException -> m Int
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeJSRuntimeException
e
      )
    Ptr JSValue
objPtr <- IO (Ptr JSValue) -> m (Ptr JSValue)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr JSValue) -> m (Ptr JSValue))
-> IO (Ptr JSValue) -> m (Ptr JSValue)
forall a b. (a -> b) -> a -> b
$ IO (Ptr JSValue)
forall a. Storable a => IO (Ptr a)
malloc
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Ptr JSValue -> JSValue -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr JSValue
objPtr JSValue
obj

    Object
res <- Ptr (Ptr JSPropertyEnum) -> Ptr JSValue -> Int -> Int -> m Object
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
Ptr (Ptr JSPropertyEnum) -> Ptr JSValue -> Int -> Int -> m Object
collectVals Ptr (Ptr JSPropertyEnum)
properties Ptr JSValue
objPtr Int
0 Int
plen m Object -> (SomeJSRuntimeException -> m Object) -> m Object
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(SomeJSRuntimeException
e::SomeJSRuntimeException) -> do
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Ptr JSValue -> IO ()
forall a. Ptr a -> IO ()
free Ptr JSValue
objPtr
        SomeJSRuntimeException -> m Object
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeJSRuntimeException
e
      )
    Ptr (Ptr JSPropertyEnum) -> Int -> m ()
forall (m :: * -> *).
MonadIO m =>
Ptr (Ptr JSPropertyEnum) -> Int -> m ()
cleanup Ptr (Ptr JSPropertyEnum)
properties Int
plen
    Object -> m Object
forall (m :: * -> *) a. Monad m => a -> m a
return Object
res
  where
    collectVals :: (MonadCatch m, MonadIO m) => Ptr (Ptr JSPropertyEnum) -> JSValueConstPtr -> Int -> Int -> m (HashMap Text Value)
    collectVals :: Ptr (Ptr JSPropertyEnum) -> Ptr JSValue -> Int -> Int -> m Object
collectVals Ptr (Ptr JSPropertyEnum)
properties Ptr JSValue
objPtr !Int
index Int
end 
      | Int
index Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
end = do
        let i :: Word32
i = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index

        Value
key <- do
          JSValue
key' <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
ptr -> [C.block| void { *$(JSValue *ptr) = JS_AtomToString($(JSContext *ctxPtr), (*$(JSPropertyEnum **properties))[$(uint32_t i)].atom); } |]
          Text -> JSContextPtr -> JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Text -> JSContextPtr -> JSValue -> m ()
checkIsException Text
"jsObjectToJSON/collectVals/1" JSContextPtr
ctxPtr JSValue
key'
          Value
res <- JSContextPtr -> JSValue -> m Value
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
JSContextPtr -> JSValue -> m Value
jsToJSON JSContextPtr
ctxPtr JSValue
key'
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
key'
          Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
res

        case Value
key of 
          String Text
k -> do
            Value
val <-  do
              JSValue
val' <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
ptr ->
                [C.block| void { *$(JSValue *ptr) = JS_GetProperty($(JSContext *ctxPtr), *$(JSValueConst *objPtr), (*$(JSPropertyEnum **properties))[$(uint32_t i)].atom); } |]
              Text -> JSContextPtr -> JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Text -> JSContextPtr -> JSValue -> m ()
checkIsException Text
"jsObjectToJSON/collectVals/2" JSContextPtr
ctxPtr JSValue
val'
              Value
res <- JSContextPtr -> JSValue -> m Value
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
JSContextPtr -> JSValue -> m Value
jsToJSON JSContextPtr
ctxPtr JSValue
val'
              IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
val'
              Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
res

            Object
xs <- Ptr (Ptr JSPropertyEnum) -> Ptr JSValue -> Int -> Int -> m Object
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
Ptr (Ptr JSPropertyEnum) -> Ptr JSValue -> Int -> Int -> m Object
collectVals Ptr (Ptr JSPropertyEnum)
properties Ptr JSValue
objPtr (Int
indexInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
end
            Object -> m Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> m Object) -> Object -> m Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert Text
k Value
val Object
xs
          Value
x -> InternalError -> m Object
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InternalError -> m Object) -> InternalError -> m Object
forall a b. (a -> b) -> a -> b
$ Text -> InternalError
InternalError (Text -> InternalError) -> Text -> InternalError
forall a b. (a -> b) -> a -> b
$ Text
"Could not get property name" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. StringConv a b => a -> b
toS (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
x)

      | Bool
otherwise = Object -> m Object
forall (m :: * -> *) a. Monad m => a -> m a
return Object
forall k v. HashMap k v
empty

    cleanup :: MonadIO m => Ptr (Ptr JSPropertyEnum) -> Int -> m ()
    cleanup :: Ptr (Ptr JSPropertyEnum) -> Int -> m ()
cleanup Ptr (Ptr JSPropertyEnum)
properties Int
plen = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Int -> (Int -> IO ()) -> IO ()
forall a (m :: * -> *).
(Num a, Ord a, Monad m) =>
a -> (a -> m ()) -> m ()
forLoop Int
plen ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index -> do
        let i :: Word32
i = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index
        [C.block| void { JS_FreeAtom($(JSContext *ctxPtr), (*$(JSPropertyEnum **properties))[$(uint32_t i)].atom); }|]

      let void_ptr :: Ptr b
void_ptr = Ptr (Ptr JSPropertyEnum) -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr JSPropertyEnum)
properties
      [C.block| void { js_free($(JSContext *ctxPtr), *$(void **void_ptr)); }|]

      Ptr (Ptr JSPropertyEnum) -> IO ()
forall a. Ptr a -> IO ()
free Ptr (Ptr JSPropertyEnum)
properties



getErrorMessage :: MonadIO m => JSContextPtr -> m Text
getErrorMessage :: JSContextPtr -> m Text
getErrorMessage JSContextPtr
ctxPtr = IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ do
  JSValue
ex <- (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
ptr -> [C.block| void { *$(JSValue *ptr) = JS_GetException($(JSContext *ctxPtr)); } |]
  ByteString
res <- JSContextPtr -> JSValue -> IO ByteString
forall (m :: * -> *).
MonadIO m =>
JSContextPtr -> JSValue -> m ByteString
jsToString JSContextPtr
ctxPtr JSValue
ex
  JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
ex
  Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
res



jsGetPropertyStr :: MonadIO m => JSContextPtr -> JSValue -> ByteString -> m JSValue
jsGetPropertyStr :: JSContextPtr -> JSValue -> ByteString -> m JSValue
jsGetPropertyStr JSContextPtr
ctxPtr JSValue
val ByteString
str = IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$
  (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
ptr -> ByteString -> (Ptr CChar -> IO ()) -> IO ()
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
useAsCString ByteString
str ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
prop -> JSValue -> (Ptr JSValue -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
val ((Ptr JSValue -> IO ()) -> IO ())
-> (Ptr JSValue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
valPtr ->
    [C.block| void { *$(JSValue *ptr) = JS_GetPropertyStr($(JSContext *ctxPtr), *$(JSValueConst *valPtr), $(const char *prop)); } |]


jsGetOwnPropertyNames :: (MonadThrow m, MonadIO m) => JSContextPtr -> JSValue -> Ptr (Ptr JSPropertyEnum) -> CInt -> m Int
jsGetOwnPropertyNames :: JSContextPtr
-> JSValue -> Ptr (Ptr JSPropertyEnum) -> CInt -> m Int
jsGetOwnPropertyNames JSContextPtr
ctxPtr JSValue
val Ptr (Ptr JSPropertyEnum)
properties CInt
flags = do
  (Word32
len,CInt
code) <- IO (Word32, CInt) -> m (Word32, CInt)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Word32, CInt) -> m (Word32, CInt))
-> IO (Word32, CInt) -> m (Word32, CInt)
forall a b. (a -> b) -> a -> b
$ (Ptr Word32 -> IO CInt) -> IO (Word32, CInt)
forall a b. Storable a => (Ptr a -> IO b) -> IO (a, b)
C.withPtr ((Ptr Word32 -> IO CInt) -> IO (Word32, CInt))
-> (Ptr Word32 -> IO CInt) -> IO (Word32, CInt)
forall a b. (a -> b) -> a -> b
$ \Ptr Word32
plen -> JSValue -> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
val ((Ptr JSValue -> IO CInt) -> IO CInt)
-> (Ptr JSValue -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
valPtr -> 
    [C.block| int { return JS_GetOwnPropertyNames($(JSContext *ctxPtr), $(JSPropertyEnum **properties), $(uint32_t *plen), *$(JSValueConst *valPtr), $(int flags)); } |]
  if CInt
code CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 then Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len)
  else InternalError -> m Int
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InternalError -> m Int) -> InternalError -> m Int
forall a b. (a -> b) -> a -> b
$ Text -> InternalError
InternalError Text
"Could not get object properties"


jsCall :: JSContextPtr -> JSValue -> CInt -> (Ptr JSValue) -> IO JSValue
jsCall :: JSContextPtr -> JSValue -> CInt -> Ptr JSValue -> IO JSValue
jsCall JSContextPtr
ctxt JSValue
fun_obj CInt
argc Ptr JSValue
argv = (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
res -> JSValue -> (Ptr JSValue -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with JSValue
fun_obj ((Ptr JSValue -> IO ()) -> IO ())
-> (Ptr JSValue -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
funPtr -> 
  [C.block| void { *$(JSValue *res) = JS_Call($(JSContext *ctxt), *$(JSValueConst *funPtr), JS_NULL, $(int argc), $(JSValueConst *argv)); } |]


jsEval :: JSContextPtr -> CString -> CSize -> CString -> CInt -> IO JSValue
jsEval :: JSContextPtr
-> Ptr CChar -> CSize -> Ptr CChar -> CInt -> IO JSValue
jsEval JSContextPtr
ctxPtr Ptr CChar
input CSize
input_len Ptr CChar
filename CInt
eval_flags = (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
ptr -> 
  [C.block| void { *$(JSValue *ptr) = JS_Eval($(JSContext *ctxPtr), $(const char *input), $(size_t input_len), $(const char *filename), $(int eval_flags)); } |]


evalRaw :: JSContextPtr -> JSEvalType -> ByteString -> IO JSValue
evalRaw :: JSContextPtr -> JSEvalType -> ByteString -> IO JSValue
evalRaw JSContextPtr
ctx JSEvalType
eTyp ByteString
code = 
    ByteString -> (Ptr CChar -> IO JSValue) -> IO JSValue
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
useAsCString ByteString
"script.js" ((Ptr CChar -> IO JSValue) -> IO JSValue)
-> (Ptr CChar -> IO JSValue) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
cfilename ->
        ByteString -> (CStringLen -> IO JSValue) -> IO JSValue
forall a. ByteString -> (CStringLen -> IO a) -> IO a
useAsCStringLen ByteString
code ((CStringLen -> IO JSValue) -> IO JSValue)
-> (CStringLen -> IO JSValue) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ccode, Int
ccode_len) -> 
            JSContextPtr
-> Ptr CChar -> CSize -> Ptr CChar -> CInt -> IO JSValue
jsEval JSContextPtr
ctx Ptr CChar
ccode (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ccode_len) Ptr CChar
cfilename (JSEvalType -> CInt
forall ty cty. ToCType ty cty => ty -> cty
toCType JSEvalType
eTyp)




evalAs :: (MonadMask m, MonadReader JSContextPtr m, MonadIO m) => JSEvalType -> ByteString -> m Value
evalAs :: JSEvalType -> ByteString -> m Value
evalAs JSEvalType
eTyp ByteString
code = do
  JSContextPtr
ctx <- m JSContextPtr
forall r (m :: * -> *). MonadReader r m => m r
ask
  JSValue
val <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSEvalType -> ByteString -> IO JSValue
evalRaw JSContextPtr
ctx JSEvalType
eTyp ByteString
code
  -- checkIsException "evalAs" ctx val
  JSContextPtr -> JSValue -> m Value
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
JSContextPtr -> JSValue -> m Value
jsToJSON JSContextPtr
ctx JSValue
val m Value -> m () -> m Value
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadReader JSContextPtr m, MonadIO m) =>
JSValue -> m ()
freeJSValue JSValue
val



{-|
Evaluates the given string and returns a 'Value' (if the result can be converted).
-}
eval :: (MonadMask m, MonadReader JSContextPtr m, MonadIO m) => ByteString -> m Value
eval :: ByteString -> m Value
eval = JSEvalType -> ByteString -> m Value
forall (m :: * -> *).
(MonadMask m, MonadReader JSContextPtr m, MonadIO m) =>
JSEvalType -> ByteString -> m Value
evalAs JSEvalType
Global

evalAs_ :: (MonadThrow m, MonadReader JSContextPtr m, MonadIO m) => JSEvalType -> ByteString -> m ()
evalAs_ :: JSEvalType -> ByteString -> m ()
evalAs_ JSEvalType
eTyp ByteString
code = do
  JSContextPtr
ctx <- m JSContextPtr
forall r (m :: * -> *). MonadReader r m => m r
ask
  JSValue
val <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSEvalType -> ByteString -> IO JSValue
evalRaw JSContextPtr
ctx JSEvalType
eTyp ByteString
code
  Text -> JSContextPtr -> JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Text -> JSContextPtr -> JSValue -> m ()
checkIsException Text
"evalAs_" JSContextPtr
ctx JSValue
val
  JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadReader JSContextPtr m, MonadIO m) =>
JSValue -> m ()
freeJSValue JSValue
val



{-|
More efficient than 'eval' if we don't care about the value of the expression, 
e.g. if we are evaluating a function definition or performing other side-effects such as
printing to console/modifying state.
-}
eval_ :: (MonadThrow m, MonadReader JSContextPtr m, MonadIO m) => ByteString -> m ()
eval_ :: ByteString -> m ()
eval_ = JSEvalType -> ByteString -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadReader JSContextPtr m, MonadIO m) =>
JSEvalType -> ByteString -> m ()
evalAs_ JSEvalType
Global


fromJSValue_ :: (MonadCatch m, MonadReader JSContextPtr m, MonadIO m) => JSValue -> m Value
fromJSValue_ :: JSValue -> m Value
fromJSValue_ JSValue
val = do
  JSContextPtr
ctx <- m JSContextPtr
forall r (m :: * -> *). MonadReader r m => m r
ask
  JSContextPtr -> JSValue -> m Value
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
JSContextPtr -> JSValue -> m Value
jsToJSON JSContextPtr
ctx JSValue
val



-- fromJSValue :: (Aeson.FromJSON a, MonadCatch m, MonadReader JSContextPtr m, MonadIO m) => JSValue -> m a
-- fromJSValue val = do
--   jsonval <- fromJSValue_ val

--   case Aeson.fromJSON jsonval of
--     Aeson.Success a -> return a
--     Aeson.Error err -> throwM $ InternalError err



{-|
Takes a value with a defined 'ToJSON' instance. This value is marshalled to a 'JSValue'
and passed as an argument to the callback function, provided as the second argument to 'withJSValue'
-}
withJSValue :: (MonadMask m, MonadReader JSContextPtr m, MonadIO m, Aeson.ToJSON a) => a -> (JSValue -> m b) -> m b
withJSValue :: a -> (JSValue -> m b) -> m b
withJSValue a
v JSValue -> m b
f = do

  JSContextPtr
ctx <- m JSContextPtr
forall r (m :: * -> *). MonadReader r m => m r
ask
  JSValue
val <- JSContextPtr -> Value -> m JSValue
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
JSContextPtr -> Value -> m JSValue
jsonToJSValue JSContextPtr
ctx (a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
v)
  JSValue -> m b
f JSValue
val m b -> m () -> m b
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadReader JSContextPtr m, MonadIO m) =>
JSValue -> m ()
freeJSValue JSValue
val




callRaw :: (MonadThrow m, MonadIO m) => JSContextPtr -> ByteString -> [JSValue] -> m JSValue
callRaw :: JSContextPtr -> ByteString -> [JSValue] -> m JSValue
callRaw JSContextPtr
ctxPtr ByteString
funName [JSValue]
args = do
    JSValue
globalObject <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ (Ptr JSValue -> IO ()) -> IO JSValue
forall a. Storable a => (Ptr a -> IO ()) -> IO a
C.withPtr_ ((Ptr JSValue -> IO ()) -> IO JSValue)
-> (Ptr JSValue -> IO ()) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Ptr JSValue
globalObjectPtr ->
      [C.block| void { *$(JSValue *globalObjectPtr) = JS_GetGlobalObject($(JSContext *ctxPtr)); } |]

    JSValue
fun <- JSContextPtr -> JSValue -> ByteString -> m JSValue
forall (m :: * -> *).
MonadIO m =>
JSContextPtr -> JSValue -> ByteString -> m JSValue
jsGetPropertyStr JSContextPtr
ctxPtr JSValue
globalObject ByteString
funName

    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
globalObject

    JSTypeEnum
ty <- JSContextPtr -> JSValue -> m JSTypeEnum
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
JSContextPtr -> JSValue -> m JSTypeEnum
jsIs JSContextPtr
ctxPtr JSValue
fun
    case JSTypeEnum
ty of
      JSTypeFromTag JSTagEnum
JSTagException -> do
        Text
err <- JSContextPtr -> m Text
forall (m :: * -> *). MonadIO m => JSContextPtr -> m Text
getErrorMessage JSContextPtr
ctxPtr 
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
fun
        JSException -> m JSValue
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JSException -> m JSValue) -> JSException -> m JSValue
forall a b. (a -> b) -> a -> b
$ Text -> Text -> JSException
JSException Text
"callRaw" Text
err
      JSTypeFromTag JSTagEnum
JSTagUndefined -> JSValueUndefined -> m JSValue
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JSValueUndefined -> m JSValue) -> JSValueUndefined -> m JSValue
forall a b. (a -> b) -> a -> b
$ Text -> JSValueUndefined
JSValueUndefined (Text -> JSValueUndefined) -> Text -> JSValueUndefined
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
funName
      JSTypeFromTag JSTagEnum
JSTagObject -> do
        JSValue
res <- IO JSValue -> m JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> m JSValue) -> IO JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ [JSValue] -> (Int -> Ptr JSValue -> IO JSValue) -> IO JSValue
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [JSValue]
args ((Int -> Ptr JSValue -> IO JSValue) -> IO JSValue)
-> (Int -> Ptr JSValue -> IO JSValue) -> IO JSValue
forall a b. (a -> b) -> a -> b
$ \Int
len Ptr JSValue
argv -> JSContextPtr -> JSValue -> CInt -> Ptr JSValue -> IO JSValue
jsCall JSContextPtr
ctxPtr JSValue
fun (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Int
len) Ptr JSValue
argv
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctxPtr JSValue
fun
        JSValue -> m JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return JSValue
res
      JSTypeEnum
_ -> JSValueIncorrectType -> m JSValue
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (JSValueIncorrectType -> m JSValue)
-> JSValueIncorrectType -> m JSValue
forall a b. (a -> b) -> a -> b
$ JSValueIncorrectType :: Text -> JSTypeEnum -> JSTypeEnum -> JSValueIncorrectType
JSValueIncorrectType {$sel:name:JSValueIncorrectType :: Text
name = ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
funName, $sel:expected:JSValueIncorrectType :: JSTypeEnum
expected = JSTagEnum -> JSTypeEnum
JSTypeFromTag JSTagEnum
JSTagObject, $sel:found:JSValueIncorrectType :: JSTypeEnum
found = JSTypeEnum
ty }


-- call :: (MonadThrow m, MonadReader JSContextPtr m, MonadIO m) => String -> [JSValue] -> m JSValue
-- call funName args = do
--   ctx <- ask
--   val <- callRaw ctx funName args
--   checkIsException ctx val
--   return val



call :: (MonadMask m, MonadReader JSContextPtr m, MonadIO m) => ByteString -> [JSValue] -> m Value
call :: ByteString -> [JSValue] -> m Value
call ByteString
funName [JSValue]
args = do
  JSContextPtr
ctx <- m JSContextPtr
forall r (m :: * -> *). MonadReader r m => m r
ask
  JSValue
val <- JSContextPtr -> ByteString -> [JSValue] -> m JSValue
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
JSContextPtr -> ByteString -> [JSValue] -> m JSValue
callRaw JSContextPtr
ctx ByteString
funName [JSValue]
args
  JSContextPtr -> JSValue -> m Value
forall (m :: * -> *).
(MonadCatch m, MonadIO m) =>
JSContextPtr -> JSValue -> m Value
jsToJSON JSContextPtr
ctx JSValue
val m Value -> m () -> m Value
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` JSValue -> m ()
forall (m :: * -> *).
(MonadThrow m, MonadReader JSContextPtr m, MonadIO m) =>
JSValue -> m ()
freeJSValue JSValue
val


freeJSValue :: (MonadThrow m, MonadReader JSContextPtr m, MonadIO m) => JSValue -> m ()
freeJSValue :: JSValue -> m ()
freeJSValue JSValue
val = do
  JSContextPtr
ctx <- m JSContextPtr
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JSContextPtr -> JSValue -> IO ()
jsFreeValue JSContextPtr
ctx JSValue
val

{-|
This function initialises a new JS runtime and performs the given computation within this context.

For example, we can evaluate an expression:

>quickjs $ do
>  res <- eval "1+2"
>  liftIO $ print res

Declare a function and call it on an argument:

>quickjs $ do
>  _ <- eval_ "f = (x) => x+1"
>  res <- eval "f(2)"
>  liftIO $ print res

Pass a Haskell value to the JS runtime:

>quickjs $ do
>  _ <- eval_ "f = (x) => x+1"
>  res <- withJSValue (3::Int) $ \x -> call "f" [x]
>  liftIO $ print res

-}
quickjs :: MonadIO m => ReaderT (Ptr JSContext) m b -> m b
quickjs :: ReaderT JSContextPtr m b -> m b
quickjs ReaderT JSContextPtr m b
f = do
  (Ptr JSRuntime
rt, JSContextPtr
ctx) <- IO (Ptr JSRuntime, JSContextPtr) -> m (Ptr JSRuntime, JSContextPtr)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr JSRuntime, JSContextPtr)
 -> m (Ptr JSRuntime, JSContextPtr))
-> IO (Ptr JSRuntime, JSContextPtr)
-> m (Ptr JSRuntime, JSContextPtr)
forall a b. (a -> b) -> a -> b
$ do
    Ptr JSRuntime
_rt <- IO (Ptr JSRuntime)
jsNewRuntime
    JSContextPtr
_ctx <- Ptr JSRuntime -> IO JSContextPtr
jsNewContext Ptr JSRuntime
_rt

    [C.block| void { 
      js_std_add_helpers($(JSContext *_ctx), -1, NULL);
    } |]
    (Ptr JSRuntime, JSContextPtr) -> IO (Ptr JSRuntime, JSContextPtr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr JSRuntime
_rt, JSContextPtr
_ctx)

  b
res <- ReaderT JSContextPtr m b -> JSContextPtr -> m b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT JSContextPtr m b
f JSContextPtr
ctx
  JSContextPtr -> Ptr JSRuntime -> m ()
forall (m :: * -> *).
MonadIO m =>
JSContextPtr -> Ptr JSRuntime -> m ()
cleanup JSContextPtr
ctx Ptr JSRuntime
rt
  b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res
  where
    cleanup :: JSContextPtr -> Ptr JSRuntime -> m ()
cleanup JSContextPtr
ctx Ptr JSRuntime
rt = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      JSContextPtr -> IO ()
jsFreeContext JSContextPtr
ctx
      Ptr JSRuntime -> IO ()
jsFreeRuntime Ptr JSRuntime
rt

{-|
This env differs from regular 'quickjs', in that it wraps the computation in the 'runInBoundThread' function.
This is needed when running the Haskell program mutithreaded (e.g. when using the testing framework Tasty),
since  quickjs does not like being called from an OS thread other than the one it was started in.
Because Haskell uses lightweight threads, this might happen if threaded mode is enabled, as is the case in Tasty.
This problem does not occur when running via Main.hs, if compiled as single threaded...
For more info see the paper [Extending the Haskell Foreign Function Interface with Concurrency](https://simonmar.github.io/bib/papers/conc-ffi.pdf)
-}
quickjsMultithreaded :: MonadUnliftIO m => ReaderT (Ptr JSContext) m b -> m b
quickjsMultithreaded :: ReaderT JSContextPtr m b -> m b
quickjsMultithreaded ReaderT JSContextPtr m b
f 
  | Bool
rtsSupportsBoundThreads = do
    (UnliftIO m
u :: UnliftIO m) <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
    
    IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> IO b -> m b
forall a b. (a -> b) -> a -> b
$ IO b -> IO b
forall a. IO a -> IO a
runInBoundThread (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$ do
      Ptr JSRuntime
rt <- IO (Ptr JSRuntime)
jsNewRuntime
      JSContextPtr
ctx <- Ptr JSRuntime -> IO JSContextPtr
jsNewContext Ptr JSRuntime
rt

      [C.block| void { 
        js_std_add_helpers($(JSContext *ctx), -1, NULL);
      } |]

      b
res <-  UnliftIO m -> forall a. m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (m b -> IO b) -> m b -> IO b
forall a b. (a -> b) -> a -> b
$ ReaderT JSContextPtr m b -> JSContextPtr -> m b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT JSContextPtr m b
f JSContextPtr
ctx
      JSContextPtr -> Ptr JSRuntime -> IO ()
cleanup JSContextPtr
ctx Ptr JSRuntime
rt
      b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res
  | Bool
otherwise = ReaderT JSContextPtr m b -> m b
forall (m :: * -> *) b.
MonadIO m =>
ReaderT JSContextPtr m b -> m b
quickjs ReaderT JSContextPtr m b
f
  where
    cleanup :: JSContextPtr -> Ptr JSRuntime -> IO ()
cleanup JSContextPtr
ctx Ptr JSRuntime
rt = do
      JSContextPtr -> IO ()
jsFreeContext JSContextPtr
ctx
      Ptr JSRuntime -> IO ()
jsFreeRuntime Ptr JSRuntime
rt