Lua.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
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
  , testFileWith
  , testsFromFile
    -- * Helpers
  , pathFailure
  )
where

import Control.Exception (throw, try)
import Control.Monad (void)
import Data.ByteString (ByteString)
import Data.FileEmbed
import Data.List (intercalate)
import Foreign.Lua (Lua, NumResults, Peekable, StackIndex)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text.Encoding
import qualified Foreign.Lua as Lua
import qualified Test.Tasty as Tasty
import qualified Test.Tasty.Providers as Tasty

-- | 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.
testFileWith :: FilePath -> (forall a . Lua a -> IO a) -> Tasty.TestTree
testFileWith fp runLua =
  let testAction = TestCase $ do
        result <- runLua (runTastyFile fp)
        case result >>= failuresMessage of
          Left errMsg -> throw (Lua.Exception errMsg)
          Right _     -> return ()
  in Tasty.singleTest fp testAction

newtype TestCase = TestCase (IO ())

instance Tasty.IsTest TestCase where
  run _ (TestCase action) _ = do
    result <- try action
    return $ case result of
      Left (Lua.Exception message) -> Tasty.testFailed message
      Right ()                     -> Tasty.testPassed ""

  testOptions = return []

-- | Run tasty.lua tests from the given file.
testsFromFile :: FilePath -> Lua Tasty.TestTree
testsFromFile fp = do
  result <- runTastyFile fp
  case result of
    Left errMsg -> return $ pathFailure fp errMsg
    Right tree  -> return $ Tasty.testGroup fp $ map testTree tree

-- | Run a tasty Lua script from a file and return either the resulting
-- test tree or the error message.
runTastyFile :: FilePath -> Lua (Either String [Tree])
runTastyFile fp = do
  Lua.openlibs
  Lua.requirehs "tasty" (void pushModule)
  res <- Lua.dofile fp
  if res == Lua.OK
    then Right <$> Lua.peekList Lua.stackTop
    else Left . toString <$> Lua.tostring' Lua.stackTop

-- | Generate a single error message from all failures in a test tree.
failuresMessage :: [Tree] -> Either String ()
failuresMessage tree =
  case mapM collectFailureMessages tree of
    Nothing   -> return ()
    Just errs -> Left $ concatMap (concatMap stringifyFailureGist) errs

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

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

-- | Extract all failures from a test result tree.
collectFailureMessages :: Tree -> Maybe [FailureGist]
collectFailureMessages (Tree name tree) =
  case tree of
    SingleTest Success       -> Nothing
    SingleTest (Failure msg) -> Just [([name], msg)]
    TestGroup subtree        -> foldr go Nothing subtree
      where go tree' acc = case acc of
              Nothing   -> collectFailureMessages tree'
              Just errs -> case collectFailureMessages tree' of
                             Nothing -> Just errs
                             Just x  -> Just (x ++ errs)

-- | Tasty Lua script
tastyScript :: ByteString
tastyScript = $(embedFile "tasty.lua")

-- | Push the Aeson module on the Lua stack.
pushModule :: Lua NumResults
pushModule = do
  result <- Lua.dostring tastyScript
  if result == Lua.OK
    then return 1
    else Lua.throwTopMessage
{-# INLINABLE pushModule #-}

-- | Report failure of testing a path.
pathFailure :: FilePath -> String -> Tasty.TestTree
pathFailure fp errMsg = Tasty.singleTest fp (Failure errMsg)

-- | Convert internal (tasty.lua) tree format into Tasty tree.
testTree :: Tree -> Tasty.TestTree
testTree (Tree name tree) =
  case tree of
    SingleTest outcome -> Tasty.singleTest name outcome
    TestGroup results  -> Tasty.testGroup name (map testTree results)

data Tree = Tree Tasty.TestName UnnamedTree

instance Peekable Tree where
  peek idx = do
    name   <- Lua.getfield idx "name"   *> Lua.popValue
    result <- Lua.getfield idx "result" *> Lua.popValue
    return $ Tree name result

instance Tasty.IsTest Outcome where
  run _ tr _ = return $ case tr of
    Success     -> Tasty.testPassed ""
    Failure msg -> Tasty.testFailed msg
  testOptions = return []

-- | Either a raw test outcome, or a nested @'Tree'@.
data UnnamedTree
  = SingleTest Outcome
  | TestGroup [Tree]

instance Peekable UnnamedTree where
  peek = peekTree

peekTree :: StackIndex -> Lua UnnamedTree
peekTree idx = do
  ty <- Lua.ltype idx
  case ty of
    Lua.TypeTable   -> TestGroup   <$> Lua.peekList idx
    _               -> SingleTest  <$> Lua.peek idx

-- | Test outcome
data Outcome = Success | Failure String

instance Peekable Outcome where
  peek idx = do
    ty <- Lua.ltype idx
    case ty of
      Lua.TypeString  -> Failure <$> Lua.peek idx
      Lua.TypeBoolean -> do
        b <- Lua.peek idx
        return $ if b then Success else Failure "???"
      _ -> do
        s <- toString <$> Lua.tostring' idx
        Lua.throwException ("not a test result: " ++ s)

-- | Convert UTF8-encoded @'ByteString'@ to a @'String'@.
toString :: ByteString -> String
toString = Text.unpack . Text.Encoding.decodeUtf8