module HsLua.Aeson
( peekValue
, pushValue
, peekViaJSON
, pushViaJSON
, jsonarray
, peekToAeson
, pushToAeson
) where
import Control.Applicative ((<|>))
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.Utf8 as UTF8
#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.Key (toText, fromText)
import qualified Data.Aeson.KeyMap as KeyMap
#else
import Data.Text (Text)
import qualified Data.HashMap.Strict as KeyMap
toText, fromText :: Text -> Text
toText = id
fromText = id
#endif
pushValue :: LuaError e => Pusher e Aeson.Value
pushValue :: forall e. LuaError e => Pusher e Value
pushValue Value
val = do
Int -> String -> LuaE e ()
forall e. LuaError e => Int -> String -> LuaE e ()
checkstack' Int
1 String
"HsLua.Aeson.pushValue"
case Value
val of
Aeson.Object Object
o -> Pusher e Key -> Pusher e Value -> Pusher e [(Key, Value)]
forall e a b.
LuaError e =>
Pusher e a -> Pusher e b -> Pusher e [(a, b)]
pushKeyValuePairs Pusher e Key
forall {e}. Key -> LuaE e ()
pushKey Pusher e Value
forall e. LuaError e => Pusher e Value
pushValue Pusher e [(Key, Value)] -> Pusher e [(Key, Value)]
forall a b. (a -> b) -> a -> b
$ Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
o
Aeson.Number Scientific
n -> forall a e. RealFloat a => a -> LuaE e ()
pushRealFloat @Double (Double -> LuaE e ()) -> Double -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
n
Aeson.String Text
s -> Pusher e Text
forall e. Pusher e Text
pushText Text
s
Aeson.Array Array
a -> Array -> LuaE e ()
forall {e}. LuaError e => Array -> LuaE e ()
pushArray Array
a
Aeson.Bool Bool
b -> Pusher e Bool
forall e. Pusher e Bool
pushBool Bool
b
Value
Aeson.Null -> Ptr Any -> LuaE e ()
forall a e. Ptr a -> LuaE e ()
pushlightuserdata Ptr Any
forall a. Ptr a
nullPtr
where
pushKey :: Key -> LuaE e ()
pushKey = Pusher e Text
forall e. Pusher e Text
pushText Pusher e Text -> (Key -> Text) -> Key -> LuaE e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
toText
pushArray :: Array -> LuaE e ()
pushArray Array
x = do
Int -> String -> LuaE e ()
forall e. LuaError e => Int -> String -> LuaE e ()
checkstack' Int
4 String
"HsLua.Aeson.pushVector"
Pusher e Value -> [Value] -> LuaE e ()
forall e a. LuaError e => Pusher e a -> [a] -> LuaE e ()
pushList Pusher e Value
forall e. LuaError e => Pusher e Value
pushValue ([Value] -> LuaE e ()) -> [Value] -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
x
LuaE e Bool -> LuaE e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LuaE e Bool -> LuaE e ()) -> LuaE e Bool -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ Name -> LuaE e Bool
forall e. Name -> LuaE e Bool
newmetatable Name
jsonarray
StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
setmetatable (CInt -> StackIndex
nth CInt
2)
jsonarray :: Name
jsonarray :: Name
jsonarray = Name
"HsLua JSON array"
peekValue :: LuaError e => Peeker e Aeson.Value
peekValue :: forall e. LuaError e => Peeker e Value
peekValue StackIndex
idx = LuaE e Type -> Peek e Type
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> LuaE e Type
forall e. StackIndex -> LuaE e Type
ltype StackIndex
idx) Peek e Type -> (Type -> Peek e Value) -> Peek e Value
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Type
TypeBoolean -> Bool -> Value
Aeson.Bool (Bool -> Value) -> Peek e Bool -> Peek e Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Peeker e Bool
forall e. Peeker e Bool
peekBool StackIndex
idx
Type
TypeNumber -> Scientific -> Value
Aeson.Number (Scientific -> Value) -> (Double -> Scientific) -> Double -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Scientific
forall a. RealFloat a => a -> Scientific
fromFloatDigits (Double -> Value) -> Peek e Double -> Peek e Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall a e. (RealFloat a, Read a) => Peeker e a
peekRealFloat @Double StackIndex
idx
Type
TypeString -> Text -> Value
Aeson.String (Text -> Value) -> Peek e Text -> Peek e Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Peeker e Text
forall e. Peeker e Text
peekText StackIndex
idx
Type
TypeLightUserdata -> LuaE e (Maybe (Ptr Any)) -> Peek e (Maybe (Ptr Any))
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> LuaE e (Maybe (Ptr Any))
forall e a. StackIndex -> LuaE e (Maybe (Ptr a))
touserdata StackIndex
idx) Peek e (Maybe (Ptr Any))
-> (Maybe (Ptr Any) -> Peek e Value) -> Peek e Value
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Ptr Any)
Nothing -> Value -> Peek e Value
forall a. a -> Peek e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Aeson.Null
Maybe (Ptr Any)
_ -> Name -> StackIndex -> Peek e ByteString
forall e. Name -> StackIndex -> Peek e ByteString
typeMismatchMessage Name
"null" StackIndex
idx Peek e ByteString -> (ByteString -> Peek e Value) -> Peek e Value
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Peek e Value
forall a e. ByteString -> Peek e a
failPeek
Type
TypeNil -> Value -> Peek e Value
forall a. a -> Peek e a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
Aeson.Null
Type
TypeTable -> Peeker e Value
forall e. LuaError e => Peeker e Value
peekValueViaMetatable StackIndex
idx Peek e Value -> Peek e Value -> Peek e Value
forall a. Peek e a -> Peek e a -> Peek e a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
LuaE e () -> Peek e ()
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e () -> Peek e ()) -> LuaE e () -> Peek e ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> LuaE e ()
forall e. LuaError e => Int -> String -> LuaE e ()
checkstack' Int
2 String
"HsLua.Aeson.peekValue"
let peekKey :: StackIndex -> Peek e Key
peekKey = (Text -> Key) -> Peek e Text -> Peek e Key
forall a b. (a -> b) -> Peek e a -> Peek e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Key
fromText (Peek e Text -> Peek e Key)
-> (StackIndex -> Peek e Text) -> StackIndex -> Peek e Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackIndex -> Peek e Text
forall e. Peeker e Text
peekText
peekArray :: Peek e Value
peekArray = Array -> Value
Aeson.Array (Array -> Value) -> ([Value] -> Array) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ([Value] -> Value) -> Peek e [Value] -> Peek e Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!>
(Name -> Peek e [Value] -> Peek e [Value]
forall e a. Name -> Peek e a -> Peek e a
retrieving Name
"vector" (Peek e [Value] -> Peek e [Value])
-> Peek e [Value] -> Peek e [Value]
forall a b. (a -> b) -> a -> b
$! Peeker e Value -> Peeker e [Value]
forall a e. LuaError e => Peeker e a -> Peeker e [a]
peekList Peeker e Value
forall e. LuaError e => Peeker e Value
peekValue StackIndex
idx)
isarray :: LuaE e Bool
isarray = StackIndex -> LuaE e Bool
forall e. StackIndex -> LuaE e Bool
getmetatable StackIndex
idx LuaE e Bool -> (Bool -> LuaE e Bool) -> LuaE e Bool
forall a b. LuaE e a -> (a -> LuaE e b) -> LuaE e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False ->
(Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
TypeNil) (Type -> Bool) -> LuaE e Type -> LuaE e Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StackIndex -> Integer -> LuaE e Type
forall e. LuaError e => StackIndex -> Integer -> LuaE e Type
rawgeti StackIndex
idx Integer
1 LuaE e Bool -> LuaE e () -> LuaE e Bool
forall a b. LuaE e a -> LuaE e b -> LuaE e a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1
Bool
True -> Name -> LuaE e Type
forall e. Name -> LuaE e Type
getmetatable' Name
jsonarray LuaE e Type -> (Type -> LuaE e Bool) -> LuaE e Bool
forall a b. LuaE e a -> (a -> LuaE e b) -> LuaE e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Type
TypeTable -> StackIndex -> StackIndex -> LuaE e Bool
forall e. StackIndex -> StackIndex -> LuaE e Bool
rawequal (CInt -> StackIndex
nth CInt
1) (CInt -> StackIndex
nth CInt
2) LuaE e Bool -> LuaE e () -> LuaE e Bool
forall a b. LuaE e a -> LuaE e b -> LuaE e a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
2
Type
_ -> Bool -> LuaE e Bool
forall a. a -> LuaE e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
LuaE e Bool -> Peek e Bool
forall e a. LuaE e a -> Peek e a
liftLua LuaE e Bool
isarray Peek e Bool -> (Bool -> Peek e Value) -> Peek e Value
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> Peek e Value
peekArray
Bool
False -> Object -> Value
Aeson.Object (Object -> Value)
-> ([(Key, Value)] -> Object) -> [(Key, Value)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([(Key, Value)] -> Value) -> Peek e [(Key, Value)] -> Peek e Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!>
Peeker e Key -> Peeker e Value -> Peeker e [(Key, Value)]
forall e a b.
LuaError e =>
Peeker e a -> Peeker e b -> Peeker e [(a, b)]
peekKeyValuePairs Peeker e Key
forall {e}. StackIndex -> Peek e Key
peekKey Peeker e Value
forall e. LuaError e => Peeker e Value
peekValue StackIndex
idx
Type
_ -> Peeker e Value
forall e. LuaError e => Peeker e Value
peekValueViaMetatable StackIndex
idx
peekValueViaMetatable :: LuaError e => Peeker e Aeson.Value
peekValueViaMetatable :: forall e. LuaError e => Peeker e Value
peekValueViaMetatable StackIndex
idx = Peeker e Value
forall e. Peeker e Value
peekValueViaToaeson StackIndex
idx Peek e Value -> Peek e Value -> Peek e Value
forall a. Peek e a -> Peek e a -> Peek e a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Peeker e Value
forall e. LuaError e => Peeker e Value
peekValueViaTojson StackIndex
idx
peekValueViaToaeson :: Peeker e Aeson.Value
peekValueViaToaeson :: forall e. Peeker e Value
peekValueViaToaeson StackIndex
idx = do
StackIndex
absidx <- LuaE e StackIndex -> Peek e StackIndex
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> LuaE e StackIndex
forall e. StackIndex -> LuaE e StackIndex
absindex StackIndex
idx)
LuaE e Type -> Peek e Type
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> Name -> LuaE e Type
forall e. StackIndex -> Name -> LuaE e Type
getmetafield StackIndex
absidx Name
"__toaeson") Peek e Type -> (Type -> Peek e Value) -> Peek e Value
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Type
TypeNil -> ByteString -> Peek e Value
forall a e. ByteString -> Peek e a
failPeek ByteString
"Object does not have a `__toaeson` metavalue."
Type
_ -> do
ToAeson e
fn <- Peeker e (ToAeson e)
forall e. Peeker e (ToAeson e)
peekToAeson StackIndex
top Peek e (ToAeson e) -> LuaE e () -> Peek e (ToAeson e)
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1
ToAeson e
fn StackIndex
absidx
peekValueViaTojson :: LuaError e => Peeker e Aeson.Value
peekValueViaTojson :: forall e. LuaError e => Peeker e Value
peekValueViaTojson StackIndex
idx = do
StackIndex
absidx <- LuaE e StackIndex -> Peek e StackIndex
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e StackIndex -> Peek e StackIndex)
-> LuaE e StackIndex -> Peek e StackIndex
forall a b. (a -> b) -> a -> b
$ StackIndex -> LuaE e StackIndex
forall e. StackIndex -> LuaE e StackIndex
absindex StackIndex
idx
LuaE e Type -> Peek e Type
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> Name -> LuaE e Type
forall e. StackIndex -> Name -> LuaE e Type
getmetafield StackIndex
absidx Name
"__tojson") Peek e Type -> (Type -> Peek e Value) -> Peek e Value
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Type
TypeNil ->
ByteString -> Peek e Value
forall a e. ByteString -> Peek e a
failPeek ByteString
"Object does not have a `__tojson` metamethod."
Type
_ -> do
LuaE e () -> Peek e ()
forall e a. LuaE e a -> Peek e a
liftLua (LuaE e () -> Peek e ()) -> LuaE e () -> Peek e ()
forall a b. (a -> b) -> a -> b
$ do
StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
pushvalue StackIndex
absidx
NumArgs -> NumResults -> LuaE e ()
forall e. LuaError e => NumArgs -> NumResults -> LuaE e ()
call NumArgs
1 NumResults
1
ByteString
json <- Peeker e ByteString
forall e. Peeker e ByteString
peekLazyByteString StackIndex
top Peek e ByteString -> LuaE e () -> Peek e ByteString
forall e a b. Peek e a -> LuaE e b -> Peek e a
`lastly` Int -> LuaE e ()
forall e. Int -> LuaE e ()
pop Int
1
Peek e Value
-> (Value -> Peek e Value) -> Maybe Value -> Peek e Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> Peek e Value
forall a e. ByteString -> Peek e a
failPeek ByteString
"Could not decode string") Value -> Peek e Value
forall a. a -> Peek e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> Peek e Value) -> Maybe Value -> Peek e Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
json
type ToAeson e = Peeker e Aeson.Value
typeNameToAeson :: Name
typeNameToAeson :: Name
typeNameToAeson = Name
"HsLua.ToAeson"
pushToAeson :: Pusher e (ToAeson e)
pushToAeson :: forall e. Pusher e (ToAeson e)
pushToAeson ToAeson e
val = do
ToAeson e -> Int -> LuaE e ()
forall a e. a -> Int -> LuaE e ()
newhsuserdatauv ToAeson e
val Int
0
Bool
_ <- Name -> LuaE e Bool
forall e. Name -> LuaE e Bool
newudmetatable Name
typeNameToAeson
StackIndex -> LuaE e ()
forall e. StackIndex -> LuaE e ()
setmetatable (CInt -> StackIndex
nth CInt
2)
peekToAeson :: Peeker e (ToAeson e)
peekToAeson :: forall e. Peeker e (ToAeson e)
peekToAeson StackIndex
idx =
LuaE e (Maybe (ToAeson e)) -> Peek e (Maybe (ToAeson e))
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> Name -> LuaE e (Maybe (ToAeson e))
forall a e. StackIndex -> Name -> LuaE e (Maybe a)
fromuserdata StackIndex
idx Name
typeNameToAeson) Peek e (Maybe (ToAeson e))
-> (Maybe (ToAeson e) -> Peek e (ToAeson e)) -> Peek e (ToAeson e)
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (ToAeson e)
Nothing -> Name -> StackIndex -> Peek e ByteString
forall e. Name -> StackIndex -> Peek e ByteString
typeMismatchMessage Name
typeNameToAeson StackIndex
idx Peek e ByteString
-> (ByteString -> Peek e (ToAeson e)) -> Peek e (ToAeson e)
forall a b. Peek e a -> (a -> Peek e b) -> Peek e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Peek e (ToAeson e)
forall a e. ByteString -> Peek e a
failPeek
Just ToAeson e
ta -> ToAeson e -> Peek e (ToAeson e)
forall a. a -> Peek e a
forall (m :: * -> *) a. Monad m => a -> m a
return ToAeson e
ta
peekViaJSON :: (Aeson.FromJSON a, LuaError e) => Peeker e a
peekViaJSON :: forall a e. (FromJSON a, LuaError e) => Peeker e a
peekViaJSON StackIndex
idx = do
Value
value <- Peeker e Value
forall e. LuaError e => Peeker e Value
peekValue StackIndex
idx
case Value -> Result a
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
value of
Aeson.Success a
x -> a -> Peek e a
forall a. a -> Peek e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Aeson.Error String
msg -> ByteString -> Peek e a
forall a e. ByteString -> Peek e a
failPeek (ByteString -> Peek e a) -> ByteString -> Peek e a
forall a b. (a -> b) -> a -> b
$ ByteString
"failed to decode: " ByteString -> ByteString -> ByteString
`B.append`
String -> ByteString
UTF8.fromString String
msg
pushViaJSON :: (Aeson.ToJSON a, LuaError e) => Pusher e a
pushViaJSON :: forall a e. (ToJSON a, LuaError e) => Pusher e a
pushViaJSON = Pusher e Value
forall e. LuaError e => Pusher e Value
pushValue Pusher e Value -> (a -> Value) -> a -> LuaE e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON