moduleTest.Framework.Runners.Console(defaultMain,defaultMainWithArgs,defaultMainWithOpts)whereimportTest.Framework.CoreimportTest.Framework.ImprovingimportTest.Framework.OptionsimportTest.Framework.Runners.Console.ColorsimportTest.Framework.Runners.Console.ProgressBarimportTest.Framework.Runners.Console.StatisticsimportTest.Framework.Runners.Console.UtilitiesimportTest.Framework.Runners.CoreimportTest.Framework.Runners.OptionsimportTest.Framework.Runners.ProcessorsimportTest.Framework.Runners.TimedConsumptionimportTest.Framework.SeedimportTest.Framework.UtilitiesimportSystem.Console.ANSIimportSystem.Console.GetOptimportSystem.EnvironmentimportSystem.ExitimportSystem.IOimportText.PrettyPrint.ANSI.LeijenimportData.ListimportData.MaybeimportData.MonoidimportControl.MonadinstanceFunctorOptDescrwherefmapf(Optionabarg_descrc)=Optionab(fmapfarg_descr)cinstanceFunctorArgDescrwherefmapf(NoArga)=NoArg(fa)fmapf(ReqArggs)=ReqArg(f.g)sfmapf(OptArggs)=OptArg(f.g)s-- | @Nothing@ signifies that usage information should be displayed.-- @Just@ simply gives us the contribution to overall options by the command line option.typeSuppliedRunnerOptions=MaybeRunnerOptionsoptionsDescription::[OptDescrSuppliedRunnerOptions]optionsDescription=[Option[]["help"](NoArgNothing)"show this help message"]++map(fmapJust)[Option['j']["threads"](ReqArg(\t->mempty{ropt_threads=Just(readt)})"NUMBER")"number of threads to use to run tests",Option[]["test-seed"](ReqArg(\t->mempty{ropt_test_options=Just(mempty{topt_seed=Just(readt)})})("NUMBER|"++showRandomSeed))"default seed for test random number generator",Option['a']["maximum-generated-tests"](ReqArg(\t->mempty{ropt_test_options=Just(mempty{topt_maximum_generated_tests=Just(readt)})})"NUMBER")"how many automated tests something like QuickCheck should try, by default",Option[]["maximum-unsuitable-generated-tests"](ReqArg(\t->mempty{ropt_test_options=Just(mempty{topt_maximum_unsuitable_generated_tests=Just(readt)})})"NUMBER")"how many unsuitable candidate tests something like QuickCheck should endure before giving up, by default",Option['o']["timeout"](ReqArg(\t->mempty{ropt_test_options=Just(mempty{topt_timeout=Just(Just(secondsToMicroseconds(readt)))})})"NUMBER")"how many seconds a test should be run for before giving up, by default",Option[]["no-timeout"](NoArg(mempty{ropt_test_options=Just(mempty{topt_timeout=JustNothing})}))"specifies that tests should be run without a timeout, by default",Option['t']["select-tests"](ReqArg(\t->mempty{ropt_test_patterns=Just[readt]})"TEST-PATTERN")"only tests that match at least one glob pattern given by an instance of this argument will be run"]interpretArgs::[String]->IO(EitherString(RunnerOptions,[String]))interpretArgsargs=doprog_name<-getProgNameletusage_header="Usage: "++prog_name++" [OPTIONS]"casegetOptPermuteoptionsDescriptionargsof(oas,n,[])|Justos<-sequenceoas->return$Right(mconcatos,n)(_,_,errs)->return$Left(concaterrs++usageInfousage_headeroptionsDescription)defaultMain::[Test]->IO()defaultMaintests=doargs<-getArgsdefaultMainWithArgstestsargsdefaultMainWithArgs::[Test]->[String]->IO()defaultMainWithArgstestsargs=dointerpreted_args<-interpretArgsargscaseinterpreted_argsofRight(ropts,[])->defaultMainWithOptstestsroptsRight(_,leftovers)->doputStrLn$"Could not understand these extra arguments: "++unwordsleftoversexitWith(ExitFailure1)Lefterror_message->doputStrLnerror_messageexitWith(ExitFailure1)defaultMainWithOpts::[Test]->RunnerOptions->IO()defaultMainWithOptstestsropts=hideCursorDuring$doletropts'=completeRunnerOptionsropts-- Get a lazy list of the test results, as executed in parallelrun_tests<-runTestsropts'tests-- Show those test results to the user as we get themlettest_statistics=initialTestStatistics(totalRunTestsListrun_tests)test_statistics'<-showRunTests0test_statisticsrun_tests-- Show the final statisticsputStrLn""putDoc$showFinalTestStatisticstest_statistics'-- Set the error code depending on whether the tests succeded or notexitWith$ifts_no_failurestest_statistics'thenExitSuccesselseExitFailure1completeRunnerOptions::RunnerOptions->CompleteRunnerOptionscompleteRunnerOptionsro=RunnerOptions{ropt_threads=K$ropt_threadsro`orElse`processorCount,ropt_test_options=K$ropt_test_optionsro`orElse`mempty,ropt_test_patterns=K$ropt_test_patternsro`orElse`mempty}totalRunTests::RunTest->TestCounttotalRunTests(RunTest_test_type_)=adjustTestCounttest_type1memptytotalRunTests(RunTestGroup_tests)=totalRunTestsListteststotalRunTestsList::[RunTest]->TestCounttotalRunTestsList=mconcat.maptotalRunTests-- This code all /really/ sucks. There must be a better way to seperate out the console-updating-- and the improvement-traversing concerns - but how?showRunTest::Int->TestStatistics->RunTest->IOTestStatisticsshowRunTestindent_leveltest_statistics(RunTestnametest_typeimproving_result)=doletprogress_bar=testStatisticsProgressBartest_statisticsproperty_suceeded<-showImprovingTestResult(return())indent_levelnameprogress_barimproving_resultreturn$updateTestStatistics(\count->adjustTestCounttest_typecountmempty)property_suceededtest_statisticsshowRunTestindent_leveltest_statistics(RunTestGroupnametests)=doputDoc$(indentindent_level(textname<>char':'))<>linebreakshowRunTests(indent_level+2)test_statisticstestsshowRunTests::Int->TestStatistics->[RunTest]->IOTestStatisticsshowRunTestsindent_level=foldM(showRunTestindent_level)testStatisticsProgressBar::TestStatistics->DoctestStatisticsProgressBartest_statistics=progressBar(colorPassOrFailno_failures)width(Progressrun_teststotal_tests)whererun_tests=testCountTotal(ts_run_teststest_statistics)total_tests=testCountTotal(ts_total_teststest_statistics)no_failures=ts_no_failurestest_statistics-- We assume a terminal width of 80, but we can't make the progress bar 80 characters wide. Why? Because if we-- do so, when we write the progress bar out Windows will move the cursor onto the next line! By using a slightly-- smaller width we prevent this from happening. Bit of a hack, but it does the job.width=79updateTestStatistics::(Int->TestCount)->Bool->TestStatistics->TestStatisticsupdateTestStatisticscount_constructortest_suceededtest_statistics=test_statistics{ts_run_tests=ts_run_teststest_statistics`mappend`(count_constructor1),ts_failed_tests=ts_failed_teststest_statistics`mappend`(count_constructor(iftest_suceededthen0else1)),ts_passed_tests=ts_passed_teststest_statistics`mappend`(count_constructor(iftest_suceededthen1else0))}consumeImprovingThing::(a:~>b)->[(a:~>b)]consumeImprovingThingimproving@(Finished_)=[improving]consumeImprovingThingimproving@(Improving_rest)=improving:consumeImprovingThingrestshowImprovingTestResult::TestResultlikeir=>IO()->Int->String->Doc->(i:~>r)->IOBoolshowImprovingTestResulteraseindent_leveltest_nameprogress_barimproving=do-- Update the screen every every 200msimproving_list<-consumeListInInterval200000(consumeImprovingThingimproving)caselistToMaybeLastimproving_listofNothing->do-- 200ms was somehow not long enough for a single result to arrive: try again!showImprovingTestResulteraseindent_leveltest_nameprogress_barimprovingJustimproving'->do-- Display that new improving value to the usershowImprovingTestResult'eraseindent_leveltest_nameprogress_barimproving'showImprovingTestResult'::TestResultlikeir=>IO()->Int->String->Doc->(i:~>r)->IOBoolshowImprovingTestResult'eraseindent_leveltest_name_(Finishedresult)=doerase-- Output the final test status and a trailing newlineputTestHeaderindent_leveltest_nameresult_doc-- There may still be a progress bar on the line below the final test result, so -- remove it as a precautionary measure in case this is the last test in a group-- and hence it will not be erased in the normal course of test display.clearLine-- Output any extra information that may be required, e.g. to show failure reasonputDocextra_docreturnsuccesswheresuccess=testSucceededresult(result_doc,extra_doc)|success=(brackets$colorPass(text(showresult)),empty)|otherwise=(brackets(colorFail(text"Failed")),text(showresult)<>linebreak)showImprovingTestResult'eraseindent_leveltest_nameprogress_bar(Improvingintermediaterest)=doeraseputTestHeaderindent_leveltest_name(brackets(textintermediate_str))putDocprogress_barhFlushstdoutshowImprovingTestResult(cursorUpLine1>>clearLine)indent_leveltest_nameprogress_barrestwhereintermediate_str=showintermediateputTestHeader::Int->String->Doc->IO()putTestHeaderindent_leveltest_nameresult=putDoc$(indentindent_level(texttest_name<>char':'<+>result))<>linebreak