hslua-aeson 2.0.1 → 2.1.0

raw patch · 5 files changed

+163/−295 lines, 5 filesdep −ieee754dep −tasty-hunitdep ~hslua-coredep ~hslua-marshallingdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies removed: ieee754, tasty-hunit

Dependency ranges changed: hslua-core, hslua-marshalling, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +28/−0
• README.md +14/−19
• hslua-aeson.cabal +11/−10
• src/HsLua/Aeson.hs +77/−179
• test/test-hslua-aeson.hs +33/−87

@@ -2,6 +2,34 @@  `hslua-aeson` uses [PVP Versioning][]. +## hslua-aeson-2.1.0++Released 29-01-2022.++-   Update to hslua 2.1.++-   Encode `null` as light userdata: The `NULL` pointer wrapped+    into a light userdata is used to encode the JSON null value.++    The `pushNull` function has been removed; use+    `pushValue Null` instead.++-   Types that are instances of `ToJSON` and `FromJSON` can be+    marshalled/unmarshalled by using the new functions+    `pushViaJSON` and `peekViaJSON`, respectively.++-   The functions `peekVector`, `pushVector`, `peekScientific`,+    `pushScientific`, `peekKeyMap`, and `pushKeyMap` are+    considered an implementation detail and are no longer+    exported.++-   Array elements are now marked with a metatable. This avoids+    the need for an extra `0` element in the table and offers+    flexibility for users who want to give special behavior to+    lists. The newly exported value `jsonarray` contains the name+    of the registry slot under which the metatable is stored. The+    table can be modified or replaced as required.+ ## hslua-aeson-2.0.1  Released 2021-12-28.

@@ -1,34 +1,29 @@ hslua-aeson =========== -[![travis build status]](https://travis-ci.org/hslua/hslua-aeson) [![MIT License]](./LICENSE) --Glue to hslua for aeson values.--This provides a `StackValue` instance for aeson's `Value` type. The following-conventions are used:+Pushes and retrieves aeson `Value`s to and from the Lua stack. -- `Null` values are encoded as a special value (stored in the registry field-  `HSLUA_AESON_NULL`). Using `nil` would cause problems with null-containing-  arrays.+- `Null` values are encoded as light userdata containing the+  @NULL@ pointer. -- Objects are converted to tables in a straight-forward way.+- Objects are converted to string-indexed tables. -- Arrays are converted to Lua tables. Array-length is included as the value at-  index 0. This makes it possible to distinguish between empty arrays and empty-  objects.+- Arrays are converted to sequence tables and are given a+  metatable. This makes it possible to distinguish between empty+  arrays and empty objects. The metatable is stored in the+  registry under key `HsLua JSON array`. -- JSON numbers are converted to Lua numbers (usually doubles), which can cause-  a loss of precision.+- JSON numbers are converted to Lua numbers, i.e., `Lua.Number`;+  the exact C type may vary, depending on compile-time Lua+  configuration.  License ------- -This project is licensed under the liberal MIT license, the same license under-which hslua and lua itself are published. See the [LICENSE](./LICENSE) file for-details.+This project is licensed under the MIT license, the same license+under which hslua and lua itself are published. See the+[LICENSE](./LICENSE) file for details. -[travis build status]: https://img.shields.io/travis/hslua/hslua-aeson/master.svg?style=flat-square [MIT License]: https://img.shields.io/github/license/hslua/hslua-aeson.svg?style=flat-square

@@ -1,10 +1,10 @@ cabal-version:       2.2 name:                hslua-aeson-version:             2.0.1-synopsis:            Allow aeson data types to be used with lua.+version:             2.1.0+synopsis:            Allow aeson data types to be used with Lua. description:         This package provides instances to push and receive any                      datatype encodable as JSON to and from the Lua stack.-homepage:            https://github.com/tarleb/hslua-aeson#readme+homepage:            https://hslua.org/ license:             MIT license-file:        LICENSE author:              Albert Krewinkel@@ -19,10 +19,13 @@                    , GHC == 8.6.5                    , GHC == 8.8.4                    , GHC == 8.10.7+                   , GHC == 9.0.1+                   , GHC == 9.2.1  source-repository head-  type:     git-  location: https://github.com/hslua/hslua-aeson+  type:                git+  location:            https://github.com/hslua/hslua+  subdir:              hslua-aeson  common common-options   default-language:    Haskell2010@@ -31,12 +34,12 @@                      , bytestring           >= 0.10.2 && < 0.12                      , containers           >= 0.5.9  && < 0.7                      , hashable             >= 1.2    && < 1.5-                     , hslua-core           >= 2.0    && < 2.1-                     , hslua-marshalling    >= 2.0    && < 2.1+                     , hslua-core           >= 2.0    && < 2.2+                     , hslua-marshalling    >= 2.1    && < 2.2                      , mtl                  >= 2.2    && < 2.3                      , scientific           >= 0.3    && < 0.4                      , unordered-containers >= 0.2    && < 0.3-                     , text                 >= 1.0    && < 1.3+                     , text                 >= 1.2    && < 2.1                      , vector               >= 0.7   default-extensions:  BangPatterns                      , CPP@@ -70,10 +73,8 @@   hs-source-dirs:      test   build-depends:       hslua-aeson                      , QuickCheck-                     , ieee754                      , quickcheck-instances                      , tasty                >= 0.11-                     , tasty-hunit          >= 0.9                      , tasty-quickcheck     >= 0.8   ghc-options:         -threaded   default-language:    Haskell2010

@@ -4,218 +4,116 @@ License     :  MIT Maintainer  :  Albert Krewinkel <tarleb@zeitkraut.de> -Glue to HsLua for aeson values.--This provides a @StackValue@ instance for aeson's @Value@ type. The following-conventions are used:+Pushes and retrieves aeson `Value`s to and from the Lua stack. -- @Null@ values are encoded as a special value (stored in the registry field-  @HSLUA_AESON_NULL@). Using @nil@ would cause problems with null-containing-  arrays.+- JSON @null@ values are encoded as light userdata containing the+  @NULL@ pointer. -- Objects are converted to tables in a straight-forward way.+- Objects are converted to string-indexed tables. -- Arrays are converted to Lua tables. Array-length is included as the value at-  index 0. This makes it possible to distinguish between empty arrays and empty-  objects.+- Arrays are converted to sequence tables and are given a+  metatable. This makes it possible to distinguish between empty+  arrays and empty objects. The metatable is stored in the+  registry under key @\'HsLua JSON array\'@' (see also+  'jsonarray'). -- JSON numbers are converted to Lua numbers (usually doubles), which can cause-  a loss of precision.+- JSON numbers are converted to Lua numbers, i.e., 'Lua.Number';+  the exact C type may vary, depending on compile-time Lua+  configuration. -} module HsLua.Aeson   ( peekValue   , pushValue-  , peekVector-  , pushVector-  , pushNull-  , peekScientific-  , pushScientific-  , peekKeyMap-  , pushKeyMap+  , peekViaJSON+  , pushViaJSON   ) where -import Control.Monad ((<$!>), when)-import Data.Scientific (Scientific, toRealFloat, fromFloatDigits)-import Data.String (IsString (fromString))-import Data.Vector (Vector)+import Control.Monad ((<$!>), void)+import Data.Scientific (toRealFloat, fromFloatDigits)+import Foreign.Ptr (nullPtr) import HsLua.Core as Lua import HsLua.Marshalling as Lua  import qualified Data.Aeson as Aeson+import qualified Data.ByteString as B import qualified Data.Vector as Vector-import qualified HsLua.Core.Unsafe as Unsafe+import qualified HsLua.Core.Utf8 as UTF8  #if MIN_VERSION_aeson(2,0,0)-import Data.Aeson.Key (Key, toText, fromText)+import Data.Aeson.Key (toText, fromText) import qualified Data.Aeson.KeyMap as KeyMap-type KeyMap = KeyMap.KeyMap #else import Data.Text (Text) import qualified Data.HashMap.Strict as KeyMap-type Key = Text-type KeyMap = KeyMap.HashMap Key-toText :: Key -> Text++toText, fromText :: Text -> Text toText = id-fromText :: Text -> Key fromText = id #endif --- Scientific-pushScientific :: Pusher e Scientific-pushScientific = pushRealFloat @Double . toRealFloat--peekScientific :: Peeker e Scientific-peekScientific idx = fromFloatDigits <$!> peekRealFloat @Double idx- -- | Hslua StackValue instance for the Aeson Value data type. pushValue :: LuaError e => Pusher e Aeson.Value-pushValue = \case-  Aeson.Object o -> pushKeyMap pushValue o-  Aeson.Number n -> checkstack 1 >>= \case-    True -> pushScientific n-    False -> failLua "stack overflow"-  Aeson.String s -> checkstack 1 >>= \case-    True -> pushText s-    False -> failLua "stack overflow"-  Aeson.Array a  -> pushVector pushValue a-  Aeson.Bool b   -> checkstack 1 >>= \case-    True -> pushBool b-    False -> failLua "stack overflow"-  Aeson.Null     -> pushNull+pushValue val = do+  checkstack' 1 "HsLua.Aeson.pushValue"+  case val of+    Aeson.Object o -> pushKeyValuePairs pushKey pushValue $ KeyMap.toList o+    Aeson.Number n -> pushRealFloat @Double $ toRealFloat n+    Aeson.String s -> pushText s+    Aeson.Array a  -> pushArray a+    Aeson.Bool b   -> pushBool b+    Aeson.Null     -> pushlightuserdata nullPtr+ where+  pushKey = pushText . toText+  pushArray x = do+    checkstack' 4 "HsLua.Aeson.pushVector"+    pushList pushValue $ Vector.toList x+    void $ newmetatable jsonarray+    setmetatable (nth 2) +-- | Name of the registry slot holding the metatable given to+-- array tables. The registry entry can be replaced with a+-- different table if needed.+jsonarray :: Name+jsonarray = "HsLua JSON array"++-- | Retrieves an Aeson 'Aeson.Value' from the Lua stack. peekValue :: LuaError e => Peeker e Aeson.Value peekValue idx = liftLua (ltype idx) >>= \case   TypeBoolean -> Aeson.Bool  <$!> peekBool idx-  TypeNumber -> Aeson.Number <$!> peekScientific idx+  TypeNumber -> Aeson.Number . fromFloatDigits <$!> peekRealFloat @Double idx   TypeString -> Aeson.String <$!> peekText idx-  TypeTable -> liftLua (checkstack 1) >>= \case-    False -> failPeek "stack overflow"-    True -> do-      isInt <- liftLua $ rawgeti idx 0 *> isinteger top <* pop 1-      if isInt-        then Aeson.Array <$!> peekVector peekValue idx-        else do-          rawlen' <- liftLua $ rawlen idx-          if rawlen' > 0-            then Aeson.Array <$!> peekVector peekValue idx-            else do-              isNull' <- liftLua $ isNull idx-              if isNull'-                then return Aeson.Null-                else Aeson.Object <$!> peekKeyMap peekValue idx+  TypeLightUserdata -> liftLua (touserdata idx) >>= \case+    -- must be the null pointer+    Nothing -> pure Aeson.Null+    _       -> typeMismatchMessage "null" idx >>= failPeek   TypeNil -> return Aeson.Null+  TypeTable -> do+      liftLua $ checkstack' 2 "HsLua.Aeson.peekValue"+      let peekKey = fmap fromText . peekText+          peekArray = Aeson.Array . Vector.fromList <$!>+            (retrieving "vector" $! peekList peekValue idx)+          isarray = getmetatable idx >>= \case+            False ->+              -- check for nonempty sequence+              (/= TypeNil) <$> rawgeti idx 1 <* pop 1+            True  -> getmetatable' jsonarray >>= \case+              TypeTable -> rawequal (nth 1) (nth 2) <* pop 2+              _         -> pure False+      liftLua isarray >>= \case+        True  -> peekArray+        False -> Aeson.Object . KeyMap.fromList <$!>+                 peekKeyValuePairs peekKey peekValue idx   luaType -> fail ("Unexpected type: " ++ show luaType) --- | Registry key containing the representation for JSON null values.-nullRegistryField :: Name-nullRegistryField = "HSLUA_AESON_NULL"---- | Push the value which represents JSON null values to the stack (a specific--- empty table by default). Internally, this uses the contents of the--- @HSLUA_AESON_NULL@ registry field; modifying this field is possible, but it--- must always be non-nil.-pushNull :: LuaError e => LuaE e ()-pushNull = checkstack 3 >>= \case-  False -> failLua "stack overflow while pushing null"-  True -> do-    pushName nullRegistryField-    rawget registryindex-    uninitialized <- isnil top-    when uninitialized $ do-      pop 1 -- remove nil-      newtable-      pushvalue top-      setfield registryindex nullRegistryField---- | Check if the value under the given index represents a @null@ value.-isNull :: LuaError e => StackIndex -> LuaE e Bool-isNull idx = do-  idx' <- absindex idx-  pushNull-  rawequal idx' top <* pop 1---- | Push a vector onto the stack.-pushVector :: LuaError e-           => Pusher e a-           -> Pusher e (Vector a)-pushVector pushItem !v = do-  checkstack 3 >>= \case-    False -> failLua "stack overflow"-    True -> do-      pushList pushItem $ Vector.toList v-      pushIntegral (Vector.length v)-      rawseti (nth 2) 0---- | Try reading the value under the given index as a vector.-peekVector :: LuaError e-           => Peeker e a-           -> Peeker e (Vector a)-peekVector peekItem = fmap (retrieving "list") .-  typeChecked "table" istable $ \idx -> do-  let elementsAt [] = return []-      elementsAt (i : is) = do-        liftLua (checkstack 2) >>= \case-          False -> failPeek "Lua stack overflow"-          True  -> do-            x  <- retrieving ("index " <> showInt i) $ do-              liftLua (rawgeti idx i)-              peekItem top `lastly` pop 1-            xs <- elementsAt is-            return (x:xs)-      showInt (Lua.Integer x) = fromString $ show x-  listLength <- liftLua (rawlen idx)-  list <- elementsAt [1..fromIntegral listLength]-  return $! Vector.fromList list---- | Pushes a 'KeyMap' onto the stack.-pushKeyMap :: LuaError e-           => Pusher e a-           -> Pusher e (KeyMap a)-pushKeyMap pushVal x =-  checkstack 3 >>= \case-    True -> pushKeyValuePairs pushKey pushVal $ KeyMap.toList x-    False -> failLua "stack overflow"---- | Retrieves a 'KeyMap' from a Lua table.-peekKeyMap :: Peeker e a-           -> Peeker e (KeyMap a)-peekKeyMap peekVal =-  typeChecked "table" istable $ \idx -> cleanup $ do-  liftLua (checkstack 1) >>= \case-    False -> failPeek "Lua stack overflow"-    True -> do-      idx' <- liftLua $ absindex idx-      let remainingPairs = nextPair peekVal idx' >>= \case-            Nothing -> return []-            Just a  -> (a:) <$!> remainingPairs-      liftLua pushnil-      KeyMap.fromList <$!> remainingPairs---- | Pushes a JSON key to the stack.-pushKey :: Pusher e Key-pushKey = pushText . toText---- | Retrieves a JSON key from the stack.-peekKey :: Peeker e Key-peekKey = fmap fromText . peekText+-- | Retrieves a value from the Lua stack via JSON.+peekViaJSON :: (Aeson.FromJSON a, LuaError e) => Peeker e a+peekViaJSON idx = do+  value <- peekValue idx+  case Aeson.fromJSON value of+    Aeson.Success x -> pure x+    Aeson.Error msg -> failPeek $ "failed to decode: " `B.append`+                       UTF8.fromString msg --- | Get the next key-value pair from a table. Assumes the last--- key to be on the top of the stack and the table at the given--- index @idx@. The next key, if it exists, is left at the top of--- the stack.------ The key must be either nil or must exist in the table, or this--- function will crash with an unrecoverable error.-nextPair :: Peeker e b -> Peeker e (Maybe (Key, b))-nextPair peekVal idx = retrieving "key-value pair" $ do-  liftLua (checkstack 1) >>= \case-    False -> failPeek "Lua stack overflow"-    True -> do-      hasNext <- liftLua $ Unsafe.next idx-      if not hasNext-        then return Nothing-        else do-        key   <- retrieving "key"   $! peekKey (nth 2)-        value <- retrieving "value" $! peekVal (nth 1)-        return (Just (key, value))-          `lastly` pop 1  -- remove value, leave the key+-- | Pushes a value to the Lua stack as a JSON-like value.+pushViaJSON :: (Aeson.ToJSON a, LuaError e) => Pusher e a+pushViaJSON = pushValue . Aeson.toJSON

@@ -6,15 +6,12 @@ Tests for Aeson–Lua glue. -} import Control.Monad (when)-import Data.AEq ((~==))-import Data.ByteString (ByteString)-import Data.Scientific (Scientific, toRealFloat, fromFloatDigits)+import Data.Text (Text) import HsLua.Core as Lua import HsLua.Marshalling import HsLua.Aeson import Test.QuickCheck.Monadic (assert) import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.HUnit ((@?=), (@?), testCase) import Test.Tasty.QuickCheck import Test.QuickCheck.Instances () @@ -23,9 +20,13 @@ import qualified Test.QuickCheck.Monadic as QC  #if MIN_VERSION_aeson(2,0,0)-import Data.Aeson.Key (Key, fromText) import qualified Data.Aeson.KeyMap as KeyMap+#if !MIN_VERSION_aeson(2,0,3)+import Data.Aeson.Key (Key, fromText)+import Data.Scientific (Scientific, fromFloatDigits)+#endif #else+import Data.Scientific (Scientific, fromFloatDigits) import qualified Data.HashMap.Strict as KeyMap #endif @@ -37,27 +38,13 @@ -- | Aeson tests tests :: TestTree tests = testGroup "hslua-aeson"-  [ testGroup "pushNull"-    [ testCase "pushes a value that is recognized as null when peeked" $ do-        val <- run @Lua.Exception (pushNull *> forcePeek (peekValue top))-        val @?= Aeson.Null-    , testCase "pushes a non-nil value" $ do-        nil <- run @Lua.Exception (pushNull *> isnil top)-        not nil @? "not of type `nil`"-    , testCase "pushes a single value" $ do-        diff <- run $ stackDiff pushNull-        diff @?= 1-    , testCase "pushes two values when called twice" $ do-        diff <- run $ stackDiff (pushNull *> pushNull)-        diff @?= 2-    ]-  , testGroup "Value"+  [ testGroup "Value"     [ testProperty "can be round-tripped through the stack" $       assertRoundtripEqual pushValue peekValue     , testProperty "can roundtrip a bool nested in 50 layers of arrays" $       \b -> QC.monadicIO $ do         let go _ x = Aeson.Array $ Vector.fromList [x]-            mkValue a = foldr go (Aeson.Bool a) [ (1::Int) .. 50]+            mkValue a = foldr go (Aeson.Bool a) [(1::Int) .. 50]         x <- QC.run . run @Lua.Exception $ do           pushValue $ mkValue b           forcePeek $ peekValue top@@ -65,63 +52,31 @@     , testProperty "can roundtrip a bool nested in 50 layers of objects" $       \b -> QC.monadicIO $ do         let go _ x = Aeson.Object $ KeyMap.fromList [("x", x)]-            mkValue a = foldr go (Aeson.Bool a) [ (1::Int) .. 50]+            mkValue a = foldr go (Aeson.Bool a) [(1::Int) .. 50]         x <- QC.run . run @Lua.Exception $ do           pushValue $ mkValue b           forcePeek $ peekValue top         return (x === mkValue b)+    , testProperty "can roundtrip a null nested in 50 layers of objects" $+      \() -> QC.monadicIO $ do+        let go _ x = Aeson.Object $ KeyMap.fromList [("x", x)]+            mkValue = foldr go Aeson.Null [(1::Int) .. 50]+        x <- QC.run . run @Lua.Exception $ do+          pushValue mkValue+          forcePeek $ peekValue top+        return (x === mkValue)     ] -  , testGroup "Value component"-    [ testGroup "Scientific"-      [ testProperty "is converted to a Lua number" $ \x ->-          luaTest "type(x) == 'number'" ("x", x, pushScientific)-      , testProperty "double precision numbers can be round-tripped" $ \x ->-          assertRoundtripEqual pushScientific peekScientific-                               (luaNumberToScientific (Lua.Number x))-      , testProperty "can be round-tripped and stays approximately equal"-          assertRoundtripApprox-      ]-    , testGroup "Vector"-      [ testProperty "is converted to a Lua table" $ \x ->-          luaTest "type(x) == 'table'" ("x", x, pushVector pushBool)-      , testProperty "can contain Bools and be round-tripped"  $-          assertRoundtripEqual (pushVector pushBool) (peekVector peekBool)-      , testProperty "can contain Text and be round-tripped" $-          assertRoundtripEqual (pushVector pushText) (peekVector peekText)-      , testProperty "can contain Aeson.Value and be round-tripped" $-          assertRoundtripEqual (pushVector pushValue)-                               (peekVector peekValue)-      ]-    , testGroup "KeyMap"-      [ testProperty "is converted to a Lua table"  $ \x ->-        luaTest "type(x) == 'table'" ("x", x, pushKeyMap pushText)-      , testProperty "can be round-tripped with Bool values" $-          assertRoundtripEqual (pushKeyMap pushBool)-                               (peekKeyMap peekBool)-          . KeyMap.fromList-      , testProperty "can be round-tripped with Text values" $-          assertRoundtripEqual (pushKeyMap pushText)-                               (peekKeyMap peekText)-          . KeyMap.fromList-      , testProperty "can be round-tripped with Aeson.Value values"  $-          assertRoundtripEqual (pushKeyMap pushValue)-                               (peekKeyMap peekValue)-          . KeyMap.fromList-      ]+  , testGroup "via JSON"+    [ testProperty "can roundtrip 'Maybe Text' via JSON" $+      assertRoundtripEqual @(Maybe Int) pushViaJSON peekViaJSON+    , testProperty "can roundtrip '(Int, Float)' via JSON" $+      assertRoundtripEqual @(Int, Float) pushViaJSON peekViaJSON+    , testProperty "can roundtrip 'Either Bool Text' via JSON" $+      assertRoundtripEqual @(Either Bool Text) pushViaJSON peekViaJSON     ]   ] -assertRoundtripApprox :: Scientific -> Property-assertRoundtripApprox x = QC.monadicIO $ do-  y <- QC.run $-       roundtrip (pushScientific @Lua.Exception)-                 (peekScientific @Lua.Exception)-                 x-  let xdouble = toRealFloat x :: Double-  let ydouble = toRealFloat y :: Double-  assert (xdouble ~== ydouble)- assertRoundtripEqual :: Eq a                      => Pusher Lua.Exception a -> Peeker Lua.Exception a                      -> a -> Property@@ -135,29 +90,19 @@   size <- gettop   when (size /= 1) $     failLua $ "not the right amount of elements on the stack: " ++ show size-  forcePeek $ peekX top--stackDiff :: Lua a -> Lua StackIndex-stackDiff op = do-  topBefore <- gettop-  _ <- op-  topAfter <- gettop-  return (topAfter - topBefore)--luaTest :: ByteString -> (Name, a, Pusher Lua.Exception a) -> Property-luaTest luaProperty (var, val, pushVal) = QC.monadicIO $ do-  result <- QC.run . run $ do-    openlibs-    pushVal val *> setglobal var-    _ <- dostring $ "return (" <> luaProperty <> ")"-    toboolean top-  assert result+  result <- forcePeek $ peekX top+  afterPeekSize <- gettop+  when (afterPeekSize /= 1) $+    failLua $ "peeking modified the stack: " ++ show afterPeekSize+  return result +-- aeson defines instances for Arbitrary since 2.0.3.0+#if !MIN_VERSION_aeson(2,0,3) luaNumberToScientific :: Lua.Number -> Scientific luaNumberToScientific = fromFloatDigits . (realToFrac :: Lua.Number -> Double)  instance Arbitrary Aeson.Value where-  arbitrary = arbitraryValue 5+  arbitrary = arbitraryValue 9  #if MIN_VERSION_aeson(2,0,0) instance Arbitrary Key where@@ -180,3 +125,4 @@     , (2, resize (size - 1) $ Aeson.Array <$> arbitrary)     , (2, resize (size - 1) $ Aeson.Object <$> arbitrary)     ]+#endif