hslua-aeson 1.0.3.1 → 2.0.0

raw patch · 8 files changed

+519/−370 lines, 8 filesdep +containersdep +hslua-coredep +hslua-marshallingdep −HUnitdep −hsluadep −hspecdep ~aesondep ~basedep ~bytestringsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, hslua-core, hslua-marshalling, mtl, tasty, tasty-hunit, tasty-quickcheck

Dependencies removed: HUnit, hslua, hspec

Dependency ranges changed: aeson, base, bytestring, hashable, scientific, text, unordered-containers, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +86/−0
• Setup.hs +0/−2
• changelog.md +0/−59
• hslua-aeson.cabal +50/−34
• src/Foreign/Lua/Aeson.hs +0/−144
• src/HsLua/Aeson.hs +209/−0
• test/AesonSpec.hs +0/−131
• test/test-hslua-aeson.hs +174/−0

@@ -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

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -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.

@@ -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 <albert+hslua@zeitkraut.de>+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

@@ -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 <tarleb@zeitkraut.de>-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)

@@ -0,0 +1,209 @@+{-|+Module      :  HsLua.Aeson+Copyright   :  © 2017–2021 Albert Krewinkel+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:++- @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

@@ -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)-    ]

@@ -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)+    ]