-- 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.{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-}#include "gadts.h"moduleDarcs.Repository.Internal(Repository(..),RepoType(..),RIO(unsafeUnRIO),RepoJob(..),maybeIdentifyRepository,identifyDarcsRepository,identifyRepositoryFor,IdentifyRepo(..),findRepository,amInRepository,amNotInRepository,amInHashedRepository,revertRepositoryChanges,announceMergeConflicts,setTentativePending,checkUnrecordedConflicts,withRecorded,readRepo,readTentativeRepo,readRepoUsingSpecificInventory,prefsUrl,makePatchLazy,withRepoLock,withRepoReadLock,withRepository,withRepositoryDirectory,withGutsOf,tentativelyAddPatch,tentativelyRemovePatches,tentativelyAddToPending,tentativelyAddPatch_,tentativelyReplacePatches,finalizeRepositoryChanges,unrevertUrl,applyToWorking,patchSetToPatches,createPristineDirectoryTree,createPartialsPristineDirectoryTree,optimizeInventory,cleanRepository,setScriptsExecutable,setScriptsExecutablePatches,getRepository,rIO,testTentative,testRecorded,UpdatePristine(..),MakeChanges(..),applyToTentativePristine,makeNewPending,seekRepo)whereimportPreludehiding(catch)importPrinter(putDocLn,(<+>),text,($$),redText,putDocLnWith,(<>),($$))importDarcs.ColorPrinter(fancyPrinters)importDarcs.Repository.Prefs(getPrefval)importDarcs.Repository.State(readRecorded,readWorking)importDarcs.Repository.LowLevel(readPending,readTentativePending,writeTentativePending,readNewPending,writeNewPending,pendingName)importSystem.Exit(ExitCode(..),exitWith)importSystem.Cmd(system)importDarcs.IO(runTolerantly,runSilently)importDarcs.SignalHandler(withSignalsBlocked)importDarcs.Repository.Format(RepoFormat,RepoProperty(Darcs2,HashedInventory,NoWorkingDir),tryIdentifyRepoFormat,formatHas,writeProblem,readProblem,readfromAndWritetoProblem)importSystem.Directory(doesDirectoryExist,setCurrentDirectory,createDirectoryIfMissing,doesFileExist)importControl.Monad(when,unless,filterM)importControl.Applicative((<$>))importControl.Exception(catch,IOException)importWorkaround(getCurrentDirectory,renameFile,setExecutable)importqualifiedData.ByteStringasB(readFile,isPrefixOf)importqualifiedData.ByteString.Char8asBC(pack)importDarcs.Patch(Effect,primIsHunk,primIsBinary,description,tryToShrink,commuteFLorComplain,commute,fromPrim)importDarcs.Patch.Dummy(DummyPatch)importDarcs.Patch.Apply(ApplyState)importDarcs.Patch.V1(Patch)importDarcs.Patch.V2(RealPatch)importDarcs.Patch.Prim.V1(Prim)importDarcs.Patch.Inspect(PatchInspect)importDarcs.Patch.Prim(PrimPatchBase,PrimOf,tryShrinkingInverse,PrimPatch)importDarcs.Patch.Bundle(scanBundle,makeBundleN)importDarcs.Patch.PatchInfoAnd(PatchInfoAnd,hopefully)importqualifiedDarcs.Repository.HashedRepoasHashedRepo(revertTentativeChanges,finalizeTentativeChanges,removeFromTentativeInventory,copyPristine,copyPartialsPristine,applyToTentativePristine,writeTentativeInventory,writeAndReadPatch,addToTentativeInventory,readRepo,readTentativeRepo,readRepoUsingSpecificInventory,cleanPristine)importqualifiedDarcs.Repository.OldasOld(readOldRepo,revertTentativeChanges,oldRepoFailMsg)importDarcs.Flags(DarcsFlag(Verbose,Quiet,MarkConflicts,AllowConflicts,NoUpdateWorking,WorkRepoUrl,WorkRepoDir,UMask,Test,LeaveTestDir,SetScriptsExecutable,DryRun),wantExternalMerge,compression,Compression)importDarcs.Witnesses.Eq(EqCheck(..))importDarcs.Witnesses.Unsafe(unsafeCoerceP,unsafeCoercePStart)importDarcs.Witnesses.Ordered(FL(..),RL(..),(:\/:)(..),(:/\:)(..),(:>)(..),(+>+),lengthFL,allFL,filterFLFL,reverseFL,mapFL_FL,concatFL)importDarcs.Patch(RepoPatch,Patchy,merge,listConflictedFiles,listTouchedFiles,Named,commuteRL,fromPrims,readPatch,effect,invert,primIsAddfile,primIsAdddir,primIsSetpref,apply,applyToTree,)importDarcs.Patch.Permutations(commuteWhatWeCanFL,removeFL)importDarcs.Patch.Set(PatchSet(..),SealedPatchSet,newset2FL)#ifdef GADT_WITNESSESimportDarcs.Patch.Set(Origin)#endifimportDarcs.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,mapSeal)importDarcs.Repository.InternalTypes(Repository(..),RepoType(..),Pristine(..))importDarcs.Global(darcsdir)importSystem.Mem(performGC)importqualifiedStorage.Hashed.TreeasTreeimportStorage.Hashed.Tree(Tree)importStorage.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))-- | Tries to identify the repository in a given directorymaybeIdentifyRepository::[DarcsFlag]->String->IO(IdentifyRepopC(rut))maybeIdentifyRepositoryopts"."=dodarcs<-doesDirectoryExistdarcsdirrf_or_e<-tryIdentifyRepoFormat"."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<-tryIdentifyRepoFormaturlcaserf_or_eofLefte->return$NonRepositoryeRightrf->casereadProblemrfofJusterr->return$BadRepositoryerrNothing->docs<-getCachesoptsurlreturn$GoodRepository$Repourloptsrf(DarcsRepositoryNoPristinecs)identifyPristine::IOPristineidentifyPristine=dopristine<-doesDirectoryExist$darcsdir++"/pristine"current<-doesDirectoryExist$darcsdir++"/current"hashinv<-doesFileExist$darcsdir++"/hashed_inventory"case(pristine||current,hashinv)of(False,False)->returnNoPristine(True,False)->returnPlainPristine(False,True)->returnHashedPristine_->fail"Multiple pristine trees."-- | identifyDarcsRepository identifies the repo at 'url'. Warning:-- you have to know what kind of patches are found in that repo.identifyDarcsRepository::forallpC(rut).[DarcsFlag]->String->IO(RepositorypC(rut))identifyDarcsRepositoryoptsurl=doer<-maybeIdentifyRepositoryoptsurlcaseerofBadRepositorys->failsNonRepositorys->failsGoodRepositoryr->returnr-- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url',-- but fails if it is not compatible for reading from and writing to.identifyRepositoryFor::forallpC(rut).RepoPatchp=>RepositorypC(rut)->String->IO(RepositorypC(rut))identifyRepositoryFor(Repo_optsrf_)url=doRepoabsurl_rf_t<-identifyDarcsRepositoryoptsurllett'=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[]=domaybe(Left$"You need to be in a repository directory "++"to run this command.")id<$>seekRepoamInHashedRepository::[DarcsFlag]->IO(EitherString())amInHashedRepositoryflags=doinrepo<-amInRepositoryflagscaseinrepoofRight_->dopristine<-identifyPristinecasepristineofHashedPristine->return(Right())_->return(LeftOld.oldRepoFailMsg)left->returnleft-- | 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. $-- The result is:-- Nothing, if no repository found-- Just (Left errorMessage), if bad repository found-- Just (Right ()), if good repository found.-- WARNING this changes the current directory for good if matchFn succeedsseekRepo::IO(Maybe(EitherString()))seekRepo=getCurrentDirectory>>=helperwherehelperstartpwd=dostatus<-maybeIdentifyRepository[]"."casestatusofGoodRepository_->return.Just$Right()BadRepositorye->return.Just$LefteNonRepository_->docd<-toFilePath`fmap`getCurrentDirectorysetCurrentDirectory".."cd'<-toFilePath`fmap`getCurrentDirectoryifcd'/=cdthenhelperstartpwdelsedosetCurrentDirectorystartpwdreturnNothing-- 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[]=maybe(Right())id<$>seekRepo-- TODO: see also Repository.State.readPendingLL ... to be removed after GHC 7.2readNewPendingLL::(RepoPatchp,ApplyStatep~Tree)=>RepositorypC(rut)->IO(Sealed((FLp)C(t)))readNewPendingLLrepo=mapSeal(mapFL_FLfromPrim)`fmap`readNewPendingrepomakeNewPending::forallpC(ruty).(RepoPatchp,ApplyStatep~Tree)=>RepositorypC(rut)->FL(PrimOfp)C(ty)->IO()makeNewPending(Repo_opts__)_|NoUpdateWorking`elem`opts=return()makeNewPendingrepo@(Repor__tp)origp=withCurrentDirectoryr$doletnewname=pendingNametp++".new"debugMessage$"Writing new pending: "++newnameSealedsfp<-return$siftForPendingorigpwriteNewPendingreposfpcur<-readRecordedrepoSealedp<-readNewPendingLLrepo-- :: IO (Sealed (FL (PrimOf p) C(t)))-- Warning: A do-notation statement discarded a result of type Tree.Tree IO._<-catch(applyToTreepcur)$\(err::IOException)->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: "++newnamesiftForPending::forallprimC(xy).PrimPatchprim=>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,ApplyStatep~Tree)=>RepositorypC(rut)->IO(PatchSetpC(Originr))readReporepo@(Repor_rf_)|formatHasHashedInventoryrf=HashedRepo.readReporepor|otherwise=doSealedps<-Old.readOldReporreturn$unsafeCoercePpsreadTentativeRepo::(RepoPatchp,ApplyStatep~Tree)=>RepositorypC(rut)->IO(PatchSetpC(Origint))readTentativeReporepo@(Repor_rf_)|formatHasHashedInventoryrf=HashedRepo.readTentativeReporepor|otherwise=failOld.oldRepoFailMsgreadRepoUsingSpecificInventory::(RepoPatchp,ApplyStatep~Tree)=>String->RepositorypC(rut)->IO(PatchSetpC(Origint))readRepoUsingSpecificInventoryinvPathrepo@(Repor_rf_)|formatHasHashedInventoryrf=HashedRepo.readRepoUsingSpecificInventoryinvPathrepor|otherwise=failOld.oldRepoFailMsgmakePatchLazy::RepoPatchp=>RepositorypC(rut)->PatchInfoAndpC(xy)->IO(PatchInfoAndpC(xy))makePatchLazy(Reporoptsrf(DarcsRepository_c))p|formatHasHashedInventoryrf=withCurrentDirectoryr$HashedRepo.writeAndReadPatchc(compressionopts)p|otherwise=failOld.oldRepoFailMsgprefsUrl::RepositorypC(rut)->StringprefsUrl(Repor__(DarcsRepository__))=r++"/"++darcsdir++"/prefs"unrevertUrl::RepositorypC(rut)->StringunrevertUrl(Repor__(DarcsRepository__))=r++"/"++darcsdir++"/patches/unrevert"applyToWorking::(ApplyState(PrimOfp)~Tree,RepoPatchp)=>RepositorypC(rut)->[DarcsFlag]->FL(PrimOfp)C(uy)->IO(RepositorypC(ryt))applyToWorking(Reporroptsrf(DarcsRepositorytc))optspatch=dounless(formatHasNoWorkingDirrf)$withCurrentDirectoryr$ifQuiet`elem`optsthenrunSilently$applypatchelserunTolerantly$applypatchreturn(Reporroptsrf(DarcsRepositorytc))handlePendForAdd::forallpC(rutxy).(RepoPatchp)=>RepositorypC(rut)->PatchInfoAndpC(xy)->IO()handlePendForAdd(Repo_opts__)_|NoUpdateWorking`elem`opts=return()handlePendForAddrepop=doSealedpend<-readTentativePendingrepoleteffectp=ifallFLisSimplependthencrudeSift$effectpelseeffectpSealednewpend<-return$rmpend(progressFL"Removing from pending:"effectp)(unsafeCoercePStartpend)writeTentativePendingrepo(unsafeCoercePStartnewpend)wherermpend::FL(PrimOfp)C(ab)->FL(PrimOfp)C(ac)->Sealed(FL(PrimOfp)C(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.isSimple::PrimPatchprim=>primC(xy)->BoolisSimplex=primIsHunkx||primIsBinaryx||primIsSetprefxcrudeSift::forallprimC(xy).PrimPatchprim=>FLprimC(xy)->FLprimC(xy)crudeSiftxs=ifallFLisSimplexsthenfilterFLFLishunkbinaryxselsexswhereishunkbinary::primC(ab)->EqCheckC(ab)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::(PrimPatchp,PatchInspectp)=>String->[DarcsFlag]->FLpC(xy)->IOBoolannounceMergeConflictscmdoptsresolved_pw=casenubsort$listTouchedFilesresolved_pwof[]->returnFalsecfs->ifMarkConflicts`elem`opts||AllowConflicts`elem`opts||wantExternalMergeopts/=NothingthendoputDocLnWithfancyPrinters$redText"We have conflicts in the following files:"$$text(unwordscfs)returnTrueelsedoputDocLnWithfancyPrinters$redText"There are conflicts in the following files:"$$text(unwordscfs)fail$"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<-identifyDarcsRepositoryopts"."cucrepositorywherecuc::RepositorypC(rut)->IOBoolcucr=doSealed(mpend::FL(PrimOfp)C(tx))<-readPendingr::IO(Sealed(FL(PrimOfp)C(t)))casempendofNilFL->returnFalsepend->casemerge(fromPrims_pend:\/:fromPrims_(concatFL$mapFL_FLeffectpc))of_:/\:pend'->caselistConflictedFilespend'of[]->returnFalsefs->doputStrLn("You have conflicting local changes to:\n"++unwordsfs)confirmed<-promptYorn"Proceed?"unlessconfirmed$doputStrLn"Cancelled."exitWithExitSuccessreturnTruefromPrims_::FL(PrimOfp)C(ab)->FLpC(ab)fromPrims_=fromPrimstentativelyAddPatch::(RepoPatchp,ApplyStatep~Tree)=>RepositorypC(rut)->Compression->PatchInfoAndpC(ty)->IO(RepositorypC(ruy))tentativelyAddPatch=tentativelyAddPatch_UpdatePristinedataUpdatePristine=UpdatePristine|DontUpdatePristinederivingEq-- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun-- :: Bool, with dryRun = unsafePerformIO $ readIORef ...tentativelyAddPatch_::(RepoPatchp,ApplyStatep~Tree)=>UpdatePristine->RepositorypC(rut)->Compression->PatchInfoAndpC(ty)->IO(RepositorypC(ruy))tentativelyAddPatch_upr@(Repodirroptsrf(DarcsRepositorytc))comprp=withCurrentDirectorydir$-- Warning: A do-notation statement discarded a result of type FilePath.do_<-decideHashedOrNormalrf$HvsO{hashed=HashedRepo.addToTentativeInventoryccomprp,old=failOld.oldRepoFailMsg}when(up==UpdatePristine)$dodebugMessage"Applying to pristine cache..."applyToTentativePristinerpdebugMessage"Updating pending..."handlePendForAddrpreturn(Repodirroptsrf(DarcsRepositorytc))applyToTentativePristine::(ApplyStateq~Tree,Effectq,Patchyq,PrimPatchBaseq)=>RepositorypC(rut)->qC(ty)->IO()applyToTentativePristine(Repodiroptsrf(DarcsRepository__))p=withCurrentDirectorydir$dowhen(Verbose`elem`opts)$putDocLn$text"Applying to pristine..."<+>descriptionpdecideHashedOrNormalrf$HvsO{hashed=HashedRepo.applyToTentativePristinep,old=failOld.oldRepoFailMsg}-- | 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]->FL(PrimOfp)C(xy)->IO()tentativelyAddToPending(Repo_opts__)__|NoUpdateWorking`elem`opts=return()|DryRun`elem`opts=bug"tentativelyAddToPending called when --dry-run is specified"tentativelyAddToPendingrepo@(Repodir___)_patch=withCurrentDirectorydir$doSealedpend<-readTentativePendingrepoFlippedSealnewpend_<-return$newpend(unsafeCoercePpend::FL(PrimOfp)C(ax))patchwriteTentativePendingrepo(unsafeCoercePStartnewpend_)wherenewpend::FLprimC(ab)->FLprimC(bc)->FlippedSeal(FLprim)C(c)newpendNilFLpatch_=flipSealpatch_newpendppatch_=flipSeal$p+>+patch_-- | 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)->FL(PrimOfp)C(xy)->IO()setTentativePending(Repo_opts__)_|NoUpdateWorking`elem`opts=return()setTentativePendingrepo@(Repodir___)patch=doSealedprims<-return$siftForPendingpatchwithCurrentDirectorydir$writeTentativePendingrepo(unsafeCoercePStartprims)-- | 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)->FL(PrimOfp)C(xy)->IO()prepend(Repo_opts__)_|NoUpdateWorking`elem`opts=return()prependrepo@(Repo____)patch=doSealedpend<-readTentativePendingrepoSealednewpend_<-return$newpend(unsafeCoercePpend)patchwriteTentativePendingrepo(unsafeCoercePStart$crudeSiftnewpend_)wherenewpend::FLprimC(bc)->FLprimC(ab)->Sealed(FLprimC(a))newpendNilFLpatch_=sealpatch_newpendppatch_=seal$patch_+>+ptentativelyRemovePatches::(RepoPatchp,ApplyStatep~Tree)=>RepositorypC(rut)->Compression->FL(PatchInfoAndp)C(xt)->IO(RepositorypC(rux))tentativelyRemovePatches=tentativelyRemovePatches_UpdatePristinetentativelyRemovePatches_::forallpC(rutx).(RepoPatchp,ApplyStatep~Tree)=>UpdatePristine->RepositorypC(rut)->Compression->FL(PatchInfoAndp)C(xt)->IO(RepositorypC(rux))tentativelyRemovePatches_uprepository@(Repodirroptsrf(DarcsRepositorytc))comprps=withCurrentDirectorydir$dowhen(up==UpdatePristine)$dodebugMessage"Adding changes to pending..."prependrepository$effectpsremoveFromUnrevertContextrepositorypsdebugMessage"Removing changes from tentative inventory..."ifformatHasHashedInventoryrfthendoHashedRepo.removeFromTentativeInventoryrepositorycomprpswhen(up==UpdatePristine)$HashedRepo.applyToTentativePristine$progressFL"Applying inverse to pristine"$invertpselsefailOld.oldRepoFailMsgreturn(Repodirroptsrf(DarcsRepositorytc))tentativelyReplacePatches::forallpC(rutx).(RepoPatchp,ApplyStatep~Tree)=>RepositorypC(rut)->Compression->FL(PatchInfoAndp)C(xt)->IO(RepositorypC(rut))tentativelyReplacePatchesrepositorycomprps=dorepository'<-tentativelyRemovePatches_DontUpdatePristinerepositorycomprpsmapAddrepository'pswheremapAdd::RepositorypC(mli)->FL(PatchInfoAndp)C(ij)->IO(RepositorypC(mlj))mapAddrNilFL=returnrmapAddr(a:>:as)=dor'<-tentativelyAddPatch_DontUpdatePristinercompramapAddr'asfinalizePending::(RepoPatchp,ApplyStatep~Tree)=>RepositorypC(rut)->IO()finalizePending(Repodiropts_rt)|NoUpdateWorking`elem`opts=withCurrentDirectorydir$removeFileMayNotExist$(pendingNamert)finalizePendingrepository@(Repodir___)=dowithCurrentDirectorydir$doSealedtpend<-readTentativePendingrepositorySealednew_pending<-return$siftForPendingtpendmakeNewPendingrepositorynew_pendingfinalizeRepositoryChanges::(RepoPatchp,ApplyStatep~Tree)=>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..."|otherwise=failOld.oldRepoFailMsgtestTentative::(RepoPatchp,ApplyStatep~Tree)=>RepositorypC(rut)->IO(ExitCode)testTentative=testAnywithTentativetestRecorded::(RepoPatchp,ApplyStatep~Tree)=>RepositorypC(rut)->IO(ExitCode)testRecorded=testAnywithRecordedtestAny::RepoPatchp=>(RepositorypC(rut)->((AbsolutePath->IO(ExitCode))->IO(ExitCode))->((AbsolutePath->IO(ExitCode))->IO(ExitCode)))->RepositorypC(rut)->IO(ExitCode)testAnywithDrepository@(Repodiropts__)=debugMessage"Considering whether to test...">>ifnot$Test`elem`optsthenreturnExitSuccesselsewithCurrentDirectorydir$doletputInfo=ifQuiet`elem`optsthenconst(return())elseputStrLndebugMessage"About to run test if it exists."testline<-getPrefval"test"casetestlineofNothing->returnExitSuccessJusttestcode->withDrepository(wd"testing")$\_->doputInfo"Running test...\n"when(SetScriptsExecutable`elem`opts)setScriptsExecutableec<-systemtestcodeifec==ExitSuccessthenputInfo"Test ran successfully.\n"elseputInfo"Test failed!\n"returnecwherewd=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<-readPendingrsetTentativePendingrxwhen(NoUpdateWorking`elem`opts)$removeFileMayNotExist$pendingNamedrdecideHashedOrNormalrf$HvsO{hashed=HashedRepo.revertTentativeChanges,old=Old.revertTentativeChanges}patchSetToPatches::RepoPatchp=>PatchSetpC(xy)->FL(Namedp)C(xy)patchSetToPatchespatchSet=mapFL_FLhopefully$newset2FLpatchSetgetUMask::[DarcsFlag]->MaybeStringgetUMask[]=NothinggetUMask((UMasku):_)=JustugetUMask(_:l)=getUMasklwithUMaskFromOpts::[DarcsFlag]->IOa->IOawithUMaskFromOpts=maybeidwithUMask.getUMaskwithGutsOf::RepositorypC(rut)->IOa->IOawithGutsOf(Repo__rf_)|formatHasHashedInventoryrf=id|otherwise=withSignalsBlockeddataRepoJoba-- = RepoJob (forall p C(r u) . RepoPatch p => Repository p C(r u r) -> IO a)-- TODO: Unbind Tree from RepoJob, possibly renaming existing RepoJob=RepoJob(forallpC(ru).(RepoPatchp,ApplyStatep~Tree,ApplyState(PrimOfp)~Tree)=>RepositorypC(rur)->IOa)|V1Job(forallC(ru).Repository(PatchPrim)C(rur)->IOa)|V2Job(forallC(ru).Repository(RealPatchPrim)C(rur)->IOa)|PrimV1Job(forallpC(ru).(RepoPatchp,ApplyStatep~Tree,PrimOfp~Prim)=>RepositorypC(rur)->IOa)onRepoJob::RepoJoba->(forallpC(ru).RepoPatchp=>(RepositorypC(rur)->IOa)->(RepositorypC(rur)->IOa))->RepoJobaonRepoJob(RepoJobjob)f=RepoJob(fjob)-- onRepoJob (TreeJob job) f = TreeJob (f job)onRepoJob(V1Jobjob)f=V1Job(fjob)onRepoJob(V2Jobjob)f=V2Job(fjob)onRepoJob(PrimV1Jobjob)f=PrimV1Job(fjob)withRepository::[DarcsFlag]->RepoJoba->IOawithRepositoryopts1=withRepositoryDirectoryopts1"."withRepositoryDirectory::foralla.[DarcsFlag]->String->RepoJoba->IOawithRepositoryDirectoryopts1urlrepojob=doRepodiroptsrf(DarcsRepositorytc)<-identifyDarcsRepositoryopts1urlifformatHasDarcs2rfthendodebugMessage$"Identified darcs-2 repo: "++dirlettherepo=Repodiroptsrf(DarcsRepositorytc)::Repository(RealPatchPrim)C(rur)caserepojobofRepoJobjob->jobtherepo-- TreeJob job -> job therepoV2Jobjob->jobtherepoPrimV1Jobjob->jobtherepoV1Job_->fail"This repository contains darcs v1 patches, but the command requires darcs v2 patches."elsedodebugMessage$"Identified darcs-1 repo: "++dirlettherepo=Repodiroptsrf(DarcsRepositorytc)::Repository(PatchPrim)C(rur)caserepojobofRepoJobjob->jobtherepo-- TreeJob job -> job therepoV1Jobjob->jobtherepoPrimV1Jobjob->jobtherepoV2Job_->fail"This repository contains darcs v2 patches, but the command requires darcs v1 patches."withRepoLock::[DarcsFlag]->RepoJoba->IOawithRepoLockoptsrepojob=withRepositoryopts$onRepoJobrepojob$\jobrepository@(Repo__rf_)->domaybe(return())fail$writeProblemrfletname="./"++darcsdir++"/lock"withUMaskFromOptsopts$ifDryRun`elem`optsthenjobrepositoryelsewithLockname(revertRepositoryChangesrepository>>jobrepository)withRepoReadLock::[DarcsFlag]->RepoJoba->IOawithRepoReadLockoptsrepojob=withRepositoryopts$onRepoJobrepojob$\jobrepository@(Repo__rf_)->domaybe(return())fail$writeProblemrfletname="./"++darcsdir++"/lock"withUMaskFromOptsopts$ifformatHasHashedInventoryrf||DryRun`elem`optsthenjobrepositoryelsewithLockname(revertRepositoryChangesrepository>>jobrepository)removeFromUnrevertContext::forallpC(rutx).(RepoPatchp,ApplyStatep~Tree)=>RepositorypC(rut)->FL(PatchInfoAndp)C(xt)->IO()removeFromUnrevertContextrepositoryps=doSealedbundle<-unrevert_patch_bundle`catchall`(return$seal(PatchSetNilRLNilRL))remove_from_unrevert_context_bundlewhereunrevert_impossible=doconfirmed<-promptYorn"This operation will make unrevert impossible!\nProceed?"ifconfirmedthenremoveFileMayNotExist(unrevertUrlrepository)elsefail"Cancelled."unrevert_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)bundle'debugMessage"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,ApplyStatep~Tree)=>RepositorypC(rut)->IO()optimizeInventoryrepository@(Repo_optsrf(DarcsRepository_c))=dops<-readReporepositorydecideHashedOrNormalrf$HvsO{hashed=dorevertRepositoryChangesrepositoryHashedRepo.writeTentativeInventoryc(compressionopts)$deepOptimizePatchsetpsfinalizeRepositoryChangesrepository,old=failOld.oldRepoFailMsg}cleanRepository::RepoPatchp=>RepositorypC(rut)->IO()cleanRepositoryrepository@(Repo__rf_)=decideHashedOrNormalrf$HvsO{hashed=HashedRepo.cleanPristinerepository,old=failOld.oldRepoFailMsg}createPristineDirectoryTree::RepoPatchp=>RepositorypC(rut)->FilePath->IO()createPristineDirectoryTree(Reporoptsrf(DarcsRepository_c))reldir|formatHasHashedInventoryrf=docreateDirectoryIfMissingTruereldirwithCurrentDirectoryreldir$HashedRepo.copyPristinec(compressionopts)r(darcsdir++"/hashed_inventory")|otherwise=failOld.oldRepoFailMsg-- fp below really should be FileName-- | Used by the commands dist and diffcreatePartialsPristineDirectoryTree::(FilePathLikefp,RepoPatchp)=>RepositorypC(rut)->[fp]->FilePath->IO()createPartialsPristineDirectoryTree(Reporoptsrf(DarcsRepository_c))prefsdir|formatHasHashedInventoryrf=docreateDirectoryIfMissingTruedirwithCurrentDirectorydir$HashedRepo.copyPartialsPristinec(compressionopts)r(darcsdir++"/hashed_inventory")prefs|otherwise=failOld.oldRepoFailMsgwithRecorded::RepoPatchp=>RepositorypC(rut)->((AbsolutePath->IOa)->IOa)->(AbsolutePath->IOa)->IOawithRecordedrepositorymk_dirf=mk_dir$\d->docreatePristineDirectoryTreerepository(toFilePathd)fdwithTentative::forallpaC(rut).(RepoPatchp,ApplyStatep~Tree)=>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@(Repodir___)mk_dirf=withRecordedrepositorymk_dir$\d->doSealedps<-read_patches(dir++"/"++darcsdir++"/tentative_pristine")applypsfdwhereread_patches::FilePath->IO(Sealed(FLpC(x)))read_patchesfil=dops<-B.readFilefilreturn$maybe(sealNilFL)id$readPatchps-- | Sets scripts in or below the current directory executable. A script is any file that starts-- with the bytes '#!'. This is used for --set-scripts-executable.setScriptsExecutable_::Patchyp=>Maybe(pC(xy))->IO()setScriptsExecutable_pw=dodebugMessage"Making scripts executable"tree<-readWorkingpaths<-casepwofJustps->filterMdoesFileExist$listTouchedFilespsNothing->return[anchorPath"."p|(p,Tree.File_)<-Tree.listtree]letsetExecutableIfScriptf=docontents<-B.readFilefwhen(BC.pack"#!"`B.isPrefixOf`contents)$dodebugMessage("Making executable: "++f)setExecutablefTruemapM_setExecutableIfScriptpathssetScriptsExecutable::IO()setScriptsExecutable=setScriptsExecutable_(Nothing::Maybe(FLDummyPatchC(xy)))setScriptsExecutablePatches::Patchyp=>pC(xy)->IO()setScriptsExecutablePatches=setScriptsExecutable_.Just