diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,86 @@ +# Changelog + +`hslua-aeson` uses [PVP Versioning][]. + +## hslua-aeson-2.0.0 + +Released 2021-12-17. + +- Changed module name from `Foreign.Lua.Aeson` to + `HsLua.Aeson`. + +- The Peekable and Pushable instances have been removed. The + package no longer defines orphaned instances. + +- Updated hslua and aeson to the respective 2.0 version. + +## hslua-aeson-1.0.3.1 + +Released 2020-10-16. + +- Allow hslua-1.3.\*. + +## hslua-aeson-1.0.3 + +Released 2020-08-15. + +- Relaxed version constraint for hslua, allowing `hslua-1.2.*`. + +## hslua-aeson-1.0.2 + +Released 2020-05-28 + +- Relaxed version constraint for aeson, allowing `aeson-1.5.*`. + +- Update CI tests to check with GHC versions 8.0 through 8.10. + Compilation with GHC 7.10 is no longer tested. + +- Bump to stackage LTS-14. + +## hslua-aeson-1.0.1 + +Released 2020-04-03 + +- Relax version constraint for packages hashable and hslua, + allow `hashable-1.3` and `hslua-1.1.*`. + +## hslua-aeson-1.0.0 + +Released 2019-09-24. + +- Update to hslua 1.0.0 + +- Function `registerNull` has been replaced by `pushNull`. + + Using `pushNull` has the advantage that users won’t have to + remember to register a special variable. Users who need a + global variable can set it by running + + pushNull + setglobal "HSLUA_AESON_NULL" + +## hslua-aeson-0.3.0 + +Released 2017-08-18. + +- Update to hslua 0.8.0. + +## hslua-aeson-0.2.0 + +Not publicly released. + +- Update to hslua 0.6.0. + +## hslua-aeson-0.1.0.4 + +Released 2017-04-17. + +- Ensure compatibility with hslua 0.5.0. + +## hslua-aeson-0.1.0.0 + +Released 2017-02-03. + +- Initial release. + + [PVP Versioning]: https://pvp.haskell.org diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/changelog.md b/changelog.md deleted file mode 100644 --- a/changelog.md +++ /dev/null @@ -1,59 +0,0 @@ -# hslua-aeson - -## v1.0.3.1 - -Released 2020-10-16. - -- Allow hslua-1.3.*. - -## v1.0.3 - -Released 2020-08-15. - -- Relaxed version constraint for hslua, allowing `hslua-1.2.*`. - -## v1.0.2 - -Released 2020-05-28 - -- Relaxed version constraint for aeson, allowing `aeson-1.5.*`. - -- Update CI tests to check with GHC versions 8.0 through 8.10. - Compilation with GHC 7.10 is no longer tested. - -- Bump to stackage LTS-14. - -## v1.0.1 - -Released 2020-04-03 - -- Relax version constraint for packages hashable and hslua, allow - `hashable-1.3` and `hslua-1.1.*`. - -## v1.0.0 - -- Update to hslua 1.0.0 - -- Function `registerNull` has been replaced by `pushNull`. - - Using `pushNull` has the advantage that users won't have to remember - to register a special variable. Users who need a global variable can - set it by running - - pushNull - setglobal "HSLUA_AESON_NULL" - - -## v0.3.0 - -- Update to hslua 0.8.0. - - -## v0.2.0 - -- Update to hslua 0.6.0. - - -## v0.1.0.4 - -- Ensure compatibility with hslua 0.5.0. diff --git a/hslua-aeson.cabal b/hslua-aeson.cabal --- a/hslua-aeson.cabal +++ b/hslua-aeson.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hslua-aeson -version: 1.0.3.1 +version: 2.0.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. @@ -8,55 +8,71 @@ license: MIT license-file: LICENSE author: Albert Krewinkel -maintainer: tarleb+hslua@zeitkraut.de -copyright: © 2017–2020 Albert Krewinkel +maintainer: Albert Krewinkel +copyright: © 2017–2021 Albert Krewinkel category: Foreign -build-type: Simple extra-source-files: README.md - changelog.md + , CHANGELOG.md tested-with: GHC == 8.0.2 , GHC == 8.2.2 - , GHC == 8.4.3 + , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.3 - , GHC == 8.10.1 + , GHC == 8.8.4 + , GHC == 8.10.7 source-repository head type: git location: https://github.com/hslua/hslua-aeson +common common-options + default-language: Haskell2010 + build-depends: base >= 4.8 && < 5 + , aeson >= 2.0 && < 2.1 + , 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 + , mtl >= 2.2 && < 2.3 + , scientific >= 0.3 && < 0.4 + , unordered-containers >= 0.2 && < 0.3 + , text >= 1.0 && < 1.3 + , vector >= 0.7 + default-extensions: BangPatterns + , LambdaCase + , OverloadedStrings + , TypeApplications + ghc-options: -Wall + -Wincomplete-record-updates + -Wnoncanonical-monad-instances + -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -Wcpp-undef + -Werror=missing-home-modules + if impl(ghc >= 8.4) + ghc-options: -Widentities + -Wincomplete-uni-patterns + -Wpartial-fields + -fhide-source-paths + library + import: common-options + exposed-modules: HsLua.Aeson hs-source-dirs: src - exposed-modules: Foreign.Lua.Aeson - build-depends: base >= 4.7 && < 5 - , aeson >= 0.11 && < 1.6 - , hashable >= 1.2 && < 1.4 - , hslua >= 1.0 && < 1.1.1 || >= 1.1.2 && < 1.4 - , scientific >= 0.3 && < 0.4 - , text >= 1.1.1.0 && < 1.3 - , unordered-containers >= 0.2 && < 0.3 - , vector >= 0.7 + build-depends: base >= 4.7 && < 5 default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-do-bind -test-suite hslua-aeson-test +test-suite test-hslua-aeson + import: common-options type: exitcode-stdio-1.0 + main-is: test-hslua-aeson.hs hs-source-dirs: test - main-is: AesonSpec.hs - build-depends: base - , aeson - , bytestring >= 0.10.2 && < 0.11 - , hspec >= 2.2 - , HUnit + build-depends: hslua-aeson , QuickCheck - , quickcheck-instances - , hashable - , hslua - , hslua-aeson , ieee754 - , scientific - , text - , unordered-containers - , vector - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + , quickcheck-instances + , tasty >= 0.11 + , tasty-hunit >= 0.9 + , tasty-quickcheck >= 0.8 + ghc-options: -threaded default-language: Haskell2010 diff --git a/src/Foreign/Lua/Aeson.hs b/src/Foreign/Lua/Aeson.hs deleted file mode 100644 --- a/src/Foreign/Lua/Aeson.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE LambdaCase #-} -{-| -Module : Foreign.Lua.Aeson -Copyright : © 2017–2020 Albert Krewinkel -License : MIT - -Maintainer : Albert Krewinkel -Stability : experimental -Portability : portable - -Glue to hslua for aeson values. - -This provides a @StackValue@ instance for aeson's @Value@ type. The following -conventions are used: - -- @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. - -- Objects are converted to tables in a straight-forward way. - -- 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. - -- JSON numbers are converted to Lua numbers (usually doubles), which can cause - a loss of precision. --} -module Foreign.Lua.Aeson - ( pushNull - ) where - -import Control.Monad (when) -import Data.HashMap.Lazy (HashMap) -import Data.Hashable (Hashable) -import Data.Scientific (Scientific, toRealFloat, fromFloatDigits) -import Data.Vector (Vector, fromList, toList) -import Foreign.Lua as Lua - -import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.Vector as Vector - --- Scientific -instance Pushable Scientific where - push = pushnumber . toRealFloat - -instance Peekable Scientific where - peek = fmap (fromFloatDigits :: Lua.Number -> Scientific) . peek - --- Vector -instance (Pushable a) => Pushable (Vector a) where - push = pushvector - -instance (Peekable a) => Peekable (Vector a) where - peek = tovector - --- HashMap -instance (Eq a, Hashable a, Pushable a, Pushable b) - => Pushable (HashMap a b) where - push = pushTextHashMap - -instance (Eq a, Hashable a, Peekable a, Peekable b) - => Peekable (HashMap a b) where - peek = fmap HashMap.fromList . peekKeyValuePairs - --- | Hslua StackValue instance for the Aeson Value data type. -instance Pushable Aeson.Value where - push = \case - Aeson.Object o -> push o - Aeson.Number n -> push n - Aeson.String s -> push s - Aeson.Array a -> push a - Aeson.Bool b -> push b - Aeson.Null -> pushNull - -instance Peekable Aeson.Value where - peek idx = - ltype idx >>= \case - TypeBoolean -> Aeson.Bool <$> peek idx - TypeNumber -> Aeson.Number <$> peek idx - TypeString -> Aeson.String <$> peek idx - TypeTable -> do - rawgeti idx 0 - isInt <- isinteger stackTop - pop 1 - if isInt - then Aeson.Array <$> peek idx - else do - rawlen' <- rawlen idx - if rawlen' > 0 - then Aeson.Array <$> peek idx - else do - isNull' <- isNull idx - if isNull' - then return Aeson.Null - else Aeson.Object <$> peek idx - TypeNil -> return Aeson.Null - luaType -> Lua.throwException ("Unexpected type: " ++ show luaType) - --- | Registry key containing the representation for JSON null values. -nullRegistryField :: String -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 :: Lua () -pushNull = do - push nullRegistryField - rawget registryindex - uninitialized <- isnil stackTop - when uninitialized $ do - pop 1 -- remove nil - newtable - pushvalue stackTop - setfield registryindex nullRegistryField - --- | Check if the value under the given index represents a @null@ value. -isNull :: StackIndex -> Lua Bool -isNull idx = do - idx' <- absindex idx - pushNull - rawequal idx' stackTop <* pop 1 - --- | Push a vector unto the stack. -pushvector :: Pushable a => Vector a -> Lua () -pushvector v = do - pushList . toList $ v - push (fromIntegral (Vector.length v) :: Lua.Integer) - rawseti (-2) 0 - --- | Try reading the value under the given index as a vector. -tovector :: Peekable a => StackIndex -> Lua (Vector a) -tovector = fmap fromList . Lua.peekList - --- | Push a hashmap unto the stack. -pushTextHashMap :: (Pushable a, Pushable b) => HashMap a b -> Lua () -pushTextHashMap hm = do - let addValue (k, v) = push k *> push v *> rawset (-3) - newtable - mapM_ addValue (HashMap.toList hm) diff --git a/src/HsLua/Aeson.hs b/src/HsLua/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/HsLua/Aeson.hs @@ -0,0 +1,209 @@ +{-| +Module : HsLua.Aeson +Copyright : © 2017–2021 Albert Krewinkel +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: + +- @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. + +- Objects are converted to tables in a straight-forward way. + +- 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. + +- JSON numbers are converted to Lua numbers (usually doubles), which can cause + a loss of precision. +-} +module HsLua.Aeson + ( peekValue + , pushValue + , peekVector + , pushVector + , pushNull + , peekScientific + , pushScientific + , peekKeyMap + , pushKeyMap + ) where + +import Control.Monad ((<$!>), when) +import Data.Aeson.Key (Key, toText, fromText) +import Data.Aeson.KeyMap +import Data.Scientific (Scientific, toRealFloat, fromFloatDigits) +import Data.String (IsString (fromString)) +import Data.Vector (Vector) +import HsLua.Core as Lua +import HsLua.Marshalling as Lua + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Vector as Vector +import qualified HsLua.Core.Unsafe as Unsafe + +-- 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 + +peekValue :: LuaError e => Peeker e Aeson.Value +peekValue idx = liftLua (ltype idx) >>= \case + TypeBoolean -> Aeson.Bool <$!> peekBool idx + TypeNumber -> Aeson.Number <$!> peekScientific 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 + TypeNil -> return Aeson.Null + 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 + +-- | 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 diff --git a/test/AesonSpec.hs b/test/AesonSpec.hs deleted file mode 100644 --- a/test/AesonSpec.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-| -Copyright : © 2017–2020 Albert Krewinkel -License : MIT - -Tests for Aeson–Lua glue. --} -import Control.Monad (forM_, when) -import Data.AEq ((~==)) -import Data.HashMap.Lazy (HashMap) -import Data.Scientific (Scientific, toRealFloat, fromFloatDigits) -import Data.Text (Text) -import Data.Vector (Vector) -import Foreign.Lua as Lua -import Foreign.Lua.Aeson (pushNull) -import Test.Hspec -import Test.HUnit -import Test.QuickCheck -import Test.QuickCheck.Instances () - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Char8 as Char8 - --- | Run this spec. -main :: IO () -main = hspec spec - --- | Specifications for Attributes parsing functions. -spec :: Spec -spec = do - describe "pushNull" $ do - it "pushes a value that is recognized as null when peeked" $ do - val <- run (pushNull *> peek stackTop) - assert (val == Aeson.Null) - it "pushes a non-nil value" $ do - nil <- run (pushNull *> isnil stackTop) - assert (not nil) - it "pushes a single value" $ do - diff <- run $ stackDiff pushNull - assert (diff == 1) - it "pushes two values when called twice" $ do - diff <- run $ stackDiff (pushNull *> pushNull) - assert (diff == 2) - describe "Value component" $ do - describe "Scientific" $ do - it "can be converted to a lua number" $ property $ - \x -> assert =<< luaTest "type(x) == 'number'" [("x", x::Scientific)] - it "can be round-tripped through the stack with numbers of double precision" $ - property $ \x -> assertRoundtripEqual (luaNumberToScientific (Lua.Number x)) - it "can be round-tripped through the stack and stays approximately equal" $ - property $ \x -> assertRoundtripApprox (x :: Scientific) - describe "Text" $ do - it "can be converted to a lua string" $ property $ - \x -> assert =<< luaTest "type(x) == 'string'" [("x", x::Text)] - it "can be round-tripped through the stack" $ property $ - \x -> assertRoundtripEqual (x::Text) - describe "Vector" $ do - it "is converted to a lua table" $ property $ - \x -> assert =<< luaTest "type(x) == 'table'" [("x", x::Vector Bool)] - it "can contain Bools and be round-tripped through the stack" $ property $ - \x -> assertRoundtripEqual (x::Vector Bool) - it "can contain Texts and be round-tripped through the stack" $ property $ - \x -> assertRoundtripEqual (x::Vector Text) - it "can contain Vector of Bools and be round-tripped through the stack" $ property $ - \x -> assertRoundtripEqual (x::(Vector (Vector Bool))) - describe "HashMap" $ do - it "is converted to a lua table" $ property $ - \x -> assert =<< luaTest "type(x) == 'table'" [("x", x::HashMap Text Bool)] - it "can be round-tripped through the stack with Text keys and Bool values" $ - property $ \x -> assertRoundtripEqual (x::HashMap Text Bool) - it "can be round-tripped through the stack with Text keys and Vector Bool values" $ - property $ \x -> assertRoundtripEqual (x::HashMap Text (Vector Bool)) - describe "Value" $ - it "can be round-tripped through the stack" . property $ - \x -> assertRoundtripEqual (x::Aeson.Value) - -assertRoundtripApprox :: Scientific -> IO () -assertRoundtripApprox x = do - y <- roundtrip x - let xdouble = toRealFloat x :: Double - let ydouble = toRealFloat y :: Double - assert (xdouble ~== ydouble) - -assertRoundtripEqual :: (Show a, Eq a, Pushable a, Peekable a) => a -> IO () -assertRoundtripEqual x = do - y <- roundtrip x - assert (x == y) - -roundtrip :: (Pushable a, Peekable a) => a -> IO a -roundtrip x = run $ do - push x - size <- gettop - when (size /= 1) $ - Prelude.error ("not the right amount of elements on the stack: " ++ show size) - peek (-1) - -stackDiff :: Lua a -> Lua StackIndex -stackDiff op = do - topBefore <- gettop - _ <- op - topAfter <- gettop - return (topAfter - topBefore) - -luaTest :: Pushable a => String -> [(String, a)] -> IO Bool -luaTest luaTestCode xs = run $ do - openlibs - forM_ xs $ \(var, value) -> - push value *> setglobal var - let luaScript = "function run() return (" ++ luaTestCode ++ ") end" - _ <- dostring (Char8.pack luaScript) - callFunc "run" - -luaNumberToScientific :: Lua.Number -> Scientific -luaNumberToScientific = fromFloatDigits . (realToFrac :: Lua.Number -> Double) - -instance Arbitrary Aeson.Value where - arbitrary = arbitraryValue 7 - -arbitraryValue :: Int -> Gen Aeson.Value -arbitraryValue size = frequency - [ (1, return Aeson.Null) - , (4, Aeson.Bool <$> arbitrary) - -- FIXME: this is cheating: we don't draw numbers from the whole possible - -- range, but only from the range of nubers that can pass through the Lua - -- stack without rounding errors. Good enough for now, but we still might - -- want to do better in the future. - , (4, Aeson.Number . luaNumberToScientific . Lua.Number <$> arbitrary) - , (4, Aeson.String <$> arbitrary) - , (2, resize (size - 1) $ Aeson.Array <$> arbitrary) - , (2, resize (size - 1) $ Aeson.Object <$> arbitrary) - ] diff --git a/test/test-hslua-aeson.hs b/test/test-hslua-aeson.hs new file mode 100644 --- /dev/null +++ b/test/test-hslua-aeson.hs @@ -0,0 +1,174 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Copyright : © 2017–2021 Albert Krewinkel +License : MIT + +Tests for Aeson–Lua glue. +-} +import Control.Monad (when) +import Data.AEq ((~==)) +import Data.Aeson.Key (Key, fromText) +import Data.ByteString (ByteString) +import Data.Scientific (Scientific, toRealFloat, fromFloatDigits) +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 () + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Vector as Vector +import qualified Test.QuickCheck.Monadic as QC + +-- | Run this spec. +main :: IO () +main = defaultMain tests + +-- | 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" + [ 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] + x <- QC.run . run @Lua.Exception $ do + pushValue $ mkValue b + forcePeek $ peekValue top + return (x === mkValue b) + , 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] + x <- QC.run . run @Lua.Exception $ do + pushValue $ mkValue b + forcePeek $ peekValue top + return (x === mkValue b) + ] + + , 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 + ] + ] + ] + +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 +assertRoundtripEqual pushX peekX x = QC.monadicIO $ do + y <- QC.run $ roundtrip pushX peekX x + assert (x == y) + +roundtrip :: Pusher Lua.Exception a -> Peeker Lua.Exception a -> a -> IO a +roundtrip pushX peekX x = run $ do + pushX x + 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 + +luaNumberToScientific :: Lua.Number -> Scientific +luaNumberToScientific = fromFloatDigits . (realToFrac :: Lua.Number -> Double) + +instance Arbitrary Aeson.Value where + arbitrary = arbitraryValue 5 + +instance Arbitrary Key where + arbitrary = fmap fromText arbitrary + +instance Arbitrary a => Arbitrary (KeyMap.KeyMap a) where + arbitrary = fmap KeyMap.fromList arbitrary + +arbitraryValue :: Int -> Gen Aeson.Value +arbitraryValue size = frequency + [ (1, return Aeson.Null) + , (4, Aeson.Bool <$> arbitrary) + -- Note: we don't draw numbers from the whole possible range, but + -- only from the range of numbers that Lua can handle without + -- rounding errors. This is ok, as JSON doesn't define a required + -- precision, and (usually) matches the behavior of JavaScript. + , (4, Aeson.Number . luaNumberToScientific . Lua.Number <$> arbitrary) + , (4, Aeson.String <$> arbitrary) + , (2, resize (size - 1) $ Aeson.Array <$> arbitrary) + , (2, resize (size - 1) $ Aeson.Object <$> arbitrary) + ]