content: {-|
  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.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 val = do
    checkstack' 1 "HsLua.Aeson.pushValue"
    case val of
      Aeson.Object o -> pushKeyValuePairs pushKey pushValue $ KeyMap.toList o
      Aeson.Number n -> pushRealFloat @Double $ toRealFloat n
      Aeson.String s -> pushText s
      Aeson.Array a  -> pushArray a
      Aeson.Bool b   -> pushBool b
      Aeson.Null     -> pushlightuserdata nullPtr
   where
    pushKey = pushText . toText
    pushArray x = do
      checkstack' 4 "HsLua.Aeson.pushVector"
      pushList pushValue $ Vector.toList x
      void $ newmetatable jsonarray
      setmetatable (nth 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 = "HsLua JSON array"
  
  -- | Retrieves an Aeson 'Aeson.Value' from the Lua stack.
  peekValue :: LuaError e => Peeker e Aeson.Value
  peekValue idx = liftLua (ltype idx) >>= \case
    TypeBoolean -> Aeson.Bool  <$!> peekBool idx
    TypeNumber -> Aeson.Number . fromFloatDigits <$!> peekRealFloat @Double idx
    TypeString -> Aeson.String <$!> peekText idx
    TypeLightUserdata -> liftLua (touserdata idx) >>= \case
      -- must be the null pointer
      Nothing -> pure Aeson.Null
      _       -> typeMismatchMessage "null" idx >>= failPeek
    TypeNil -> return Aeson.Null
    TypeTable -> peekValueViaMetatable idx <|> do
        liftLua $ checkstack' 2 "HsLua.Aeson.peekValue"
        let peekKey = fmap fromText . peekText
            peekArray = Aeson.Array . Vector.fromList <$!>
              (retrieving "vector" $! peekList peekValue idx)
            isarray = getmetatable idx >>= \case
              False ->
                -- check for nonempty sequence
                (/= TypeNil) <$> rawgeti idx 1 <* pop 1
              True  -> getmetatable' jsonarray >>= \case
                TypeTable -> rawequal (nth 1) (nth 2) <* pop 2
                _         -> pure False
        liftLua isarray >>= \case
          True  -> peekArray
          False -> Aeson.Object . KeyMap.fromList <$!>
                   peekKeyValuePairs peekKey peekValue idx
    _ -> peekValueViaMetatable idx
  
  --
  -- Peek via __toaeson metamethod
  --
  
  -- | Retrieves a JSON value by using special metafields or metamethods.
  peekValueViaMetatable :: LuaError e => Peeker e Aeson.Value
  peekValueViaMetatable idx = peekValueViaToaeson idx <|> peekValueViaTojson idx
  
  -- | Retrieves a JSON value by calling an object's @__toaeson@
  -- metamethod.
  peekValueViaToaeson :: Peeker e Aeson.Value
  peekValueViaToaeson idx = do
    absidx <- liftLua (absindex idx)
    liftLua (getmetafield absidx "__toaeson") >>= \case
      TypeNil -> failPeek "Object does not have a `__toaeson` metavalue."
      _ -> do
        fn <- peekToAeson top `lastly` pop 1
        fn absidx
  
  peekValueViaTojson :: LuaError e => Peeker e Aeson.Value
  peekValueViaTojson idx = do
    absidx <- liftLua $ absindex idx
    liftLua (getmetafield absidx "__tojson") >>= \case
      TypeNil ->
        failPeek "Object does not have a `__tojson` metamethod."
      _ -> do
        -- Try to use the field value as function
        liftLua $ do
          pushvalue absidx
          call 1 1
        json <- peekLazyByteString top `lastly` pop 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 = "HsLua.ToAeson"
  
  -- | Pushes a function that converts the object at a given index into a
  -- 'Aeson.Value'.
  pushToAeson :: Pusher e (ToAeson e)
  pushToAeson val = do
    newhsuserdatauv val 0
    _ <- newudmetatable typeNameToAeson
    setmetatable (nth 2)
  
  -- | Gets the 'ToAeson' function from a Lua userdata object.
  peekToAeson :: Peeker e (ToAeson e)
  peekToAeson idx =
    liftLua (fromuserdata idx typeNameToAeson) >>= \case
      Nothing -> typeMismatchMessage typeNameToAeson idx >>= failPeek
      Just ta -> return 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 idx = do
    value <- peekValue idx
    case Aeson.fromJSON value of
      Aeson.Success x -> pure x
      Aeson.Error msg -> failPeek $ "failed to decode: " `B.append`
                         UTF8.fromString msg
  
  -- | Pushes a value to the Lua stack as a JSON-like value.
  pushViaJSON :: (Aeson.ToJSON a, LuaError e) => Pusher e a
  pushViaJSON = pushValue . Aeson.toJSON
  