module Test.Framework.Runners.Console.Run (
showRunTestsTop
) where
import Test.Framework.Core
import Test.Framework.Improving
import Test.Framework.Runners.Console.Colors
import Test.Framework.Runners.Console.ProgressBar
import Test.Framework.Runners.Console.Statistics
import Test.Framework.Runners.Console.Utilities
import Test.Framework.Runners.Core
import Test.Framework.Runners.Statistics
import Test.Framework.Runners.TimedConsumption
import Test.Framework.Utilities
import System.Console.ANSI
import System.IO
import Text.PrettyPrint.ANSI.Leijen
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mempty)
#endif
import Control.Arrow (second, (&&&))
import Control.Monad (unless)
showRunTestsTop :: Bool -> Bool -> [RunningTest] -> IO [FinishedTest]
showRunTestsTop isplain hide_successes running_tests = (if isplain then id else hideCursorDuring) $ do
let test_statistics = initialTestStatistics (totalRunTestsList running_tests)
(test_statistics', finished_tests) <- showRunTests isplain hide_successes 0 test_statistics running_tests
putStrLn ""
putDoc $ possiblyPlain isplain $ showFinalTestStatistics test_statistics'
return finished_tests
showRunTest :: Bool -> Bool -> Int -> TestStatistics -> RunningTest -> IO (TestStatistics, FinishedTest)
showRunTest isplain hide_successes indent_level test_statistics (RunTest name test_type (SomeImproving improving_result)) = do
let progress_bar = testStatisticsProgressBar test_statistics
(property_text, property_suceeded) <- showImprovingTestResult isplain hide_successes indent_level name progress_bar improving_result
return (updateTestStatistics (\count -> adjustTestCount test_type count mempty) property_suceeded test_statistics, RunTest name test_type (property_text, property_suceeded))
showRunTest isplain hide_successes indent_level test_statistics (RunTestGroup name tests) = do
putDoc $ (indent indent_level (text name <> char ':')) <> linebreak
fmap (second $ RunTestGroup name) $ showRunTests isplain hide_successes (indent_level + 2) test_statistics tests
showRunTests :: Bool -> Bool -> Int -> TestStatistics -> [RunningTest] -> IO (TestStatistics, [FinishedTest])
showRunTests isplain hide_successes indent_level = mapAccumLM (showRunTest isplain hide_successes indent_level)
testStatisticsProgressBar :: TestStatistics -> Doc
testStatisticsProgressBar test_statistics = progressBar (colorPassOrFail no_failures) terminal_width (Progress run_tests total_tests)
where
run_tests = testCountTotal (ts_run_tests test_statistics)
total_tests = testCountTotal (ts_total_tests test_statistics)
no_failures = ts_no_failures test_statistics
terminal_width = 79
showImprovingTestResult :: TestResultlike i r => Bool -> Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)
showImprovingTestResult isplain hide_successes indent_level test_name progress_bar improving = do
(result, success) <- if isplain then return $ improvingLast improving'
else showImprovingTestResultProgress (return ()) indent_level test_name progress_bar improving'
unless (success && hide_successes) $ do
let (result_doc, extra_doc) | success = (brackets $ colorPass (text result), empty)
| otherwise = (brackets (colorFail (text "Failed")), text result <> linebreak)
putTestHeader indent_level test_name (possiblyPlain isplain result_doc)
putDoc extra_doc
return (result, success)
where
improving' = bimapImproving show (show &&& testSucceeded) improving
showImprovingTestResultProgress :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool)
showImprovingTestResultProgress erase indent_level test_name progress_bar improving = do
improving_list <- consumeListInInterval 200000 (consumeImproving improving)
case listToMaybeLast improving_list of
Nothing -> do
showImprovingTestResultProgress erase indent_level test_name progress_bar improving
Just improving' -> do
showImprovingTestResultProgress' erase indent_level test_name progress_bar improving'
showImprovingTestResultProgress' :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool)
showImprovingTestResultProgress' erase _ _ _ (Finished result) = do
erase
putStrLn ""
clearLine
cursorUpLine 1
return result
showImprovingTestResultProgress' erase indent_level test_name progress_bar (Improving intermediate rest) = do
erase
putTestHeader indent_level test_name (brackets (text intermediate))
putDoc progress_bar
hFlush stdout
showImprovingTestResultProgress (cursorUpLine 1 >> clearLine) indent_level test_name progress_bar rest
possiblyPlain :: Bool -> Doc -> Doc
possiblyPlain True = plain
possiblyPlain False = id
putTestHeader :: Int -> String -> Doc -> IO ()
putTestHeader indent_level test_name result = putDoc $ (indent indent_level (text test_name <> char ':' <+> result)) <> linebreak