{-|
Module      :  HsLua.Aeson
Copyright   :  © 2017–2022 Albert Krewinkel
License     :  MIT
Maintainer  :  Albert Krewinkel <tarleb@zeitkraut.de>

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

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