{-# LANGUAGE TemplateHaskell, UndecidableInstances, ScopedTypeVariables,
MultiParamTypeClasses, FlexibleContexts, FlexibleInstances,
TypeSynonymInstances, GADTs
#-}------------------------------------------------------------------------------- |-- Module : RepLib.Lib-- License : BSD---- Maintainer : sweirich@cis.upenn.edu-- Stability : experimental-- Portability : non-portable---- A library of type-indexed functions-------------------------------------------------------------------------------moduleGenerics.RepLib.Lib(-- * Available for all representable typessubtrees,deepSeq,rnf,-- * Specializable type-indexed functionsGSum(..),Zero(..),Generate(..),Enumerate(..),Shrink(..),Lreduce(..),Rreduce(..),-- * Generic operations based on FoldFold(..),crush,gproduct,gand,gor,flatten,count,comp,gconcat,gall,gany,gelem,-- * Auxiliary types and generators for derivable classesGSumD(..),ZeroD(..),GenerateD(..),EnumerateD(..),ShrinkD(..),LreduceD(..),RreduceD(..),rnfR,deepSeqR,gsumR1,zeroR1,generateR1,enumerateR1,lreduceR1,rreduceR1)whereimportGenerics.RepLib.RimportGenerics.RepLib.R1importGenerics.RepLib.RepAuximportGenerics.RepLib.PreludeReps()importGenerics.RepLib.AbstractReps()importData.List(inits)importData.Set(Set)importqualifiedData.SetasSetimportData.Map(Map)importqualifiedData.MapasMap------------------- Subtrees ---------------------------- there is no point in using R1 for subtrees-- From Mark P. Jones, Functional programming with-- overloading and higher-order polymorphism-- Also the same function as "children" from SYB III-- | Produce all children of a datastructure with the same type. Note-- that subtrees is available for all representable types. For those-- that are not recursive datatypes, subtrees will always return the-- empty list. But, these trivial instances are convenient to have for-- the Shrink operation below.subtrees::foralla.Repa=>a->[a]subtreesx=[y|Justy<-gmapQ(cast::Query(Maybea))x]-------------------- DeepSeq ------------------------- | Recursively force the evaluation of the first-- argument. For example,-- @-- deepSeq ( x , y ) z where-- x = ...-- y = ...-- @-- will evaluate both @x@ and @y@ then return @z@deepSeq::Repa=>a->b->bdeepSeq=deepSeqRrep-- | Force the evaluation of *datatypes* to their normal-- forms. Other types are left alone and not forced.rnf::Repa=>a->arnf=rnfRreprnfR::Ra->a->arnfR(Data_cons)x=case(findConconsx)ofValembrepsargs->toemb(map_lrnfRrepsargs)rnfR_x=xdeepSeqR::Ra->a->b->bdeepSeqR(Data_cons)=\x->case(findConconsx)ofVal_repsargs->foldl_l(\rabba->(deepSeqRraa).bb)idrepsargsdeepSeqR_=seq------------------- Generic Sum ------------------------ | Add together all of the @Int@s in a datastructure-- For example:-- gsum ( 1 , True, ("a", Maybe 3, []) , Nothing)-- 4--classRep1GSumDa=>GSumawheregsum::a->Intgsum=gsumR1rep1dataGSumDa=GSumD{gsumD::a->Int}gsumR1::R1GSumDa->a->IntgsumR1Int1x=xgsumR1(Arrow1__)_=error"urk"gsumR1(Data1_cons)x=case(findConconsx)ofVal_reckids->foldl_l(\caab->(gsumDcab)+a)0reckidsgsumR1__=0instanceGSuma=>Sat(GSumDa)wheredict=GSumDgsuminstanceGSumFloatinstanceGSumIntinstanceGSumBoolinstanceGSum()instanceGSumIntegerinstanceGSumCharinstanceGSumDoubleinstance(GSuma,GSumb)=>GSum(a,b)instance(GSuma)=>GSum[a]instance(Repk,GSuma)=>GSum(Mapka)wheregsum=gsum.Map.elemsinstanceGSuma=>GSum(Seta)wheregsum=gsum.Set.elems-------------------- Zero -------------------------------- | Create a zero element of a type-- @-- ( zero :: ((Int, Maybe Int), Float))-- ((0, Nothing), 0.0)-- @class(Rep1ZeroDa)=>Zeroawherezero::azero=zeroR1rep1dataZeroDa=ZD{zeroD::a}instanceZeroa=>Sat(ZeroDa)wheredict=ZDzerozeroR1::R1ZeroDa->azeroR1Int1=0zeroR1Char1=minBoundzeroR1(Arrow1_z2)=const(zeroDz2)zeroR1Integer1=0zeroR1Float1=0.0zeroR1Double1=0.0zeroR1(Data1_(Conembrec:_))=toemb(fromTupzeroDrec)zeroR1IOError1=userError"Default Error"zeroR1r1=error("No zero element of type: "++showr1)instanceZeroIntinstanceZeroCharinstance(Zeroa,Zerob)=>Zero(a->b)instanceZeroIntegerinstanceZeroFloatinstanceZeroDoubleinstanceZeroIOErrorinstanceZero()instanceZeroBoolinstance(Zeroa,Zerob)=>Zero(a,b)instanceZeroa=>Zero[a]instance(Repk,Repa)=>Zero(Mapka)wherezero=Map.emptyinstance(Repa)=>Zero(Seta)wherezero=Set.empty---------- Generate ------------------------------dataGenerateDa=GenerateD{generateD::Int->[a]}-- | Generate elements of a type up to a certain depth--classRep1GenerateDa=>Generateawheregenerate::Int->[a]generate=generateR1rep1instanceGeneratea=>Sat(GenerateDa)wheredict=GenerateDgenerategenEnum::(Enuma)=>Int->[a]genEnumd=enumFromTo(toEnum0)(toEnumd)generateR1::R1GenerateDa->Int->[a]generateR1Int1d=genEnumdgenerateR1Char1d=genEnumdgenerateR1Integer1d=genEnumdgenerateR1Float1d=genEnumdgenerateR1Double1d=genEnumdgenerateR1(Data1__)0=[]generateR1(Data1_cons)d=[toembl|(Conembrec)<-cons,l<-fromTupM(\x->generateDx(d-1))rec]generateR1r1_=error("No way to generate type: "++showr1)instanceGenerateIntinstanceGenerateCharinstanceGenerateIntegerinstanceGenerateFloatinstanceGenerateDoubleinstanceGenerate()instance(Generatea,Generateb)=>Generate(a,b)instanceGeneratea=>Generate[a]instance(Orda,Generatea)=>Generate(Seta)wheregeneratei=mapSet.fromList(generatei)instance(Ordk,Generatek,Generatea)=>Generate(Mapka)wheregenerate0=[]generatei=mapMap.fromList(inits[(k,v)|k<-generate(i-1),v<-generate(i-1)])------------ Enumerate --------------------------------- note that this is not the same as the Enum class in the standard preludedataEnumerateDa=EnumerateD{enumerateD::[a]}instanceEnumeratea=>Sat(EnumerateDa)wheredict=EnumerateD{enumerateD=enumerate}-- | enumerate the elements of a type, in DFS order.classRep1EnumerateDa=>Enumerateawhereenumerate::[a]enumerate=enumerateR1rep1enumerateR1::R1EnumerateDa->[a]enumerateR1Int1=[minBound..(maxBound::Int)]enumerateR1Char1=[minBound..(maxBound::Char)]enumerateR1(Data1_cons)=enumerateConsconsenumerateR1r1=error("No way to enumerate type: "++showr1)enumerateCons::[ConEnumerateDa]->[a]enumerateCons(Conembrec:rest)=(map(toemb)(fromTupMenumerateDrec))++(enumerateConsrest)enumerateCons[]=[]instanceEnumerateIntinstanceEnumerateCharinstanceEnumerateIntegerinstanceEnumerateFloatinstanceEnumerateDoubleinstanceEnumerateBoolinstanceEnumerate()instance(Enumeratea,Enumerateb)=>Enumerate(a,b)-- doesn't really work for infinite types.instanceEnumeratea=>Enumerate[a]instance(Orda,Enumeratea)=>Enumerate(Seta)whereenumerate=mapSet.fromListenumerateinstance(Ordk,Enumeratek,Enumeratea)=>Enumerate(Mapka)whereenumerate=mapMap.fromList(inits[(k,v)|k<-enumerate,v<-enumerate])----------------- Shrink (from SYB III) -------------------------------dataShrinkDa=ShrinkD{shrinkD::a->[a]}instanceShrinka=>Sat(ShrinkDa)wheredict=ShrinkD{shrinkD=shrink}-- | Given an element, return smaller elements of the same type-- for example, to automatically find small counterexamples when testingclass(Rep1ShrinkDa)=>Shrinkawhereshrink::a->[a]shrinka=subtreesa++shrinkStepawhereshrinkStep_t=letM_ts=gmapM1maintsm::forallb.ShrinkDb->b->Mbmdx=Mx(shrinkDdx)dataMa=Ma[a]instanceMonadMwherereturnx=Mx[](Mxxs)>>=k=Mr(rs1++rs2)whereMrrs1=kxrs2=[r'|x'<-xs,letMr'_=kx']instanceShrinkIntinstanceShrinka=>Shrink[a]instanceShrinkCharinstanceShrink()instance(Shrinka,Shrinkb)=>Shrink(a,b)instance(Orda,Shrinka)=>Shrink(Seta)whereshrinkx=mapSet.fromList(shrink(Set.toListx))instance(Ordk,Shrinkk,Shrinka)=>Shrink(Mapka)whereshrinkm=mapMap.fromList(shrink(Map.toListm))------------ Reduce -------------------------------dataRreduceDba=RreduceD{rreduceD::a->b->b}dataLreduceDba=LreduceD{lreduceD::b->a->b}-- | A general version of fold right, use for Fold class belowclassRep1(RreduceDb)a=>Rreducebawhererreduce::a->b->brreduce=rreduceR1rep1-- | A general version of fold left, use for Fold class belowclassRep1(LreduceDb)a=>Lreducebawherelreduce::b->a->blreduce=lreduceR1rep1-- For example-- @ instance Fold [] where-- foldRight op = rreduceR1 (rList1 (RreduceD { rreduceD = op })-- (RreduceD { rreduceD = foldRight op }))-- foldLeft op = lreduceR1 (rList1 (LreduceD { lreduceD = op })-- (LreduceD { lreduceD = foldLeft op }))-- @instanceRreduceba=>Sat(RreduceDba)wheredict=RreduceD{rreduceD=rreduce}instanceLreduceba=>Sat(LreduceDba)wheredict=LreduceD{lreduceD=lreduce}lreduceR1::R1(LreduceDb)a->b->a->blreduceR1(Data1_cons)ba=case(findConconsa)ofVal_recargs->foldl_llreduceDbrecargslreduceR1_b_=brreduceR1::R1(RreduceDb)a->a->b->brreduceR1(Data1_cons)ab=case(findConconsa)ofVal_recargs->foldr_lrreduceDbrecargsrreduceR1__b=b-- Instances for standard typesinstanceLreducebIntinstanceLreduceb()instanceLreducebCharinstanceLreducebBoolinstance(Lreduceca,Lreducecb)=>Lreducec(a,b)instanceLreduceca=>Lreducec[a]instance(Orda,Lreduceba)=>Lreduceb(Seta)wherelreduceba=(lreduceb(Set.toLista))instanceRreducebIntinstanceRreduceb()instanceRreducebCharinstanceRreducebBoolinstance(Rreduceca,Rreducecb)=>Rreducec(a,b)instanceRreduceca=>Rreducec[a]instance(Orda,Rreduceba)=>Rreduceb(Seta)whererreduceab=(rreduce(Set.toLista)b)-------------------- Fold --------------------------------- | All of the functions below are defined using instances-- of the following classclassFoldfwherefoldRight::Repa=>(a->b->b)->fa->b->bfoldLeft::Repa=>(b->a->b)->b->fa->b-- | Fold a bindary operation left over a datastructurecrush::(Repa,Foldt)=>(a->a->a)->a->ta->acrushop=foldLeftop-- | Multiply all elements togethergproduct::(Repa,Numa,Foldt)=>ta->agproductt=foldLeft(*)1t-- | Ensure all booleans are truegand::(Foldt)=>tBool->Boolgandt=foldLeft(&&)Truet-- | Ensure at least one boolean is truegor::(Foldt)=>tBool->Boolgort=foldLeft(||)Falset-- | Convert to listflatten::(Repa,Foldt)=>ta->[a]flattent=foldRight(:)t[]-- | Count number of @a@s that appear in the argumentcount::(Repa,Foldt)=>ta->Intcountt=foldRight(const(+1))t0-- | Compose all functions in the datastructure togethercomp::(Repa,Foldt)=>t(a->a)->a->acompt=foldLeft(.)idt-- | Concatenate all lists in the datastructure togethergconcat::(Repa,Foldt)=>t[a]->[a]gconcatt=foldLeft(++)[]t-- | Ensure property holds of all datagall::(Repa,Foldt)=>(a->Bool)->ta->Boolgallpt=foldLeft(\ab->a&&pb)Truet-- | Ensure property holds of some elementgany::(Repa,Foldt)=>(a->Bool)->ta->Boolganypt=foldLeft(\ab->a||pb)Falset-- | Is an element stored in a datastructuregelem::(Repa,Eqa,Foldt)=>a->ta->Boolgelemxt=foldRight(\ab->a==x||b)tFalseinstanceFold[]wherefoldRightop=rreduceR1(rList1(RreduceD{rreduceD=op})(RreduceD{rreduceD=foldRightop}))foldLeftop=lreduceR1(rList1(LreduceD{lreduceD=op})(LreduceD{lreduceD=foldLeftop}))instanceFoldSetwherefoldRightopxb=foldRightop(Set.toListx)bfoldLeftopbx=foldLeftopb(Set.toListx)instanceFold(Mapk)wherefoldRightopxb=foldRightop(Map.elemsx)bfoldLeftopbx=foldLeftopb(Map.elemsx)