{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module      : Test.Tasty.Lua
Copyright   : © 2019–2020 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <albert+hslua@zeitkraut.de>
Stability   : alpha
Portability : Requires TemplateHaskell

Convert Lua test results into a tasty test trees.
-}
module Test.Tasty.Lua
  ( -- * Lua module
    pushModule
    -- * Running tests
  , testLuaFile
  , translateResultsFromFile
    -- * Helpers
  , pathFailure
  )
where

import Control.Exception (SomeException, try)
import Data.Bifunctor (first)
import Data.List (intercalate)
import Data.Semigroup (Semigroup (..))
import Foreign.Lua (Lua)
import Test.Tasty (TestName, TestTree)
import Test.Tasty.Providers (IsTest (..), singleTest, testFailed, testPassed)
import Test.Tasty.Lua.Module (pushModule)
import Test.Tasty.Lua.Core (Outcome (..), ResultTree (..), UnnamedTree (..),
                            runTastyFile)
import Test.Tasty.Lua.Translate (pathFailure, translateResultsFromFile)

-- | Run the given file as a single test. It is possible to use
-- `tasty.lua` in the script. This test collects and summarizes all
-- errors, but shows generally no information on the successful tests.
testLuaFile :: (forall a . Lua a -> IO a)
             -> TestName
             -> FilePath
             -> TestTree
testLuaFile :: (forall a. Lua a -> IO a) -> TestName -> TestName -> TestTree
testLuaFile forall a. Lua a -> IO a
runLua TestName
name TestName
fp =
  let testAction :: TestCase
testAction = IO ResultSummary -> TestCase
TestCase (IO ResultSummary -> TestCase) -> IO ResultSummary -> TestCase
forall a b. (a -> b) -> a -> b
$ do
        Either TestName [ResultTree]
eitherResult <- Lua (Either TestName [ResultTree])
-> IO (Either TestName [ResultTree])
forall a. Lua a -> IO a
runLua (TestName -> Lua (Either TestName [ResultTree])
runTastyFile TestName
fp)
        ResultSummary -> IO ResultSummary
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultSummary -> IO ResultSummary)
-> ResultSummary -> IO ResultSummary
forall a b. (a -> b) -> a -> b
$ case Either TestName [ResultTree]
eitherResult of
          Left TestName
errMsg  -> [FailureInfo] -> ResultSummary
FailureSummary [([TestName
name], TestName
errMsg)]
          Right [ResultTree]
result -> [ResultTree] -> ResultSummary
summarize [ResultTree]
result
  in TestName -> TestCase -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
singleTest TestName
name TestCase
testAction

-- | Lua test case action
newtype TestCase = TestCase (IO ResultSummary)

instance IsTest TestCase where
  run :: OptionSet -> TestCase -> (Progress -> IO ()) -> IO Result
run OptionSet
_ (TestCase IO ResultSummary
action) Progress -> IO ()
_ = do
    Either SomeException ResultSummary
result <- IO ResultSummary -> IO (Either SomeException ResultSummary)
forall e a. Exception e => IO a -> IO (Either e a)
try IO ResultSummary
action
    Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ case Either SomeException ResultSummary
result of
      Left SomeException
e        -> TestName -> Result
testFailed (SomeException -> TestName
forall a. Show a => a -> TestName
show (SomeException
e :: SomeException))
      Right ResultSummary
summary -> case ResultSummary
summary of
        SuccessSummary Int
n ->
          TestName -> Result
testPassed (TestName -> Result) -> TestName -> Result
forall a b. (a -> b) -> a -> b
$ TestName
"+++ Success: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
n TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" Lua tests passed"
        FailureSummary [FailureInfo]
fails ->
          TestName -> Result
testFailed (TestName -> Result) -> TestName -> Result
forall a b. (a -> b) -> a -> b
$ (FailureInfo -> TestName) -> [FailureInfo] -> TestName
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FailureInfo -> TestName
stringifyFailureGist [FailureInfo]
fails

  testOptions :: Tagged TestCase [OptionDescription]
testOptions = [OptionDescription] -> Tagged TestCase [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return []

summarize :: [ResultTree] -> ResultSummary
summarize :: [ResultTree] -> ResultSummary
summarize = (ResultTree -> ResultSummary -> ResultSummary)
-> ResultSummary -> [ResultTree] -> ResultSummary
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ResultSummary -> ResultSummary -> ResultSummary
forall a. Semigroup a => a -> a -> a
(<>) (ResultSummary -> ResultSummary -> ResultSummary)
-> (ResultTree -> ResultSummary)
-> ResultTree
-> ResultSummary
-> ResultSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultTree -> ResultSummary
collectSummary) (Int -> ResultSummary
SuccessSummary Int
0)

-- | Failure message generated by tasty.lua
type LuaErrorMessage = String
-- | Info about a single failure
type FailureInfo = ([TestName], LuaErrorMessage)

-- | Summary about a test result
data ResultSummary
  = SuccessSummary Int -- ^ Number of successful tests
  | FailureSummary [FailureInfo]
  -- ^ Failure messages, together with the test paths

-- | Convert a test failure, given as the pair of the test's path and
-- its error message, into an error string.
stringifyFailureGist :: FailureInfo -> String
stringifyFailureGist :: FailureInfo -> TestName
stringifyFailureGist ([TestName]
names, TestName
msg) =
  TestName -> [TestName] -> TestName
forall a. [a] -> [[a]] -> [a]
intercalate TestName
" // " [TestName]
names TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
":\n" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
msg TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
"\n\n"

-- | Combine all failures (or successes) from a test result tree into a
-- @'ResultSummary'@. If the tree contains only successes, the result
-- will be @'SuccessSummary'@ with the number of successful tests; if
-- there was at least one failure, the result will be
-- @'FailureSummary'@, with a @'FailureInfo'@ for each failure.
collectSummary :: ResultTree -> ResultSummary
collectSummary :: ResultTree -> ResultSummary
collectSummary (ResultTree TestName
name UnnamedTree
tree) =
  case UnnamedTree
tree of
    SingleTest Outcome
Success       -> Int -> ResultSummary
SuccessSummary Int
1
    SingleTest (Failure TestName
msg) -> [FailureInfo] -> ResultSummary
FailureSummary [([TestName
name], TestName
msg)]
    TestGroup [ResultTree]
subtree        -> (ResultTree -> ResultSummary) -> [ResultTree] -> ResultSummary
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (TestName -> ResultSummary -> ResultSummary
addGroup TestName
name (ResultSummary -> ResultSummary)
-> (ResultTree -> ResultSummary) -> ResultTree -> ResultSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultTree -> ResultSummary
collectSummary)
                                        [ResultTree]
subtree

-- | Add the name of the current test group to all failure summaries.
addGroup :: TestName -> ResultSummary -> ResultSummary
addGroup :: TestName -> ResultSummary -> ResultSummary
addGroup TestName
name  (FailureSummary [FailureInfo]
fs) = [FailureInfo] -> ResultSummary
FailureSummary ((FailureInfo -> FailureInfo) -> [FailureInfo] -> [FailureInfo]
forall a b. (a -> b) -> [a] -> [b]
map (([TestName] -> [TestName]) -> FailureInfo -> FailureInfo
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TestName
nameTestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
:)) [FailureInfo]
fs)
addGroup TestName
_name ResultSummary
summary             = ResultSummary
summary

instance Semigroup ResultSummary where
  (SuccessSummary Int
n)  <> :: ResultSummary -> ResultSummary -> ResultSummary
<> (SuccessSummary Int
m)  = Int -> ResultSummary
SuccessSummary (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m)
  (SuccessSummary Int
_)  <> (FailureSummary [FailureInfo]
fs) = [FailureInfo] -> ResultSummary
FailureSummary [FailureInfo]
fs
  (FailureSummary [FailureInfo]
fs) <> (SuccessSummary Int
_)  = [FailureInfo] -> ResultSummary
FailureSummary [FailureInfo]
fs
  (FailureSummary [FailureInfo]
fs) <> (FailureSummary [FailureInfo]
gs) = [FailureInfo] -> ResultSummary
FailureSummary ([FailureInfo]
fs [FailureInfo] -> [FailureInfo] -> [FailureInfo]
forall a. [a] -> [a] -> [a]
++ [FailureInfo]
gs)

instance Monoid ResultSummary where
  mempty :: ResultSummary
mempty = Int -> ResultSummary
SuccessSummary Int
0
  mappend :: ResultSummary -> ResultSummary -> ResultSummary
mappend = ResultSummary -> ResultSummary -> ResultSummary
forall a. Semigroup a => a -> a -> a
(<>)             -- GHC 8.2 compatibility