-- Copyright (C) 2002-2005 David Roundy-- Copyright (C) 2004 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 #-}{-# LANGUAGE CPP #-}#include "gadts.h"moduleDarcs.Repository.Pristine(Pristine,flagsToPristine,nopristine,createPristine,removePristine,identifyPristine,slurpPristine,applyPristine,createPristineFromWorking,syncPristine,replacePristine,replacePristineFromSlurpy,getPristinePop,pristineDirectory,pristineToFlagString,easyCreatePristineDirectoryTree,easyCreatePartialsPristineDirectoryTree)whereimportData.Maybe(isJust)importControl.Monad(when,liftM)importSystem.Directory(createDirectory,doesDirectoryExist,doesFileExist,renameDirectory,removeFile)importDarcs.Lock(rm_recursive,writeBinFile)importDarcs.Diff(sync)importWorkaround(getCurrentDirectory)importDarcs.SlurpDirectory(Slurpy,mmap_slurp,co_slurp,writeSlurpy)importDarcs.Utils(catchall)importDarcs.PopulationData(Population,getPopFrom)importDarcs.Flags(DarcsFlag(PristinePlain,PristineNone))importDarcs.Repository.Format(RepoFormat,format_has,RepoProperty(HashedInventory))importDarcs.IO(WriteableDirectory(mWithCurrentDirectory))importDarcs.Patch(Patchy,apply)importDarcs.Patch.Info(PatchInfo)importDarcs.Patch.FileName(fp2fn)importqualifiedData.ByteStringasB(empty)importDarcs.RepoPath(FilePathLike,toFilePath)importSHA1(sha1PS)importDarcs.External(cloneTree,cloneTreeExcept,clonePartialsTree)importDarcs.Repository.InternalTypes(Pristine(..))importDarcs.Global(darcsdir)#include "impossible.h"nopristine::Pristinenopristine=NoPristine"aack?"pristineName::StringpristineName="pristine"identifyPristine::IO(Pristine)identifyPristine=domp<-reallyIdentifyPristinecasempofNothing->fail"Pristine tree doesn't exist."Justpristine->returnpristinereallyIdentifyPristine::IO(MaybePristine)reallyIdentifyPristine=dodir<-findpristinedoesDirectoryExist""none<-findpristinedoesFileExist".none"hashinv<-doesFileExist$darcsdir++"/hashed_inventory"hashpris<-doesDirectoryExisthashedPristineDirectorycase(dir,none,hashinv&&hashpris)of(Nothing,Nothing,False)->returnNothing(Justn,Nothing,False)->return(Just(PlainPristinen))(Nothing,Justn,False)->return(Just(NoPristinen))(Nothing,Nothing,True)->return(JustHashedPristine)_->fail"Multiple pristine trees."wherefindpristinefnext=doe1<-fnn1e2<-fnn2case(e1,e2)of(False,False)->returnNothing(True,False)->return(Justn1)(False,True)->return(Justn2)(True,True)->fail"Multiple pristine trees."wheren1=darcsdir++"/pristine"++extn2=darcsdir++"/current"++extflagsToPristine::[DarcsFlag]->RepoFormat->PristineflagsToPristine_rf|format_hasHashedInventoryrf=HashedPristineflagsToPristine(PristineNone:_)_=NoPristine(darcsdir++"/"++pristineName++".none")flagsToPristine(PristinePlain:_)_=PlainPristine(darcsdir++"/"++pristineName)flagsToPristine(_:t)rf=flagsToPristinetrfflagsToPristine[]rf=flagsToPristine[PristinePlain]rfcreatePristine::Pristine->IOPristinecreatePristinep=dooldpristine<-reallyIdentifyPristinewhen(isJustoldpristine)$fail"Pristine tree already exists."casepofNoPristinen->writeBinFilen"Do not delete this file.\n"PlainPristinen->createDirectorynHashedPristine->docreateDirectoryhashedPristineDirectorywriteFile(hashedPristineDirectory++"/"++sha1PSB.empty)""returnphashedPristineDirectory::StringhashedPristineDirectory=darcsdir++"/pristine.hashed"removePristine::Pristine->IO()removePristine(NoPristinen)=removeFilenremovePristine(PlainPristinen)=rm_recursivenremovePristineHashedPristine=rm_recursivehashedPristineDirectoryslurpPristine::Pristine->IO(MaybeSlurpy)slurpPristine(PlainPristinen)=docwd<-getCurrentDirectoryslurpy<-mmap_slurp(cwd++"/"++n)return(Justslurpy)slurpPristine(NoPristine_)=returnNothingslurpPristineHashedPristine=bug"HashedPristine is not implemented yet."applyPristine::Patchyp=>Pristine->pC(xy)->IO()applyPristine(NoPristine_)_=return()-- We don't need flags for now, since we don't care about-- SetScriptsExecutable for the pristine cache.applyPristine(PlainPristinen)p=mWithCurrentDirectory(fp2fnn)$apply[]papplyPristineHashedPristine_=bug"3 HashedPristine is not implemented yet."createPristineFromWorking::Pristine->IO()createPristineFromWorking(NoPristine_)=return()createPristineFromWorking(PlainPristinen)=cloneTreeExcept[darcsdir]"."ncreatePristineFromWorkingHashedPristine=bug"HashedPristine is not implemented yet."syncPristine::Pristine->IO()syncPristine(NoPristine_)=return()syncPristine(PlainPristinen)=doocur<-mmap_slurpnowork<-co_slurpocur"."syncnocuroworksyncPristineHashedPristine=return()-- FIXME this should be implemented!replacePristine::FilePath->Pristine->IO()replacePristine_(NoPristine_)=return()replacePristinenewcur(PlainPristinen)=dorm_recursivenold`catchall`return()renameDirectorynnoldrenameDirectorynewcurnreturn()wherenold=darcsdir++"/"++pristineName++"-old"replacePristine_HashedPristine=bug"HashedPristine is not implemented yet."replacePristineFromSlurpy::Slurpy->Pristine->IO()replacePristineFromSlurpy_(NoPristine_)=return()replacePristineFromSlurpys(PlainPristinen)=dorm_recursivenold`catchall`return()writeSlurpysntmprenameDirectorynnoldrenameDirectoryntmpnreturn()wherenold=darcsdir++"/"++pristineName++"-old"ntmp=darcsdir++"/"++pristineName++"-tmp"replacePristineFromSlurpy_HashedPristine=bug"HashedPristine is not implemented yet."getPristinePop::PatchInfo->Pristine->IO(MaybePopulation)getPristinePoppinfo(PlainPristinen)=Just`liftM`getPopFromnpinfogetPristinePop__=returnNothingpristineDirectory::Pristine->MaybeStringpristineDirectory(PlainPristinen)=JustnpristineDirectory_=NothingpristineToFlagString::Pristine->StringpristineToFlagString(NoPristine_)="--no-pristine-tree"pristineToFlagString(PlainPristine_)="--plain-pristine-tree"pristineToFlagStringHashedPristine=bug"HashedPristine is not implemented yet."easyCreatePristineDirectoryTree::Pristine->FilePath->IOBooleasyCreatePristineDirectoryTree(NoPristine_)_=returnFalseeasyCreatePristineDirectoryTree(PlainPristinen)p=cloneTreenp>>returnTrueeasyCreatePristineDirectoryTreeHashedPristine_=bug"HashedPristine is not implemented yet."easyCreatePartialsPristineDirectoryTree::FilePathLikefp=>[fp]->Pristine->FilePath->IOBooleasyCreatePartialsPristineDirectoryTree_(NoPristine_)_=returnFalseeasyCreatePartialsPristineDirectoryTreeprefs(PlainPristinen)p=clonePartialsTreenp(maptoFilePathprefs)>>returnTrueeasyCreatePartialsPristineDirectoryTree_HashedPristine_=bug"HashedPristine is not implemented yet."