content: {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TypeApplications #-}
  {-|
  Module      : HsLua.Marshalling.PushTests
  Copyright   : © 2020-2024 Albert Krewinkel
  License     : MIT
  Maintainer  : Albert Krewinkel <tarleb@hslua.org>
  Stability   : alpha
  Portability : OverloadedStrings, TypeApplications
  
  Test pushing Haskell values to the stack.
  -}
  module HsLua.Marshalling.PushTests (tests) where
  
  import Control.Monad (forM)
  import Data.ByteString (ByteString)
  import Data.Maybe (fromMaybe)
  import HsLua.Core (Lua, Number)
  import HsLua.Marshalling.Push
  
  import Lua.Arbitrary ()
  import Test.Tasty.HsLua ((=:), pushLuaExpr)
  import Test.QuickCheck.Instances ()
  import Test.QuickCheck.Monadic (monadicIO, run, assert)
  import Test.Tasty (TestTree, testGroup)
  import Test.Tasty.HUnit (Assertion, assertFailure)
  import Test.Tasty.QuickCheck (Arbitrary, testProperty)
  
  import qualified Data.Map as Map
  import qualified Data.Set as Set
  import qualified HsLua.Core as Lua
  import qualified HsLua.Core.Utf8 as Utf8
  
  -- | Calling Haskell functions from Lua.
  tests :: TestTree
  tests = testGroup "Push"
    [ testGroup "pushBool"
      [ "True" =:
        assertLuaEqual (pushBool True) "true"
      , "False" =:
        assertLuaEqual (pushBool False) "false"
  
      , testSingleElementProperty pushBool
      ]
  
    , testGroup "pushIntegral"
      [ testGroup "@Int"
        [ "0" =:
          assertLuaEqual (pushIntegral @Int 0) "0"
        , "23" =:
          assertLuaEqual (pushIntegral @Int 23) "23"
        , "-5" =:
          assertLuaEqual (pushIntegral @Int (-5)) "-5"
        , testSingleElementProperty (pushIntegral @Int)
        ]
      , testGroup "@Integer"
        [ "2^128 + 1" =:
          assertLuaEqual (pushIntegral @Integer
                           340282366920938463463374607431768211457)
                         "'340282366920938463463374607431768211457'"
        , "-2^129 + 1" =:
          assertLuaEqual (pushIntegral @Integer
                          (-680564733841876926926749214863536422911))
                         "'-680564733841876926926749214863536422911'"
        , testSingleElementProperty (pushIntegral @Integer)
        ]
      ]
  
    , testGroup "pushRealFloat"
      [ testGroup "@Number"
        [ "0.0" =:
          assertLuaEqual (pushRealFloat @Number 0.0) "0.0"
        , "42.0" =:
          assertLuaEqual (pushRealFloat @Number 42.0) "42.0"
        , "0.1" =:
          assertLuaEqual (pushRealFloat @Number 0.1) "0.1"
        , "-13.37" =:
          assertLuaEqual (pushRealFloat @Number (-13.37)) "-13.37"
        , testSingleElementProperty (pushRealFloat @Number)
        ]
  
      -- This test may fail if Lua is compiled with Float as the Number
      -- type. Usually though, numbers are doubles.
      , testGroup "@Float pushes strings"
        [ "0.0" =:
          assertLuaEqual (pushRealFloat @Float 0.0) "'0.0'"
        , "42.0" =:
          assertLuaEqual (pushRealFloat @Float 42.0) "'42.0'"
        , "-0.00071" =:
          assertLuaEqual (pushRealFloat @Float (-0.00071)) "'-7.1e-4'"
        , "-13.37" =:
          assertLuaEqual (pushRealFloat @Float (-13.37)) "'-13.37'"
        , testSingleElementProperty (pushRealFloat @Float)
        ]
      ]
  
    , testGroup "Strings"
      [ testGroup "pushByteString"
        [ "\"test\"" =:
          assertLuaEqual (pushByteString "test") "\"test\""
        , testSingleElementProperty pushByteString
        ]
  
      , testGroup "pushString"
        [ "\"test\"" =:
          assertLuaEqual (pushString "test") "\"test\""
        , "unicode" =:
          assertLuaEqual (pushString "ÄÉÏøûßð") (Utf8.fromString "'ÄÉÏøûßð'")
        , testSingleElementProperty pushString
        ]
  
      , testGroup "pushText"
        [ "\"test\"" =:
          assertLuaEqual (pushText "test") "\"test\""
        , "unicode" =:
          assertLuaEqual (pushText "ÄÉÏøûßð") (Utf8.fromString "'ÄÉÏøûßð'")
        , testSingleElementProperty pushText
        ]
  
      , testGroup "pushName"
        [ "\"test\"" =:
          assertLuaEqual (pushName "test") "\"test\""
        , "unicode" =:
          assertLuaEqual (pushName "ÄÉÏøûßð") (Utf8.fromString "'ÄÉÏøûßð'")
        , testSingleElementProperty (pushName . Lua.Name)
        ]
      ]
  
    , testGroup "Collections"
      [ testGroup "pushList"
        [ testProperty "creates a table" $ \x -> monadicIO $ do
            producesTable <- run $ Lua.run @Lua.Exception $ do
              pushList pushBool x
              listType <- Lua.ltype Lua.top
              return $ Lua.TypeTable == listType
            assert producesTable
  
        , testProperty "numeric indices start at 1" $ \list -> monadicIO $ do
            retrievedList <- run $ Lua.run @Lua.Exception $ do
              pushList (pushIntegral @Lua.Integer) list
              listIdx <- Lua.absindex Lua.top
              forM [1..(fromIntegral $ length list)] $ \n ->
                Lua.rawgeti listIdx n
                *> (fromMaybe 0 <$> Lua.tointeger Lua.top)
                <* Lua.pop 1
            assert $ retrievedList == list
  
        , testProperty "table size equals list length" $ \list -> monadicIO $ do
            tableSize <- run $ Lua.run @Lua.Exception $ do
              pushList pushString list
              Lua.rawlen Lua.top
            assert $ tableSize == length list
  
        , testSingleElementProperty (pushList pushText)
        ]
  
      , testGroup "pushNonEmpty"
        [ testProperty "table size equals list length" $ \list -> monadicIO $ do
            tableSize <- run $ Lua.run @Lua.Exception $ do
              pushNonEmpty pushString list
              Lua.rawlen Lua.top
            assert $ tableSize == length list
        ]
  
      , testGroup "pushKeyValuePairs"
        [ testProperty "creates a table" $ \x -> monadicIO $ do
            producesTable <- run $ Lua.run @Lua.Exception $ do
              pushKeyValuePairs pushText (pushIntegral @Int) x
              listType <- Lua.ltype Lua.top
              return $ Lua.TypeTable == listType
            assert producesTable
  
        , testSingleElementProperty $
          pushKeyValuePairs (pushIntegral @Int) pushText
        ]
  
      , testGroup "pushSet"
        [ testProperty "creates a table" $ \x -> monadicIO $ do
            producesTable <- run $ Lua.run @Lua.Exception $ do
              pushSet pushString x
              listType <- Lua.ltype Lua.top
              return $ Lua.TypeTable == listType
            assert producesTable
  
        , testProperty "set values become table keys" $ \set -> monadicIO $
            case Set.lookupMin set of
              Nothing -> return ()
              Just el -> do
                hasKey <- run $ Lua.run @Lua.Exception $ do
                  pushSet (pushIntegral @Lua.Integer) set
                  pushIntegral el
                  Lua.gettable (Lua.nth 2)
                  Lua.toboolean Lua.top
                assert hasKey
  
        , testSingleElementProperty (pushSet pushText)
        ]
  
      , testGroup "pushMap"
        [ testProperty "creates a table" $ \m -> monadicIO $ do
            producesTable <- run $ Lua.run @Lua.Exception $ do
              pushMap pushString pushString m
              listType <- Lua.ltype Lua.top
              return $ Lua.TypeTable == listType
            assert producesTable
  
        , testProperty "pairs are in table" $ \m -> monadicIO $
            case Map.lookupMax m of
              Nothing -> return ()
              Just (k, v) -> do
                tabVal <- run $ Lua.run @Lua.Exception $ do
                  pushMap pushText (pushRealFloat @Lua.Number) m
                  pushText k
                  Lua.gettable (Lua.nth 2)
                  fromMaybe (error "key not found") <$>
                    Lua.tonumber Lua.top
                assert (tabVal == v)
  
        , testSingleElementProperty (pushMap pushText (pushRealFloat @Double))
        ]
      ]
    , testGroup "Combinators"
      [ testProperty "pushPair" $ \(a, b) -> monadicIO $ do
          mpair <- run $ Lua.run @Lua.Exception $ do
            pushPair pushIntegral pushByteString (a, b)
            ma <- Lua.rawgeti Lua.top 1 *> Lua.tointeger Lua.top <* Lua.pop 1
            mb <- Lua.rawgeti Lua.top 2 *> Lua.tostring Lua.top  <* Lua.pop 1
            return $ (,) <$> ma <*> mb
          assert (mpair == Just (a, b))
  
      , testProperty "pushTriple" $ \(a, b, c) -> monadicIO $ do
          mpair <- run $ Lua.run @Lua.Exception $ do
            pushTriple pushIntegral pushByteString Lua.pushnumber (a, b, c)
            ma <- Lua.rawgeti Lua.top 1 *> Lua.tointeger Lua.top <* Lua.pop 1
            mb <- Lua.rawgeti Lua.top 2 *> Lua.tostring Lua.top  <* Lua.pop 1
            mc <- Lua.rawgeti Lua.top 3 *> Lua.tonumber Lua.top  <* Lua.pop 1
            return $ (,,) <$> ma <*> mb <*> mc
          assert (mpair == Just (a, b, c))
  
      , testProperty "pushAsTable" $ \(a, b) -> monadicIO $ do
          mpair <- run $ Lua.run @Lua.Exception $ do
            let fields = [ ("int", Lua.pushinteger . fst)
                         , ("str", Lua.pushstring . snd)
                         ]
            pushAsTable fields (a, b)
            ma <- Lua.getfield Lua.top "int" *> Lua.tointeger Lua.top <* Lua.pop 1
            mb <- Lua.getfield Lua.top "str" *> Lua.tostring Lua.top  <* Lua.pop 1
            return $ (,) <$> ma <*> mb
          assert (mpair == Just (a, b))
      ]
    ]
  
  -- | Executes a Lua action and checks whether a the value at the top of the
  -- stack equals the value represented by the string.
  assertLuaEqual :: Lua () -> ByteString -> Assertion
  assertLuaEqual action lit =
    let comparison = Lua.run $ do
          action
          pushLuaExpr lit
          isSame <- Lua.rawequal (Lua.nth 1) (Lua.nth 2)
          if isSame
            then return Nothing
            else do
              expectedType <- Lua.ltype (Lua.nth 1) >>= Lua.typename
              actualType <- Lua.ltype (Lua.nth 2) >>= Lua.typename
              actual <- Lua.tostring' (Lua.nth 2)
              return . Just . Utf8.toString $
                "Expected '" <> lit <> "' (" <> expectedType <>
                ") but got '" <> actual <> "'" <> " (" <> actualType <> ")"
    in comparison >>= \case
      Nothing -> return ()
      Just err -> assertFailure err
  
  
  -- | Verifies that the operation adds exactly one element to the Lua stack.
  testSingleElementProperty :: (Arbitrary a, Show a)
                            => Pusher Lua.Exception a -> TestTree
  testSingleElementProperty push = testProperty "pushes single element" $ \x ->
    monadicIO $ do
      (oldSize, newSize) <- run . Lua.run $ do
        old <- Lua.gettop
        push x
        new <- Lua.gettop
        return (old, new)
      assert (newSize == succ oldSize)
  