-- vim:fdm=marker:foldtext=foldtext()---------------------------------------------------------------------- |-- Module : Test.SmallCheck.Property-- Copyright : (c) Colin Runciman et al.-- License : BSD3-- Maintainer: Roman Cheplyaka <roma@ro-che.info>---- Properties and tools to construct them.--------------------------------------------------------------------{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies,
ScopedTypeVariables, DeriveDataTypeable #-}-- CPP is for Typeable1 vs Typeable{-# LANGUAGE CPP #-}-- Are we using new, polykinded and derivable Typeable yet?#define NEWTYPEABLE MIN_VERSION_base(4,7,0)#if NEWTYPEABLE{-# LANGUAGE Safe #-}#else-- Trustworthy is needed because of the hand-written Typeable instance{-# LANGUAGE Trustworthy #-}#endifmoduleTest.SmallCheck.Property(-- * ConstructorsforAll,exists,existsUnique,over,(==>),monadic,changeDepth,changeDepth1,-- * Property's entrailsProperty,PropertySuccess(..),PropertyFailure(..),runProperty,TestQuality(..),Argument,Reason,Depth,Testable(..),)whereimportTest.SmallCheck.SeriesimportTest.SmallCheck.SeriesMonadimportTest.SmallCheck.Property.ResultimportControl.MonadimportControl.Monad.LogicimportControl.Monad.ReaderimportControl.ApplicativeimportData.Typeable-------------------------------- Property-related types--------------------------------{{{-- | The type of properties over the monad @m@newtypePropertym=Property{unProperty::Reader(Envm)(PropertySeriesm)}#if NEWTYPEABLEderivingTypeable#endifdataPropertySeriesm=PropertySeries{searchExamples::SeriesmPropertySuccess,searchCounterExamples::SeriesmPropertyFailure,searchClosest::Seriesm(Propertym,[Argument])}dataEnvm=Env{quantification::Quantification,testHook::TestQuality->m()}dataQuantification=Forall|Exists|ExistsUniquedataTestQuality=GoodTest|BadTestderiving(Eq,Ord,Enum,Show)#if !NEWTYPEABLE-- Typeable here is not polykinded yet, and also GHC doesn't know how to-- derive this.instanceTypeable1m=>Typeable(Propertym)wheretypeOf_=mkTyConApp(mkTyCon3"smallcheck""Test.SmallCheck.Property""Property")[typeOf(undefined::m())]#endif-- }}}-------------------------------------- Property runners and constructors--------------------------------------{{{unProp::Envt->Propertyt->PropertySeriestunPropq(Propertyp)=runReaderpqrunProperty::Monadm=>Depth->(TestQuality->m())->Propertym->m(MaybePropertyFailure)runPropertydepthhookprop=(\l->runLogicTl(\x_->return$Justx)(returnNothing))$runSeriesdepth$searchCounterExamples$fliprunReader(EnvForallhook)$unPropertypropatomicProperty::SeriesmPropertySuccess->SeriesmPropertyFailure->PropertySeriesmatomicPropertysf=letprop=PropertySeriessf(pure(Property$pureprop,[]))inpropmakeAtomic::Propertym->PropertymmakeAtomic(Propertyprop)=Property$flipfmapprop$\ps->atomicProperty(searchExamplesps)(searchCounterExamplesps)-- | @'over' s $ \\x -> p x@ makes @x@ range over the 'Series' @s@ (by-- default, all variables range over the 'series' for their types).---- Note that, unlike the quantification operators, this affects only the-- variable following the operator and not subsequent variables.---- 'over' does not affect the quantification context.over::(Showa,Testablemb)=>Seriesma->(a->b)->Propertymover=testFunction-- | Execute a monadic testmonadic::Testablema=>ma->Propertymmonadica=Property$reader$\env->letpair=unPropenv.freshContext<$>liftainatomicProperty(searchExamples=<<pair)(searchCounterExamples=<<pair)-- }}}--------------------------------- Testable class and instances--------------------------------- {{{-- | Class of tests that can be run in a monad. For pure tests, it is-- recommended to keep their types polymorphic in @m@ rather than-- specialising it to 'Identity'.classMonadm=>Testablemawheretest::a->PropertyminstanceMonadm=>TestablemBoolwheretestb=Property$reader$\env->letsuccess=dolift$testHookenvGoodTestifbthenreturn$PropertyTrueNothingelsemzerofailure=PropertyFalseNothing<$lnotsuccessinatomicPropertysuccessfailure-- | Works like the 'Bool' instance, but includes an explanation of the result.---- 'Left' and 'Right' correspond to test failure and success-- respectively.instanceMonadm=>Testablem(EitherReasonReason)wheretestr=Property$reader$\env->letsuccess=dolift$testHookenvGoodTesteither(constmzero)(pure.PropertyTrue.Just)rfailure=dolift$testHookenvGoodTesteither(pure.PropertyFalse.Just)(constmzero)rinatomicPropertysuccessfailureinstance(Serialma,Showa,Testablemb)=>Testablem(a->b)wheretest=testFunctionseriesinstance(Monadm,m~n)=>Testablen(Propertym)wheretest=idtestFunction::(Showa,Testablemb)=>Seriesma->(a->b)->PropertymtestFunctionsf=Property$reader$\env->letclosest=dox<-s(p,args)<-searchClosest$unPropenv$test$fxreturn(p,showx:args)incasequantificationenvofForall->PropertySeriessuccessfailureclosest-- {{{wherefailure=dox<-sfailure<-searchCounterExamples$unPropenv$test$fxletarg=showxreturn$casefailureofCounterExampleargsetc->CounterExample(arg:args)etc_->CounterExample[arg]failuresuccess=PropertyTrueNothing<$lnotfailure-- }}}Exists->PropertySeriessuccessfailureclosest-- {{{wheresuccess=dox<-ss<-searchExamples$unPropenv$test$fxletarg=showxreturn$casesofExistargsetc->Exist(arg:args)etc_->Exist[arg]sfailure=NotExist<$lnotsuccess-- }}}ExistsUnique->PropertySeriessuccessfailureclosest-- {{{wheresearch=atMost2$do(prop,args)<-closestex<-once$searchExamples$unPropenv$testpropreturn(args,ex)success=search>>=\examples->caseexamplesof[(x,s)]->return$ExistUniquexs_->mzerofailure=search>>=\examples->caseexamplesof[]->returnNotExist(x1,s1):(x2,s2):_->return$AtLeastTwox1s1x2s2_->mzero-- }}}atMost::MonadLogicm=>Int->ma->m[a]atMostnm|n<=0=return[]|otherwise=dom'<-msplitmcasem'ofNothing->return[]Just(x,rest)->(x:)`liftM`atMost(n-1)rest-- }}}-------------------------------- Test constructors-------------------------------- {{{quantify::Quantification->Propertym->Propertymquantifyq(Propertya)=makeAtomic$Property$local(\env->env{quantification=q})afreshContext::Testablema=>a->PropertymfreshContext=forAll-- | Set the universal quantification contextforAll::Testablema=>a->PropertymforAll=quantifyForall.test-- | Set the existential quantification contextexists::Testablema=>a->Propertymexists=quantifyExists.test-- | Set the uniqueness quantification context.---- Bear in mind that ∃! (x, y): p x y is not the same as ∃! x: ∃! y: p x y.---- For example, ∃! x: ∃! y: |x| = |y| is true (it holds only when x=0), but ∃! (x,y): |x| = |y| is false (there are many such pairs).---- As is customary in mathematics,-- @'existsUnique' $ \\x y -> p x y@ is equivalent to-- @'existsUnique' $ \\(x,y) -> p x y@ and not to-- @'existsUnique' $ \\x -> 'existsUnique' $ \\y -> p x y@-- (the latter, of course, may be explicitly written when desired).---- That is, all the variables affected by the same uniqueness context are-- quantified simultaneously as a tuple.existsUnique::Testablema=>a->PropertymexistsUnique=quantifyExistsUnique.test-- | The '==>' operator can be used to express a restricting condition-- under which a property should hold. It corresponds to implication in the-- classical logic.---- Note that '==>' resets the quantification context for its operands to-- the default (universal).infixr0==>(==>)::(Testablemc,Testablema)=>c->a->Propertymcond==>prop=Property$doenv<-askletcounterExample=once$searchCounterExamples$unPropenv'$freshContextcond-- NB: we do not invoke the test hook in the antecedentwhereenv'=env{testHook=const$return()}consequent=unPropenv$freshContextpropbadTestHook=lift$testHookenvBadTestsuccess=iftecounterExample-- then(\ex->dobadTestHookreturn$Vacuouslyex)-- else(searchExamplesconsequent)failure=iftecounterExample-- then(const$dolift$testHookenvBadTestmzero)-- else(searchCounterExamplesconsequent)return$atomicPropertysuccessfailure-- | Run property with a modified depth. Affects all quantified variables-- in the property.changeDepth::Testablema=>(Depth->Depth)->a->PropertymchangeDepthmodifyDeptha=Property(changeDepthPS<$>unProperty(testa))wherechangeDepthPS(PropertySeriessssfsc)=PropertySeries(localDepthmodifyDepthss)(localDepthmodifyDepthsf)((\(prop,args)->(changeDepthmodifyDepthprop,args))<$>localDepthmodifyDepthsc)-- | Quantify the function's argument over its 'series', but adjust the-- depth. This doesn't affect any subsequent variables.changeDepth1::(Showa,Serialma,Testablemb)=>(Depth->Depth)->(a->b)->PropertymchangeDepth1modifyDepth=over$localDepthmodifyDepthseries-- }}}