{-|
Module      : HsLua.Marshalling.Push
Copyright   : © 2020-2022 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb+hslua@zeitkraut.de>
Stability   : beta
Portability : Portable

Functions which marshal and push Haskell values onto Lua's stack.
-}
module HsLua.Marshalling.Push
  ( Pusher
  -- * Primitives
  , pushBool
  , pushIntegral
  , pushRealFloat
  -- * Strings
  , pushByteString
  , pushLazyByteString
  , pushString
  , pushText
  , pushName
  -- * Collections
  , pushList
  , pushKeyValuePairs
  , pushMap
  , pushSet
  -- * Combinators
  , pushPair
  , pushTriple
  , pushAsTable
  ) where

import Control.Monad (forM_, zipWithM_)
import Data.ByteString (ByteString)
import Data.Map (Map, toList)
import Data.Set (Set)
import HsLua.Core as Lua
import Numeric (showGFloat)

import qualified Data.Text as T
import qualified Data.ByteString.Lazy as BL
import qualified HsLua.Core.Utf8 as Utf8

-- | Function to push a value to Lua's stack.
type Pusher e a = a -> LuaE e ()

-- | Pushes a 'Bool' as a Lua boolean.
pushBool :: Pusher e Bool
pushBool :: Pusher e Bool
pushBool = Pusher e Bool
forall e. Bool -> LuaE e ()
pushboolean

-- | Pushes a 'T.Text' value as a UTF-8 encoded string.
pushText :: Pusher e T.Text
pushText :: Pusher e Text
pushText = ByteString -> LuaE e ()
forall e. ByteString -> LuaE e ()
pushstring (ByteString -> LuaE e ()) -> (Text -> ByteString) -> Pusher e Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Utf8.fromText

-- | Pushes a 'ByteString' as a raw string.
pushByteString :: Pusher e ByteString
pushByteString :: Pusher e ByteString
pushByteString = Pusher e ByteString
forall e. ByteString -> LuaE e ()
pushstring

-- | Pushes a lazy 'BL.ByteString' as a raw string.
pushLazyByteString :: Pusher e BL.ByteString
pushLazyByteString :: Pusher e ByteString
pushLazyByteString = ByteString -> LuaE e ()
forall e. ByteString -> LuaE e ()
pushstring (ByteString -> LuaE e ())
-> (ByteString -> ByteString) -> Pusher e ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict

-- | Pushes a 'String' as a UTF-8 encoded Lua string.
pushString :: String -> LuaE e ()
pushString :: String -> LuaE e ()
pushString = ByteString -> LuaE e ()
forall e. ByteString -> LuaE e ()
pushstring (ByteString -> LuaE e ())
-> (String -> ByteString) -> String -> LuaE e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
Utf8.fromString

-- | Pushes a 'Name' as a UTF-8 encoded Lua string.
pushName :: Name -> LuaE e ()
pushName :: Name -> LuaE e ()
pushName (Name ByteString
n) = Pusher e ByteString
forall e. ByteString -> LuaE e ()
pushByteString ByteString
n

-- | Pushes an @Integer@ to the Lua stack. Values representable as Lua
-- integers are pushed as such; bigger integers are represented using
-- their string representation.
pushIntegral :: (Integral a, Show a) => a -> LuaE e ()
pushIntegral :: a -> LuaE e ()
pushIntegral a
i =
  let maxInt :: Integer
maxInt = Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
forall a. Bounded a => a
maxBound :: Lua.Integer)
      minInt :: Integer
minInt = Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
forall a. Bounded a => a
minBound :: Lua.Integer)
      i' :: Integer
i' = a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i :: Prelude.Integer
  in if Integer
i' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
minInt Bool -> Bool -> Bool
&& Integer
i' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxInt
     then Integer -> LuaE e ()
forall e. Integer -> LuaE e ()
pushinteger (Integer -> LuaE e ()) -> Integer -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i
     else String -> LuaE e ()
forall e. String -> LuaE e ()
pushString  (String -> LuaE e ()) -> String -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
i

-- | Push a floating point number to the Lua stack. Uses a string
-- representation for all types which do not match the float properties
-- of the 'Lua.Number' type.
pushRealFloat :: RealFloat a => a -> LuaE e ()
pushRealFloat :: a -> LuaE e ()
pushRealFloat a
f =
  let
    number :: Number
number = Number
0 :: Lua.Number
    realFloatFitsInNumber :: Bool
realFloatFitsInNumber = Number -> Integer
forall a. RealFloat a => a -> Integer
floatRadix Number
number Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Integer
forall a. RealFloat a => a -> Integer
floatRadix a
f
      Bool -> Bool -> Bool
&& Number -> Int
forall a. RealFloat a => a -> Int
floatDigits Number
number Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Int
forall a. RealFloat a => a -> Int
floatDigits a
f
      Bool -> Bool -> Bool
&& Number -> (Int, Int)
forall a. RealFloat a => a -> (Int, Int)
floatRange Number
number (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== a -> (Int, Int)
forall a. RealFloat a => a -> (Int, Int)
floatRange a
f
  in if Bool
realFloatFitsInNumber
     then Number -> LuaE e ()
forall e. Number -> LuaE e ()
pushnumber (a -> Number
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
f :: Lua.Number)
     else String -> LuaE e ()
forall e. String -> LuaE e ()
pushString (Maybe Int -> a -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showGFloat Maybe Int
forall a. Maybe a
Nothing a
f String
"")

-- | Push list of pairs as default key-value Lua table.
pushKeyValuePairs :: LuaError e
                  => Pusher e a -> Pusher e b -> Pusher e [(a,b)]
pushKeyValuePairs :: Pusher e a -> Pusher e b -> Pusher e [(a, b)]
pushKeyValuePairs Pusher e a
pushKey Pusher e b
pushValue [(a, b)]
m = Int -> LuaE e Bool
forall e. Int -> LuaE e Bool
checkstack Int
3 LuaE e Bool -> (Bool -> LuaE e ()) -> LuaE e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
False -> String -> LuaE e ()
forall e a. LuaError e => String -> LuaE e a
failLua String
"stack overflow while pushing key-value pairs"
  Bool
True  -> do
    let addValue :: (a, b) -> LuaE e ()
addValue (a
k, b
v) = Pusher e a
pushKey a
k LuaE e () -> LuaE e () -> LuaE e ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Pusher e b
pushValue b
v LuaE e () -> LuaE e () -> LuaE e ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (-StackIndex
3)
    LuaE e ()
forall e. LuaE e ()
newtable
    ((a, b) -> LuaE e ()) -> Pusher e [(a, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (a, b) -> LuaE e ()
addValue [(a, b)]
m

-- | Push list as numerically indexed table.
pushList :: LuaError e => Pusher e a -> [a] -> LuaE e ()
pushList :: Pusher e a -> [a] -> LuaE e ()
pushList Pusher e a
push [a]
xs = Int -> LuaE e Bool
forall e. Int -> LuaE e Bool
checkstack Int
2 LuaE e Bool -> (Bool -> LuaE e ()) -> LuaE e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
False -> String -> LuaE e ()
forall e a. LuaError e => String -> LuaE e a
failLua String
"stack overflow while pushing a list"
  Bool
True  -> do
    let setField :: Integer -> Pusher e a
setField Integer
i a
x = Pusher e a
push a
x LuaE e () -> LuaE e () -> LuaE e ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StackIndex -> Integer -> LuaE e ()
forall e. LuaError e => StackIndex -> Integer -> LuaE e ()
rawseti (-StackIndex
2) Integer
i
    LuaE e ()
forall e. LuaE e ()
newtable
    (Integer -> Pusher e a) -> [Integer] -> [a] -> LuaE e ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Integer -> Pusher e a
setField [Integer
1..] [a]
xs

-- | Push 'Map' as default key-value Lua table.
pushMap :: LuaError e => Pusher e a -> Pusher e b -> Pusher e (Map a b)
pushMap :: Pusher e a -> Pusher e b -> Pusher e (Map a b)
pushMap Pusher e a
pushKey Pusher e b
pushValue Map a b
m = Pusher e a -> Pusher e b -> Pusher e [(a, b)]
forall e a b.
LuaError e =>
Pusher e a -> Pusher e b -> Pusher e [(a, b)]
pushKeyValuePairs Pusher e a
pushKey Pusher e b
pushValue Pusher e [(a, b)] -> Pusher e [(a, b)]
forall a b. (a -> b) -> a -> b
$ Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
toList Map a b
m

-- | Push a 'Set' as idiomatic Lua set, i.e., as a table with the set
-- elements as keys and @true@ as values.
pushSet :: LuaError e => Pusher e a -> Pusher e (Set a)
pushSet :: Pusher e a -> Pusher e (Set a)
pushSet Pusher e a
pushElement Set a
set = Int -> LuaE e Bool
forall e. Int -> LuaE e Bool
checkstack Int
3 LuaE e Bool -> (Bool -> LuaE e ()) -> LuaE e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
False -> String -> LuaE e ()
forall e a. LuaError e => String -> LuaE e a
failLua String
"stack overflow while pushing a set"
  Bool
True  -> do
    let addItem :: Pusher e a
addItem a
item = Pusher e a
pushElement a
item LuaE e () -> LuaE e () -> LuaE e ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> LuaE e ()
forall e. Bool -> LuaE e ()
pushboolean Bool
True LuaE e () -> LuaE e () -> LuaE e ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (-StackIndex
3)
    LuaE e ()
forall e. LuaE e ()
newtable
    Pusher e a -> Pusher e (Set a)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Pusher e a
addItem Set a
set

--
-- Combinators
--
-- | Pushes an object as a table, defined by a list of
-- field-names/push-function pairs.
pushAsTable :: LuaError e
            => [(Name, a -> LuaE e ())]
            -> a -> LuaE e ()
pushAsTable :: [(Name, a -> LuaE e ())] -> a -> LuaE e ()
pushAsTable [(Name, a -> LuaE e ())]
props a
obj = do
  Int -> Int -> LuaE e ()
forall e. Int -> Int -> LuaE e ()
createtable Int
0 ([(Name, a -> LuaE e ())] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, a -> LuaE e ())]
props)
  [(Name, a -> LuaE e ())]
-> ((Name, a -> LuaE e ()) -> LuaE e ()) -> LuaE e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, a -> LuaE e ())]
props (((Name, a -> LuaE e ()) -> LuaE e ()) -> LuaE e ())
-> ((Name, a -> LuaE e ()) -> LuaE e ()) -> LuaE e ()
forall a b. (a -> b) -> a -> b
$ \(Name
name, a -> LuaE e ()
pushValue) -> do
    Name -> LuaE e ()
forall e. Name -> LuaE e ()
pushName Name
name
    a -> LuaE e ()
pushValue a
obj
    StackIndex -> LuaE e ()
forall e. LuaError e => StackIndex -> LuaE e ()
rawset (CInt -> StackIndex
nth CInt
3)

-- | Pushes a pair of values as a two element list.
pushPair :: LuaError e
         => Pusher e a -> Pusher e b
         -> (a, b)
         -> LuaE e ()
pushPair :: Pusher e a -> Pusher e b -> (a, b) -> LuaE e ()
pushPair Pusher e a
pushA Pusher e b
pushB (a
a,b
b) = do
  LuaE e ()
forall e. LuaE e ()
newtable
  Pusher e a
pushA a
a
  StackIndex -> Integer -> LuaE e ()
forall e. LuaError e => StackIndex -> Integer -> LuaE e ()
rawseti (CInt -> StackIndex
nth CInt
2) Integer
1
  Pusher e b
pushB b
b
  StackIndex -> Integer -> LuaE e ()
forall e. LuaError e => StackIndex -> Integer -> LuaE e ()
rawseti (CInt -> StackIndex
nth CInt
2) Integer
2

-- | Pushes a value triple as a three element list.
pushTriple :: LuaError e
           => Pusher e a -> Pusher e b -> Pusher e c
           -> (a, b, c)
           -> LuaE e ()
pushTriple :: Pusher e a -> Pusher e b -> Pusher e c -> (a, b, c) -> LuaE e ()
pushTriple Pusher e a
pushA Pusher e b
pushB Pusher e c
pushC (a
a,b
b,c
c) = do
  LuaE e ()
forall e. LuaE e ()
newtable
  (LuaE e () -> Integer -> LuaE e ())
-> [LuaE e ()] -> [Integer] -> LuaE e ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\LuaE e ()
p Integer
i -> LuaE e ()
p LuaE e () -> LuaE e () -> LuaE e ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StackIndex -> Integer -> LuaE e ()
forall e. LuaError e => StackIndex -> Integer -> LuaE e ()
rawseti (CInt -> StackIndex
nth CInt
2) Integer
i)
            [Pusher e a
pushA a
a, Pusher e b
pushB b
b, Pusher e c
pushC c
c]
            [Integer
1..]