-- Copyright (C) 2005 David Roundy---- 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 -fglasgow-exts #-}moduleDarcs.IO(ReadableDirectory(..),WriteableDirectory(..),TolerantIO,runTolerantly,runSilently,)whereimportPreludehiding(catch)importData.Char(toLower)importData.List(isSuffixOf)importSystem.IO.Error(isDoesNotExistError,isPermissionError)importControl.Exception(catch,catchJust,ioErrors)importControl.Monad.ErrorimportSystem.Directory(getDirectoryContents,createDirectory,removeDirectory,removeFile,renameFile,renameDirectory,doesDirectoryExist,doesFileExist,)importByteStringUtils(linesPS,unlinesPS)importqualifiedData.ByteStringasB(ByteString,empty,null,readFile)importqualifiedData.ByteString.Char8asBC(unpack,pack)importDarcs.Utils(withCurrentDirectory,prettyException)importDarcs.External(backupByCopying,backupByRenaming)importPrinter(Doc,renderPS)importDarcs.Patch.FileName(FileName,fn2fp,fp2fn)importDarcs.Lock(writeBinFile,readBinFile,writeAtomicFilePS)importWorkaround(setExecutable)class(Functorm,MonadPlusm)=>ReadableDirectorymwheremDoesDirectoryExist::FileName->mBoolmDoesFileExist::FileName->mBoolmInCurrentDirectory::FileName->ma->mamGetDirectoryContents::m[FileName]mReadBinFile::FileName->mStringmReadBinFilef=liftMBC.unpack$mReadFilePSfmReadFilePS::FileName->mB.ByteStringmReadFilePSs::FileName->m[B.ByteString]mReadFilePSsf=linesPS`liftM`mReadFilePSfclassReadableDirectorym=>WriteableDirectorymwheremWithCurrentDirectory::FileName->ma->mamSetFileExecutable::FileName->Bool->m()mWriteBinFile::FileName->String->m()mWriteBinFilefns=mWriteFilePSfn$BC.packsmWriteFilePS::FileName->B.ByteString->m()mWriteFilePSs::FileName->[B.ByteString]->m()mWriteFilePSsfss=mWriteFilePSf(unlinesPSss)mCreateDirectory::FileName->m()mRemoveDirectory::FileName->m()mWriteDoc::FileName->Doc->m()mWriteDocfd=mWriteFilePSf(renderPSd)mCreateFile::FileName->m()mCreateFilef=mWriteFilePSfB.emptymRemoveFile::FileName->m()mRename::FileName->FileName->m()mModifyFilePS::FileName->(B.ByteString->mB.ByteString)->m()mModifyFilePSfj=dops<-mReadFilePSfps'<-jpsmWriteFilePSfps'mModifyFilePSs::FileName->([B.ByteString]->m[B.ByteString])->m()mModifyFilePSsfj=dops<-mReadFilePSsfps'<-jpsmWriteFilePSsfps'instanceReadableDirectoryIOwheremDoesDirectoryExist=doesDirectoryExist.fn2fpmDoesFileExist=doesFileExist.fn2fpmInCurrentDirectory=withCurrentDirectory.fn2fpmGetDirectoryContents=mapfp2fn`liftM`getDirectoryContents"."mReadBinFile=readBinFile.fn2fpmReadFilePS=B.readFile.fn2fpinstanceWriteableDirectoryIOwheremWithCurrentDirectory=mInCurrentDirectorymSetFileExecutable=setExecutable.fn2fpmWriteBinFile=writeBinFile.fn2fpmWriteFilePS=writeAtomicFilePS.fn2fpmCreateDirectory=createDirectory.fn2fpmCreateFilef=doexf<-mDoesFileExistfifexfthenfail$"File '"++fn2fpf++"' already exists!"elsedoexd<-mDoesDirectoryExistfifexdthenfail$"File '"++fn2fpf++"' already exists!"elsemWriteFilePSfB.emptymRemoveFilef=doletfp=fn2fpfx<-B.readFilefpwhen(not$B.nullx)$fail$"Cannot remove non-empty file "++fpremoveFilefpmRemoveDirectory=removeDirectory.fn2fpmRenameab=catchJustioErrors(renameDirectoryxy`mplus`renameFilexy)-- We need to catch does not exist errors, since older-- versions of darcs allowed users to rename nonexistent-- files. :((\e->ifisDoesNotExistErrorethenreturn()elseioErrore)wherex=fn2fpay=fn2fpbclassMonadm=>TolerantMonadmwherewarning::IO()->m()runIO::ma->IOarunTM::IOa->manewtypeTolerantIOa=TIO{runTolerantly::IOa}instanceTolerantMonadTolerantIOwherewarningio=TIO$io`catch`\e->putStrLn$"Warning: "++prettyExceptionerunIO(TIOio)=iorunTMio=TIOionewtypeSilentIOa=SIO{runSilently::IOa}instanceTolerantMonadSilentIOwherewarningio=SIO$io`catch`\_->return()runIO(SIOio)=iorunTMio=SIOio-- NOTE: The following instance declarations are duplicated merely to avoid-- enabling -fallow-undecidable-instances. If we used-- -fallow-undecidable-instances, we would write instead:-- instance TolerantMonad m => Monad m where-- ...-- etc.instanceFunctorTolerantIOwherefmapfm=m>>=return.finstanceMonadTolerantIOwheref>>=g=runTM$runIOf>>=runIO.gf>>g=runTM$runIOf>>runIOgfails=runTM$failsreturnx=runTM$returnxinstanceFunctorSilentIOwherefmapfm=m>>=return.finstanceMonadSilentIOwheref>>=g=runTM$runIOf>>=runIO.gf>>g=runTM$runIOf>>runIOgfails=runTM$failsreturnx=runTM$returnxinstanceMonadPlusTolerantIOwheremzero=runTMmzeromplusab=runTM(mplus(runIOa)(runIOb))instanceMonadPlusSilentIOwheremzero=runTMmzeromplusab=runTM(mplus(runIOa)(runIOb))instanceReadableDirectoryTolerantIOwheremDoesDirectoryExistd=runTM$mDoesDirectoryExistdmDoesFileExistf=runTM$mDoesFileExistfmInCurrentDirectoryij=runTM$mInCurrentDirectoryi(runIOj)mGetDirectoryContents=runTMmGetDirectoryContentsmReadBinFilef=runTM$mReadBinFilefmReadFilePSf=runTM$mReadFilePSfinstanceReadableDirectorySilentIOwheremDoesDirectoryExistd=runTM$mDoesDirectoryExistdmDoesFileExistf=runTM$mDoesFileExistfmInCurrentDirectoryij=runTM$mInCurrentDirectoryi(runIOj)mGetDirectoryContents=runTMmGetDirectoryContentsmReadBinFilef=runTM$mReadBinFilefmReadFilePSf=runTM$mReadFilePSfinstanceWriteableDirectoryTolerantIOwheremWithCurrentDirectory=mInCurrentDirectorymSetFileExecutablefe=warning$mSetFileExecutablefemWriteBinFilefs=warning$mWriteBinFilefsmWriteFilePSfs=warning$mWriteFilePSfsmCreateFilef=warning$backupf>>mWriteFilePSfB.emptymCreateDirectoryd=warning$backupd>>mCreateDirectorydmRemoveFilef=warning$mRemoveFilefmRemoveDirectoryd=warning$catchJustioErrors(mRemoveDirectoryd)(\e->if"(Directory not empty)"`isSuffixOf`showethenioError$userError$"Not deleting "++fn2fpd++" because it is not empty."elseioError$userError$"Not deleting "++fn2fpd++" because:\n"++showe)mRenameab=warning$catchJustioErrors(letdo_backup=if(maptoLowerx==maptoLowery)thenbackupByCopyingy-- avoid making the original vanishelsebackupByRenamingyindo_backup>>mRenameab)(\e->case()of_|isPermissionErrore->ioError$userError$couldNotRename++"."|isDoesNotExistErrore->ioError$userError$couldNotRename++" because "++x++" does not exist."|otherwise->ioErrore)wherex=fn2fpay=fn2fpbcouldNotRename="Could not rename "++x++" to "++yinstanceWriteableDirectorySilentIOwheremWithCurrentDirectory=mInCurrentDirectorymSetFileExecutablefe=warning$mSetFileExecutablefemWriteBinFilefs=warning$mWriteBinFilefsmWriteFilePSfs=warning$mWriteFilePSfsmCreateFilef=warning$backupf>>mWriteFilePSfB.emptymCreateDirectoryd=warning$backupd>>mCreateDirectorydmRemoveFilef=warning$mRemoveFilefmRemoveDirectoryd=warning$catchJustioErrors(mRemoveDirectoryd)(\e->if"(Directory not empty)"`isSuffixOf`showethenioError$userError$"Not deleting "++fn2fpd++" because it is not empty."elseioError$userError$"Not deleting "++fn2fpd++" because:\n"++showe)mRenameab=warning$catchJustioErrors(letdo_backup=if(maptoLowerx==maptoLowery)thenbackupByCopyingy-- avoid making the original vanishelsebackupByRenamingyindo_backup>>mRenameab)(\e->case()of_|isPermissionErrore->ioError$userError$couldNotRename++"."|isDoesNotExistErrore->ioError$userError$couldNotRename++" because "++x++" does not exist."|otherwise->ioErrore)wherex=fn2fpay=fn2fpbcouldNotRename="Could not rename "++x++" to "++ybackup::FileName->IO()backupf=backupByRenaming$fn2fpf