{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Tasty.Runners.Reporter
( ingredient,
SkippingTests (TestSkipped, TestOnly),
OnlyTestResult (OnlyTestPassed, OnlyTestFailed),
)
where
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception.Safe as Exception
import Control.Exception.Safe (displayException)
import Control.Monad (Monad)
import Control.Monad.IO.Class (liftIO)
import qualified Control.Monad.State as State
import Data.Function ((&))
import qualified Data.IntMap as IntMap
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid (mappend, mempty), Sum (getSum))
import Data.Proxy (Proxy (Proxy))
import Data.Semigroup
import Data.String (fromString)
import Data.Tagged (Tagged (Tagged))
import qualified Data.Text as Text
import Data.Text (Text)
import Data.Typeable (Typeable)
import Numeric (showFFloat)
import System.Console.ANSI (hSupportsANSIColor)
import System.Console.Concurrent (outputConcurrent, withConcurrentOutput)
import System.Directory (canonicalizePath, createDirectoryIfMissing)
import System.FilePath (FilePath, takeDirectory)
import System.IO (stdout)
import Test.Console.Color (Style, Styled, black, green, grey, red, styled, underlined, unlines, unstyled, yellow)
import qualified Test.Tasty as Tasty
import qualified Test.Tasty.Options as Tasty
import qualified Test.Tasty.Runners as Tasty
import qualified Text.XML.JUnit as JUnit
import Prelude hiding (unlines)
ingredient :: Tasty.Ingredient
ingredient =
Tasty.TestReporter optionDescription $ \options testTree ->
Tasty.lookupOption options
& runner options testTree
& Just
data SkippingTests = TestSkipped | TestOnly OnlyTestResult deriving (Show)
instance Exception.Exception SkippingTests
data OnlyTestResult
= OnlyTestPassed String
| OnlyTestFailed String
deriving (Show)
newtype JunitXMLPath = JunitXMLPath FilePath
deriving (Typeable)
instance Tasty.IsOption (Maybe JunitXMLPath) where
defaultValue = Nothing
parseValue = Just . Just . JunitXMLPath
optionName = Tagged "xml"
optionHelp = Tagged "A file path to store the test results in JUnit-compatible XML"
data Summary
= Summary
{ failures :: Sum Int,
errors :: Sum Int,
successes :: Sum Int,
skipped :: Sum Int,
hasOnly :: Bool,
testSuites :: [JUnit.TestSuite]
}
instance Monoid Summary where
mempty =
Summary
{ failures = mempty,
errors = mempty,
successes = mempty,
skipped = mempty,
hasOnly = False,
testSuites = mempty
}
instance Semigroup Summary where
a <> b =
Summary
{ failures = failures a <> failures b,
errors = errors a <> errors b,
successes = successes a <> successes b,
skipped = skipped a <> skipped b,
hasOnly = hasOnly a || hasOnly b,
testSuites = testSuites a <> testSuites b
}
newtype TraversalT m a = TraversalT {appTraversalT :: m a}
instance (Monad m, Monoid a) => Monoid (TraversalT m a) where
mempty = TraversalT (pure mempty)
instance (Monad m, Semigroup a) => Semigroup (TraversalT m a) where
TraversalT f1 <> TraversalT f2 = TraversalT $ do
a <- f1
b <- f2
pure (a <> b)
type StateIO = State.StateT IntMap.Key IO
newtype GroupNames = GroupNames [Text]
deriving (Monoid, Semigroup)
optionDescription :: [Tasty.OptionDescription]
optionDescription = [Tasty.Option (Proxy :: Proxy (Maybe JunitXMLPath))]
runner ::
Tasty.OptionSet ->
Tasty.TestTree ->
Maybe JunitXMLPath ->
IntMap.IntMap (STM.TVar Tasty.Status) ->
IO (Tasty.Time -> IO Bool)
runner options testTree path statusMap = withConcurrentOutput $ do
(summary, _) <-
Tasty.foldTestTree
Tasty.trivialFold
{ Tasty.foldSingle = runTest statusMap,
#if MIN_VERSION_tasty(1,4,0)
Tasty.foldGroup = \_ -> runGroup
#else
Tasty.foldGroup = runGroup
#endif
}
options
testTree
& (\x -> x mempty)
& appTraversalT
& (\x -> State.runStateT x 0)
pure (createOutputs summary path)
createOutputs :: Summary -> Maybe JunitXMLPath -> Tasty.Time -> IO Bool
createOutputs summary@Summary {errors, failures, testSuites, hasOnly} maybePath elapsedTime = do
printSummary summary elapsedTime
case maybePath of
Nothing -> pure ()
Just (JunitXMLPath path) -> do
createPathDirIfMissing path
JUnit.writeXmlReport path testSuites
pure (getSum (failures `mappend` errors) == 0 && not hasOnly)
runTest ::
IntMap.IntMap (STM.TVar Tasty.Status) ->
o ->
Tasty.TestName ->
t ->
GroupNames ->
TraversalT StateIO Summary
runTest statusMap _ testName_ _ groupNames = TraversalT $ do
let testName = Text.pack testName_
index <- State.get
result <- liftIO $ STM.atomically $ do
status <-
IntMap.lookup index statusMap
& fromMaybe (error "Attempted to lookup test by index outside bounds")
& STM.readTVar
case status of
Tasty.Done result -> pure result
_ -> STM.retry
_ <- State.modify (+ 1)
liftIO (resultToSummary groupNames testName result)
resultToSummary :: GroupNames -> Text -> Tasty.Result -> IO Summary
resultToSummary groupNames testName Tasty.Result {Tasty.resultOutcome, Tasty.resultTime, Tasty.resultDescription} =
case resultOutcome of
Tasty.Success ->
mempty
{ testSuites =
[ JUnit.passed testName
& JUnit.time resultTime
& inSuite groupNames
],
successes = Sum 1
}
& pure
Tasty.Failure (Tasty.TestThrewException err) ->
case Exception.fromException err of
Just TestSkipped -> do
printLines
[ prettyPath [yellow] testName groupNames_,
"Test was skipped",
"\n"
]
mempty
{ testSuites =
[ JUnit.skipped testName
& inSuite groupNames
],
skipped = Sum 1
}
& pure
Just (TestOnly (OnlyTestPassed _)) -> do
let errorMessage =
unlines
[ "This test passed, but there is a `Test.only` in your test.",
"I failed the test, because it's easy to forget to remove `Test.only`."
]
printLines
[ prettyPath [red] testName groupNames_,
errorMessage,
"\n"
]
mempty
{ testSuites =
[ JUnit.errored testName
& JUnit.time resultTime
& JUnit.errorMessage (unstyled errorMessage)
& inSuite groupNames
],
hasOnly = True,
successes = Sum 1
}
& pure
Just (TestOnly (OnlyTestFailed str)) -> do
printLines
[ prettyPath [red] testName groupNames_,
fromString str,
"\n"
]
mempty
{ testSuites =
[ JUnit.failed testName
& JUnit.failureMessage "This test failed and contains a `Test.only. `Test.only` will also fail your build even if the test passes."
& JUnit.stderr (Text.pack str)
& JUnit.time resultTime
& inSuite groupNames
],
errors = Sum 1
}
& pure
_ -> do
let errorMessage = "Test threw an exception"
printLines
[ prettyPath [red] testName groupNames_,
errorMessage,
fromString (displayException err),
"\n"
]
mempty
{ testSuites =
[ JUnit.errored testName
& JUnit.stderr (Text.pack (displayException err))
& JUnit.errorMessage (unstyled errorMessage)
& JUnit.time resultTime
& inSuite groupNames
],
errors = Sum 1
}
& pure
Tasty.Failure (Tasty.TestTimedOut _) ->
mempty
{ testSuites =
[ JUnit.errored testName
& JUnit.errorMessage "Test timed out"
& JUnit.time resultTime
& inSuite groupNames
],
errors = Sum 1
}
& pure
Tasty.Failure _ -> do
printLines
[ prettyPath [red] testName groupNames_,
fromString resultDescription,
"\n"
]
mempty
{ testSuites =
[ JUnit.failed testName
& JUnit.stderr ("Test result:\n\n" <> Text.pack resultDescription)
& JUnit.time resultTime
& inSuite groupNames
],
failures = Sum 1
}
& pure
where
(GroupNames groupNames_) = groupNames
runGroup ::
String ->
(GroupNames -> TraversalT StateIO Summary) ->
GroupNames ->
TraversalT StateIO Summary
runGroup groupName children (GroupNames groupNames) =
Text.pack groupName : groupNames
& GroupNames
& children
& appTraversalT
& TraversalT
printSummary :: Summary -> Tasty.Time -> IO ()
printSummary Summary {failures, errors, successes, skipped, hasOnly} duration = do
color <- hSupportsANSIColor stdout
[ -- Title "TEST RUN ..."
if hasOnly
then
styled [yellow, underlined] "TEST RUN INCOMPLETE"
<> styled [yellow] " because there is an `only` in your tests."
else
if failedTestsTotal > 0
then styled [red, underlined] "TEST RUN FAILED"
else
if skippedTestsTotal > 0
then
styled [yellow, underlined] "TEST RUN INCOMPLETE"
<> if skippedTestsTotal == 1
then styled [yellow] (" because there was " <> fromInt skippedTestsTotal <> " test skipped.")
else styled [yellow] (" because there were " <> fromInt skippedTestsTotal <> " tests skipped.")
else styled [green, underlined] "TEST RUN PASSED",
"\n\n",
-- Infos
-- Duration: 0.001s
-- Passed: 23
-- Skipped: 1
-- Failed: 0
styled [black] ("Duration: " <> showTime duration <> "s"),
"\n",
styled [black] ("Passed: " <> fromInt (getSum successes)),
"\n",
if skippedTestsTotal > 0
then styled [black] ("Skipped: " <> fromInt skippedTestsTotal <> "\n")
else "",
styled [black] ("Failed: " <> fromInt failedTestsTotal),
"\n\n"
]
& mconcat
& if color then outputConcurrent else outputConcurrent . unstyled
where
failedTestsTotal = getSum (failures <> errors)
skippedTestsTotal = getSum skipped
prettyPath :: Style -> Text -> [Text] -> Styled Text
prettyPath style name path =
mconcat
[ reverse path
& map (styled [grey] . (<>) "↓ ")
& unlines,
styled style ("✗ " <> name) <> "\n"
]
inSuite :: GroupNames -> JUnit.TestReport outcome -> JUnit.TestSuite
inSuite (GroupNames groupNames) = JUnit.inSuite (Text.intercalate "." groupNames)
printLines :: [Styled Text] -> IO ()
printLines ts = do
color <- hSupportsANSIColor stdout
if color
then outputConcurrent (unlines ts)
else outputConcurrent (unstyled $ unlines ts)
timeDigits :: Num p => p
timeDigits = 3
showTime :: Tasty.Time -> Text
showTime time = Text.pack (showFFloat (Just timeDigits) time "")
fromInt :: Int -> Text
fromInt = Text.pack . Prelude.show
createPathDirIfMissing :: FilePath -> IO ()
createPathDirIfMissing path = do
dirPath <- fmap takeDirectory (canonicalizePath path)
createDirectoryIfMissing True dirPath