{-|
Module      :  HsLua.Aeson
Copyright   :  © 2017-2026 Albert Krewinkel
License     :  MIT
Maintainer  :  Albert Krewinkel <tarleb@hslua.org>

Pushes and retrieves aeson `Value`s to and from the Lua stack.

- JSON @null@ values are encoded as light userdata containing the
  @NULL@ pointer.

- Objects are converted to string-indexed tables.

- Arrays are converted to sequence tables and are given a
  metatable. This makes it possible to distinguish between empty
  arrays and empty objects. The metatable is stored in the
  registry under key @\'HsLua JSON array\'@' (see also
  'jsonarray').

- JSON numbers are converted to Lua numbers, i.e., 'Lua.Number';
  the exact C type may vary, depending on compile-time Lua
  configuration.
-}
module HsLua.Aeson
  ( peekValue
  , pushValue
  , peekViaJSON
  , pushViaJSON
  , jsonarray
    -- * Encoding arbitrary objects
  , peekToAeson
  , pushToAeson
  ) where

import Control.Applicative ((<|>))
import Control.Monad ((<$!>), void)
import Data.Aeson.Key (toText, fromText)
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.Aeson.KeyMap as KeyMap
import qualified Data.ByteString as B
import qualified Data.Vector as Vector
import qualified HsLua.Core.Utf8 as UTF8

-- | Hslua StackValue instance for the Aeson Value data type.
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 (ZonkAny 1) -> LuaE e ()
forall a e. Ptr a -> LuaE e ()
pushlightuserdata Ptr (ZonkAny 1)
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)

-- | Name of the registry slot holding the metatable given to
-- array tables. The registry entry can be replaced with a
-- different table if needed.
jsonarray :: Name
jsonarray :: Name
jsonarray = Name
"HsLua JSON array"

-- | Retrieves an Aeson 'Aeson.Value' from the Lua stack.
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 (ZonkAny 0)))
-> Peek e (Maybe (Ptr (ZonkAny 0)))
forall e a. LuaE e a -> Peek e a
liftLua (StackIndex -> LuaE e (Maybe (Ptr (ZonkAny 0)))
forall e a. StackIndex -> LuaE e (Maybe (Ptr a))
touserdata StackIndex
idx) Peek e (Maybe (Ptr (ZonkAny 0)))
-> (Maybe (Ptr (ZonkAny 0)) -> 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
    -- must be the null pointer
    Maybe (Ptr (ZonkAny 0))
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 (ZonkAny 0))
_       -> 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 ->
              -- check for nonempty sequence
              (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

--
-- Peek via __toaeson metamethod
--

-- | Retrieves a JSON value by using special metafields or metamethods.
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

-- | Retrieves a JSON value by calling an object's @__toaeson@
-- metamethod.
peekValueViaToaeson :: Peeker e Aeson.Value
peekValueViaToaeson :: forall e. Peeker e Value
peekValueViaToaeson StackIndex
idx = do
  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)
  liftLua (getmetafield absidx "__toaeson") >>= \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
      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
      fn absidx

peekValueViaTojson :: LuaError e => Peeker e Aeson.Value
peekValueViaTojson :: forall e. LuaError e => Peeker e Value
peekValueViaTojson StackIndex
idx = do
  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
  liftLua (getmetafield absidx "__tojson") >>= \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
      -- Try to use the field value as function
      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
      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
      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 :: Name
typeNameToAeson = Name
"HsLua.ToAeson"

-- | Pushes a function that converts the object at a given index into a
-- 'Aeson.Value'.
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
  _ <- Name -> LuaE e Bool
forall e. Name -> LuaE e Bool
newudmetatable Name
typeNameToAeson
  setmetatable (nth 2)

-- | Gets the 'ToAeson' function from a Lua userdata object.
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

--
-- Retrieving any value via JSON
--

-- | Retrieves a value from the Lua stack via JSON.
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 <- Peeker e Value
forall e. LuaError e => Peeker e Value
peekValue StackIndex
idx
  case Aeson.fromJSON 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

-- | Pushes a value to the Lua stack as a JSON-like value.
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