diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ hslua-aeson =========== -[![travis build status](https://img.shields.io/travis/tarleb/hslua-aeson/master.svg?style=flat-square)](https://travis-ci.org/tarleb/hslua-aeson) -[![MIT License](https://img.shields.io/github/license/tarleb/hslua-aeson.svg?style=flat-square)](./LICENSE) +[![travis build status]](https://travis-ci.org/hslua/hslua-aeson) +[![MIT License]](./LICENSE) Glue to hslua for aeson values. @@ -26,3 +26,6 @@ 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. + +[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/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,13 @@ +# hslua-aeson + +## 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,25 +1,31 @@ name: hslua-aeson -version: 0.1.0.4 -synopsis: Glue between aeson and hslua -description: Please see README.md +version: 0.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. homepage: https://github.com/tarleb/hslua-aeson#readme license: MIT license-file: LICENSE author: Albert Krewinkel maintainer: tarleb+hslua@zeitkraut.de copyright: © 2017 Albert Krewinkel -category: Scripting +category: Foreign build-type: Simple extra-source-files: README.md + changelog.md cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/hslua/hslua-aeson + library hs-source-dirs: src - exposed-modules: Scripting.Lua.Aeson + exposed-modules: Foreign.Lua.Aeson build-depends: base >= 4.7 && < 5 , aeson >= 0.11 && < 1.3 , hashable >= 1.2 && < 1.3 - , hslua >= 0.4 && < 0.6 + , hslua >= 0.8 && < 0.9 , scientific >= 0.3 && < 0.4 , text >= 1.1.1.0 && < 1.3 , unordered-containers >= 0.2 && < 0.3 @@ -47,7 +53,3 @@ , vector ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 - -source-repository head - type: git - location: https://github.com/tarleb/hslua-aeson diff --git a/src/Foreign/Lua/Aeson.hs b/src/Foreign/Lua/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Lua/Aeson.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-| +Module : Foreign.Lua.Aeson +Copyright : © 2017 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 the special global @_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. +-} +module Foreign.Lua.Aeson + ( registerNull + ) where + +#if MIN_VERSION_base(4,8,0) +#else +import Control.Applicative ((<$>), (<*>), (*>), (<*)) +#endif +import Data.HashMap.Lazy (HashMap) +import Data.Hashable (Hashable) +import Data.Scientific (Scientific, toRealFloat, fromFloatDigits) +import Data.Vector (Vector, fromList, toList) +import Foreign.Lua hiding (newstate, toList) + +import qualified 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 ToLuaStack Scientific where + push n = pushnumber (toRealFloat n) + +instance FromLuaStack Scientific where + peek n = fromFloatDigits <$> (peek n :: Lua LuaNumber) + +-- Vector +instance (ToLuaStack a) => ToLuaStack (Vector a) where + push v = pushvector v + +instance (FromLuaStack a) => FromLuaStack (Vector a) where + peek i = tovector i + +-- HashMap +instance (Eq a, Hashable a, ToLuaStack a, ToLuaStack b) + => ToLuaStack (HashMap a b) where + push h = pushTextHashMap h + +instance (Eq a, Hashable a, FromLuaStack a, FromLuaStack b) + => FromLuaStack (HashMap a b) where + peek i = HashMap.fromList <$> pairsFromTable i + +-- | Hslua StackValue instance for the Aeson Value data type. +instance ToLuaStack 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 -> getglobal "_NULL" + +instance FromLuaStack Aeson.Value where + peek i = do + ltype' <- ltype i + case ltype' of + TypeBoolean -> Aeson.Bool <$> peek i + TypeNumber -> Aeson.Number <$> peek i + TypeString -> Aeson.String <$> peek i + TypeTable -> do + rawgeti i 0 + isInt <- isnumber (-1) + pop 1 + if isInt + then Aeson.Array <$> peek i + else do + rawlen' <- rawlen i + if rawlen' > 0 + then Aeson.Array <$> peek i + else do + isNull <- isLuaNull i + if isNull + then return Aeson.Null + else Aeson.Object <$> peek i + TypeNil -> return Aeson.Null + _ -> error $ "Unexpected type: " ++ (show ltype') + +-- | Create a new lua state suitable for use with aeson values. This behaves +-- like @newstate@ in hslua, but initializes the @_NULL@ global. That variable +-- is used to encode null values. +registerNull :: Lua () +registerNull = do + createtable 0 0 + setglobal "_NULL" + +-- | Check if the value under the given index is rawequal to @_NULL@. +isLuaNull :: StackIndex -> Lua Bool +isLuaNull i = do + let i' = if i < 0 then i - 1 else i + getglobal "_NULL" + rawequal i' (-1) <* pop 1 + +-- | Push a vector unto the stack. +pushvector :: ToLuaStack a => Vector a -> Lua () +pushvector v = do + pushList . toList $ v + push (fromIntegral (Vector.length v) :: LuaInteger) + rawseti (-2) 0 + +-- | Try reading the value under the given index as a vector. +tovector :: FromLuaStack a => StackIndex -> Lua (Vector a) +tovector = fmap fromList . Lua.toList + +-- | Push a hashmap unto the stack. +pushTextHashMap :: (ToLuaStack a, ToLuaStack b) => HashMap a b -> Lua () +pushTextHashMap hm = do + let xs = HashMap.toList hm + let addValue (k, v) = push k *> push v *> rawset (-3) + newtable + mapM_ addValue xs diff --git a/src/Scripting/Lua/Aeson.hs b/src/Scripting/Lua/Aeson.hs deleted file mode 100644 --- a/src/Scripting/Lua/Aeson.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-| -Module : Scripting.Lua.Aeson -Copyright : © 2017 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 the special global @_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. --} -module Scripting.Lua.Aeson - ( module Scripting.Lua - , newstate - ) where - -#if MIN_VERSION_base(4,8,0) -#else -import Control.Applicative ((<$>), (<*>), (*>)) -#endif -import Data.HashMap.Lazy (HashMap) -import Data.Hashable (Hashable) -import Data.Scientific (Scientific, toRealFloat, fromFloatDigits) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Vector (Vector, fromList, toList) -import Scripting.Lua (LuaState, StackValue) - -import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.Vector as Vector -import qualified Scripting.Lua as Lua - -instance StackValue Scientific where - push lua n = Lua.pushnumber lua (toRealFloat n) - peek lua n = fmap fromFloatDigits <$> - (Lua.peek lua n :: IO (Maybe Lua.LuaNumber)) - valuetype _ = Lua.TNUMBER - -instance StackValue Text where - push lua t = Lua.push lua (encodeUtf8 t) - peek lua i = fmap decodeUtf8 <$> Lua.peek lua i - valuetype _ = Lua.TSTRING - -instance (StackValue a) => StackValue (Vector a) where - push lua v = pushvector lua v - peek lua i = tovector lua i - valuetype _ = Lua.TTABLE - -instance (Eq a, Hashable a, StackValue a, StackValue b) - => StackValue (HashMap a b) where - push lua h = pushTextHashMap lua h - peek lua i = fmap HashMap.fromList <$> getPairs lua i - valuetype _ = Lua.TTABLE - --- | Hslua StackValue instance for the Aeson Value data type. -instance StackValue Aeson.Value where - push lua = \case - Aeson.Object o -> Lua.push lua o - Aeson.Number n -> Lua.push lua n - Aeson.String s -> Lua.push lua s - Aeson.Array a -> Lua.push lua a - Aeson.Bool b -> Lua.push lua b - Aeson.Null -> Lua.getglobal lua "_NULL" - peek lua i = do - ltype <- Lua.ltype lua i - case ltype of - Lua.TBOOLEAN -> fmap Aeson.Bool <$> Lua.peek lua i - Lua.TNUMBER -> fmap Aeson.Number <$> Lua.peek lua i - Lua.TSTRING -> fmap Aeson.String <$> Lua.peek lua i - Lua.TTABLE -> do - Lua.rawgeti lua i 0 - len <- Lua.peek lua (-1) - Lua.pop lua 1 - case (len :: Maybe Int) of - Just _ -> fmap Aeson.Array <$> Lua.peek lua i - Nothing -> do - objlen <- Lua.objlen lua i - if objlen > 0 - then fmap Aeson.Array <$> Lua.peek lua i - else do - isNull <- isLuaNull lua i - if isNull - then return $ Just Aeson.Null - else fmap Aeson.Object <$> Lua.peek lua i - Lua.TNIL -> return $ Just Aeson.Null - _ -> error $ "Unexpected type: " ++ (show ltype) - valuetype = \case - Aeson.Object _ -> Lua.TTABLE - Aeson.Number _ -> Lua.TNUMBER - Aeson.String _ -> Lua.TSTRING - Aeson.Array _ -> Lua.TTABLE - Aeson.Bool _ -> Lua.TBOOLEAN - Aeson.Null -> Lua.TTABLE - --- | Create a new lua state suitable for use with aeson values. This behaves --- like @newstate@ in hslua, but initializes the @_NULL@ global. That variable --- is used to encode null values. -newstate :: IO LuaState -newstate = do - lua <- Lua.newstate - Lua.createtable lua 0 0 - Lua.setglobal lua "_NULL" - return lua - --- | Check if the value under the given index is lua-equal to @_NULL@. -isLuaNull :: LuaState -> Int -> IO Bool -isLuaNull lua i = do - let i' = if i < 0 then i - 1 else i - Lua.getglobal lua "_NULL" - res <- Lua.equal lua i' (-1) - Lua.pop lua 1 - return res - --- | Push a vector unto the stack. -pushvector :: StackValue a => LuaState -> Vector a -> IO () -pushvector lua v = do - Lua.pushlist lua . toList $ v - Lua.push lua (Vector.length v) - Lua.rawseti lua (-2) 0 - --- | Try reading the value under the given index as a vector. -tovector :: StackValue a => LuaState -> Int -> IO (Maybe (Vector a)) -tovector = fmap (fmap (fmap fromList)) . Lua.tolist - --- | Try reading the value under the given index as a list of key-value pairs. -getPairs :: (StackValue a, StackValue b) - => LuaState -> Int -> IO (Maybe [(a, b)]) -getPairs lua t = do - Lua.pushnil lua - pairs <- sequence <$> remainingPairs - return pairs - where - t' = if t < 0 then t - 1 else t - remainingPairs = do - res <- nextPair - case res of - Nothing -> return [] - Just a -> (a:) <$> remainingPairs - nextPair = do - hasNext <- Lua.next lua t' - if hasNext - then do - val <- Lua.peek lua (-1) - key <- Lua.peek lua (-2) - Lua.pop lua 1 -- removes the value, keeps the key - return $ Just <$> ((,) <$> key <*> val) - else do - return Nothing - --- | Push a hashmap unto the stack. -pushTextHashMap :: (StackValue a, StackValue b) => LuaState -> HashMap a b -> IO () -pushTextHashMap lua hm = do - let xs = HashMap.toList hm - Lua.createtable lua (length xs + 1) 0 - let addValue (k, v) = Lua.push lua k *> Lua.push lua v *> - Lua.rawset lua (-3) - mapM_ addValue xs diff --git a/test/AesonSpec.hs b/test/AesonSpec.hs --- a/test/AesonSpec.hs +++ b/test/AesonSpec.hs @@ -17,14 +17,14 @@ import Data.Scientific (Scientific, toRealFloat, fromFloatDigits) import Data.Text (Text) import Data.Vector (Vector) -import Scripting.Lua.Aeson (StackValue, newstate) +import Foreign.Lua +import Foreign.Lua.Aeson (registerNull) import Test.Hspec import Test.HUnit import Test.QuickCheck import Test.QuickCheck.Instances () import qualified Data.Aeson as Aeson -import qualified Scripting.Lua as Lua -- | Run this spec. main :: IO () @@ -38,7 +38,7 @@ 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 x) + property $ \x -> assertRoundtripEqual (luaNumberToScientific (LuaNumber x)) it "can be round-tripped through the stack and stays approximately equal" $ property $ \x -> assertRoundtripApprox (x :: Scientific) describe "Text" $ do @@ -73,40 +73,33 @@ let ydouble = toRealFloat y :: Double assert (xdouble ~== ydouble) -assertRoundtripEqual :: (Show a, Eq a, StackValue a) => a -> IO () +assertRoundtripEqual :: (Show a, Eq a, ToLuaStack a, FromLuaStack a) => a -> IO () assertRoundtripEqual x = do y <- roundtrip x assert (x == y) -roundtrip :: (StackValue a) => a -> IO a -roundtrip x = do - lua <- newstate - Lua.push lua x - size <- Lua.gettop lua +roundtrip :: (ToLuaStack a, FromLuaStack a) => a -> IO a +roundtrip x = runLua $ do + registerNull + push x + size <- gettop when (size /= 1) $ error ("not the right amount of elements on the stack: " ++ show size) - res <- Lua.peek lua (-1) - retval <- case res of - Nothing -> error "could not read from stack" - Just y -> return y - Lua.close lua - return retval + peek (-1) -luaTest :: StackValue a => String -> [(String, a)] -> IO Bool -luaTest luaTestCode xs = do - lua <- Lua.newstate +luaTest :: ToLuaStack a => String -> [(String, a)] -> IO Bool +luaTest luaTestCode xs = runLua $ do + openlibs + registerNull forM_ xs $ \(var, value) -> - Lua.push lua value *> Lua.setglobal lua var + push value *> setglobal var let luaScript = "function run() return (" ++ luaTestCode ++ ") end" - Lua.openlibs lua - _ <- loadstring lua luaScript "test script" - Lua.call lua 0 0 - retval <- Lua.callfunc lua "run" - Lua.close lua - return retval + _ <- loadstring luaScript + call 0 0 + callFunc "run" -luaNumberToScientific :: Lua.LuaNumber -> Scientific -luaNumberToScientific = fromFloatDigits +luaNumberToScientific :: LuaNumber -> Scientific +luaNumberToScientific = fromFloatDigits . (realToFrac :: LuaNumber -> Double) instance Arbitrary Aeson.Value where arbitrary = arbitraryValue 7 @@ -115,16 +108,12 @@ arbitraryValue size = frequency $ [ (1, return Aeson.Null) , (4, Aeson.Bool <$> arbitrary) - , (4, Aeson.Number . luaNumberToScientific <$> arbitrary) + -- FIXME: this is cheating: we don't draw numbers from the whole possible + -- range, but only fro 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 . LuaNumber <$> arbitrary) , (4, Aeson.String <$> arbitrary) , (2, resize (size - 1) $ Aeson.Array <$> arbitrary) , (2, resize (size - 1) $ Aeson.Object <$> arbitrary) ] - --- | Interpret string as lua code and load into the lua environment. -loadstring :: Lua.LuaState -> String -> String -> IO Int -#if MIN_VERSION_hslua(0,5,0) -loadstring lua script _ = Lua.loadstring lua script -#else -loadstring lua script cn = Lua.loadstring lua script cn -#endif