{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE GADTs #-}{-# LANGUAGE KindSignatures #-}{-# LANGUAGE MultiParamTypeClasses #-}{-# LANGUAGE RankNTypes #-}{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE TypeOperators #-}{-# LANGUAGE EmptyDataDecls #-}------------------------------------------------------------------------------- |-- Module : Generics.MultiRec.Zipper-- Copyright : (c) 2008--2009 Universiteit Utrecht-- License : BSD3---- Maintainer : generics@haskell.org-- Stability : experimental-- Portability : non-portable------ The generic zipper.-------------------------------------------------------------------------------moduleGenerics.MultiRec.Zipper(-- * LocationsLoc(),-- * Context framesCtx(),-- * Generic zipper classZipper(..),-- * Interfaceenter,down,down',up,right,left,dfnext,dfprev,leave,on,update,foldZipper)whereimportPreludehiding(last)importControl.MonadimportControl.ApplicativeimportData.MaybeimportData.TraversableimportGenerics.MultiRec.BaseimportGenerics.MultiRec.FoldimportGenerics.MultiRec.HFunctor-- * Locations and context stacks-- | Abstract type of locations. A location contains the current focus-- and its context. A location is parameterized over the family of-- datatypes and over the type of the complete value.dataLoc::(*->*)->(*->*)->*->*whereLoc::(Famphi,Zipperphi(PFphi))=>phiix->rix->Ctxsphiixra->LocphiradataCtxs::(*->*)->*->(*->*)->*->*whereEmpty::CtxsphiaraPush::phiix->Ctx(PFphi)brix->Ctxsphiixra->Ctxsphibra-- * Context frames-- | Abstract type of context frames. Not required for the high-level-- navigation functions.datafamilyCtx(f::(*->*)->*->*)::*->(*->*)->*->*datainstanceCtx(Ka)brixdatainstanceCtxUbrixdatainstanceCtx(f:+:g)brix=CL(Ctxfbrix)|CR(Ctxgbrix)datainstanceCtx(f:*:g)brix=C1(Ctxfbrix)(grix)|C2(frix)(Ctxgbrix)datainstanceCtx([]:.:g)brix=CCL[grix](Ctxgbrix)[grix]datainstanceCtx(Maybe:.:g)brix=CCM(Ctxgbrix)-- The equality constraints simulate GADTs. GHC currently-- does not allow us to use GADTs as data family instances.datainstanceCtx(Ixi)brix=CId(b:=:xi)datainstanceCtx(f:>:xi)brix=CTag(ix:=:xi)(Ctxfbrix)datainstanceCtx(Ccf)brix=CC(Ctxfbrix)-- * Contexts and locations are functorsinstanceZipperphif=>HFunctorphi(Ctxfb)wherehmapA=cmapAinstanceZipperphi(PFphi)=>HFunctorphi(Ctxsphib)wherehmapAfp'Empty=pureEmptyhmapAfp'(Pushpcs)=liftA2(Pushp)(hmapAfpc)(hmapAfp's)instanceHFunctorphi(Locphi)wherehmapAfp'(Locpxs)=liftA2(Locp)(fpx)(hmapAfp's)-- * Generic navigation functions-- | It is in general not necessary to use the generic navigation-- functions directly. The functions listed in the ``Interface'' section-- below are more user-friendly.--classHFunctorphif=>ZipperphifwherecmapA::Applicativea=>(forallix.phiix->rix->a(r'ix))->phiix->Ctxfbrix->a(Ctxfbr'ix)fill::phib->Ctxfbrix->rb->frixfirst,last::(forallb.phib->rb->Ctxfbrix->a)->frix->Maybeanext,prev::(forallb.phib->rb->Ctxfbrix->a)->phib->Ctxfbrix->rb->MaybeainstanceElphixi=>Zipperphi(Ixi)wherecmapAfp(CIdprf)=pure(CIdprf)fillp(CIdprf)x=castIdprfIxfirstf(Ix)=return(fproofx(CIdRefl))lastf(Ix)=return(fproofx(CIdRefl))nextfp(CIdprf)x=Nothingprevfp(CIdprf)x=NothinginstanceZipperphi(Ka)wherecmapAfpvoid=impossiblevoidfillpvoidx=impossiblevoidfirstf(Ka)=Nothinglastf(Ka)=Nothingnextfpvoidx=impossiblevoidprevfpvoidx=impossiblevoidinstanceZipperphiUwherecmapAfpvoid=impossiblevoidfillpvoidx=impossiblevoidfirstfU=NothinglastfU=Nothingnextfpvoidx=impossiblevoidprevfpvoidx=impossiblevoidinstance(Zipperphif,Zipperphig)=>Zipperphi(f:+:g)wherecmapAfp(CLc)=liftACL(cmapAfpc)cmapAfp(CRc)=liftACR(cmapAfpc)fillp(CLc)x=L(fillpcx)fillp(CRc)y=R(fillpcy)firstf(Lx)=first(\pz->fpz.CL)xfirstf(Ry)=first(\pz->fpz.CR)ylastf(Lx)=last(\pz->fpz.CL)xlastf(Ry)=last(\pz->fpz.CR)ynextfp(CLc)x=next(\pz->fpz.CL)pcxnextfp(CRc)y=next(\pz->fpz.CR)pcyprevfp(CLc)x=prev(\pz->fpz.CL)pcxprevfp(CRc)y=prev(\pz->fpz.CR)pcyinstance(Zipperphif,Zipperphig)=>Zipperphi(f:*:g)wherecmapAfp(C1cy)=liftA2C1(cmapAfpc)(hmapAfpy)cmapAfp(C2xc)=liftA2C2(hmapAfpx)(cmapAfpc)fillp(C1cy)x=fillpcx:*:yfillp(C2xc)y=x:*:fillpcyfirstf(x:*:y)=first(\pzc->fpz(C1cy))x`mplus`first(\pzc->fpz(C2xc))ylastf(x:*:y)=last(\pzc->fpz(C2xc))y`mplus`last(\pzc->fpz(C1cy))xnextfp(C1cy)x=next(\p'zc'->fp'z(C1c'y))pcx`mplus`first(\p'zc'->fp'z(C2(fillpcx)c'))ynextfp(C2xc)y=next(\p'zc'->fp'z(C2xc'))pcyprevfp(C1cy)x=prev(\p'zc'->fp'z(C1c'y))pcxprevfp(C2xc)y=prev(\p'zc'->fp'z(C2xc'))pcy`mplus`last(\p'zc'->fp'z(C1c'(fillpcy)))x-- For the time being, we support just [] and Maybe. I think we-- might be able to support a whole class (Foldable).instance(Zipperphig)=>Zipperphi([]:.:g)wherecmapAfp(CCLpbcpe)=CCL<$>traverse(hmapAfp)pb<*>cmapAfpc<*>traverse(hmapAfp)pefillp(CCLpbcpe)x=D(reversepb++fillpcx:pe)firstf(D[])=Nothingfirstf(D(x:xs))=first(\pzc->fpz(CCL[]cxs))xlastf(Dxs)=casereversexsof[]->Nothingy:ys->last(\pzc->fpz(CCLysc[]))ynextfp(CCLpbcpe)x=next(\pzc->fpz(CCLpbcpe))pcx`mplus`casepeof[]->Nothingy:ys->first(\p'zc'->fp'z(CCL(fillpcx:pb)c'ys))yprevfp(CCLpbcpe)x=prev(\pzc->fpz(CCLpbcpe))pcx`mplus`casepbof[]->Nothingy:ys->last(\p'zc'->fp'z(CCLysc'(fillpcx:pe)))yinstance(Zipperphig)=>Zipperphi(Maybe:.:g)wherecmapAfp(CCMc)=CCM<$>cmapAfpcfillp(CCMc)x=D(Just(fillpcx))firstf(DNothing)=Nothingfirstf(D(Justx))=first(\pz->fpz.CCM)xlastf(DNothing)=Nothinglastf(D(Justx))=last(\pz->fpz.CCM)xnextfp(CCMc)x=next(\pz->fpz.CCM)pcxprevfp(CCMc)x=prev(\pz->fpz.CCM)pcxinstanceZipperphif=>Zipperphi(f:>:xi)wherecmapAfp(CTagprfc)=liftA(CTagprf)(cmapAfpc)fillp(CTagprfc)x=castTagprfTag(fillpcx)firstf(Tagx)=first(\pz->fpz.CTagRefl)xlastf(Tagx)=last(\pz->fpz.CTagRefl)xnextfp(CTagprfc)x=next(\pz->fpz.CTagprf)pcxprevfp(CTagprfc)x=prev(\pz->fpz.CTagprf)pcxinstance(Constructorc,Zipperphif)=>Zipperphi(Ccf)wherecmapAfp(CCc)=liftACC(cmapAfpc)fillp(CCc)x=C(fillpcx)firstf(Cx)=first(\pz->fpz.CC)xlastf(Cx)=last(\pz->fpz.CC)xnextfp(CCc)x=next(\pz->fpz.CC)pcxprevfp(CCc)x=prev(\pz->fpz.CC)pcx-- * Interface-- ** Introduction-- | Start navigating a datastructure. Returns a location that-- focuses the entire value and has an empty context.enter::(Famphi,Zipperphi(PFphi))=>phiix->ix->LocphiI0ixenterpx=Locp(I0x)Empty-- ** Navigation-- | Move down to the leftmost child. Returns 'Nothing' if the-- current focus is a leaf.down::LocphiI0ix->Maybe(LocphiI0ix)-- | Move down to the rightmost child. Returns 'Nothing' if the-- current focus is a leaf.down'::LocphiI0ix->Maybe(LocphiI0ix)-- | Move up to the parent. Returns 'Nothing' if the current-- focus is the root.up::LocphiI0ix->Maybe(LocphiI0ix)-- | Move to the right sibling. Returns 'Nothing' if the current-- focus is the rightmost sibling.right::Locphirix->Maybe(Locphirix)-- | Move to the left sibling. Returns 'Nothing' if the current-- focus is the leftmost sibling.left::Locphirix->Maybe(Locphirix)down(Locp(I0x)s)=first(\p'zc->Locp'z(Pushpcs))(frompx)down'(Locp(I0x)s)=last(\p'zc->Locp'z(Pushpcs))(frompx)up(LocpxEmpty)=Nothingup(Locpx(Pushp'cs))=return(Locp'(I0$top'(fillpcx))s)right(LocpxEmpty)=Nothingright(Locpx(Pushp'cs))=next(\pzc'->Locpz(Pushp'c's))pcxleft(LocpxEmpty)=Nothingleft(Locpx(Pushp'cs))=prev(\pzc'->Locpz(Pushp'c's))pcx-- ** Derived navigation.df::(a->Maybea)->(a->Maybea)->(a->Maybea)->a->Maybeadfdulrl=casedlofNothing->df'lr->rwheredf'l=caselrlofNothing->caseulofNothing->NothingJustl'->df'l'r->r-- | Move through all positions in depth-first left-to-right order.dfnext::LocphiI0ix->Maybe(LocphiI0ix)dfnext=dfdownupright-- | Move through all positions in depth-first right-to-left order.dfprev::LocphiI0ix->Maybe(LocphiI0ix)dfprev=dfdown'upleft-- ** Elimination-- | Return the entire value, independent of the current focus.leave::LocphiI0ix->ixleave(Locp(I0x)Empty)=xleaveloc=leave(fromJust(uploc))-- | Operate on the current focus. This function can be used to-- extract the current point of focus.on::(forallxi.phixi->rxi->a)->Locphirix->aonf(Locpx_)=fpx-- | Update the current focus without changing its type.update::(forallxi.phixi->xi->xi)->LocphiI0ix->LocphiI0ixupdatef(Locp(I0x)s)=Locp(I0$fpx)s-- | Most general eliminator. Both 'on' and 'update' can be defined-- in terms of 'foldZipper'.foldZipper::(forallxi.phixi->xi->rxi)->Algebraphir->LocphiI0ix->rixfoldZipperfalg(Locp(I0x)c)=cfoldalgpc(fpx)wherecfold::(Famphi,Zipperphi(PFphi))=>Algebraphir->phib->CtxsphibI0a->rb->racfoldalgp'Emptyx=xcfoldalgp'(Pushpcs)x=cfoldalgps(algp(fillp'(hmap(\p(I0x)->foldalgpx)pc)x))-- * Internal functionsimpossible::a->bimpossiblex=error"impossible"-- Helping the typechecker to apply equality proofs correctly ...castId::(b:=:xi)->(rxi->Ixirix)->(rb->Ixirix)castTag::(ix:=:xi)->(frix->(f:>:ix)rix)->(frix->(f:>:xi)rix)castIdReflf=fcastTagReflf=f