diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/hslua-aeson.cabal b/hslua-aeson.cabal --- a/hslua-aeson.cabal +++ b/hslua-aeson.cabal @@ -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 diff --git a/src/HsLua/Aeson.hs b/src/HsLua/Aeson.hs --- a/src/HsLua/Aeson.hs +++ b/src/HsLua/Aeson.hs @@ -4,218 +4,116 @@ License : MIT Maintainer : Albert Krewinkel -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 diff --git a/test/test-hslua-aeson.hs b/test/test-hslua-aeson.hs --- a/test/test-hslua-aeson.hs +++ b/test/test-hslua-aeson.hs @@ -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