diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,29 @@ `hslua-aeson` uses [PVP Versioning][]. +## hslua-aeson-2.3.0 + +Release pending. + +- The `peekValue` peeker now checks for a `__toaeson` metafield + or `__tojson` metamethod and uses them to compute the `Value` + of an object: + + The `__toaeson` metafield, if set, must be a function pushed + via `pushToAeson`. That function is called on a given object, + and the returned *Value* becomes the result of calling + `peekValue`. + + Likewise, the `__tojson` metamethod must be a function that + returns a valid JSON string. The result in that case is the + decoded string. + + If both, `__toaeson` and `__tojson` are set, then `__toaeson` + takes precedent. + +- The test suite now has *tasty-hunit* as an additional + dependency. + ## hslua-aeson-2.2.1 Released 2022-06-23. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright © 2017–2019 Albert Krewinkel +Copyright © 2017–2023 Albert Krewinkel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal 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: 2.2.1 +version: 2.3.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. @@ -9,18 +9,17 @@ license-file: LICENSE author: Albert Krewinkel maintainer: Albert Krewinkel -copyright: © 2017–2022 Albert Krewinkel +copyright: © 2017–2023 Albert Krewinkel category: Foreign extra-source-files: README.md , CHANGELOG.md -tested-with: GHC == 8.0.2 - , GHC == 8.2.2 - , GHC == 8.4.4 +tested-with: GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 - , GHC == 9.2.3 + , GHC == 9.2.5 + , GHC == 9.4.4 source-repository head type: git @@ -34,7 +33,7 @@ , bytestring >= 0.10.2 && < 0.12 , containers >= 0.5.9 && < 0.7 , hashable >= 1.2 && < 1.5 - , hslua-core >= 2.0 && < 2.3 + , hslua-core >= 2.0 && < 2.4 , hslua-marshalling >= 2.1 && < 2.3 , mtl >= 2.2 && < 2.4 , scientific >= 0.3 && < 0.4 @@ -76,5 +75,6 @@ , quickcheck-instances , tasty >= 0.11 , tasty-quickcheck >= 0.8 + , tasty-hunit >= 0.10 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 @@ -27,8 +27,12 @@ , peekViaJSON , pushViaJSON , jsonarray + -- * Encoding arbitrary objects + , peekToAeson + , pushToAeson ) where +import Control.Applicative ((<|>)) import Control.Monad ((<$!>), void) import Data.Scientific (toRealFloat, fromFloatDigits) import Foreign.Ptr (nullPtr) @@ -88,7 +92,7 @@ Nothing -> pure Aeson.Null _ -> typeMismatchMessage "null" idx >>= failPeek TypeNil -> return Aeson.Null - TypeTable -> do + TypeTable -> peekValueViaMetatable idx <|> do liftLua $ checkstack' 2 "HsLua.Aeson.peekValue" let peekKey = fmap fromText . peekText peekArray = Aeson.Array . Vector.fromList <$!> @@ -104,7 +108,66 @@ True -> peekArray False -> Aeson.Object . KeyMap.fromList <$!> peekKeyValuePairs peekKey peekValue idx - luaType -> fail ("Unexpected type: " ++ show luaType) + _ -> peekValueViaMetatable idx + +-- +-- Peek via __toaeson metamethod +-- + +-- | Retrieves a JSON value by using special metafields or metamethods. +peekValueViaMetatable :: LuaError e => Peeker e Aeson.Value +peekValueViaMetatable idx = peekValueViaToaeson idx <|> peekValueViaTojson idx + +-- | Retrieves a JSON value by calling an object's @__toaeson@ +-- metamethod. +peekValueViaToaeson :: Peeker e Aeson.Value +peekValueViaToaeson idx = do + absidx <- liftLua (absindex idx) + liftLua (getmetafield absidx "__toaeson") >>= \case + TypeNil -> failPeek "Object does not have a `__toaeson` metavalue." + _ -> do + fn <- peekToAeson top `lastly` pop 1 + fn absidx + +peekValueViaTojson :: LuaError e => Peeker e Aeson.Value +peekValueViaTojson idx = do + absidx <- liftLua $ absindex idx + liftLua (getmetafield absidx "__tojson") >>= \case + TypeNil -> + failPeek "Object does not have a `__tojson` metamethod." + _ -> do + -- Try to use the field value as function + liftLua $ do + pushvalue absidx + call 1 1 + json <- peekLazyByteString top `lastly` pop 1 + maybe (failPeek "Could not decode string") pure $ Aeson.decode json + +-- | Type for the function that gets an Aeson value from a Lua object. +type ToAeson e = Peeker e Aeson.Value + +-- | Lua type name for 'ToAeson' values. +typeNameToAeson :: Name +typeNameToAeson = "HsLua.ToAeson" + +-- | Pushes a function that converts the object at a given index into a +-- 'Aeson.Value'. +pushToAeson :: Pusher e (ToAeson e) +pushToAeson val = do + newhsuserdatauv val 0 + _ <- newudmetatable typeNameToAeson + setmetatable (nth 2) + +-- | Gets the 'ToAeson' function from a Lua userdata object. +peekToAeson :: Peeker e (ToAeson e) +peekToAeson idx = + liftLua (fromuserdata idx typeNameToAeson) >>= \case + Nothing -> typeMismatchMessage typeNameToAeson idx >>= failPeek + Just ta -> return ta + +-- +-- Retrieving any value via JSON +-- -- | Retrieves a value from the Lua stack via JSON. peekViaJSON :: (Aeson.FromJSON a, LuaError e) => Peeker e a 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,12 +6,14 @@ Tests for Aeson–Lua glue. -} import Control.Monad (when) +import Data.Aeson (ToJSON, object, (.=)) 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 () @@ -75,6 +77,27 @@ , testProperty "can roundtrip 'Either Bool Text' via JSON" $ assertRoundtripEqual @(Either Bool Text) pushViaJSON peekViaJSON ] + + , testGroup "special encodings" + [ testGroup "__toaeson" + [ testCase "respect __toaeson metamethod" . run @Lua.Exception $ do + pushTwentyThree TwentyThree + val <- forcePeek $ peekValue top + liftIO $ object [ "title" .= (23 :: Int) ] @?= val + ] + , testGroup "__tojson" + [ testCase "respect __tojson metamethod" . run @Lua.Exception $ do + newtable -- object + + newtable -- metatable + pushHaskellFunction (1 <$ pushText "{\"answer\": 42}") + setfield (nth 2) "__tojson" + + setmetatable (nth 2) + val <- forcePeek $ peekValue top + liftIO $ object [ "answer" .= (42 :: Int) ] @?= val + ] + ] ] assertRoundtripEqual :: Eq a @@ -126,3 +149,28 @@ , (2, resize (size - 1) $ Aeson.Object <$> arbitrary) ] #endif + +-- +-- Type for __toaeson tests +-- + +-- | Example type with custom JSON encoding. +data TwentyThree = TwentyThree + +instance ToJSON TwentyThree where + toJSON _ = object + [ "title" .= (23 :: Int) + ] + +peekTwentyThree :: Peeker e TwentyThree +peekTwentyThree = + reportValueOnFailure "TwentyThree" (`Lua.fromuserdata` "TwentyThree") + +pushTwentyThree :: LuaError e => Pusher e TwentyThree +pushTwentyThree _ = do + Lua.newhsuserdatauv TwentyThree 0 + created <- Lua.newudmetatable "TwentyThree" + when created $ do + pushToAeson (fmap Aeson.toJSON . peekTwentyThree) + setfield (nth 2) "__toaeson" + setmetatable (nth 2)