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
import Data.Monoid (mempty)
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