Lua.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module      : Test.Tasty.Lua
Copyright   : © 2019 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.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 runLua name fp =
  let testAction = TestCase $ do
        eitherResult <- runLua (runTastyFile fp)
        return $ case eitherResult of
          Left errMsg  -> FailureSummary [([name], errMsg)]
          Right result -> summarize result
  in singleTest name testAction

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

instance IsTest TestCase where
  run _ (TestCase action) _ = do
    result <- try action
    return $ case result of
      Left e        -> testFailed (show (e :: SomeException))
      Right summary -> case summary of
        SuccessSummary n ->
          testPassed $ "+++ Success: " ++ show n ++ " Lua tests passed"
        FailureSummary fails ->
          testFailed $ concatMap stringifyFailureGist fails

  testOptions = return []

summarize :: [ResultTree] -> ResultSummary
summarize = foldr ((<>) . collectSummary) (SuccessSummary 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 (names, msg) =
  intercalate " // " names ++ ":\n" ++ msg ++ "\n\n"

-- | Extract all failures from a test result tree.
collectSummary :: ResultTree -> ResultSummary
collectSummary (ResultTree name tree) =
  case tree of
    SingleTest Success       -> SuccessSummary 1
    SingleTest (Failure msg) -> FailureSummary [([name], msg)]
    TestGroup subtree        -> foldr go (SuccessSummary 0) subtree
      where go r summary = collectSummary r <> addGroup name summary

addGroup :: TestName -> ResultSummary -> ResultSummary
addGroup name (FailureSummary fs) = FailureSummary (map addName fs)
  where addName (names, msg) = (name : names, msg)
addGroup _name summary = summary

instance Semigroup ResultSummary where
  (SuccessSummary n)  <> (SuccessSummary m)  = SuccessSummary (n + m)
  (SuccessSummary _)  <> (FailureSummary fs) = FailureSummary fs
  (FailureSummary fs) <> (SuccessSummary _)  = FailureSummary fs
  (FailureSummary fs) <> (FailureSummary gs) = FailureSummary (fs ++ gs)