{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables, GADTs #-}moduleCompiler.Hoopl.Combinators(thenFwdRw,deepFwdRw3,deepFwdRw,iterFwdRw,thenBwdRw,deepBwdRw3,deepBwdRw,iterBwdRw,pairFwd,pairBwd,pairLattice)whereimportControl.MonadimportData.MaybeimportCompiler.Hoopl.CollectionsimportCompiler.Hoopl.DataflowimportCompiler.Hoopl.FuelimportCompiler.Hoopl.Graph(Graph,C,O,Shape(..))importCompiler.Hoopl.Label----------------------------------------------------------------deepFwdRw3::FuelMonadm=>(nCO->f->m(Maybe(GraphnCO)))->(nOO->f->m(Maybe(GraphnOO)))->(nOC->f->m(Maybe(GraphnOC)))->(FwdRewritemnf)deepFwdRw::FuelMonadm=>(forallex.nex->f->m(Maybe(Graphnex)))->FwdRewritemnfdeepFwdRw3fml=iterFwdRw$mkFRewrite3fmldeepFwdRwf=deepFwdRw3fff-- N.B. rw3, rw3', and rw3a are triples of functions.-- But rw and rw' are single functions.-- @ start comb1.texthenFwdRw::Monadm=>FwdRewritemnf->FwdRewritemnf->FwdRewritemnf-- @ end comb1.texthenFwdRwrw3rw3'=wrapFR2thenrwrw3rw3'wherethenrwrwrw'nf=rwnf>>=fwdReswherefwdResNothing=rw'nffwdRes(Justgr)=return$Just$fadd_rwrw3'gr-- @ start iterf.texiterFwdRw::Monadm=>FwdRewritemnf->FwdRewritemnf-- @ end iterf.texiterFwdRwrw3=wrapFRiterrw3whereiterrwn=(liftM$liftM$fadd_rw(iterFwdRwrw3)).rwn_iter=frewrite_cps(return.Just.fadd_rw(iterFwdRwrw3))(returnNothing)-- | Function inspired by 'rew' in the paperfrewrite_cps::Monadm=>((Graphnex,FwdRewritemnf)->ma)->ma->(forallex.nex->f->m(Maybe(Graphnex,FwdRewritemnf)))->nex->f->mafrewrite_cpsjnrwnodef=domg<-rwnodefcasemgofNothing->nJustgr->jgr-- | Function inspired by 'add' in the paperfadd_rw::Monadm=>FwdRewritemnf->(Graphnex,FwdRewritemnf)->(Graphnex,FwdRewritemnf)fadd_rwrw2(g,rw1)=(g,rw1`thenFwdRw`rw2)----------------------------------------------------------------deepBwdRw3::FuelMonadm=>(nCO->f->m(Maybe(GraphnCO)))->(nOO->f->m(Maybe(GraphnOO)))->(nOC->FactBasef->m(Maybe(GraphnOC)))->(BwdRewritemnf)deepBwdRw::FuelMonadm=>(forallex.nex->Factxf->m(Maybe(Graphnex)))->BwdRewritemnfdeepBwdRw3fml=iterBwdRw$mkBRewrite3fmldeepBwdRwf=deepBwdRw3fffthenBwdRw::Monadm=>BwdRewritemnf->BwdRewritemnf->BwdRewritemnfthenBwdRwrw1rw2=wrapBR2frw1rw2wheref_rw1rw2'nf=dores1<-rw1nfcaseres1ofNothing->rw2'nfJustgr->return$Just$badd_rwrw2griterBwdRw::Monadm=>BwdRewritemnf->BwdRewritemnfiterBwdRwrw=wrapBRfrwwheref_rw'nf=liftM(liftM(badd_rw(iterBwdRwrw)))(rw'nf)-- | Function inspired by 'add' in the paperbadd_rw::Monadm=>BwdRewritemnf->(Graphnex,BwdRewritemnf)->(Graphnex,BwdRewritemnf)badd_rwrw2(g,rw1)=(g,rw1`thenBwdRw`rw2)-- @ start pairf.texpairFwd::Monadm=>FwdPassmnf->FwdPassmnf'->FwdPassmn(f,f')-- @ end pairf.texpairFwdpass1pass2=FwdPasslatticetransferrewritewherelattice=pairLattice(fp_latticepass1)(fp_latticepass2)transfer=mkFTransfer3(tftf1tf2)(tftm1tm2)(tfbtl1tl2)wheretft1t2n(f1,f2)=(t1nf1,t2nf2)tfbt1t2n(f1,f2)=mapMapWithKeywithfb2fb1wherefb1=t1nf1fb2=t2nf2withfb2lf=(f,fromMaybebot2$lookupFactlfb2)bot2=fact_bot(fp_latticepass2)(tf1,tm1,tl1)=getFTransfer3(fp_transferpass1)(tf2,tm2,tl2)=getFTransfer3(fp_transferpass2)rewrite=liftfst(fp_rewritepass1)`thenFwdRw`liftsnd(fp_rewritepass2)whereliftproj=wrapFRprojectwhereprojectrw=\npair->liftM(liftMrepair)$rwn(projpair)repair(g,rw')=(g,liftprojrw')pairBwd::forallmnff'.Monadm=>BwdPassmnf->BwdPassmnf'->BwdPassmn(f,f')pairBwdpass1pass2=BwdPasslatticetransferrewritewherelattice=pairLattice(bp_latticepass1)(bp_latticepass2)transfer=mkBTransfer3(tftf1tf2)(tftm1tm2)(tfbtl1tl2)wheretft1t2n(f1,f2)=(t1nf1,t2nf2)tfbt1t2nfb=(t1n$mapMapfstfb,t2n$mapMapsndfb)(tf1,tm1,tl1)=getBTransfer3(bp_transferpass1)(tf2,tm2,tl2)=getBTransfer3(bp_transferpass2)rewrite=liftfst(bp_rewritepass1)`thenBwdRw`liftsnd(bp_rewritepass2)wherelift::forallf1.((f,f')->f1)->BwdRewritemnf1->BwdRewritemn(f,f')liftproj=wrapBRprojectwhereproject::forallex.Shapex->(nex->Factxf1->m(Maybe(Graphnex,BwdRewritemnf1)))->(nex->Factx(f,f')->m(Maybe(Graphnex,BwdRewritemn(f,f'))))projectOpen=\rwnpair->liftM(liftMrepair)$rwn(projpair)projectClosed=\rwnpair->liftM(liftMrepair)$rwn(mapMapprojpair)repair(g,rw')=(g,liftprojrw')-- XXX specialize repair so that the cost-- of discriminating is one per combinator not one-- per rewritepairLattice::forallff'.DataflowLatticef->DataflowLatticef'->DataflowLattice(f,f')pairLatticel1l2=DataflowLattice{fact_name=fact_namel1++" x "++fact_namel2,fact_bot=(fact_botl1,fact_botl2),fact_join=join}wherejoinlbl(OldFact(o1,o2))(NewFact(n1,n2))=(c',(f1,f2))where(c1,f1)=fact_joinl1lbl(OldFacto1)(NewFactn1)(c2,f2)=fact_joinl2lbl(OldFacto2)(NewFactn2)c'=case(c1,c2)of(NoChange,NoChange)->NoChange_->SomeChange