{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE FlexibleContexts #-}moduleData.Git.TreewhereimportBindings.Libgit2importControl.Concurrent.ParallelIOimportData.Git.BlobimportData.Git.CommonimportData.Git.ErrorimportData.Git.InternalimportqualifiedData.MapasMimportqualifiedData.TextasTimportqualifiedFilesystem.Path.CurrentOSasFimportqualifiedPreludedefault(Text)dataTreeEntry=BlobEntry{blobEntry::ObjRefBlob,blobEntryIsExe::Bool}|TreeEntry{treeEntry::ObjRefTree}blobRefWithMode::Bool->Blob->TreeEntryblobRefWithModemodeb=BlobEntry(ObjRefb)modeblobRef::Blob->TreeEntryblobRef=blobRefWithModeFalseexeBlobRef::Blob->TreeEntryexeBlobRef=blobRefWithModeTrueblobIdRef::Oid->Bool->TreeEntryblobIdRef(Oidcoid)=BlobEntry(IdRefcoid)blobIdRef(PartialOid{})=throwObjectRefRequiresFullOidtreeRef::Tree->TreeEntrytreeReft=TreeEntry(ObjReft)treeIdRef::Oid->TreeEntrytreeIdRef(Oidcoid)=TreeEntry(IdRefcoid)treeIdRef(PartialOid{})=throwObjectRefRequiresFullOid-- instance Eq TreeEntry where-- (BlobEntry x x2) == (BlobEntry y y2) = x == y && x2 == y2-- (TreeEntry x) == (TreeEntry y) = x == y-- _ == _ = FalsetypeTreeMap=M.MapTextTreeEntrydataTree=Tree{treeInfo::BaseTree,treeContents::TreeMap}instanceShowTreewhereshowx=casegitId(treeInfox)ofPending_->"Tree"Storedy->"Tree#"++showyinstanceShowTreeEntrywhereshowbe@(BlobEntry{})=showbeshowte@(TreeEntry{})=showteinstanceUpdatableTreewheregetIdx=gitId(treeInfox)objectRepox=gitRepo(treeInfox)objectPtrx=gitObj(treeInfox)update=writeTreelookupFunction=lookupTreenewTreeBase::Tree->BaseTreenewTreeBaset=newBase(gitRepo(treeInfot))(Pending(doWriteTree>=>return.snd))Nothing-- | Create a new, empty tree.---- Since empty trees cannot exist in Git, attempting to write out an empty-- tree is a no-op.createTree::Repository->TreecreateTreerepo=Tree{treeInfo=newBaserepo(Pending(doWriteTree>=>return.snd))Nothing,treeContents=M.empty}lookupTree::Oid->Repository->IO(MaybeTree)lookupTreeoidrepo=lookupObject'oidrepoc'git_tree_lookupc'git_tree_lookup_prefix$\coidobj_->doentriesMap<-withForeignPtrobj$\treePtr->doentryCount<-c'git_tree_entrycount(castPtrtreePtr)foldM(\midx->doentry<-c'git_tree_entry_byindex(castPtrtreePtr)(fromIntegralidx)entryId<-c'git_tree_entry_identrycoid<-mallocForeignPtrwithForeignPtrcoid$\coid'->c'git_oid_cpycoid'entryIdentryName<-c'git_tree_entry_nameentry>>=peekCString>>=return.T.packentryAttrs<-c'git_tree_entry_attributesentryentryType<-c'git_tree_entry_typeentryletentryObj=ifentryType==c'GIT_OBJ_BLOBthenBlobEntry(IdRef(COidcoid))FalseelseTreeEntry(IdRef(COidcoid))return$M.insertentryNameentryObjm)M.empty[1..entryCount]returnTree{treeInfo=newBaserepo(Storedcoid)(Justobj),treeContents=entriesMap}doLookupTreeEntry::[Text]->Tree->IO(MaybeTreeEntry)doLookupTreeEntry[]t=return(Just(TreeEntry(ObjReft)))doLookupTreeEntry(name:names)t=do-- Lookup the current name in this tree. If it doesn't exist, and there are-- more names in the path and 'createIfNotExist' is True, create a new Tree-- and descend into it. Otherwise, if it exists we'll have @Just (TreeEntry-- {})@, and if not we'll have Nothing.Prelude.putStrLn$"Tree: "++showtPrelude.putStrLn$"Tree Entries: "++show(treeContentst)Prelude.putStrLn$"Lookup: "++toStringnamey<-caseM.lookupname(treeContentst)ofNothing->returnNothingJustj->casejofBlobEntrybmode->dobl<-loadObjectbtforbl$\x->return$BlobEntry(ObjRefx)modeTreeEntryt'->dotr<-loadObjectt'tfortr$\x->return$TreeEntry(ObjRefx)Prelude.putStrLn$"Result: "++showyPrelude.putStrLn$"Names: "++shownamesifnullnamesthenreturnyelsecaseyofJust(BlobEntry{})->throwTreeCannotTraverseBlobJust(TreeEntry(ObjReft'))->doLookupTreeEntrynamest'_->returnNothinglookupTreeEntry::FilePath->Tree->IO(MaybeTreeEntry)lookupTreeEntry=doLookupTreeEntry.splitPathwithGitTree::Updatableb=>ObjRefTree->b->(PtrC'git_tree->IOa)->IOawithGitTreetrefobjf=withForeignPtr(repositoryPtr(objectRepoobj))$\repoPtr->casetrefofIdRef(COidoid)->withGitTreeOidrepoPtroidObjRef(Tree{treeInfo=Base{gitId=Stored(COidoid)}})->withGitTreeOidrepoPtroidObjRef(Tree{treeInfo=Base{gitObj=Justt}})->withForeignPtrt(f.castPtr)ObjReft->dot'<-updatetwithGitTree(ObjReft')objfwherewithGitTreeOidrepoPtroid=withForeignPtroid$\tree_id->alloca$\ptr->dor<-c'git_tree_lookupptrrepoPtrtree_idwhen(r<0)$throwIOTreeLookupFailedf=<<peekptr-- | Write out a tree to its repository. If it has already been written,-- nothing will happen.writeTree::Tree->IOTreewriteTreet@(Tree{treeInfo=Base{gitId=Stored_}})=returntwriteTreet=fst<$>doWriteTreetdoWriteTree::Tree->IO(Tree,COid)doWriteTreet=alloca$\ptr->withForeignPtrrepo$\repoPtr->dor<-c'git_treebuilder_createptrnullPtrwhen(r<0)$throwIOTreeBuilderCreateFailedbuilder<-peekptr-- jww (2012-10-14): With the loose object backend, there should be no-- race conditions here as there will never be a request to access the-- same file by multiple threads. If that ever does happen, or if this-- code is changed to write to the packed object backend, simply change-- the function 'parallel' to 'sequence' here.oids<-parallel$flipmap(M.toList(treeContentst))$\(k,v)->casevofBlobEntryblexe->withObjectblt$\bl'->do(Oidcoid)<-objectIdbl'return(k,BlobEntry(IdRefcoid)exe,coid,ifexethen0o100755else0o100644)TreeEntrytr->withObjecttrt$\tr'->do(Oidcoid)<-objectIdtr'return(k,TreeEntry(IdRefcoid),coid,0o040000)newList<-foroids$\(k,entry,coid,flags)->doinsertObjectbuilderkcoidflagsreturn(k,entry)coid<-mallocForeignPtrwithForeignPtrcoid$\coid'->dor3<-c'git_treebuilder_writecoid'repoPtrbuilderwhen(r3<0)$throwIOTreeBuilderWriteFailedreturn(t{treeInfo=(treeInfot){gitId=Stored(COidcoid)},treeContents=M.fromListnewList},COidcoid)whererepo=fromMaybe(error"Repository invalid")(repoObj(gitRepo(treeInfot)))insertObject::(CStringablea)=>PtrC'git_treebuilder->a->COid->CUInt->IO()insertObjectbuilderkey(COidcoid)attrs=withForeignPtrcoid$\coid'->withCStringablekey$\name->dor2<-c'git_treebuilder_insertnullPtrbuildernamecoid'attrswhen(r2<0)$throwIOTreeBuilderInsertFaileddoModifyTree::[Text]->(MaybeTreeEntry->Eithera(MaybeTreeEntry))->Bool->Tree->IO(EitheraTree)doModifyTree[]___=throwTreeLookupFaileddoModifyTree(name:names)fcreateIfNotExistt=do-- Lookup the current name in this tree. If it doesn't exist, and there are-- more names in the path and 'createIfNotExist' is True, create a new Tree-- and descend into it. Otherwise, if it exists we'll have @Just (TreeEntry-- {})@, and if not we'll have Nothing.y<-caseM.lookupname(treeContentst)ofNothing->return$ifcreateIfNotExist&&not(nullnames)thenJust.TreeEntry.ObjRef.createTree$gitRepo(treeInfot)elseNothingJustj->casejofBlobEntrybmode->dobl<-loadObjectbtforbl$\x->return$BlobEntry(ObjRefx)modeTreeEntryt'->dotr<-loadObjectt'tfortr$\x->return$TreeEntry(ObjRefx)ifnullnamesthendo-- If there are no further names in the path, call the transformer-- function, f. It receives a @Maybe TreeEntry@ to indicate if there-- was a previous entry at this path. It should return a 'Left' value-- to propagate out a user-defined error, or a @Maybe TreeEntry@ to-- indicate whether the entry at this path should be deleted or-- replaced with something new.---- NOTE: There is no provision for leaving the entry unchanged! It is-- assumed to always be changed, as we have no reliable method of-- testing object equality that is not O(n).letze=fycasezeofLefterr->return$LefterrRightz->return$Right$t{treeInfo=newTreeBaset,treeContents=casezofNothing->M.deletename(treeContentst)Justz'->M.insertnamez'(treeContentst)}else-- If there are further names in the path, descend them now. If-- 'createIfNotExist' was False and there is no 'Tree' under the-- current name, or if we encountered a 'Blob' when a 'Tree' was-- required, throw an exception to avoid colliding with user-defined-- 'Left' values.caseyofJust(BlobEntry{})->throwTreeCannotTraverseBlobJust(TreeEntry(ObjReft'))->dost<-doModifyTreenamesfcreateIfNotExistt'casestoferr@(Left_)->returnerrRightst'->return$Right$t{treeInfo=newTreeBaset,treeContents=ifM.null(treeContentsst')thenM.deletename(treeContentst)elseM.insertname(TreeEntry(ObjRefst'))(treeContentst)}_->throwTreeLookupFailedmodifyTree::FilePath->(MaybeTreeEntry->Eithera(MaybeTreeEntry))->Bool->Tree->IO(EitheraTree)modifyTree=doModifyTree.splitPathdoUpdateTree::[Text]->TreeEntry->Tree->IOTreedoUpdateTreexsitemt=dot'<-doModifyTreexs(const(Right(Justitem)))Truetcaset'ofRighttr->returntr_->undefinedupdateTree::FilePath->TreeEntry->Tree->IOTreeupdateTree=doUpdateTree.splitPathremoveFromTree::FilePath->Tree->IOTreeremoveFromTreeptr=dot'<-modifyTreep(const(RightNothing))Falsetrcaset'ofRighttr'->returntr'_->undefinedsplitPath::FilePath->[Text]splitPathpath=T.splitOn"/"textwheretext=caseF.toTextpathofLeftx->error$"Invalid path: "++T.unpackxRighty->y-- Tree.hs