{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}-- | The abstract representation of a Tree and useful abstract utilities to-- handle those.moduleStorage.Hashed.Tree(Tree,Blob(..),TreeItem(..),ItemType(..),Hash(..),makeTree,makeTreeWithHash,emptyTree,emptyBlob,makeBlob,makeBlobBS-- * Unfolding stubbed (lazy) Trees.---- | By default, Tree obtained by a read function is stubbed: it will-- contain Stub items that need to be executed in order to access the-- respective subtrees. 'expand' will produce an unstubbed Tree.,expandUpdate,expand,expandPath-- * Tree access and lookup.,items,list,listImmediate,treeHash,lookup,find,findFile,findTree,itemHash,itemType,zipCommonFiles,zipFiles,zipTrees,diffTrees-- * Files (Blobs).,readBlob-- * Filtering trees.,FilterTree(..),restrict-- * Manipulating trees.,modifyTree,updateTree,partiallyUpdateTree,updateSubtrees,overlay,addMissingHashes)whereimportPreludehiding(lookup,filter,all)importStorage.Hashed.AnchoredPathimportStorage.Hashed.HashimportqualifiedData.ByteString.Lazy.Char8asBLimportqualifiedData.ByteString.Char8asBSimportqualifiedData.MapasMimportData.Maybe(catMaybes,isNothing)importData.List(union,sort)importControl.Applicative((<$>))---------------------------------- Tree, Blob and friends--dataBlobm=Blob!(mBL.ByteString)!HashdataTreeItemm=File!(Blobm)|SubTree!(Treem)|Stub!(m(Treem))!HashdataItemType=BlobType|TreeTypederiving(Show,Eq)-- | Abstraction of a filesystem tree.-- Please note that the Tree returned by the respective read operations will-- have TreeStub items in it. To obtain a Tree without such stubs, call-- expand on it, eg.:---- > tree <- readDarcsPristine "." >>= expand---- When a Tree is expanded, it becomes \"final\". All stubs are forced and the-- Tree can be traversed purely. Access to actual file contents stays in IO-- though.---- A Tree may have a Hash associated with it. A pair of Tree's is identical-- whenever their hashes are (the reverse need not hold, since not all Trees-- come equipped with a hash).dataTreem=Tree{items::(M.MapName(TreeItemm))-- | Get hash of a Tree. This is guaranteed to uniquely-- identify the Tree (including any blob content), as far as-- cryptographic hashes are concerned. Sha256 is recommended.,treeHash::!Hash}listImmediate::Treem->[(Name,TreeItemm)]listImmediate=M.toList.items-- | Get a hash of a TreeItem. May be Nothing.itemHash::TreeItemm->HashitemHash(File(Blob_h))=hitemHash(SubTreet)=treeHashtitemHash(Stub_h)=hitemType::TreeItemm->ItemTypeitemType(File_)=BlobTypeitemType(SubTree_)=TreeTypeitemType(Stub__)=TreeTypeemptyTree::(Monadm)=>TreememptyTree=Tree{items=M.empty,treeHash=NoHash}emptyBlob::(Monadm)=>BlobmemptyBlob=Blob(returnBL.empty)NoHashmakeBlob::(Monadm)=>BL.ByteString->BlobmmakeBlobstr=Blob(returnstr)(sha256str)makeBlobBS::(Monadm)=>BS.ByteString->BlobmmakeBlobBSs'=lets=BL.fromChunks[s']inBlob(returns)(sha256s)makeTree::(Monadm)=>[(Name,TreeItemm)]->TreemmakeTreel=Tree{items=M.fromListl,treeHash=NoHash}makeTreeWithHash::(Monadm)=>[(Name,TreeItemm)]->Hash->TreemmakeTreeWithHashlh=Tree{items=M.fromListl,treeHash=h}------------------------------------- Tree access and lookup---- | Look up a 'Tree' item (an immediate subtree or blob).lookup::Treem->Name->Maybe(TreeItemm)lookuptn=M.lookupn(itemst)find'::TreeItemm->AnchoredPath->Maybe(TreeItemm)find't(AnchoredPath[])=Justtfind'(SubTreet)(AnchoredPath(d:rest))=caselookuptdofJustsub->find'sub(AnchoredPathrest)Nothing->Nothingfind'__=Nothing-- | Find a 'TreeItem' by its path. Gives 'Nothing' if the path is invalid.find::Treem->AnchoredPath->Maybe(TreeItemm)find=find'.SubTree-- | Find a 'Blob' by its path. Gives 'Nothing' if the path is invalid, or does-- not point to a Blob.findFile::Treem->AnchoredPath->Maybe(Blobm)findFiletp=casefindtpofJust(Filex)->Justx_->Nothing-- | Find a 'Tree' by its path. Gives 'Nothing' if the path is invalid, or does-- not point to a Tree.findTree::Treem->AnchoredPath->Maybe(Treem)findTreetp=casefindtpofJust(SubTreex)->Justx_->Nothing-- | List all contents of a 'Tree'.list::Treem->[(AnchoredPath,TreeItemm)]listt_=pathst_(AnchoredPath[])wherepathstp=[(appendPathpn,i)|(n,i)<-listImmediatet]++concat[pathssubt(appendPathpsubn)|(subn,SubTreesubt)<-listImmediatet]expandUpdate::(Monadm)=>(AnchoredPath->Treem->m(Treem))->Treem->m(Treem)expandUpdateupdatet_=go(AnchoredPath[])t_wheregopatht=doletsubtree(name,sub)=dotree<-go(path`appendPath`name)=<<unstubsubreturn(name,SubTreetree)expanded<-mapMsubtree[x|x@(_,item)<-listImmediatet,isSubitem]letorig=[i|i<-listImmediatet,not$isSub$sndi]orig_map=M.filter(not.isSub)(itemst)expanded_map=M.fromListexpandedtree=t{items=M.unionorig_mapexpanded_map}updatepathtree-- | Expand a stubbed Tree into a one with no stubs in it. You might want to-- filter the tree before expanding to save IO. This is the basic-- implementation, which may be overriden by some Tree instances (this is-- especially true of the Index case).expand::(Monadm)=>Treem->m(Treem)expand=expandUpdate$\_->return-- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is-- reachable without crossing any stubs. Moreover, the leaf ought not be a Stub-- in the resulting Tree. A non-existent path is expanded as far as it can be.expandPath::(Monadm)=>Treem->AnchoredPath->m(Treem)expandPatht_path_=expand't_path_whereexpand't(AnchoredPath[])=returntexpand't(AnchoredPath(n:rest))=caselookuptnof(Justitem)|isSubitem->amendtnrest=<<unstubitem_->returnt-- fail $ "Descent error in expandPath: " ++ show path_amendtnamerestsub=dosub'<-expand'sub(AnchoredPathrest)lettree=t{items=M.insertname(SubTreesub')(itemst)}returntreeclass(Monadm)=>FilterTreeamwhere-- | Given @pred tree@, produce a 'Tree' that only has items for which-- @pred@ returns @True@.-- The tree might contain stubs. When expanded, these will be subject to-- filtering as well.filter::(AnchoredPath->TreeItemm->Bool)->am->aminstance(Monadm)=>FilterTreeTreemwherefilterpredicatet_=filter't_(AnchoredPath[])wherefilter'tpath=letsubs=(catMaybes[(,)name`fmap`wibblepathnameitem|(name,item)<-listImmediatet])int{items=M.mapMaybeWithKey(wibblepath)$itemst}wibblepathnameitem=letnpath=path`appendPath`nameinifpredicatenpathitemthenJust$filterSubnpathitemelseNothingfilterSubnpath(SubTreet)=SubTree$filter'tnpathfilterSubnpath(Stubstubh)=Stub(dox<-stubreturn$filter'xnpath)hfilterSub_x=x-- | Given two Trees, a @guide@ and a @tree@, produces a new Tree that is a-- identical to @tree@, but only has those items that are present in both-- @tree@ and @guide@. The @guide@ Tree may not contain any stubs.restrict::(FilterTreetm,Monadn)=>Treen->tm->tmrestrictguidetree=filteraccepttreewhereacceptpathitem=case(findguidepath,item)of(Just(SubTree_),SubTree_)->True(Just(SubTree_),Stub__)->True(Just(File_),File_)->True(Just(Stub__),_)->error"*sulk* Go away, you, you precondition violator!"(_,_)->False-- | Read a Blob into a Lazy ByteString. Might be backed by an mmap, use with-- care.readBlob::Blobm->mBL.ByteStringreadBlob(Blobr_)=r-- | For every pair of corresponding blobs from the two supplied trees,-- evaluate the supplied function and accumulate the results in a list. Hint:-- to get IO actions through, just use sequence on the resulting list.-- NB. This won't expand any stubs.zipCommonFiles::(AnchoredPath->Blobm->Blobm->a)->Treem->Treem->[a]zipCommonFilesfab=catMaybes[flip(fp)x`fmap`findFileap|(p,Filex)<-listb]-- | For each file in each of the two supplied trees, evaluate the supplied-- function (supplying the corresponding file from the other tree, or Nothing)-- and accumulate the results in a list. Hint: to get IO actions through, just-- use sequence on the resulting list. NB. This won't expand any stubs.zipFiles::(AnchoredPath->Maybe(Blobm)->Maybe(Blobm)->a)->Treem->Treem->[a]zipFilesfab=[fp(findFileap)(findFilebp)|p<-pathsa`sortedUnion`pathsb]wherepathst=sort[p|(p,File_)<-listt]zipTrees::(AnchoredPath->Maybe(TreeItemm)->Maybe(TreeItemm)->a)->Treem->Treem->[a]zipTreesfab=[fp(findap)(findbp)|p<-reverse(pathsa`sortedUnion`pathsb)]wherepathst=sort[p|(p,_)<-listt]-- | Helper function for taking the union of AnchoredPath lists that-- are already sorted. This function does not check the precondition-- so use it carefully.sortedUnion::[AnchoredPath]->[AnchoredPath]->[AnchoredPath]sortedUnion[]ys=yssortedUnionxs[]=xssortedUniona@(x:xs)b@(y:ys)=casecomparexyofLT->x:sortedUnionxsbEQ->x:sortedUnionxsysGT->y:sortedUnionays-- | Cautiously extracts differing subtrees from a pair of Trees. It will never-- do any unneccessary expanding. Tree hashes are used to cut the comparison as-- high up the Tree branches as possible. The result is a pair of trees that do-- not share any identical subtrees. They are derived from the first and second-- parameters respectively and they are always fully expanded. It might be-- advantageous to feed the result into 'zipFiles' or 'zipTrees'.diffTrees::forallm.(Functorm,Monadm)=>Treem->Treem->m(Treem,Treem)diffTreesleftright=iftreeHashleft`match`treeHashrightthenreturn(emptyTree,emptyTree)elsediffleftrightwhereisFile(File_)=TrueisFile_=FalsenotFile=not.isFileisEmpty=null.listImmediatesubtree::TreeItemm->m(Treem)subtree(Stubx_)=xsubtree(SubTreex)=returnxsubtree(File_)=error"diffTrees tried to descend a File as a subtree"maybeUnfold(Stubx_)=SubTree`fmap`(x>>=expand)maybeUnfold(SubTreex)=SubTree`fmap`expandxmaybeUnfoldi=returniimmediateNt=[n|(n,_)<-listImmediatet]diffleft'right'=dois<-sequence[case(lookupleft'n,lookupright'n)of(Justl,Nothing)->dol'<-maybeUnfoldlreturn(n,Justl',Nothing)(Nothing,Justr)->dor'<-maybeUnfoldrreturn(n,Nothing,Justr')(Justl,Justr)|itemHashl`match`itemHashr->return(n,Nothing,Nothing)|notFilel&&notFiler->dox<-subtreely<-subtreer(x',y')<-diffTreesxyifisEmptyx'&&isEmptyy'thenreturn(n,Nothing,Nothing)elsereturn(n,Just$SubTreex',Just$SubTreey')|isFilel&&isFiler->return(n,Justl,Justr)|otherwise->dol'<-maybeUnfoldlr'<-maybeUnfoldrreturn(n,Justl',Justr')_->error"n lookups failed"|n<-immediateNleft'`union`immediateNright']letis_l=[(n,l)|(n,Justl,_)<-is]is_r=[(n,r)|(n,_,Justr)<-is]return(makeTreeis_l,makeTreeis_r)-- | Modify a Tree (by replacing, or removing or adding items).modifyTree::(Monadm)=>Treem->AnchoredPath->Maybe(TreeItemm)->TreemmodifyTreet_p_i_=snd$got_p_i_wherefixtunmoditems'=(unmod,t{items=countmapitems'`seq`items',treeHash=ifunmodthentreeHashtelseNoHash})got(AnchoredPath[])(Just(SubTreesub))=(treeHasht`match`treeHashsub,sub)got(AnchoredPath[n])(Justitem)=fixtunmoditems'where!items'=M.insertnitem(itemst)!unmod=itemHashitem`match`caselookuptnofNothing->NoHashJusti->itemHashigot(AnchoredPath[n])Nothing=fixtunmoditems'where!items'=M.deleten(itemst)!unmod=isNothing$lookuptngotpath@(AnchoredPath(n:r))item=fixtunmoditems'wheresubtrees=gos(AnchoredPathr)item!items'=M.insertnsub(itemst)!sub=sndsub'!unmod=fstsub'!sub'=caselookuptnofJust(SubTrees)->let(mod,sub)=subtreesin(mod,SubTreesub)Just(Stubs_)->(False,Stub(dox<-sreturn$!snd$!subtreex)NoHash)Nothing->(False,SubTree$!snd$!subtreeemptyTree)_->error$"Modify tree at "++showpathgo_(AnchoredPath[])(Just(Stub__))=error$"BUG: Error descending in modifyTree, path = "++showp_go_(AnchoredPath[])(Just(File_))=error$"BUG: Error descending in modifyTree, path = "++showp_go_(AnchoredPath[])Nothing=error$"BUG: Error descending in modifyTree, path = "++showp_countmap=M.fold(\_i->i+1)0updateSubtrees::(Treem->Treem)->Treem->TreemupdateSubtreesfunt=fun$t{items=M.mapWithKey(curry$snd.update)$itemst,treeHash=NoHash}whereupdate(k,SubTrees)=(k,SubTree$updateSubtreesfuns)update(k,Filef)=(k,Filef)update(_,Stub__)=error"Stubs not supported in updateTreePostorder"-- | Does /not/ expand the tree.updateTree::(Functorm,Monadm)=>(TreeItemm->m(TreeItemm))->Treem->m(Treem)updateTreefunt=partiallyUpdateTreefun(\__->True)t-- | Does /not/ expand the tree.partiallyUpdateTree::(Functorm,Monadm)=>(TreeItemm->m(TreeItemm))->(AnchoredPath->TreeItemm->Bool)->Treem->m(Treem)partiallyUpdateTreefunpredt'=go(AnchoredPath[])t'wheregopatht=doitems'<-M.fromList<$>mapM(maybeupdatepath)(listImmediatet)SubTreet'<-fun.SubTree$t{items=items',treeHash=NoHash}returnt'maybeupdatepath(k,item)=casepred(path`appendPath`k)itemofTrue->update(path`appendPath`k)(k,item)False->return(k,item)updatepath(k,SubTreetree)=(\new->(k,SubTreenew))<$>gopathtreeupdate_(k,item)=(\new->(k,new))<$>funitem-- | Lay one tree over another. The resulting Tree will look like the base (1st-- parameter) Tree, although any items also present in the overlay Tree will be-- taken from the overlay. It is not allowed to overlay a different kind of an-- object, nor it is allowed for the overlay to add new objects to base. This-- means that the overlay Tree should be a subset of the base Tree (although-- any extraneous items will be ignored by the implementation).overlay::(Functorm,Monadm)=>Treem->Treem->Treemoverlaybaseover=Tree{items=M.fromListimmediate,treeHash=NoHash}whereimmediate=[(n,getn)|(n,_)<-listImmediatebase]getn=case(M.lookupn$itemsbase,M.lookupn$itemsover)of(Just(File_),Justf@(File_))->f(Just(SubTreeb),Just(SubTreeo))->SubTree$overlaybo(Just(Stubb_),Just(SubTreeo))->Stub(flipoverlayo`fmap`b)NoHash(Just(SubTreeb),Just(Stubo_))->Stub(overlayb`fmap`o)NoHash(Just(Stubb_),Just(Stubo_))->Stub(doo'<-ob'<-breturn$overlayb'o')NoHash(Justx,_)->x(_,_)->error$"Unexpected case in overlay at get "++shown++"."addMissingHashes::(Monadm,Functorm)=>(TreeItemm->mHash)->Treem->m(Treem)addMissingHashesmake=updateTreeupdate-- use partiallyUpdateTree herewhereupdate(SubTreet)=make(SubTreet)>>=\x->return$SubTree(t{treeHash=x})update(Fileblob@(BlobconNoHash))=dohash<-make$Fileblobreturn$File(Blobconhash)update(StubsNoHash)=update.SubTree=<<supdatex=returnx------ Private utilities shared among multiple functions. --------unstub::(Monadm)=>TreeItemm->m(Treem)unstub(Stubs_)=sunstub(SubTrees)=returnsisSub::TreeItemm->BoolisSub(File_)=FalseisSub_=True