    {-|
    Module      :  HsLua.Aeson
    Copyright   :  © 2017-2024 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.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
      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