---- Copyright (c) 2009 Stefan Wehr - http://www.stefanwehr.de---- This library is free software; you can redistribute it and/or-- modify it under the terms of the GNU Lesser General Public-- License as published by the Free Software Foundation; either-- version 2.1 of the License, or (at your option) any later version.---- This library is distributed in the hope that it will be useful,-- but WITHOUT ANY WARRANTY; without even the implied warranty of-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU-- Lesser General Public License for more details.---- You should have received a copy of the GNU Lesser General Public-- License along with this library; if not, write to the Free Software-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA--moduleTest.Framework.TestManager(TestID,Assertion,Test,TestSuite,Filter,FlatTest(..),TestSort(..),TestableHTF,quickCheckTestFail,quickCheckTestError,unitTestFail,blackBoxTestFail,makeQuickCheckTest,makeUnitTest,makeBlackBoxTest,makeTestSuite,makeAnonTestSuite,addToTestSuite,testSuiteAsTest,runTest,runTestWithArgs,runTestWithFilter)whereimportControl.MonadimportControl.Monad.StateimportData.List(isInfixOf)importText.PrettyPrintimportqualifiedTest.HUnit.LangasHUimportTest.Framework.Location(Location,showLoc)importTest.Framework.Utils(readM)typeAssertion=IO()typeTestID=StringassertFailureHTF::String->Assertion-- Important: force the string argument, otherwise an error embedded-- lazily inside the string might escape.assertFailureHTFs=lengths`seq`HU.assertFailures-- This is a HACK: we encode a custom error message for QuickCheck-- failures and errors in a string, which is later parsed using read!quickCheckTestError::MaybeString->AssertionquickCheckTestErrorm=assertFailureHTF(show(False,m))quickCheckTestFail::MaybeString->AssertionquickCheckTestFailm=assertFailureHTF(show(True,m))unitTestFail::String->IOaunitTestFails=doassertFailureHTFserror"unitTestFail: UNREACHABLE"blackBoxTestFail::String->AssertionblackBoxTestFail=assertFailureHTFmakeQuickCheckTest::TestID->Location->Assertion->TestmakeQuickCheckTestidlocass=BaseTestQuickCheckTestid(Justloc)assmakeUnitTest::TestID->Location->IOa->TestmakeUnitTestidlocass=BaseTestUnitTestid(Justloc)(ass>>return())makeBlackBoxTest::TestID->Assertion->TestmakeBlackBoxTestidass=BaseTestBlackBoxTestidNothingassmakeTestSuite::TestID->[Test]->TestSuitemakeTestSuite=TestSuitemakeAnonTestSuite::[Test]->TestSuitemakeAnonTestSuite=AnonTestSuitetestSuiteAsTest::TestSuite->TesttestSuiteAsTest=CompoundTestaddToTestSuite::TestSuite->[Test]->TestSuiteaddToTestSuite(TestSuiteidts)ts'=TestSuiteid(ts++ts')addToTestSuite(AnonTestSuitets)ts'=AnonTestSuite(ts++ts')dataTestSort=UnitTest|QuickCheckTest|BlackBoxTestderiving(Eq,Show,Read)dataTest=BaseTestTestSortTestID(MaybeLocation)Assertion|CompoundTestTestSuitedataTestSuite=TestSuiteTestID[Test]|AnonTestSuite[Test]dataFlatTest=FlatTestTestSortTestID(MaybeLocation)AssertionclassTestableHTFtwhereflatten::t->[FlatTest]instanceTestableHTFTestwhereflatten=flattenTestNothinginstanceTestableHTFTestSuitewhereflatten=flattenTestSuiteNothinginstanceTestableHTFt=>TestableHTF[t]whereflatten=concatMapflattentypePath=MaybeStringflattenTest::Path->Test->[FlatTest]flattenTestpath(BaseTestsortidmlocass)=[FlatTestsort(path`concatPath`id)mlocass]flattenTestpath(CompoundTestts)=flattenTestSuitepathtsflattenTestSuite::Path->TestSuite->[FlatTest]flattenTestSuitepath(TestSuiteidts)=concatMap(flattenTest(Just(path`concatPath`id)))tsflattenTestSuitepath(AnonTestSuitets)=concatMap(flattenTestpath)tsconcatPath::Path->String->StringconcatPathNothings=sconcatPath(Justs1)s2=s1++pathSep++s2wherepathSep=":"dataTestState=TestState{ts_passed::[String],ts_failed::[String],ts_error::[String]}initTestState::TestStateinitTestState=TestState[][][]typeTR=StateTTestStateIOrunFlatTest::FlatTest->TR()runFlatTest(FlatTestsortidmlocass)=doletname=id++casemlocofNothing->""Justloc->" ("++showLocloc++")"liftIO$reportnameres<-liftIO$HU.performTestCaseasscaseresofNothing->reportSuccessnameJust(isFailure',msg')->let(isFailure,msg,doReport)=ifsort/=QuickCheckTestthen(isFailure',msg',True)elsecasereadMmsg'::Maybe(Bool,MaybeString)ofNothing->error("ERROR: "++"Cannot deserialize QuickCheck "++"error message "++showmsg')Just(b,ms)->casemsofNothing->(b,"",False)Justs->(b,s,True)inifisFailurethendomodify(\s->s{ts_failed=name:(ts_faileds)})whendoReport$reportFailuremsgelsedomodify(\s->s{ts_error=name:(ts_errors)})whendoReport$reportErrormsgliftIO$report""wherereportSuccessname=domodify(\s->s{ts_passed=name:(ts_passeds)})when(sort/=QuickCheckTest)$liftIO$report"+++ OK"reportFailuremsg=reportMessagemsgfailurePrefixreportErrormsg=reportMessagemsgerrorPrefixreportMessagemsgprefix=liftIO$report(prefix++msg)failurePrefix="*** Failed! "errorPrefix="@@@ Error! "runFlatTests::[FlatTest]->TR()runFlatTests=mapM_runFlatTestrunTest::TestableHTFt=>t->IO()runTest=runTestWithFilter(\_->True)runTestWithArgs::TestableHTFt=>[String]->t->IO()runTestWithArgs[]=runTestrunTestWithArgsl=runTestWithFilterpredwherepred(FlatTest_id__)=any(\s->s`isInfixOf`id)ltypeFilter=FlatTest->BoolrunTestWithFilter::TestableHTFt=>Filter->t->IO()runTestWithFilterpredt=dos<-execStateT(runFlatTests(filterpred(flattent)))initTestStateletpassed=length(ts_passeds)failed=length(ts_faileds)error=length(ts_errors)total=passed+failed+errorreport("* Tests: "++showtotal++"\n"++"* Passed: "++showpassed++"\n"++"* Failures: "++showfailed++"\n"++"* Errors: "++showerror)when(failed>0)$reportDoc(text"\nFailures:"$$renderTestNames(reverse(ts_faileds)))when(error>0)$reportDoc(text"\nFailures:"$$renderTestNames(reverse(ts_errors)))return()whererenderTestNamesl=nest2(vcat(map(\name->text"*"<+>textname)l))report::String->IO()report=putStrLnreportDoc::Doc->IO()reportDocdoc=report(renderdoc)