Skip to content

Commit 5c73cdd

Browse files
goodlyrottenapplegoodlyrottenapple
committed
pull lambdamechanic/master changes
1 parent ee16830 commit 5c73cdd

File tree

4 files changed

+84
-88
lines changed

4 files changed

+84
-88
lines changed

‎quickjs

‎quickjs-hs.cabal

Lines changed: 14 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
12
cabal-version: 1.12
23
name: quickjs-hs
34
version: 0.1.2.4
@@ -20,15 +21,7 @@ description:
2021
To get started, see the ReadMe below.
2122

2223
extra-source-files:
23-
quickjs/cutils.h
24-
, quickjs/libbf.h
25-
, quickjs/libunicode-table.h
26-
, quickjs/libunicode.h
27-
, quickjs/libregexp-opcode.h
28-
, quickjs/libregexp.h
29-
, quickjs/list.h
30-
, quickjs/quickjs-atom.h
31-
, quickjs/quickjs-opcode.h
24+
quickjs/*.h
3225

3326
source-repository head
3427
type: git
@@ -57,21 +50,21 @@ library
5750
unliftio-core >=0.1 && <0.3,
5851
unordered-containers >=0.2.8 && <0.3,
5952
vector >=0.12 && <0.14
60-
53+
6154
default-language: Haskell2010
6255
include-dirs: quickjs
63-
c-sources:
56+
c-sources:
6457
quickjs/cutils.c
6558
, quickjs/libbf.c
6659
, quickjs/libunicode.c
6760
, quickjs/libregexp.c
68-
, quickjs/quickjs.h
6961
, quickjs/quickjs.c
70-
, quickjs/quickjs-libc.h
7162
, quickjs/quickjs-libc.c
72-
73-
cc-options:
74-
-static -D_GNU_SOURCE
63+
includes:
64+
quickjs/quickjs.h
65+
, quickjs/quickjs-libc.h
66+
cc-options:
67+
-static -D_GNU_SOURCE
7568
-DCONFIG_VERSION="2020-11-08"
7669
-DCONFIG_BIGNUM
7770

@@ -87,12 +80,11 @@ test-suite quickjs-hs-test
8780
, quickjs-hs -any
8881
, aeson
8982
, exceptions
90-
, HUnit >=1.6.0.0 && <1.7
91-
, QuickCheck >=2.9 && <2.15
92-
, tasty >=1.0 && <1.3
93-
, tasty-hunit >=0.10 && <0.11
94-
, tasty-quickcheck >=0.9 && <0.11
83+
, HUnit >=1.6.0.0
84+
, QuickCheck >=2.9
85+
, tasty >=1.0
86+
, tasty-hunit >=0.10
87+
, tasty-quickcheck >=0.9
9588
, text
9689
, unordered-containers
9790
, vector
98-

‎src/Quickjs.hs

Lines changed: 45 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -25,12 +25,13 @@ import Control.Monad.Reader (MonadReader, runReaderT, ask)
2525
import Control.Monad.Trans.Reader (ReaderT)
2626
import Control.Monad.IO.Class (MonadIO, liftIO)
2727
import Control.Monad.IO.Unlift (MonadUnliftIO(..), UnliftIO(..), askUnliftIO)
28-
import Data.Aeson (Value(..), encode, toJSON)
28+
import Data.Aeson (Key,Value(..), encode, toJSON)
2929
import qualified Data.Aeson as Aeson
30+
import qualified Data.Aeson.Key as Key
3031
import Data.Scientific (fromFloatDigits, toRealFloat, toBoundedInteger, isInteger)
3132
import Data.Text (Text)
3233
import Data.Vector (fromList, imapM_)
33-
import Data.HashMap.Strict (HashMap, empty, insert, toList)
34+
import Data.Aeson.KeyMap (KeyMap, empty, insert, toList)
3435
import Data.String.Conv (toS)
3536
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
3637
import Control.Concurrent (rtsSupportsBoundThreads, runInBoundThread)
@@ -50,8 +51,6 @@ foreign import ccall "JS_NewRuntime"
5051
foreign import ccall "JS_FreeRuntime"
5152
jsFreeRuntime :: Ptr JSRuntime -> IO ()
5253

53-
54-
5554
foreign import ccall "JS_NewContext"
5655
jsNewContext :: Ptr JSRuntime -> IO (Ptr JSContext)
5756

@@ -93,7 +92,7 @@ jsIsDate ctxPtr val = do
9392
dateConstructor <- jsGetPropertyStr ctxPtr globalObject "Date"
9493
liftIO $ do
9594
jsFreeValue ctxPtr globalObject
96-
res <- with val $ \valPtr -> with dateConstructor $ \dateCPtr ->
95+
res <- with val $ \valPtr -> with dateConstructor $ \dateCPtr ->
9796
[C.block| int { return JS_IsInstanceOf($(JSContext *ctxPtr), *$(JSValueConst *valPtr), *$(JSValueConst *dateCPtr)); } |]
9897
jsFreeValue ctxPtr dateConstructor
9998
return $ res > 0
@@ -110,16 +109,16 @@ jsIsTryAll _ _ _ _ = throwM $ InternalError $ "jsIsTryAll_ unreachable case"
110109

111110
jsIs :: (MonadIO m, MonadThrow m) => JSContextPtr -> JSValue -> m JSTypeEnum
112111
jsIs ctx jsval = case fromCType $ tag jsval of
113-
Just JSTagObject ->
112+
Just JSTagObject ->
114113
jsIsTryAll jsval [jsIsArray ctx, jsIsDate ctx] [JSIsArray, JSIsDate] (JSTypeFromTag JSTagObject)
115-
Just t | t == JSTagBigDecimal ||
114+
Just t | t == JSTagBigDecimal ||
116115
t == JSTagBigInt ||
117116
t == JSTagBigFloat ||
118-
t == JSTagInt ||
117+
t == JSTagInt ||
119118
t == JSTagFloat64 -> return JSIsNumber
120119
| otherwise -> return $ JSTypeFromTag t
121120
Nothing -> throwM $ UnknownJSTag (tag jsval)
122-
121+
123122

124123

125124
jsNullValue :: JSValue
@@ -149,7 +148,7 @@ checkIsException :: (MonadThrow m, MonadIO m) => Text -> JSContextPtr -> JSValue
149148
checkIsException loc ctxPtr val =
150149
case fromCType $ tag val of
151150
Just JSTagException -> do
152-
err <- getErrorMessage ctxPtr
151+
err <- getErrorMessage ctxPtr
153152
liftIO $ jsFreeValue ctxPtr val
154153
throwM $ JSException loc err
155154
_ -> pure ()
@@ -159,25 +158,25 @@ checkIsException loc ctxPtr val =
159158
jsonToJSValue :: (MonadThrow m, MonadIO m) => JSContextPtr -> Value -> m JSValue
160159
jsonToJSValue _ Null = pure jsNullValue
161160
jsonToJSValue ctx (Bool b) = liftIO $ jsNewBool ctx b
162-
jsonToJSValue ctx (Number n) =
161+
jsonToJSValue ctx (Number n) =
163162
if not (isInteger n) then liftIO $ jsNewFloat64 ctx (toRealFloat n)
164163
else case toBoundedInteger n of
165164
Just i -> liftIO $ jsNewInt64 ctx i
166165
Nothing -> throwM $ InternalError "Value does not fit in Int64"
167166
jsonToJSValue ctx (String s) = liftIO $ jsNewString ctx $ toS s
168167
jsonToJSValue ctxPtr (Array xs) = do
169168
arrVal <- liftIO (C.withPtr_ $ \arrValPtr -> [C.block| void { *$(JSValueConst *arrValPtr) = JS_NewArray($(JSContext *ctxPtr)); } |])
170-
169+
171170
checkIsException "jsonToJSValue/Array/1" ctxPtr arrVal
172171

173-
flip imapM_ xs $ \index value -> do
172+
flip imapM_ xs $ \index value -> do
174173
val <- jsonToJSValue ctxPtr value
175174
checkIsException "jsonToJSValue/Array/2" ctxPtr val
176175

177176
let idx = fromIntegral index
178-
code <- liftIO (with arrVal $ \arrValPtr -> with val $ \valPtr ->
177+
code <- liftIO (with arrVal $ \arrValPtr -> with val $ \valPtr ->
179178
[C.block| int { return JS_DefinePropertyValueUint32(
180-
$(JSContext *ctxPtr),
179+
$(JSContext *ctxPtr),
181180
*$(JSValueConst *arrValPtr),
182181
$(uint32_t idx),
183182
*$(JSValueConst *valPtr),
@@ -192,25 +191,25 @@ jsonToJSValue ctxPtr (Array xs) = do
192191

193192
return arrVal
194193
jsonToJSValue ctxPtr (Object o) = do
195-
objVal <- liftIO (C.withPtr_ $ \objValPtr ->
194+
objVal <- liftIO (C.withPtr_ $ \objValPtr ->
196195
[C.block| void { *$(JSValueConst *objValPtr) = JS_NewObject($(JSContext *ctxPtr)); } |])
197196

198197
checkIsException "jsonToJSValue/Object/1" ctxPtr objVal
199-
198+
200199
forM_ (toList o) $ \(key,value) -> do
201200
val <- jsonToJSValue ctxPtr value
202201
checkIsException "jsonToJSValue/Object/2" ctxPtr val
203202

204-
code <- liftIO (with objVal $ \objValPtr -> with val $ \valPtr ->
205-
useAsCString (encodeUtf8 key) $ \cstringPtr -> do
206-
[C.block| int {
203+
code <- liftIO (with objVal $ \objValPtr -> with val $ \valPtr ->
204+
useAsCString (encodeUtf8 $ Key.toText key) $ \cstringPtr -> do
205+
[C.block| int {
207206
return JS_DefinePropertyValueStr(
208-
$(JSContext *ctxPtr),
207+
$(JSContext *ctxPtr),
209208
*$(JSValueConst *objValPtr),
210209
$(const char *cstringPtr),
211210
*$(JSValueConst *valPtr),
212211
JS_PROP_C_W_E
213-
);
212+
);
214213
} |])
215214

216215
when (code < 0) $ do
@@ -262,7 +261,7 @@ jsToJSON ctx jsval = do
262261
ty <- jsIs ctx jsval
263262
case ty of
264263
JSTypeFromTag JSTagException -> do
265-
err <- getErrorMessage ctx
264+
err <- getErrorMessage ctx
266265
liftIO $ jsFreeValue ctx jsval
267266
throwM $ JSException "jsToJSON/JSTagException" err
268267
JSTypeFromTag JSTagNull -> return Null
@@ -278,16 +277,16 @@ jsToJSON ctx jsval = do
278277
return $ String $ toS s
279278
JSIsArray -> do
280279
len <- do
281-
lenVal <- jsGetPropertyStr ctx jsval "length"
280+
lenVal <- jsGetPropertyStr ctx jsval "length"
282281
len' <- jsToInt64 ctx lenVal
283282
liftIO $ jsFreeValue ctx lenVal
284283
return len'
285284
vs <- jsArrayToJSON ctx jsval 0 (fromIntegral len)
286285
return $ Array $ fromList vs
287286
JSIsDate -> do
288-
getter <- jsGetPropertyStr ctx jsval "getTime"
287+
getter <- jsGetPropertyStr ctx jsval "getTime"
289288

290-
timestampRaw <- liftIO $ C.withPtr_ $ \res -> with getter $ \getterPtr -> with jsval $ \jsvalPtr ->
289+
timestampRaw <- liftIO $ C.withPtr_ $ \res -> with getter $ \getterPtr -> with jsval $ \jsvalPtr ->
291290
[C.block| void { *$(JSValue *res) = JS_Call($(JSContext *ctx), *$(JSValueConst *getterPtr), *$(JSValueConst *jsvalPtr), 0, NULL); } |]
292291

293292
timestamp <- jsToFloat64 ctx timestampRaw
@@ -297,17 +296,17 @@ jsToJSON ctx jsval = do
297296
return $ toJSON $ posixSecondsToUTCTime $ realToFrac $ timestamp / 1000
298297
JSTypeFromTag JSTagObject -> do
299298
o <- jsObjectToJSON ctx jsval
300-
return $ Object o
299+
return $ Object o
301300
JSTypeFromTag f -> throwM $ UnsupportedTypeTag f
302301
JSIsError -> throwM $ InternalError "JSIsError unreachable"
303302

304303

305304
jsArrayToJSON :: (MonadCatch m, MonadIO m) => JSContextPtr -> JSValue -> Int -> Int -> m [Value]
306-
jsArrayToJSON ctxPtr jsval index len =
305+
jsArrayToJSON ctxPtr jsval index len =
307306
if index < len then do
308307
v <- do
309308
let idx = fromIntegral index
310-
val <- liftIO $ C.withPtr_ $ \ptr -> with jsval $ \jsvalPtr ->
309+
val <- liftIO $ C.withPtr_ $ \ptr -> with jsval $ \jsvalPtr ->
311310
[C.block| void { *$(JSValue *ptr) = JS_GetPropertyUint32($(JSContext *ctxPtr), *$(JSValueConst *jsvalPtr), $(uint32_t idx)); } |]
312311

313312
checkIsException "jsArrayToJSON" ctxPtr val
@@ -333,11 +332,11 @@ forLoop end f = go 0
333332

334333

335334

336-
jsObjectToJSON :: (MonadCatch m, MonadIO m) => JSContextPtr -> JSValue -> m (HashMap Text Value)
335+
jsObjectToJSON :: (MonadCatch m, MonadIO m) => JSContextPtr -> JSValue -> m (KeyMap Value)
337336
jsObjectToJSON ctxPtr obj = do
338337
let flags = unJSGPNMask $ jsGPNStringMask .|. jsGPNSymbolMask .|. jsGPNEnumOnly
339338
properties <- liftIO $ malloc
340-
plen <- jsGetOwnPropertyNames ctxPtr obj properties flags
339+
plen <- jsGetOwnPropertyNames ctxPtr obj properties flags
341340
`catch` (\(e::SomeJSRuntimeException) -> do
342341
liftIO $ free properties
343342
throwM e
@@ -352,8 +351,8 @@ jsObjectToJSON ctxPtr obj = do
352351
cleanup properties plen
353352
return res
354353
where
355-
collectVals :: (MonadCatch m, MonadIO m) => Ptr (Ptr JSPropertyEnum) -> JSValueConstPtr -> Int -> Int -> m (HashMap Text Value)
356-
collectVals properties objPtr !index end
354+
collectVals :: (MonadCatch m, MonadIO m) => Ptr (Ptr JSPropertyEnum) -> JSValueConstPtr -> Int -> Int -> m (KeyMap Value)
355+
collectVals properties objPtr !index end
357356
| index < end = do
358357
let i = fromIntegral index
359358

@@ -364,7 +363,7 @@ jsObjectToJSON ctxPtr obj = do
364363
liftIO $ jsFreeValue ctxPtr key'
365364
return res
366365

367-
case key of
366+
case key of
368367
String k -> do
369368
val <- do
370369
val' <- liftIO $ C.withPtr_ $ \ptr ->
@@ -375,7 +374,7 @@ jsObjectToJSON ctxPtr obj = do
375374
return res
376375

377376
xs <- collectVals properties objPtr (index+1) end
378-
return $ insert k val xs
377+
return $ insert (Key.fromText k) val xs
379378
x -> throwM $ InternalError $ "Could not get property name" <> toS (encode x)
380379

381380
| otherwise = return empty
@@ -410,26 +409,26 @@ jsGetPropertyStr ctxPtr val str = liftIO $
410409

411410
jsGetOwnPropertyNames :: (MonadThrow m, MonadIO m) => JSContextPtr -> JSValue -> Ptr (Ptr JSPropertyEnum) -> CInt -> m Int
412411
jsGetOwnPropertyNames ctxPtr val properties flags = do
413-
(len,code) <- liftIO $ C.withPtr $ \plen -> with val $ \valPtr ->
412+
(len,code) <- liftIO $ C.withPtr $ \plen -> with val $ \valPtr ->
414413
[C.block| int { return JS_GetOwnPropertyNames($(JSContext *ctxPtr), $(JSPropertyEnum **properties), $(uint32_t *plen), *$(JSValueConst *valPtr), $(int flags)); } |]
415414
if code == 0 then return (fromIntegral len)
416415
else throwM $ InternalError "Could not get object properties"
417416

418417

419418
jsCall :: JSContextPtr -> JSValue -> CInt -> (Ptr JSValue) -> IO JSValue
420-
jsCall ctxt fun_obj argc argv = C.withPtr_ $ \res -> with fun_obj $ \funPtr ->
419+
jsCall ctxt fun_obj argc argv = C.withPtr_ $ \res -> with fun_obj $ \funPtr ->
421420
[C.block| void { *$(JSValue *res) = JS_Call($(JSContext *ctxt), *$(JSValueConst *funPtr), JS_NULL, $(int argc), $(JSValueConst *argv)); } |]
422421

423422

424423
jsEval :: JSContextPtr -> CString -> CSize -> CString -> CInt -> IO JSValue
425-
jsEval ctxPtr input input_len filename eval_flags = C.withPtr_ $ \ptr ->
424+
jsEval ctxPtr input input_len filename eval_flags = C.withPtr_ $ \ptr ->
426425
[C.block| void { *$(JSValue *ptr) = JS_Eval($(JSContext *ctxPtr), $(const char *input), $(size_t input_len), $(const char *filename), $(int eval_flags)); } |]
427426

428427

429428
evalRaw :: JSContextPtr -> JSEvalType -> ByteString -> IO JSValue
430-
evalRaw ctx eTyp code =
429+
evalRaw ctx eTyp code =
431430
useAsCString "script.js" $ \cfilename ->
432-
useAsCStringLen code $ \(ccode, ccode_len) ->
431+
useAsCStringLen code $ \(ccode, ccode_len) ->
433432
jsEval ctx ccode (fromIntegral ccode_len) cfilename (toCType eTyp)
434433

435434

@@ -460,7 +459,7 @@ evalAs_ eTyp code = do
460459

461460

462461
{-|
463-
More efficient than 'eval' if we don't care about the value of the expression,
462+
More efficient than 'eval' if we don't care about the value of the expression,
464463
e.g. if we are evaluating a function definition or performing other side-effects such as
465464
printing to console/modifying state.
466465
-}
@@ -511,7 +510,7 @@ callRaw ctxPtr funName args = do
511510
ty <- jsIs ctxPtr fun
512511
case ty of
513512
JSTypeFromTag JSTagException -> do
514-
err <- getErrorMessage ctxPtr
513+
err <- getErrorMessage ctxPtr
515514
liftIO $ jsFreeValue ctxPtr fun
516515
throwM $ JSException "callRaw" err
517516
JSTypeFromTag JSTagUndefined -> throwM $ JSValueUndefined $ toS funName
@@ -573,7 +572,7 @@ quickjs f = do
573572
_rt <- jsNewRuntime
574573
_ctx <- jsNewContext _rt
575574

576-
[C.block| void {
575+
[C.block| void {
577576
js_std_add_helpers($(JSContext *_ctx), -1, NULL);
578577
} |]
579578
return (_rt, _ctx)
@@ -595,15 +594,15 @@ This problem does not occur when running via Main.hs, if compiled as single thre
595594
For more info see the paper [Extending the Haskell Foreign Function Interface with Concurrency](https://simonmar.github.io/bib/papers/conc-ffi.pdf)
596595
-}
597596
quickjsMultithreaded :: MonadUnliftIO m => ReaderT (Ptr JSContext) m b -> m b
598-
quickjsMultithreaded f
597+
quickjsMultithreaded f
599598
| rtsSupportsBoundThreads = do
600599
(u :: UnliftIO m) <- askUnliftIO
601-
600+
602601
liftIO $ runInBoundThread $ do
603602
rt <- jsNewRuntime
604603
ctx <- jsNewContext rt
605604

606-
[C.block| void {
605+
[C.block| void {
607606
js_std_add_helpers($(JSContext *ctx), -1, NULL);
608607
} |]
609608

@@ -615,4 +614,3 @@ quickjsMultithreaded f
615614
cleanup ctx rt = do
616615
jsFreeContext ctx
617616
jsFreeRuntime rt
618-

0 commit comments

Comments
 (0)