{-
Copyright © 2017 Albert Krewinkel

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
-}
{-# LANGUAGE OverloadedStrings #-}
{-| Tests for lua -}
module Foreign.LuaTest (tests) where

import Prelude hiding (concat)

import Control.Applicative ((<|>), empty)
import Control.Monad (when)
import Data.ByteString (ByteString)
import Data.Either (isLeft, isRight)
import Data.Monoid ((<>))
import Foreign.Lua
import System.Mem (performMajorGC)
import Test.HsLua.Util (luaTestCase, pushLuaExpr)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assert, assertBool, assertEqual, testCase)

import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

-- | Specifications for Attributes parsing functions.
tests :: TestTree
tests = testGroup "lua integration tests"
  [ testCase "print version" .
    runLua $ do
      openlibs
      getglobal "assert"
      push ("Hello from " :: ByteString)
      getglobal "_VERSION"
      concat 2
      call 1 0

  , testCase "functions stored in / retrieved from registry" .
    runLua $ do
      pushLuaExpr "function() return 2 end, function() return 1 end"
      idx1 <- ref registryindex
      idx2 <- ref registryindex
      -- functions are removed from stack
      liftIO . assert =<< fmap (TFUNCTION /=) (ltype (-1))

      -- get functions from registry
      rawgeti registryindex idx1
      call 0 1
      r1 <- peek (-1) :: Lua LuaInteger
      liftIO (assert (r1 == 1))

      rawgeti registryindex idx2
      call 0 1
      r2 <- peek (-1) :: Lua LuaInteger
      liftIO (assert (r2 == 2))

      -- delete references
      unref registryindex idx1
      unref registryindex idx2

  , luaTestCase "getting a nested global works" $ do
      pushLuaExpr "{greeting = 'Moin'}"
      setglobal "hamburg"

      getglobal' "hamburg.greeting"
      pushLuaExpr "'Moin'"
      equal (-1) (-2)

  , testCase "table reading" .
    runLua $ do
      openbase
      let tableStr = "{firstname = 'Jane', surname = 'Doe'}"
      pushLuaExpr $ "setmetatable(" <> tableStr <> ", {'yup'})"
      getfield (-1) "firstname"
      firstname <- peek (-1) <* pop 1 :: Lua ByteString
      liftIO (assert (firstname == "Jane"))

      push ("surname" :: ByteString)
      rawget (-2)
      surname <- peek (-1) <* pop 1 :: Lua ByteString
      liftIO (assert (surname == "Doe"))

      hasMetaTable <- getmetatable (-1)
      liftIO (assert hasMetaTable)
      rawgeti (-1) 1
      mt1 <- peek (-1) <* pop 1 :: Lua ByteString
      liftIO (assert (mt1 == "yup"))

  , testGroup "stack values"
    [ testCase "unicode ByteString" $ do
        let val = T.pack "öçşiğüİĞı"
        val' <- runLua $ do
          pushstring (T.encodeUtf8 val)
          T.decodeUtf8 `fmap` tostring 1
        assertEqual "Popped a different value or pop failed" val val'

    , testCase "ByteString should survive after GC/Lua destroyed" $ do
        (val, val') <- runLua $ do
          let v = B.pack "ByteString should survive"
          pushstring v
          v' <- tostring 1
          pop 1
          return (v, v')
        performMajorGC
        assertEqual "Popped a different value or pop failed" val val'
    , testCase "String with NUL byte should be pushed/popped correctly" $ do
        let str = "A\NULB"
        str' <- runLua $ pushstring (B.pack str) *> tostring 1
        assertEqual "Popped string is different than what's pushed"
          str (B.unpack str')
    ]

  , testGroup "luaopen_* functions" $ map (uncurry testOpen)
    [ ("debug", opendebug)
    , ("io", openio)
    , ("math", openmath)
    , ("os", openos)
    , ("package", openpackage)
    , ("string", openstring)
    , ("table", opentable)
    ]
  , testGroup "luaopen_base returns the right number of tables" testOpenBase

  , testGroup "C functions"
    [ testCase "pushing a C function to and calling it from Lua" $
      -- Closures would usually be defined on the Haskell, unless the upvalues
      -- cannot be read from the stack.
      let greeter :: String -> HaskellFunction
          greeter greetee = do
            greeting <- peek (upvalueindex 1)
            push (greeting ++ (", " :: String) ++ greetee ++ ("!" :: String))
            return 1

          comp :: Lua String
          comp = do
            fn <- newCFunction (greeter "World")
            push ("Hello" :: String)
            pushcclosure fn 1
            call 0 multret
            freeCFunction fn
            peek (-1)

      in assertEqual "greeting function failed" (Right "Hello, World!") =<<
         runLuaEither comp
    ]

  , testGroup "error handling"
    [ testCase "lua errors are caught" $
      assertBool "error was not intercepted" . isLeft =<<
      runLuaEither (push True *> peek (-1) :: Lua String)

    , testCase "error-less code gives in 'Right' result" $
      assertBool "error was not intercepted" . isRight =<<
      runLuaEither (push True *> peek (-1) :: Lua Bool)

    , testCase "catching lua errors within the lua type" $
      assert . isLeft =<< (runLua $ tryLua (throwLuaError "test"))

    , testCase "second alternative is used when first fails" $
      assertEqual "alternative failed" (Right True) =<<
      runLuaEither (throwLuaError "test" <|> return True)

    , testCase "Applicative.empty implementation throws an exception" $
      assertBool "empty doesn't throw" . isLeft =<< runLuaEither empty

    , testCase "catching error of a failing meta method" $
      assertBool "compuation was expected to fail" . isLeft =<<
      let comp = do
            pushLuaExpr "setmetatable({}, {__index = error})"
            getfield (-1) "foo" :: Lua ()
      in runLuaEither comp

    , testCase "calling a function that errors throws exception" $
      let msg = "error message"
          luaCode = "return error('" ++ msg ++ "')"
          err =  "[string \"" ++ luaCode ++ "\"]:1: " ++ msg
          errTest x = x == (Left (LuaException msg)) || -- LuaJIT
                      x == (Left (LuaException err))    -- default Lua
      in assertBool "problem in error" . errTest =<<
      (runLuaEither $ do
          openbase
          res <- loadstring luaCode
          when (res == LuaOK) $ call 0 0)
    ]
  ]

--------------------------------------------------------------------------------
-- luaopen_* functions

testOpen :: String -> Lua () -> TestTree
testOpen lib openfn = testCase ("open" ++ lib) $
  assertBool "opening the library failed" =<<
  runLua (openfn *> istable (-1))

testOpenBase :: [TestTree]
testOpenBase = (:[]) .
  testCase "openbase" $
  assertBool "loading base didn't push the expected number of tables" =<<
  (runLua $ do
    -- openbase returns one table in lua 5.2 and later, but two in 5.1
    openbase
    getglobal "_VERSION"
    version <- peek (-1) <* pop 1
    if version == ("Lua 5.1" :: ByteString)
      then (&&) <$> istable (-1) <*> istable (-2)
      else istable (-1))