------------------------------------------------------------------------------- |-- Module : Data.Unfolder-- Copyright : (c) Sjoerd Visscher 2012-- License : BSD-style (see the file LICENSE)---- Maintainer : sjoerd@w3future.com-- Stability : experimental-- Portability : non-portable---- Unfolders provide a way to unfold data structures.-- They are basically 'Alternative' instances, but the 'choose' method-- allows the unfolder to do something special for the recursive positions-- of the data structure.-----------------------------------------------------------------------------{-# LANGUAGE
GeneralizedNewtypeDeriving
, RankNTypes
, Trustworthy
#-}moduleData.Unfolder(-- * UnfolderUnfolder(..),chooseMonadDefault,between,betweenD,boundedEnum,boundedEnumD-- ** Unfolder instances,Random(..),Arb(..),arbUnit,NumConst(..)-- * UnfolderTransformer,UnfolderTransformer(..),ala,ala2,ala3-- ** UnfolderTransformer instances,DualA(..),NT(..),WithRec(..),withRec,limitDepth,BFS(..),Split,bfs,bfsBySum)whereimportControl.ApplicativeimportControl.MonadimportControl.Arrow(ArrowZero,ArrowPlus)importData.Functor.ProductimportData.Functor.ComposeimportData.Functor.ReverseimportControl.Applicative.BackwardsimportControl.Applicative.LiftimportControl.Monad.Trans.ErrorimportControl.Monad.Trans.ListimportControl.Monad.Trans.MaybeimportControl.Monad.Trans.RWSimportControl.Monad.Trans.ReaderimportControl.Monad.Trans.StateimportControl.Monad.Trans.WriterimportqualifiedSystem.RandomasRimportTest.QuickCheck.Arbitrary(Arbitrary(..))importTest.QuickCheck.Gen(Gen(..))importData.Monoid(Monoid(..))importData.Maybe(catMaybes,listToMaybe)importData.Foldable(asum)importData.Traversable(traverse)-- | Unfolders provide a way to unfold data structures.-- The methods have default implementations in terms of 'Alternative',-- but you can implement 'choose' to act on recursive positions of the-- data structure, or simply to provide a faster implementation than 'asum'.classAlternativef=>Unfolderfwhere-- | Choose one of the values from the list.choose::[fx]->fxchoose=asum-- | Given a number 'n', return a number between '0' and 'n - 1'.chooseInt::Int->fIntchooseIntn=choose$mappure[0..n-1]-- | If an unfolder is monadic, 'choose' can be implemented in terms of 'chooseInt'.chooseMonadDefault::(Monadm,Unfolderm)=>[mx]->mxchooseMonadDefaultms=chooseInt(lengthms)>>=(ms!!)-- | If a datatype is enumerable, we can use 'chooseInt' to generate a value.-- This is the function to use if you want to unfold a datatype that has no type arguments (has kind @*@).between::(Unfolderf,Enuma)=>a->a->fabetweenlbub=(\x->toEnum(x+fromEnumlb))<$>chooseInt(1+fromEnumub-fromEnumlb)-- | If a datatype is also bounded, we choose between all possible values.---- > boundedEnum = between minBound maxBoundboundedEnum::(Unfolderf,Boundeda,Enuma)=>faboundedEnum=betweenminBoundmaxBound-- | 'betweenD' uses 'choose' to generate a value. It chooses between the lower bound and one-- of the higher values. This means that f.e. breadth-first unfolding and arbitrary will prefer-- lower values.betweenD::(Unfolderf,Enuma)=>a->a->fabetweenDlbub=betweenD'lb(fromEnumub-fromEnumlb)wherebetweenD'lbn|n<0=empty|otherwise=choose[purelb,betweenD'(succlb)(predn)]-- | > boundedEnumD = betweenD minBound maxBoundboundedEnumD::(Unfolderf,Boundeda,Enuma)=>faboundedEnumD=betweenDminBoundmaxBound-- | Derived instance.instanceMonadPlusm=>Unfolder(WrappedMonadm)-- | Derived instance.instance(ArrowZeroa,ArrowPlusa)=>Unfolder(WrappedArrowab)-- | Don't choose but return all items.instanceUnfolder[]wherechoose=concatchooseIntn=[0..n-1]-- | Always choose the first item.instanceUnfolderMaybewherechoose[]=Nothingchoosems=headmschooseInt0=NothingchooseInt_=Just0-- | Derived instance.instance(Unfolderp,Unfolderq)=>Unfolder(Productpq)wherechooseps=Pair(choose$mapfstPps)(choose$mapsndPps)wherefstP(Pairp_)=psndP(Pair_q)=qchooseIntn=Pair(chooseIntn)(chooseIntn)-- | Derived instance.instance(Unfolderp,Applicativeq)=>Unfolder(Composepq)wherechoose=Compose.choose.mapgetComposechooseIntn=Compose$pure<$>chooseIntn-- | Derived instance.instanceUnfolderf=>Unfolder(Reversef)wherechoose=Reverse.choose.mapgetReversechooseIntn=Reverse$chooseIntn-- | Derived instance.instanceUnfolderf=>Unfolder(Backwardsf)wherechoose=Backwards.choose.mapforwardschooseIntn=Backwards$chooseIntn-- | Derived instance.instanceUnfolderf=>Unfolder(Liftf)-- | Derived instance.instance(Functorm,Monadm,Errore)=>Unfolder(ErrorTem)-- | Derived instance.instanceApplicativef=>Unfolder(ListTf)wherechoosems=ListT$concat<$>traverserunListTmschooseIntn=ListT$pure[0..n-1]-- | Derived instance.instance(Functorm,Monadm)=>Unfolder(MaybeTm)wherechoosems=MaybeT$listToMaybe.catMaybes<$>mapMrunMaybeTmschooseInt0=MaybeT$returnNothingchooseInt_=MaybeT$return(Just0)-- | Derived instance.instance(Monoidw,MonadPlusm,Unfolderm)=>Unfolder(RWSTrwsm)wherechoosems=RWST$\rs->choose$map(\m->runRWSTmrs)ms-- | Derived instance.instance(MonadPlusm,Unfolderm)=>Unfolder(StateTsm)wherechoosems=StateT$\s->choose$map(`runStateT`s)ms-- | Derived instance.instanceUnfolderm=>Unfolder(ReaderTrm)wherechoosems=ReaderT$\r->choose$map(`runReaderT`r)ms-- | Derived instance.instance(Monoidw,Unfolderm)=>Unfolder(WriterTwm)wherechoose=WriterT.choose.maprunWriterTnewtypeRandomgma=Random{getRandom::StateTgma}deriving(Functor,Applicative,Monad)instance(Functorm,Monadm,R.RandomGeng)=>Alternative(Randomgm)whereempty=choose[]a<|>b=choose[a,b]instance(Functorm,Monadm,R.RandomGeng)=>MonadPlus(Randomgm)wheremzero=choose[]mplusab=choose[a,b]-- | Choose randomly.instance(Functorm,Monadm,R.RandomGeng)=>Unfolder(Randomgm)wherechoose=chooseMonadDefaultchooseInt0=Random.StateT$const(fail"Random chooseInt 0")chooseIntn=Random.StateT$return.R.randomR(0,n-1)-- | An 'UnfolderTransformer' changes the way an 'Unfolder' unfolds. classUnfolderTransformertwhere-- | Lift a computation from the argument unfolder to the constructed unfolder.lift::Unfolderf=>fa->tfa-- | Run an unfolding function with one argument using an 'UnfolderTransformer', given a way to run the transformer.ala::(UnfolderTransformert,Unfolderf)=>(tfb->fb)->(tfa->tfb)->fa->fbalalowerf=lower.f.lift-- | Run an unfolding function with two arguments using an 'UnfolderTransformer', given a way to run the transformer.ala2::(UnfolderTransformert,Unfolderf)=>(tfc->fc)->(tfa->tfb->tfc)->fa->fb->fcala2lowerf=alalower.f.lift-- | Run an unfolding function with three arguments using an 'UnfolderTransformer', given a way to run the transformer.ala3::(UnfolderTransformert,Unfolderf)=>(tfd->fd)->(tfa->tfb->tfc->tfd)->fa->fb->fc->fdala3lowerf=ala2lower.f.lift-- | 'DualA' flips the @\<|>@ operator from `Alternative`.newtypeDualAfa=DualA{getDualA::fa}deriving(Eq,Show,Functor,Applicative)instanceAlternativef=>Alternative(DualAf)whereempty=DualAemptyDualAa<|>DualAb=DualA(b<|>a)-- | Reverse the list passed to choose.instanceUnfolderf=>Unfolder(DualAf)wherechoose=DualA.choose.reverse.mapgetDualAchooseIntn=DualA$(\x->n-1-x)<$>chooseIntninstanceUnfolderTransformerDualAwherelift=DualA-- | Natural transformationsdataNTfg=NT{getNT::foralla.fa->ga}newtypeWithRecfa=WithRec{getWithRec::ReaderT(Int->NTff)fa}deriving(Functor,Applicative,Alternative)-- | Applies a certain function depending on the depth at every recursive position.instanceUnfolderf=>Unfolder(WithRecf)wherechoosems=WithRec.ReaderT$\f->getNT(f0)$choose(map(\(WithRec(ReaderTm))->m(f.succ))ms)instanceUnfolderTransformerWithRecwherelift=WithRec.ReaderT.const-- | Apply a certain function of type @f a -> f a@ to the result of a 'choose'.-- The depth is passed as 'Int', so you can apply a different function at each depth.-- Because of a @forall@, the function needs to be wrapped in a 'NT' constructor.-- See 'limitDepth' for an example how to use this function.withRec::(Int->NTff)->WithRecfa->fawithRecf=(`runReaderT`f).getWithRec-- | Limit the depth of an unfolding.limitDepth::Unfolderf=>Int->WithRecfa->falimitDepthm=withRec(\d->NT$ifd==mthenconstemptyelseid)-- | Return a generator of values of a given depth.-- Returns 'Nothing' if there are no values of that depth or deeper.-- The depth is the number of 'choose' calls.newtypeBFSfx=BFS{getBFS::(Int,Split)->Maybe[fx]}typeSplit=Int->[(Int,Int)]instanceFunctorf=>Functor(BFSf)wherefmapf=BFS.(fmap(map(fmapf)).).getBFSinstanceApplicativef=>Applicative(BFSf)wherepure=packBFS.pureBFSff<*>BFSfx=BFS$\(d,split)->flattenBFS$[liftA2(liftA2(<*>))(ff(i,split))(fx(j,split))|(i,j)<-splitd]instanceApplicativef=>Alternative(BFSf)whereempty=BFS$\(d,_)->ifd==0thenJust[]elseNothingBFSfa<|>BFSfb=BFS$\d->flattenBFS[fad,fbd]-- | Choose between values of a given depth only.instanceApplicativef=>Unfolder(BFSf)wherechoosems=BFS$\(d,split)->ifd==0thenJust[]elseflattenBFS(map(`getBFS`(d-1,split))ms)instanceUnfolderTransformerBFSwherelift=packBFSbySum::SplitbySumd=[(i,d-i)|i<-[0..d]]byMax::SplitbyMaxd=[(i,d)|i<-[0..d-1]]++[(d,i)|i<-[0..d]]bfsBy::Unfolderf=>Split->BFSfx->fxbfsBysplit(BFSf)=choose(loop0)whereloopd=maybe[](++loop(d+1))(f(d,split))-- | Change the order of unfolding to be breadth-first, by maximum depth of the components.bfs::Unfolderf=>BFSfx->fxbfs=bfsBybyMax-- | Change the order of unfolding to be breadth-first, by the sum of depths of the components.bfsBySum::Unfolderf=>BFSfx->fxbfsBySum=bfsBybySumpackBFS::fx->BFSfxpackBFSr=BFS$\(d,_)->ifd==0thenJust[r]elseNothingflattenBFS::[Maybe[a]]->Maybe[a]flattenBFSms=casecatMaybesmsof[]->Nothingms'->Just(concatms')-- | A variant of Test.QuickCheck.Gen, with failure -- and a count of the number of recursive positions.dataArba=ArbInt(R.StdGen->Int->Maybea)instanceFunctorArbwherefmapf(Arbig)=Arbi$fmap(fmap(fmapf))ginstanceApplicativeArbwherepure=Arb0.pure.pure.pureArbi1ff<*>Arbi2fx=Arb(i1+i2)$\r->let(r1,r2)=R.splitrinliftA2(<*>)(ffr1)(fxr2)instanceAlternativeArbwhereempty=Arb0(\__->Nothing)Arbiafa<|>Arbibfb=Arb((ia+ib+1)`div`2)$\rn->let(r1,r2)=R.splitrinflattenArbr1[far2n,fbr2n]-- | Limit the depth of the generated data structure by -- dividing the given size by the number of recursive positions.instanceUnfolderArbwherechoosems=Arb1gwhereg_0=Nothinggrn=let(r1,r2)=R.splitrinflattenArbr1$map(\(Arbif)->fr2(n`div`maxi1))msflattenArb::R.StdGen->[Maybea]->MaybeaflattenArbrms=casecatMaybesmsof[]->Nothingms'->Just$ms'!!fst(R.randomR(0,lengthms'-1)r)arbUnit::Arbitrarya=>ArbaarbUnit=Arb0(\rn->Just$unGenarbitraryrn)-- | Variant of 'Data.Functor.Constant' that does multiplication of the constants for @\<*>@ and addition for @\<|>@.newtypeNumConstax=NumConst{getNumConst::a}deriving(Eq,Show)instanceFunctor(NumConsta)wherefmap_(NumConsta)=NumConstainstanceNuma=>Applicative(NumConsta)wherepure_=NumConst1NumConsta<*>NumConstb=NumConst$a*binstanceNuma=>Alternative(NumConsta)whereempty=NumConst0NumConsta<|>NumConstb=NumConst$a+b-- | Unfolds to a constant numeric value. Useful for counting shapes.instanceNuma=>Unfolder(NumConsta)wherechoose[]=emptychooseas=foldr1(<|>)as