-- 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 -fno-warn-orphans #-}{-# LANGUAGE MultiParamTypeClasses #-}moduleDarcs.IO(runTolerantly,runSilently)whereimportPreludehiding(catch)importData.Char(toLower)importData.List(isSuffixOf)importSystem.IO.Error(isDoesNotExistError,isPermissionError)importControl.Exception.Extensible(catch,SomeException,IOException)importControl.Monad.ErrorimportSystem.Directory(createDirectory,removeDirectory,removeFile,renameFile,renameDirectory,doesDirectoryExist,doesFileExist)importDarcs.Repository.Prefs(changePrefval)importqualifiedData.ByteStringasB(empty,null,readFile)importDarcs.Utils(prettyException)importDarcs.External(backupByCopying,backupByRenaming)importDarcs.Patch.FileName(FileName,fn2fp)importDarcs.Lock(writeAtomicFilePS)importDarcs.Patch.ApplyMonad(ApplyMonad(..))importStorage.Hashed.Tree(Tree)instanceApplyMonadIOTreewheretypeApplyMonadBaseIO=IOmDoesDirectoryExist=doesDirectoryExist.fn2fpmChangePref=changePrefvalmModifyFilePSfj=B.readFile(fn2fpf)>>=j>>=writeAtomicFilePS(fn2fpf)mCreateDirectory=createDirectory.fn2fpmCreateFilef=doexf<-doesFileExist(fn2fpf)ifexfthenfail$"File '"++fn2fpf++"' already exists!"elsedoexd<-doesDirectoryExist$fn2fpfifexdthenfail$"File '"++fn2fpf++"' already exists!"elsewriteAtomicFilePS(fn2fpf)B.emptymRemoveFilef=doletfp=fn2fpfx<-B.readFilefpwhen(not$B.nullx)$fail$"Cannot remove non-empty file "++fpremoveFilefpmRemoveDirectory=removeDirectory.fn2fpmRenameab=catch(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`\(_::SomeException)->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$returnxinstanceApplyMonadTolerantIOTreewheretypeApplyMonadBaseTolerantIO=IOmDoesDirectoryExistd=runTM$mDoesDirectoryExistdmReadFilePSf=runTM$mReadFilePSfmChangePrefabc=warning$mChangePrefabcmModifyFilePSfj=warning$mModifyFilePSf(runIO.j)mCreateFilef=warning$backupf>>mCreateFilefmCreateDirectoryd=warning$backupd>>mCreateDirectorydmRemoveFilef=warning$mRemoveFilefmRemoveDirectoryd=warning$catch(mRemoveDirectoryd)(\(e::IOException)->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$catch(letdo_backup=if(maptoLowerx==maptoLowery)thenbackupByCopying(fn2fpb)-- avoid making the original vanishelsebackupByRenaming(fn2fpb)indo_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 "++yinstanceApplyMonadSilentIOTreewheretypeApplyMonadBaseSilentIO=IOmDoesDirectoryExistd=runTM$mDoesDirectoryExistdmReadFilePSf=runTM$mReadFilePSfmChangePrefabc=warning$mChangePrefabcmModifyFilePSfj=warning$mModifyFilePSf(runIO.j)mCreateFilef=warning$backupf>>mCreateFilefmCreateDirectoryd=warning$backupd>>mCreateDirectorydmRemoveFilef=warning$mRemoveFilefmRemoveDirectoryd=warning$catch(mRemoveDirectoryd)(\(e::SomeException)->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$catch(letdo_backup=if(maptoLowerx==maptoLowery)thenbackupByCopying(fn2fpb)-- avoid making the original vanishelsebackupByRenaming(fn2fpb)indo_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)