{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, PatternGuards, CPP #-}moduleData.Generics.Geniplate(genUniverseBi,genUniverseBiT,genTransformBi,genTransformBiT,genTransformBiM,genTransformBiMT,UniverseBi(..),universe,instanceUniverseBi,instanceUniverseBiT,TransformBi(..),transform,instanceTransformBi,instanceTransformBiT,TransformBiM(..),transformM,instanceTransformBiM,instanceTransformBiMT,)whereimportControl.MonadimportControl.Exception(assert)importControl.Monad.State.StrictimportData.MaybeimportLanguage.Haskell.THimportLanguage.Haskell.TH.Syntaxhiding(lift)importSystem.IO---- Overloaded interface, same as Uniplate.-- | Class for 'universeBi'.classUniverseBistwhereuniverseBi::s->[t]-- | Class for 'transformBi'.classTransformBistwheretransformBi::(s->s)->t->t-- | Class for 'transformBiM'.class{-(Monad m) => -}TransformBiMmstwheretransformBiM::(s->ms)->t->mtuniverse::(UniverseBiaa)=>a->[a]universe=universeBitransform::(TransformBiaa)=>(a->a)->a->atransform=transformBitransformM::(TransformBiMmaa)=>(a->ma)->a->matransformM=transformBiM------ | Create a 'UniverseBi' instance.-- The 'TypeQ' argument should be a pair; the /source/ and /target/ types for 'universeBi'.instanceUniverseBi::TypeQ-- ^(source, target) types->Q[Dec]instanceUniverseBi=instanceUniverseBiT[]-- | Create a 'UniverseBi' instance with certain types being abstract.-- The 'TypeQ' argument should be a pair; the /source/ and /target/ types for 'universeBi'.instanceUniverseBiT::[TypeQ]-- ^types not touched by 'universeBi'->TypeQ-- ^(source, target) types->Q[Dec]instanceUniverseBiTstopsty=instanceUniverseBiT'stops=<<tyinstanceUniverseBiT'::[TypeQ]->Type->Q[Dec]instanceUniverseBiT'stops(ForallT__t)=instanceUniverseBiT'stopstinstanceUniverseBiT'stopsty|(TupleT_,[from,to])<-splitTypeAppty=do(ds,f)<-uniBiQstopsfromtox<-newName"_x"lete=LamE[VarPx]$LetEds$AppE(AppEf(VarEx))(ListE[])return$instDef''UniverseBi[from,to]'universeBieinstanceUniverseBiT'_t=genError"instanceUniverseBi: the argument should be of the form [t| (S, T) |]"funDef::Name->Exp->[Dec]funDeffe=[FunDf[Clause[](NormalBe)[]]]instDef::Name->[Type]->Name->Exp->[Dec]instDefclstsmete=[InstanceD[](foldlAppT(ConTcls)ts)(funDefmete)]-- | Create a 'TransformBi' instance.-- The 'TypeQ' argument should be a pair; the /inner/ and /outer/ types for 'transformBi'.instanceTransformBi::TypeQ-- ^(inner, outer) types->Q[Dec]instanceTransformBi=instanceTransformBiT[]-- | Create a 'TransformBi' instance with certain types being abstract.-- The 'TypeQ' argument should be a pair; the /inner/ and /outer/ types for 'transformBi'.instanceTransformBiT::[TypeQ]-- ^types not touched by 'transformBi'->TypeQ-- ^(inner, outer) types->Q[Dec]instanceTransformBiTstopsty=instanceTransformBiT'stops=<<tyinstanceTransformBiT'::[TypeQ]->Type->Q[Dec]instanceTransformBiT'stops(ForallT__t)=instanceTransformBiT'stopstinstanceTransformBiT'stopsty|(TupleT_,[ft,st])<-splitTypeAppty=dof<-newName"_f"x<-newName"_x"(ds,tr)<-trBiQraNormalstopsfftstlete=LamE[VarPf,VarPx]$LetEds$AppEtr(VarEx)return$instDef''TransformBi[ft,st]'transformBieinstanceTransformBiT'_t=genError"instanceTransformBiT: the argument should be of the form [t| (S, T) |]"-- | Create a 'TransformBiM' instance.instanceTransformBiM::TypeQ->TypeQ->Q[Dec]instanceTransformBiM=instanceTransformBiMT[]-- | Create a 'TransformBiM' instance with certain types being abstract.instanceTransformBiMT::[TypeQ]->TypeQ->TypeQ->Q[Dec]instanceTransformBiMTstopsmndqty=instanceTransformBiMT'stopsmndq=<<tyinstanceTransformBiMT'::[TypeQ]->TypeQ->Type->Q[Dec]instanceTransformBiMT'stopsmndq(ForallT__t)=instanceTransformBiMT'stopsmndqtinstanceTransformBiMT'stopsmndqty|(TupleT_,[ft,st])<-splitTypeAppty=domnd<-mndqf<-newName"_f"x<-newName"_x"(ds,tr)<-trBiQraMonadstopsfftstlete=LamE[VarPf,VarPx]$LetEds$AppEtr(VarEx)return$instDef''TransformBiM[mnd,ft,st]'transformBiMeinstanceTransformBiMT'__t=genError"instanceTransformBiMT: the argument should be of the form [t| (S, T) |]"-- | Generate TH code for a function that extracts all subparts of a certain type.-- The argument to 'genUniverseBi' is a name with the type @S -> [T]@, for some types-- @S@ and @T@. The function will extract all subparts of type @T@ from @S@.genUniverseBi::Name-- ^function of type @S -> [T]@->QExpgenUniverseBi=genUniverseBiT[]-- | Same as 'genUniverseBi', but does not look inside any types mention in the-- list of types.genUniverseBiT::[TypeQ]-- ^types not touched by 'universeBi'->Name-- ^function of type @S -> [T]@->QExpgenUniverseBiTstopsname=do(_tvs,from,tos)<-getNameTypenameletto=unListtos-- qRunIO $ print (from, to)(ds,f)<-uniBiQstopsfromtox<-newName"_x"lete=LamE[VarPx]$LetEds$AppE(AppEf(VarEx))(ListE[])-- qRunIO $ do putStrLn $ pprint e; hFlush stdoutreturnetypeU=StateT(MapTypeDec,MapTypeBool)QinstanceQuasiUwhereqNewName=lift.qNewNameqReportb=lift.qReportbqRecover=error"Data.Generics.Geniplate: qRecover not implemented"qReify=lift.qReify#if MIN_VERSION_template_haskell(2,7,0)qReifyInstancesn=lift.qReifyInstancesn#elseqClassInstancesn=lift.qClassInstancesn#endifqLocation=liftqLocationqRunIO=lift.qRunIO#if MIN_VERSION_template_haskell(2,7,0)qLookupNamens=lift.qLookupNamensqAddDependentFile=lift.qAddDependentFile#endifuniBiQ::[TypeQ]->Type->Type->Q([Dec],Exp)uniBiQstopsfromato=doss<-sequencestopsto<-expandSynato(f,(m,_))<-runStateT(uniBifromto)(mEmpty,mFromList$zipss(repeatFalse))return(mElemsm,f)uniBi::Type->Type->UExpuniBiafromto=do(m,c)<-getfrom<-expandSynafromcasemLookupfrommofJust(FunDn_)->return$VarEn_->dof<-qNewName"_f"letmkRec=doput(mInsertfrom(FunDf[Clause[](NormalB$TupE[])[]])m,c)-- insert something to break recursion, will be replaced below.uniBiCasefromtocs<-iffrom==tothendob<-contains'tofromifbthendo-- Recursive data type, we need the current value and all values inside.g<-qNewName"_g"gcs<-mkRecletdg=FunDggcs-- Insert with a dummy type, just to get the definition in the map for mElems.modify$\(m',c')->(mInsert(ConTg)dgm',c')unFun[d|f_x_r=_x:$(return(VarEg))_x_r|]else-- Non-recursive type, just use this value.unFun[d|f_x_r=_x:_r|]elsedo-- Types differ, look inside.b<-containstofromifbthendo-- Occurrences inside, recurse.mkRecelse-- No occurrences of to inside from, so add nothing.unFun[d|f__r=_r|]letd=FunDfcsmodify$\(m',c')->(mInsertfromdm',c')return$VarEf-- Check if the second type is contained anywhere in the first type.contains::Type->Type->UBoolcontainstoafrom=do-- qRunIO $ print ("contains", to, from)from<-expandSynafromiffrom==tothenreturnTrueelsedoc<-getssndcasemLookupfromcofJustb->returnbNothing->contains'tofrom-- Check if the second type is contained somewhere inside the first.contains'::Type->Type->UBoolcontains'tofrom=do-- qRunIO $ print ("contains'", to, from)let(con,ts)=splitTypeAppfrommodify$\(m,c)->(m,mInsertfromFalsec)-- To make the fixpoint of the recursion False.b<-caseconofConTn->containsConntotsTupleT_->fmapor$mapM(containsto)tsArrowT->returnFalseListT->ifto==fromthenreturnTrueelsecontainsto(headts)VarT_->returnFalset->genError$"contains: unexpected type: "++pprintfrom++" ("++showt++")"modify$\(m,c)->(m,mInsertfrombc)returnbcontainsCon::Name->Type->[Type]->UBoolcontainsConcontots=do-- qRunIO $ print ("containsCon", con, to, ts)(tvs,cons)<-getTyConInfoconletconCon(NormalC_xs)=fmapor$mapM(field.snd)xsconCon(InfixCx1_x2)=fmapor$mapMfield[sndx1,sndx2]conCon(RecC_xs)=fmapor$mapMfield[t|(_,_,t)<-xs]conConc=genError$"containsCon: "++showcs=mkSubsttvstsfieldt=containsto(substst)fmapor$mapMconConconsunFunD::[Dec]->[Clause]unFunD[FunD_cs]=csunFunD_=genError$"unFunD"unFun::Q[Dec]->U[Clause]unFun=lift.fmapunFunDuniBiCase::Type->Type->U[Clause]uniBiCasefromto=dolet(con,ts)=splitTypeAppfromcaseconofConTn->uniBiConntstoTupleT_->uniBiTupletsto-- ArrowT -> unFun [d| f _ _r = _r |] -- Stop at functionsListT->uniBiList(headts)tot->genError$"uniBiCase: unexpected type: "++pprintfrom++" ("++showt++")"uniBiList::Type->Type->U[Clause]uniBiListtto=douni<-uniBittorec<-uniBi(AppTListTt)tounFun[d|f[]_r=_r;f(_x:_xs)_r=$(returnuni)_x($(returnrec)_xs_r)|]uniBiTuple::[Type]->Type->U[Clause]uniBiTupletsto=fmap(:[])$mkArmto[]TupPtsuniBiCon::Name->[Type]->Type->U[Clause]uniBiConcontsto=do(tvs,cons)<-getTyConInfoconletgenArm(NormalCcxs)=arm(ConPc)xsgenArm(InfixCx1cx2)=arm(\[p1,p2]->InfixPp1cp2)[x1,x2]genArm(RecCcxs)=arm(ConPc)[(b,t)|(_,b,t)<-xs]genArmc=genError$"uniBiCon: "++showcs=mkSubsttvstsarmcxs=mkArmtosc$mapsndxsifnullconsthen-- No constructurs, return nothingunFun[d|f__r=_r|]elsemapMgenArmconsmkArm::Type->Subst->([Pat]->Pat)->[Type]->UClausemkArmtoscts=dor<-qNewName"_r"vs<-mapM(const$qNewName"_x")tsletsubvt=dolett'=subststuni<-uniBit'toreturn$AppE(AppEuni(VarEv))es<-zipWithMsubvstsletbody=foldr($)(VarEr)esreturn$Clause[c(mapVarPvs),VarPr](NormalBbody)[]typeSubst=[(Name,Type)]mkSubst::[TyVarBndr]->[Type]->SubstmkSubstvsts=letvs'=mapunvsun(PlainTVv)=vun(KindedTVv_)=vinassert(lengthvs'==lengthts)$zipvs'tssubst::Subst->Type->Typesubsts(ForallTvct)=ForallTvc$subststsubstst@(VarTn)=fromMaybet$lookupnssubsts(AppTt1t2)=AppT(substst1)(substst2)substs(SigTtk)=SigT(substst)ksubst_t=tgetTyConInfo::(Quasiq)=>Name->q([TyVarBndr],[Con])getTyConInfocon=doinfo<-qReifyconcaseinfoofTyConI(DataD__tvscs_)->return(tvs,cs)TyConI(NewtypeD__tvsc_)->return(tvs,[c])PrimTyConI{}->return([],[])i->genError$"unexpected TyCon: "++showigetNameType::(Quasiq)=>Name->q([TyVarBndr],Type,Type)getNameTypename=doinfo<-qReifynameletsplit(ForallTtvs_t)=(tvs++tvs',from,to)where(tvs',from,to)=splittsplit(AppT(AppTArrowTfrom)to)=([],from,to)splitt=genError$"Type is not an arrow: "++pprinttcaseinfoofVarI_t__->return$splitt_->genError$"Name is not variable: "++pprintnameunList::Type->TypeunList(AppT(ConTn)t)|n==''[]=tunList(AppTListTt)=tunListt=genError$"universeBi: Type is not a list: "++pprintt-- ++ " (" ++ show t ++ ")"splitTypeApp::Type->(Type,[Type])splitTypeApp(AppTar)=(c,rs++[r])where(c,rs)=splitTypeAppasplitTypeAppt=(t,[])expandSyn::(Quasiq)=>Type->qTypeexpandSyn(ForallTtvsctxt)=liftM(ForallTtvsctx)$expandSyntexpandSynt@AppT{}=expandSynAppt[]expandSynt@ConT{}=expandSynAppt[]expandSyn(SigTtk)=expandSynt-- Ignore kind synonymsexpandSynt=returntexpandSynApp::(Quasiq)=>Type->[Type]->qTypeexpandSynApp(AppTt1t2)ts=dot2'<-expandSynt2;expandSynAppt1(t2':ts)expandSynApp(ConTn)ts|nameBasen=="[]"=return$foldlAppTListTtsexpandSynAppt@(ConTn)ts=doinfo<-qReifyncaseinfoofTyConI(TySynD_tvsrhs)->let(ts',ts'')=splitAt(lengthtvs)tss=mkSubsttvsts'rhs'=substsrhsinexpandSynApprhs'ts''_->return$foldlAppTttsexpandSynApptts=dot'<-expandSynt;return$foldlAppTt'tsgenError::String->agenErrormsg=error$"Data.Generics.Geniplate: "++msg------------------------------------------------------ Exp has type (S -> S) -> T -> T, for some S and T-- | Generate TH code for a function that transforms all subparts of a certain type.-- The argument to 'genTransformBi' is a name with the type @(S->S) -> T -> T@, for some types-- @S@ and @T@. The function will transform all subparts of type @S@ inside @T@ using the given function.genTransformBi::Name-- ^function of type @(S->S) -> T -> T@->QExpgenTransformBi=genTransformBiT[]-- | Same as 'genTransformBi', but does not look inside any types mention in the-- list of types.genTransformBiT::[TypeQ]->Name->QExpgenTransformBiT=transformBiGraNormalraNormal::RetApraNormal=(id,AppE,AppE)genTransformBiM::Name->QExpgenTransformBiM=genTransformBiMT[]genTransformBiMT::[TypeQ]->Name->QExpgenTransformBiMT=transformBiGraMonadraMonad::RetApraMonad=(eret,eap,emap)whereerete=AppE(VarE'Control.Monad.return)eeapfa=AppE(AppE(VarE'Control.Monad.ap)f)aemapfa=AppE(AppE(VarE'(Control.Monad.=<<))f)atypeRetAp=(Exp->Exp,Exp->Exp->Exp,Exp->Exp->Exp)transformBiG::RetAp->[TypeQ]->Name->QExptransformBiGrastopsname=do(_tvs,fcn,res)<-getNameTypenamef<-newName"_f"x<-newName"_x"(ds,tr)<-case(fcn,res)of(AppT(AppTArrowTs)s',AppT(AppTArrowTt)t')|s==s'&&t==t'->trBiQrastopsfst(AppT(AppTArrowTs)(AppTms'),AppT(AppTArrowTt)(AppTm't'))|s==s'&&t==t'&&m==m'->trBiQrastopsfst_->genError$"transformBi: malformed type: "++pprint(AppT(AppTArrowTfcn)res)++", should have form (S->S) -> (T->T)"lete=LamE[VarPf,VarPx]$LetEds$AppEtr(VarEx)-- qRunIO $ do putStrLn $ pprint e; hFlush stdoutreturnetrBiQ::RetAp->[TypeQ]->Name->Type->Type->Q([Dec],Exp)trBiQrastopsfaftst=doss<-sequencestopsft<-expandSynaft(tr,(m,_))<-runStateT(trBira(VarEf)ftst)(mEmpty,mFromList$zipss(repeatFalse))return(mElemsm,tr)arrow::Type->Type->Typearrowt1t2=AppT(AppTArrowTt1)t2trBi::RetAp->Exp->Type->Type->UExptrBira@(ret,_,rbind)fftast=do(m,c)<-getst<-expandSynast-- qRunIO $ print (ft, st)casemLookupstmofJust(FunDn_)->return$VarEn_->dotr<-qNewName"_tr"letmkRec=doput(mInsertst(FunDtr[Clause[](NormalB$TupE[])[]])m,c)-- insert something to break recursion, will be replaced below.trBiCaserafftstcs<-ifft==stthendob<-contains'ftstifbthendog<-qNewName"_g"gcs<-mkRecletdg=FunDggcs-- Insert with a dummy type, just to get the definition in the map for mElems.modify$\(m',c')->(mInsert(ConTg)dgm',c')x<-qNewName"_x"return[Clause[VarPx](NormalB$rbindf(AppE(VarEg)(VarEx)))[]]elsedox<-qNewName"_x"return[Clause[VarPx](NormalB$AppEf(VarEx))[]]elsedob<-containsftst-- qRunIO $ print (b, ft, st)ifbthendomkRecelsedox<-qNewName"_x"return[Clause[VarPx](NormalB$ret$VarEx)[]]letd=FunDtrcsmodify$\(m',c')->(mInsertstdm',c')return$VarEtrtrBiCase::RetAp->Exp->Type->Type->U[Clause]trBiCaserafftst=dolet(con,ts)=splitTypeAppstcaseconofConTn->trBiConrafnftsttsTupleT_->trBiTuplerafftstts-- ArrowT -> unFun [d| f _ _r = _r |] -- Stop at functionsListT->trBiListrafftst(headts)_->genError$"trBiCase: unexpected type: "++pprintst++" ("++showst++")"trBiList::RetAp->Exp->Type->Type->Type->U[Clause]trBiListrafftstet=donil<-trMkArmrafftst[](const$ListP[])(ListE[])[]cons<-trMkArmrafftst[](ConP'(:))(ConE'(:))[et,st]return[nil,cons]trBiTuple::RetAp->Exp->Type->Type->[Type]->U[Clause]trBiTuplerafftstts=dovs<-mapM(const$qNewName"_t")tslettupE=LamE(mapVarPvs)$TupE(mapVarEvs)c<-trMkArmrafftst[]TupPtupEtsreturn[c]trBiCon::RetAp->Exp->Name->Type->Type->[Type]->U[Clause]trBiConrafconftstts=do(tvs,cons)<-getTyConInfoconletgenArm(NormalCcxs)=arm(ConPc)(ConEc)xsgenArm(InfixCx1cx2)=arm(\[p1,p2]->InfixPp1cp2)(ConEc)[x1,x2]genArm(RecCcxs)=arm(ConPc)(ConEc)[(b,t)|(_,b,t)<-xs]genArmc=genError$"trBiCon: "++showcs=mkSubsttvstsarmcecxs=trMkArmrafftstscec$mapsndxsmapMgenArmconstrMkArm::RetAp->Exp->Type->Type->Subst->([Pat]->Pat)->Exp->[Type]->UClausetrMkArmra@(ret,apl,_)fftstscects=dovs<-mapM(const$qNewName"_x")tsletsubvt=dolett'=subststtr<-trBirafftt'return$AppEtr(VarEv)conTy=foldrarrowst(map(substs)ts)es<-zipWithMsubvstsletbody=foldlapl(retec)esreturn$Clause[c(mapVarPvs)](NormalBbody)[]------------------------------------------------------ Can't use Data.Map since TH stuff is not in OrdnewtypeMapab=Map[(a,b)]mEmpty::MapabmEmpty=Map[]mLookup::(Eqa)=>a->Mapab->MaybebmLookupa(Mapxys)=lookupaxysmInsert::(Eqa)=>a->b->Mapab->MapabmInsertab(Mapxys)=Map$(a,b):filter((/=a).fst)xysmElems::Mapab->[b]mElems(Mapxys)=mapsndxysmFromList::[(a,b)]->MapabmFromListxys=Mapxys