-- Copyright (C) 2002-2004,2007-2008 David Roundy-- Copyright (C) 2005 Juliusz Chroboczek---- This program is free software; you can redistribute it and/or modify-- it under the terms of the GNU General Public License as published by-- the Free Software Foundation; either version 2, or (at your option)-- any later version.---- This program is distributed in the hope that it will be useful,-- but WITHOUT ANY WARRANTY; without even the implied warranty of-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the-- GNU General Public License for more details.---- You should have received a copy of the GNU General Public License-- along with this program; see the file COPYING. If not, write to-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,-- Boston, MA 02110-1301, USA.{-# OPTIONS_GHC -cpp -fglasgow-exts #-}{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-}#include "gadts.h"moduleDarcs.Repository.Internal(Repository(..),RepoType(..),RIO(unsafeUnRIO),($-),maybeIdentifyRepository,identifyDarcs1Repository,identifyRepositoryFor,IdentifyRepo(..),findRepository,amInRepository,amNotInRepository,revertRepositoryChanges,announceMergeConflicts,setTentativePending,checkUnrecordedConflicts,withRecorded,readRepo,readTentativeRepo,prefsUrl,makePatchLazy,withRepoLock,withRepoReadLock,withRepository,withRepositoryDirectory,withGutsOf,tentativelyAddPatch,tentativelyRemovePatches,tentativelyAddToPending,tentativelyAddPatch_,tentativelyReplacePatches,finalizeRepositoryChanges,unrevertUrl,applyToWorking,patchSetToPatches,createPristineDirectoryTree,createPartialsPristineDirectoryTree,optimizeInventory,cleanRepository,getMarkedupFile,PatchSet,SealedPatchSet,setScriptsExecutable,getRepository,rIO,testTentative,testRecorded,UpdatePristine(..),MakeChanges(..),applyToTentativePristine,makeNewPending)whereimportPrinter(putDocLn,(<+>),text,($$))importDarcs.Repository.Prefs(getPrefval)importDarcs.Repository.State(readRecorded,readWorking)importDarcs.Repository.LowLevel(readPending,pendingName,readPrims,readPendingfile)importSystem.Exit(ExitCode(..),exitWith)importSystem.Cmd(system)importDarcs.External(clonePartialsTree)importDarcs.IO(runTolerantly,runSilently)importDarcs.Repository.Pristine(identifyPristine,nopristine,easyCreatePristineDirectoryTree,easyCreatePartialsPristineDirectoryTree)importDarcs.SignalHandler(withSignalsBlocked)importDarcs.Repository.Format(RepoFormat,RepoProperty(Darcs2,HashedInventory),identifyRepoFormat,formatHas,writeProblem,readProblem,readfromAndWritetoProblem)importSystem.Directory(doesDirectoryExist,setCurrentDirectory,createDirectoryIfMissing)importControl.Monad(liftM,when,unless)importWorkaround(getCurrentDirectory,renameFile,setExecutable)importByteStringUtils(gzReadFilePS)importqualifiedData.ByteStringasB(empty,readFile,isPrefixOf)importqualifiedData.ByteString.Char8asBC(pack)importDarcs.Patch(Patch,RealPatch,Effect,primIsHunk,primIsBinary,description,tryToShrink,commuteFLorComplain,commute)importDarcs.Patch.Prim(tryShrinkingInverse)importDarcs.Patch.Bundle(scanBundle,makeBundleN)importDarcs.Hopefully(PatchInfoAnd,info,hopefully,hopefullyM)importDarcs.Repository.ApplyPatches(applyPatches)importqualifiedDarcs.Repository.HashedRepoasHashedRepo(revertTentativeChanges,finalizeTentativeChanges,removeFromTentativeInventory,copyPristine,copyPartialsPristine,applyToTentativePristine,writeTentativeInventory,writeAndReadPatch,addToTentativeInventory,readRepo,readTentativeRepo,cleanPristine)importqualifiedDarcs.Repository.DarcsRepoasDarcsRepoimportDarcs.Flags(DarcsFlag(Verbose,Quiet,MarkConflicts,AllowConflicts,NoUpdateWorking,WorkRepoUrl,WorkRepoDir,UMask,Test,LeaveTestDir,SetScriptsExecutable,DryRun),wantExternalMerge,compression)importDarcs.Witnesses.Ordered(FL(..),RL(..),EqCheck(..),unsafeCoerceP,(:\/:)(..),(:/\:)(..),(:>)(..),(+>+),lengthFL,allFL,filterFLFL,reverseFL,mapFL_FL,concatFL)importDarcs.Patch(RepoPatch,Patchy,Prim,merge,joinPatches,listConflictedFiles,listTouchedFiles,Named,patchcontents,commuteRL,fromPrims,readPatch,writePatch,effect,invert,primIsAddfile,primIsAdddir,primIsSetpref,apply,applyToTree,emptyMarkedupFile,MarkedUpFile)importDarcs.Patch.Permutations(commuteWhatWeCanFL,removeFL)importDarcs.Patch.Info(PatchInfo)importDarcs.Patch.Set(PatchSet(..),SealedPatchSet,newset2FL)#ifdef GADT_WITNESSESimportDarcs.Patch.Set(Origin)#endifimportDarcs.Patch.Apply(markupFile,LineMark(None))importDarcs.Patch.Depends(deepOptimizePatchset,removeFromPatchSet,mergeThem)importDarcs.RepoPath(FilePathLike,AbsolutePath,toFilePath,ioAbsoluteOrRemote,toPath)importDarcs.Utils(promptYorn,catchall,withCurrentDirectory,withUMask,nubsort)importProgress(debugMessage)importDarcs.ProgressPatches(progressFL)importDarcs.URL(isFile)importDarcs.Repository.Prefs(getCaches)importDarcs.Lock(withLock,writeDocBinFile,removeFileMayNotExist,withTempDir,withPermDir)importDarcs.Witnesses.Sealed(Sealed(Sealed),seal,FlippedSeal(FlippedSeal),flipSeal)importDarcs.Repository.InternalTypes(Repository(..),RepoType(..))importDarcs.Global(darcsdir)importSystem.Mem(performGC)importqualifiedStorage.Hashed.TreeasTreeimportStorage.Hashed.AnchoredPath(anchorPath)#include "impossible.h"-- | Repository IO monad. This monad-like datatype is responsible for-- sequencing IO actions that modify the tentative recorded state of-- the repository.newtypeRIOpC(rutt1)a=RIO{unsafeUnRIO::RepositorypC(rut)->IOa-- ^ converts @RIO a@ to @IO a@.}-- | This is just like @>>=@ from the Monad class except that it-- respects type witness safe repository transformations. Even so, it-- only tracks modifications to the tentative recorded state.(>>>=)::RIOpC(rutt1)a->(a->RIOpC(rut1t2)b)->RIOpC(rutt2)bm>>>=k=RIO$\(Repoxyzw)->doa<-unsafeUnRIOm(Repoxyzw)unsafeUnRIO(ka)(Repoxyzw)-- | This corresponds to @>>@ from the Monad class.(>>>)::RIOpC(rutt1)a->RIOpC(rut1t2)b->RIOpC(rutt2)ba>>>b=a>>>=(constb)-- | This corresponds to @return@ from the Monad class.returnR::a->RIOpC(rutt)areturnR=rIO.return-- | This the @RIO@ equivalent of @liftIO@.rIO::IOa->RIOpC(rutt)arIO=RIO.constinstanceFunctor(RIOpC(rutt))wherefmapfm=RIO$\r->fmapf(unsafeUnRIOmr)-- | We have an instance of Monad so that IO actions that do not-- change the tentative recorded state are convenient in the IO monad.instanceMonad(RIOpC(rutt))where(>>=)=(>>>=)(>>)=(>>>)return=returnRfail=rIO.fail-- | Similar to the @ask@ function of the MonadReader class.-- This allows actions in the RIO monad to get the current-- repository.-- FIXME: Don't export this. If we don't export this-- it makes it harder for arbitrary IO actions to access-- the repository and hence our code is easier to audit.getRepository::RIOpC(rutt)(RepositorypC(rut))getRepository=RIOreturn-- | The status of a given directory: is it a darcs repository?dataIdentifyRepopC(rut)=BadRepositoryString-- ^ looks like a repository with some error|NonRepositoryString-- ^ safest guess|GoodRepository(RepositorypC(rut))maybeIdentifyRepository::[DarcsFlag]->String->IO(IdentifyRepopC(rut))maybeIdentifyRepositoryopts"."=dodarcs<-doesDirectoryExistdarcsdirrf_or_e<-identifyRepoFormat"."here<-toPath`fmap`ioAbsoluteOrRemote"."caserf_or_eofLefterr->return$NonRepositoryerrRightrf->casereadProblemrfofJusterr->return$BadRepositoryerrNothing->ifdarcsthendopris<-identifyPristinecs<-getCachesoptsherereturn$GoodRepository$Repohereoptsrf(DarcsRepositorypriscs)elsereturn(NonRepository"Not a repository")maybeIdentifyRepositoryoptsurl'=dourl<-toPath`fmap`ioAbsoluteOrRemoteurl'rf_or_e<-identifyRepoFormaturlcaserf_or_eofLefte->return$NonRepositoryeRightrf->casereadProblemrfofJusterr->return$BadRepositoryerrNothing->docs<-getCachesoptsurlreturn$GoodRepository$Repourloptsrf(DarcsRepositorynopristinecs)identifyDarcs1Repository::[DarcsFlag]->String->IO(RepositoryPatchC(rut))identifyDarcs1Repositoryoptsurl=doer<-maybeIdentifyRepositoryoptsurlcaseerofBadRepositorys->failsNonRepositorys->failsGoodRepositoryr->returnridentifyRepositoryFor::forallpC(rut).RepoPatchp=>RepositorypC(rut)->String->IO(RepositorypC(rut))identifyRepositoryFor(Repo_optsrf_)url=doRepoabsurl_rf_t<-identifyDarcs1Repositoryoptsurllett'=casetofDarcsRepositoryxc->DarcsRepositoryxccasereadfromAndWritetoProblemrf_rfofJuste->fail$"Incompatibility with repository "++url++":\n"++eNothing->return$Repoabsurloptsrf_t'amInRepository::[DarcsFlag]->IO(EitherString())amInRepository(WorkRepoDird:_)=dosetCurrentDirectoryd`catchall`(fail$"can't set directory to "++d)status<-maybeIdentifyRepository[]"."casestatusofGoodRepository_->return(Right())BadRepositorye->return(Left$"While "++d++" looks like a repository directory, we have a problem with it:\n"++e)NonRepository_->return(Left"You need to be in a repository directory to run this command.")amInRepository(_:fs)=amInRepositoryfsamInRepository[]=seekRepo(Left"You need to be in a repository directory to run this command.")-- | hunt upwards for the darcs repository-- This keeps changing up one parent directory, testing at each-- step if the current directory is a repository or not. $-- WARNING this changes the current directory for good if matchFn succeedsseekRepo::EitherString()-- ^ what to return if we don't find a repository->IO(EitherString())seekRepoonFail=getCurrentDirectory>>=helperwherehelperstartpwd=dostatus<-maybeIdentifyRepository[]"."casestatusofGoodRepository_->return(Right())BadRepositorye->return(Lefte)NonRepository_->docd<-toFilePath`fmap`getCurrentDirectorysetCurrentDirectory".."cd'<-toFilePath`fmap`getCurrentDirectoryifcd'/=cdthenhelperstartpwdelsedosetCurrentDirectorystartpwdreturnonFail-- The performGC in this function is a workaround for a library/GHC bug,-- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a-- problem on fast machines, but virtual ones trip this from time to time)amNotInRepository::[DarcsFlag]->IO(EitherString())amNotInRepository(WorkRepoDird:_)=docreateDirectoryIfMissingFalsed`catchall`(performGC>>createDirectoryIfMissingFalsed)-- note that the above could always failsetCurrentDirectorydamNotInRepository[]amNotInRepository(_:f)=amNotInRepositoryfamNotInRepository[]=dostatus<-maybeIdentifyRepository[]"."casestatusofGoodRepository_->return(Left$"You may not run this command in a repository.")BadRepositorye->return(Left$"You may not run this command in a repository.\nBy the way, we have a problem with it:\n"++e)NonRepository_->return(Right())findRepository::[DarcsFlag]->IO(EitherString())findRepository(WorkRepoUrld:_)|isFiled=dosetCurrentDirectoryd`catchall`(fail$"can't set directory to "++d)findRepository[]findRepository(WorkRepoDird:_)=dosetCurrentDirectoryd`catchall`(fail$"can't set directory to "++d)findRepository[]findRepository(_:fs)=findRepositoryfsfindRepository[]=seekRepo(Right())makeNewPending::forallpC(ruty).RepoPatchp=>RepositorypC(rut)->FLPrimC(ty)->IO()makeNewPending(Repo_opts__)_|NoUpdateWorking`elem`opts=return()makeNewPendingrepo@(Repor__tp)origp=withCurrentDirectoryr$doletnewname=pendingNametp++".new"debugMessage$"Writing new pending: "++newnameSealedsfp<-return$siftForPendingorigpwriteSealedPatchnewname$seal$fromPrims$sfpcur<-readRecordedrepoSealedp<-readPendingfilenewnamecatch(applyToTreepcur)$\err->doletbuggyname=pendingNametp++"_buggy"renameFilenewnamebuggynamebugDoc$text("There was an attempt to write an invalid pending! "++showerr)$$text"If possible, please send the contents of"<+>textbuggyname$$text"along with a bug report."renameFilenewname(pendingNametp)debugMessage$"Finished writing new pending: "++newnamewherewriteSealedPatch::FilePath->Sealed(PatchC(x))->IO()writeSealedPatchfp(Sealedp)=writePatchfppsiftForPending::FLPrimC(xy)->Sealed(FLPrimC(x))siftForPendingsimple_ps=letoldps=maybesimple_psid$tryShrinkingInverse$crudeSiftsimple_psinifallFL(\p->primIsAddfilep||primIsAdddirp)$oldpsthensealoldpselsefromJust$doSealedx<-return$sfpNilFL$reverseFLoldpsreturn(casetryToShrinkxofps|lengthFLps<lengthFLoldps->siftForPendingps|otherwise->sealps)wheresfp::FLPrimC(ab)->RLPrimC(ca)->Sealed(FLPrimC(c))sfpsofarNilRL=sealsofarsfpsofar(p:<:ps)|primIsHunkp||primIsBinaryp=casecommuteFLorComplain(p:>sofar)ofRight(sofar':>_)->sfpsofar'psLeft_->sfp(p:>:sofar)pssfpsofar(p:<:ps)=sfp(p:>:sofar)ps-- @todo: we should not have to open the result of HashedRepo and-- seal it. Instead, update this function to work with type witnesses-- by fixing DarcsRepo to match HashedRepo in the handling of-- Repository state.readRepo::RepoPatchp=>RepositorypC(rut)->IO(PatchSetpC(Originr))readReporepo@(Reporoptsrf_)|formatHasHashedInventoryrf=dops<-HashedRepo.readReporeporreturnps|otherwise=doSealedps<-DarcsRepo.readRepooptsrreturn$unsafeCoercePpsreadTentativeRepo::RepoPatchp=>RepositorypC(rut)->IO(PatchSetpC(Origint))readTentativeReporepo@(Reporoptsrf_)|formatHasHashedInventoryrf=dops<-HashedRepo.readTentativeReporeporreturnps|otherwise=doSealedps<-DarcsRepo.readTentativeRepooptsrreturn$unsafeCoercePpsmakePatchLazy::RepoPatchp=>RepositorypC(rut)->PatchInfoAndpC(xy)->IO(PatchInfoAndpC(xy))makePatchLazy(Reporoptsrf(DarcsRepository_c))p|formatHasHashedInventoryrf=withCurrentDirectoryr$HashedRepo.writeAndReadPatchc(compressionopts)p|otherwise=withCurrentDirectoryr$DarcsRepo.writeAndReadPatchoptspprefsUrl::RepositorypC(rut)->StringprefsUrl(Repor__(DarcsRepository__))=r++"/"++darcsdir++"/prefs"unrevertUrl::RepositorypC(rut)->StringunrevertUrl(Repor__(DarcsRepository__))=r++"/"++darcsdir++"/patches/unrevert"applyToWorking::Patchyp=>Repositoryp1C(rut)->[DarcsFlag]->pC(uy)->IO(Repositoryp1C(ryt))applyToWorking(Reporroptsrf(DarcsRepositorytc))optspatch=dowithCurrentDirectoryr$ifQuiet`elem`optsthenrunSilently$applyoptspatchelserunTolerantly$applyoptspatchreturn(Reporroptsrf(DarcsRepositorytc))handlePendForAdd::forallpqC(rutxy).(RepoPatchp,Effectq)=>RepositorypC(rut)->qC(xy)->IO()handlePendForAdd(Repo_opts__)_|NoUpdateWorking`elem`opts=return()handlePendForAdd(Repo___rt)p=doletpn=pendingNamert++".tentative"Sealedpend<-(readPrims`fmap`gzReadFilePSpn)`catchall`(return$SealedNilFL)leteffectp=ifallFLisSimplependthencrudeSift$effectpelseeffectpSealednewpend<-return$rmpend(progressFL"Removing from pending:"effectp)pendwritePatchpn$fromPrims_newpendwherermpend::FLPrimC(ab)->FLPrimC(ac)->Sealed(FLPrimC(b))rmpendNilFLx=Sealedxrmpend_NilFL=SealedNilFLrmpend(x:>:xs)xys|Justys<-removeFLxxys=rmpendxsysrmpend(x:>:xs)ys=casecommuteWhatWeCanFL(x:>xs)ofa:>x':>b->casermpendaysofSealedys'->casecommute(invert(x':>:b):>ys')ofJust(ys'':>_)->sealys''Nothing->seal$invert(x':>:b)+>+ys'-- DJR: I don't think this-- last case should be-- reached, but it also-- shouldn't lead to-- corruption.fromPrims_::FLPrimC(ab)->PatchC(ab)fromPrims_=fromPrimsisSimple::PrimC(xy)->BoolisSimplex=primIsHunkx||primIsBinaryx||primIsSetprefxcrudeSift::FLPrimC(xy)->FLPrimC(xy)crudeSiftxs=ifallFLisSimplexsthenfilterFLFLishunkbinaryxselsexswhereishunkbinary::PrimC(xy)->EqCheckC(xy)ishunkbinaryx|primIsHunkx||primIsBinaryx=unsafeCoercePIsEq|otherwise=NotEqdataHashedVsOlda=HvsO{old,hashed::a}decideHashedOrNormal::Monadm=>RepoFormat->HashedVsOld(ma)->madecideHashedOrNormalrf(HvsO{hashed=h,old=o})|formatHasHashedInventoryrf=h|otherwise=odataMakeChanges=MakeChanges|DontMakeChangesderiving(Eq)announceMergeConflicts::String->[DarcsFlag]->FLPrimC(xy)->IOBoolannounceMergeConflictscmdoptsresolved_pw=casenubsort$listTouchedFiles$resolved_pwof[]->returnFalsecfs->ifMarkConflicts`elem`opts||AllowConflicts`elem`opts||wantExternalMergeopts/=NothingthendoputStrLn"We have conflicts in the following files:"putStrLn$unwordscfsreturnTrueelsedoputStrLn"There are conflicts in the following files:"putStrLn$unwordscfsfail$"Refusing to "++cmd++" patches leading to conflicts.\n"++"If you would rather apply the patch and mark the conflicts,\n"++"use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++"These can set as defaults by adding\n"++" "++cmd++" mark-conflicts\n"++"to "++darcsdir++"/prefs/defaults in the target repo. "checkUnrecordedConflicts::forallpC(ty).RepoPatchp=>[DarcsFlag]->FL(Namedp)C(ty)->IOBoolcheckUnrecordedConflictsopts_|NoUpdateWorking`elem`opts=returnFalsecheckUnrecordedConflictsoptspc=dorepository<-identifyDarcs1Repositoryopts"."cucrepositorywherecuc::RepositoryPatchC(rut)->IOBoolcucr=doSealedmpend<-readPendingr::IO(Sealed(FLPrimC(t)))casempendofNilFL->returnFalsepend->casemerge(fromPrims_pend:\/:fromPrims_(concatFL$mapFL_FLeffectpc))of_:/\:pend'->caselistConflictedFilespend'of[]->returnFalsefs->doputStrLn("You have conflicting local changes to:\n"++unwordsfs)yorn<-promptYorn"Proceed?"when(yorn/='y')$doputStrLn"Cancelled."exitWithExitSuccessreturnTruefromPrims_::FLPrimC(ab)->pC(ab)fromPrims_=fromPrimstentativelyAddPatch::RepoPatchp=>RepositorypC(rut)->[DarcsFlag]->PatchInfoAndpC(ty)->IO(RepositorypC(ruy))tentativelyAddPatch=tentativelyAddPatch_UpdatePristinedataUpdatePristine=UpdatePristine|DontUpdatePristinederivingEqtentativelyAddPatch_::RepoPatchp=>UpdatePristine->RepositorypC(rut)->[DarcsFlag]->PatchInfoAndpC(ty)->IO(RepositorypC(ruy))tentativelyAddPatch___opts_|DryRun`elem`opts=bug"tentativelyAddPatch_ called when --dry-run is specified"tentativelyAddPatch_upr@(Repodirroptsrf(DarcsRepositorytc))optsp=withCurrentDirectorydir$dodecideHashedOrNormalrf$HvsO{hashed=HashedRepo.addToTentativeInventoryc(compressionopts)p,old=DarcsRepo.addToTentativeInventoryopts(hopefullyp)}when(up==UpdatePristine)$dodebugMessage"Applying to pristine cache..."applyToTentativePristinerpdebugMessage"Updating pending..."handlePendForAddrpreturn(Repodirroptsrf(DarcsRepositorytc))applyToTentativePristine::(Effectq,Patchyq)=>RepositorypC(rut)->qC(ty)->IO()applyToTentativePristine(Repodiroptsrf(DarcsRepository_c))p=withCurrentDirectorydir$dowhen(Verbose`elem`opts)$putDocLn$text"Applying to pristine..."<+>descriptionpdecideHashedOrNormalrf$HvsO{hashed=HashedRepo.applyToTentativePristineoptsp,old=DarcsRepo.addToTentativePristinep}-- | This fuction is unsafe because it accepts a patch that works on the tentative-- pending and we don't currently track the state of the tentative pending.tentativelyAddToPending::forallpC(rutxy).RepoPatchp=>RepositorypC(rut)->[DarcsFlag]->FLPrimC(xy)->IO()tentativelyAddToPending(Repo_opts__)__|NoUpdateWorking`elem`opts=return()|DryRun`elem`opts=bug"tentativelyAddToPending called when --dry-run is specified"tentativelyAddToPending(Repodir__rt)_patch=withCurrentDirectorydir$doletpn=pendingNamerttpn=pn++".tentative"Sealedpend<-readPrims`liftM`(gzReadFilePStpn`catchall`(returnB.empty))FlippedSealnewpend_<-return$newpend(unsafeCoercePpend::FLPrimC(ax))patchwritePatchtpn$fromPrims_newpend_wherenewpend::FLPrimC(ab)->FLPrimC(bc)->FlippedSeal(FLPrim)C(c)newpendNilFLpatch_=flipSealpatch_newpendppatch_=flipSeal$p+>+patch_fromPrims_::FLPrimC(ab)->PatchC(ab)fromPrims_=fromPrims-- | setTentativePending is basically unsafe. It overwrites the pending state with a new one, not related to-- the repository state.setTentativePending::forallpC(rutxy).RepoPatchp=>RepositorypC(rut)->FLPrimC(xy)->IO()setTentativePending(Repo_opts__)_|NoUpdateWorking`elem`opts=return()setTentativePending(Repodir__rt)patch=doSealedprims<-return$siftForPendingpatchwithCurrentDirectorydir$writePatch(pendingNamert++".tentative")$fromPrims_primswherefromPrims_::FLPrimC(ab)->PatchC(ab)fromPrims_=fromPrims-- | prepend is basically unsafe. It overwrites the pending state-- with a new one, not related to the repository state.prepend::forallpC(rutxy).RepoPatchp=>RepositorypC(rut)->FLPrimC(xy)->IO()prepend(Repo_opts__)_|NoUpdateWorking`elem`opts=return()prepend(Repo___rt)patch=doletpn=pendingNamert++".tentative"Sealedpend<-readPrims`liftM`(gzReadFilePSpn`catchall`(returnB.empty))Sealednewpend_<-return$newpendpendpatchwritePatchpn$fromPrims_(crudeSiftnewpend_)wherenewpend::FLPrimC(bc)->FLPrimC(ab)->Sealed(FLPrimC(a))newpendNilFLpatch_=sealpatch_newpendppatch_=seal$patch_+>+pfromPrims_::FLPrimC(ab)->PatchC(ab)fromPrims_=fromPrimstentativelyRemovePatches::RepoPatchp=>RepositorypC(rut)->[DarcsFlag]->FL(PatchInfoAndp)C(xt)->IO(RepositorypC(rux))tentativelyRemovePatches=tentativelyRemovePatches_UpdatePristinetentativelyRemovePatches_::forallpC(rutx).RepoPatchp=>UpdatePristine->RepositorypC(rut)->[DarcsFlag]->FL(PatchInfoAndp)C(xt)->IO(RepositorypC(rux))tentativelyRemovePatches_uprepository@(Repodirroptsrf(DarcsRepositorytc))optsps=withCurrentDirectorydir$dowhen(up==UpdatePristine)$dodebugMessage"Adding changes to pending..."prependrepository$effectpsremoveFromUnrevertContextrepositorypsdebugMessage"Removing changes from tentative inventory..."ifformatHasHashedInventoryrfthendoHashedRepo.removeFromTentativeInventoryrepository(compressionopts)pswhen(up==UpdatePristine)$HashedRepo.applyToTentativePristineopts$progressFL"Applying inverse to pristine"$invertpselseDarcsRepo.removeFromTentativeInventory(up==UpdatePristine)optspsreturn(Repodirroptsrf(DarcsRepositorytc))tentativelyReplacePatches::forallpC(rutx).RepoPatchp=>RepositorypC(rut)->[DarcsFlag]->FL(PatchInfoAndp)C(xt)->IO(RepositorypC(rut))tentativelyReplacePatchesrepositoryoptsps=dorepository'<-tentativelyRemovePatches_DontUpdatePristinerepositoryoptspsmapAddrepository'pswheremapAdd::RepositorypC(mli)->FL(PatchInfoAndp)C(ij)->IO(RepositorypC(mlj))mapAddrNilFL=returnrmapAddr(a:>:as)=dor'<-tentativelyAddPatch_DontUpdatePristineroptsamapAddr'asfinalizePending::RepoPatchp=>RepositorypC(rut)->IO()finalizePending(Repodiropts_rt)|NoUpdateWorking`elem`opts=withCurrentDirectorydir$removeFileMayNotExist$(pendingNamert)finalizePendingrepository@(Repodir__rt)=dowithCurrentDirectorydir$doletpn=pendingNamerttpn=pn++".tentative"tpfile<-gzReadFilePStpn`catchall`(returnB.empty)Sealedtpend<-return$readPrimstpfileSealednew_pending<-return$siftForPendingtpendmakeNewPendingrepositorynew_pendingfinalizeRepositoryChanges::RepoPatchp=>RepositorypC(rut)->IO()finalizeRepositoryChanges(Repo_opts__)|DryRun`elem`opts=bug"finalizeRepositoryChanges called when --dry-run specified"finalizeRepositoryChangesrepository@(Repodiroptsrf_)|formatHasHashedInventoryrf=withCurrentDirectorydir$dodebugMessage"Considering whether to test..."testTentativerepositorydebugMessage"Finalizing changes..."withSignalsBlocked$doHashedRepo.finalizeTentativeChangesrepository(compressionopts)finalizePendingrepositorydebugMessage"Done finalizing changes..."finalizeRepositoryChangesrepository@(Repodir__(DarcsRepository__))=withCurrentDirectorydir$dodebugMessage"Considering whether to test..."testTentativerepositorydebugMessage"Finalizing changes..."withSignalsBlocked$doDarcsRepo.finalizePristineChangesDarcsRepo.finalizeTentativeChangesfinalizePendingrepositorytestTentative::RepoPatchp=>RepositorypC(rut)->IO()testTentative=testAnywithTentativetestRecorded::RepoPatchp=>RepositorypC(rut)->IO()testRecorded=testAnywithRecordedtestAny::RepoPatchp=>(RepositorypC(rut)->((AbsolutePath->IO())->IO())->(AbsolutePath->IO())->IO())->RepositorypC(rut)->IO()testAnywithDrepository@(Repodiropts__)=when(Test`elem`opts)$withCurrentDirectorydir$doletputInfo=ifnot$Quiet`elem`optsthenputStrLnelseconst(return())debugMessage"About to run test if it exists."testline<-getPrefval"test"casetestlineofNothing->return()Justtestcode->withDrepository(wd"testing")$\_->doputInfo"Running test...\n"when(SetScriptsExecutable`elem`opts)setScriptsExecutableec<-systemtestcodeifec==ExitSuccessthenputInfo"Test ran successfully.\n"elsedoputInfo"Test failed!\n"exitWithecwherewd=ifLeaveTestDir`elem`optsthenwithPermDirelsewithTempDirrevertRepositoryChanges::RepoPatchp=>RepositorypC(rut)->IO()revertRepositoryChanges(Repo_opts__)|DryRun`elem`opts=bug"revertRepositoryChanges called when --dry-run is specified"revertRepositoryChangesr@(Repodiroptsrfdr@(DarcsRepository__))=withCurrentDirectorydir$doremoveFileMayNotExist(pendingNamedr++".tentative")Sealedx<-readPendingrsetTentativePendingr$effectxwhen(NoUpdateWorking`elem`opts)$removeFileMayNotExist$pendingNamedrdecideHashedOrNormalrf$HvsO{hashed=HashedRepo.revertTentativeChanges,old=DarcsRepo.revertTentativeChanges}patchSetToPatches::RepoPatchp=>PatchSetpC(xy)->FL(Namedp)C(xy)patchSetToPatchespatchSet=mapFL_FLhopefully$newset2FLpatchSetgetUMask::[DarcsFlag]->MaybeStringgetUMask[]=NothinggetUMask((UMasku):_)=JustugetUMask(_:l)=getUMasklwithGutsOf::RepositorypC(rut)->IO()->IO()withGutsOf(Repo__rf_)|formatHasHashedInventoryrf=id|otherwise=withSignalsBlockedwithRepository::[DarcsFlag]->(forallpC(ru).RepoPatchp=>RepositorypC(rur)->IOa)->IOawithRepositoryopts1=withRepositoryDirectoryopts1"."withRepositoryDirectory::foralla.[DarcsFlag]->String->(forallpC(ru).RepoPatchp=>RepositorypC(rur)->IOa)->IOawithRepositoryDirectoryopts1urljob=doRepodiroptsrfrt<-identifyDarcs1Repositoryopts1urlletrt'=casertofDarcsRepositorytc->DarcsRepositorytcifformatHasDarcs2rfthendodebugMessage$"Identified darcs-2 repo: "++dirjob1_(Repodiroptsrfrt')elsedodebugMessage$"Identified darcs-1 repo: "++dirjob2_(Repodiroptsrfrt)wherejob1_::Repository(FLRealPatch)C(rur)->IOajob1_=jobjob2_::RepositoryPatchC(rur)->IOajob2_=job-- RankNTypes-- $- works around the lack of impredicative instantiation in GHC($-)::((forallpC(ru).RepoPatchp=>RepositorypC(rur)->IOa)->IOa)->(forallpC(ru).RepoPatchp=>RepositorypC(rur)->IOa)->IOax$-y=xywithRepoLock::[DarcsFlag]->(forallpC(ru).RepoPatchp=>RepositorypC(rur)->IOa)->IOawithRepoLockoptsjob=withRepositoryopts$-\repository@(Repo__rf_)->docasewriteProblemrfofNothing->return()Justerr->failerrletname="./"++darcsdir++"/lock"wu=case(getUMaskopts)ofNothing->idJustu->withUMaskuwu$ifDryRun`elem`optsthenjobrepositoryelsewithLockname(revertRepositoryChangesrepository>>jobrepository)withRepoReadLock::[DarcsFlag]->(forallpC(ru).RepoPatchp=>RepositorypC(rur)->IOa)->IOawithRepoReadLockoptsjob=withRepositoryopts$-\repository@(Repo__rf_)->docasewriteProblemrfofNothing->return()Justerr->failerrletname="./"++darcsdir++"/lock"wu=case(getUMaskopts)ofNothing->idJustu->withUMaskuwu$ifformatHasHashedInventoryrf||DryRun`elem`optsthenjobrepositoryelsewithLockname(revertRepositoryChangesrepository>>jobrepository)removeFromUnrevertContext::forallpC(rutx).RepoPatchp=>RepositorypC(rut)->FL(PatchInfoAndp)C(xt)->IO()removeFromUnrevertContextrepositoryps=doSealedbundle<-unrevert_patch_bundle`catchall`(return$seal(PatchSetNilRLNilRL))remove_from_unrevert_context_bundlewhereunrevert_impossible=doyorn<-promptYorn"This operation will make unrevert impossible!\nProceed?"caseyornof'n'->fail"Cancelled."'y'->removeFileMayNotExist(unrevertUrlrepository)_->impossibleunrevert_patch_bundle::IO(SealedPatchSetpC(Origin))unrevert_patch_bundle=dopf<-B.readFile(unrevertUrlrepository)casescanBundlepfofRightfoo->returnfooLefterr->fail$"Couldn't parse unrevert patch:\n"++errremove_from_unrevert_context_::PatchSetpC(Originz)->IO()remove_from_unrevert_context_(PatchSetNilRLNilRL)=return()remove_from_unrevert_context_bundle=dodebugMessage"Adjusting the context of the unrevert changes..."debugMessage$"Removing "++show(lengthFLps)++" patches in removeFromUnrevertContext!"ref<-readTentativeReporepositoryletwithSinglet::Sealed(FLpppC(xxx))->(FORALL(yyy)pppC(xxxyyy)->IO())->IO()withSinglet(Sealed(x:>:NilFL))j=jxwithSinglet__=return()withSinglet(mergeThemrefbundle)$\h_us->casecommuteRL(reverseFLps:>h_us)ofNothing->unrevert_impossibleJust(us':>_)->caseremoveFromPatchSetpsrefofNothing->unrevert_impossibleJustcommon->dodebugMessage"Have now found the new context..."bundle<-makeBundleNNothingcommon(hopefullyus':>:NilFL)writeDocBinFile(unrevertUrlrepository)bundledebugMessage"Done adjusting the context of the unrevert changes!"-- | Writes out a fresh copy of the inventory that minimizes the-- amount of inventory that need be downloaded when people pull from-- the repository.---- Specifically, it breaks up the inventory on the most recent tag.-- This speeds up most commands when run remotely, both because a-- smaller file needs to be transfered (only the most recent-- inventory). It also gives a guarantee that all the patches prior-- to a given tag are included in that tag, so less commutation and-- history traversal is needed. This latter issue can become very-- important in large repositories.optimizeInventory::RepoPatchp=>RepositorypC(rut)->IO()optimizeInventoryrepository@(Reporoptsrf(DarcsRepository_c))=dops<-readReporepositorydecideHashedOrNormalrf$HvsO{hashed=dorevertRepositoryChangesrepositoryHashedRepo.writeTentativeInventoryc(compressionopts)$deepOptimizePatchsetpsfinalizeRepositoryChangesrepository,old=DarcsRepo.writeInventoryr$deepOptimizePatchsetps}cleanRepository::RepoPatchp=>RepositorypC(rut)->IO()cleanRepositoryrepository@(Repo__rf_)=decideHashedOrNormalrf$HvsO{hashed=HashedRepo.cleanPristinerepository,old=return()}createPristineDirectoryTree::RepoPatchp=>RepositorypC(rut)->FilePath->IO()createPristineDirectoryTreerepo@(Reporoptsrf(DarcsRepositoryprisc))reldir|formatHasHashedInventoryrf=docreateDirectoryIfMissingTruereldirwithCurrentDirectoryreldir$HashedRepo.copyPristinec(compressionopts)r(darcsdir++"/hashed_inventory")|otherwise=dodir<-toPath`fmap`ioAbsoluteOrRemotereldirdone<-withCurrentDirectoryr$easyCreatePristineDirectoryTreeprisdirunlessdone$doSealedpatches<-(seal.newset2FL)`liftM`readReporepocreateDirectoryIfMissingTruedirwithCurrentDirectorydir$applyPatches[]patches-- fp below really should be FileNamecreatePartialsPristineDirectoryTree::(FilePathLikefp,RepoPatchp)=>RepositorypC(rut)->[fp]->FilePath->IO()createPartialsPristineDirectoryTree(Reporoptsrf(DarcsRepository_c))prefsdir|formatHasHashedInventoryrf=docreateDirectoryIfMissingTruedirwithCurrentDirectorydir$HashedRepo.copyPartialsPristinec(compressionopts)r(darcsdir++"/hashed_inventory")prefscreatePartialsPristineDirectoryTreer@(Repordir__(DarcsRepositorypris_))prefsdir=withCurrentDirectoryrdir$dodone<-easyCreatePartialsPristineDirectoryTreeprefsprisdirunlessdone$withRecordedr(withTempDir"recorded")$\_->doclonePartialsTree"."dir(maptoFilePathprefs)withRecorded::RepoPatchp=>RepositorypC(rut)->((AbsolutePath->IOa)->IOa)->(AbsolutePath->IOa)->IOawithRecordedrepositorymk_dirf=mk_dir$\d->docreatePristineDirectoryTreerepository(toFilePathd)fdwithTentative::forallpaC(rut).RepoPatchp=>RepositorypC(rut)->((AbsolutePath->IOa)->IOa)->(AbsolutePath->IOa)->IOawithTentative(Repodiroptsrf(DarcsRepository_c))mk_dirf|formatHasHashedInventoryrf=mk_dir$\d->doHashedRepo.copyPristinec(compressionopts)dir(darcsdir++"/tentative_pristine")fdwithTentativerepository@(Repodiropts__)mk_dirf=withRecordedrepositorymk_dir$\d->doSealedps<-read_patches(dir++"/"++darcsdir++"/tentative_pristine")applyopts$joinPatchespsfdwhereread_patches::FilePath->IO(Sealed(FLpC(x)))read_patchesfil=dops<-B.readFilefilreturn$casereadPatchpsofJust(x,_)->xNothing->sealNilFLgetMarkedupFile::RepoPatchp=>RepositorypC(rut)->PatchInfo->FilePath->IOMarkedUpFilegetMarkedupFilerepositorypinfof=doSealed(FlippedSealpatches)<-(seal.dropWhileFL((/=pinfo).info).newset2FL)`liftM`readReporepositoryreturn$snd$doMarkAllpatches(f,emptyMarkedupFile)wheredropWhileFL::(FORALL(xy)aC(xy)->Bool)->FLaC(rv)->FlippedSeal(FLa)C(v)dropWhileFL_NilFL=flipSealNilFLdropWhileFLpxs@(x:>:xs')|px=dropWhileFLpxs'|otherwise=flipSealxsdoMarkAll::RepoPatchp=>FL(PatchInfoAndp)C(xy)->(FilePath,MarkedUpFile)->(FilePath,MarkedUpFile)doMarkAll(hp:>:pps)(f,mk)=casehopefullyMhpofJustp->doMarkAllpps$markupFile(infohp)(patchcontentsp)(f,mk)Nothing->(f,[(BC.pack"Error reading a patch!",None)])doMarkAllNilFL(f,mk)=(f,mk)-- | Sets scripts in or below the current directory executable. A script is any file that starts-- with the bytes '#!'. This is used sometimes for --set-scripts-executable, but at other times-- --set-scripts-executable is handled by the hunk patch case of applyFL.setScriptsExecutable::IO()setScriptsExecutable=dodebugMessage"Making scripts executable"myname<-getCurrentDirectorytree<-readWorkingletpaths=[anchorPath"."p|(p,Tree.File_)<-Tree.listtree]setExecutableIfScriptf=docontents<-B.readFilefwhen(BC.pack"#!"`B.isPrefixOf`contents)$dodebugMessage("Making executable: "++f)setExecutablefTruemapM_setExecutableIfScriptpaths