% 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.
\documentclass{article}
\usepackage{verbatim}
\newenvironment{code}{\verbatim}{\endverbatim}
\begin{document}
\title{The DarcsIO library}
\author{David Roundy}
\maketitle
\begin{abstract}
This paper hasn't been written.
\end{abstract}
\begin{comment}
\begin{code}
{-# OPTIONS_GHC -fglasgow-exts #-}
module Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..),
TolerantIO, runTolerantly, runSilently,
) where
import Prelude hiding ( catch )
import Data.Char ( toLower )
import Data.List ( isSuffixOf )
import System.IO.Error ( isDoesNotExistError, isPermissionError )
import Control.Exception ( catch, catchJust, ioErrors )
import Control.Monad.Error
import System.Directory ( getDirectoryContents, createDirectory,
removeDirectory, removeFile,
renameFile, renameDirectory,
doesDirectoryExist, doesFileExist,
)
import FastPackedString ( PackedString, readFilePS, linesPS, nullPS,
unlinesPS, nilPS, packString, unpackPS,
)
import Darcs.Utils ( withCurrentDirectory, prettyException )
import Darcs.External ( backupByCopying, backupByRenaming )
import Printer ( Doc, renderPS )
import FileName ( FileName, fn2fp, fp2fn )
import Darcs.Lock ( writeBinFile, readBinFile, writeAtomicFilePS )
import Workaround ( setExecutable )
\end{code}
\end{comment}
\begin{comment}
\begin{code}
class MonadPlus m => ReadableDirectory m where
mDoesDirectoryExist :: FileName -> m Bool
mDoesFileExist :: FileName -> m Bool
mInCurrentDirectory :: FileName -> m a -> m a
mGetDirectoryContents :: m [FileName]
mReadBinFile :: FileName -> m String
mReadBinFile f = liftM unpackPS $ mReadFilePS f
mReadFilePS :: FileName -> m PackedString
mReadFilePSs :: FileName -> m [PackedString]
mReadFilePSs f = linesPS `liftM` mReadFilePS f
class ReadableDirectory m => WriteableDirectory m where
mWithCurrentDirectory :: FileName -> m a -> m a
mSetFileExecutable :: FileName -> Bool -> m ()
mWriteBinFile :: FileName -> String -> m ()
mWriteBinFile fn s = mWriteFilePS fn $ packString s
mWriteFilePS :: FileName -> PackedString -> m ()
mWriteFilePSs :: FileName -> [PackedString] -> m ()
mWriteFilePSs f ss = mWriteFilePS f (unlinesPS ss)
mCreateDirectory :: FileName -> m ()
mRemoveDirectory :: FileName -> m ()
mWriteDoc :: FileName -> Doc -> m ()
mWriteDoc f d = mWriteFilePS f (renderPS d)
mCreateFile :: FileName -> m ()
mCreateFile f = mWriteFilePS f nilPS
mRemoveFile :: FileName -> m ()
mRename :: FileName -> FileName -> m ()
mModifyFilePS :: FileName -> (PackedString -> m PackedString) -> m ()
mModifyFilePS f j = do ps <- mReadFilePS f
ps' <- j ps
mWriteFilePS f ps'
mModifyFilePSs :: FileName -> ([PackedString] -> m [PackedString]) -> m ()
mModifyFilePSs f j = do ps <- mReadFilePSs f
ps' <- j ps
mWriteFilePSs f ps'
instance ReadableDirectory IO where
mDoesDirectoryExist = doesDirectoryExist . fn2fp
mDoesFileExist = doesFileExist . fn2fp
mInCurrentDirectory = withCurrentDirectory . fn2fp
mGetDirectoryContents = map fp2fn `liftM` getDirectoryContents "."
mReadBinFile = readBinFile . fn2fp
mReadFilePS = readFilePS . fn2fp
instance WriteableDirectory IO where
mWithCurrentDirectory = mInCurrentDirectory
mSetFileExecutable = setExecutable . fn2fp
mWriteBinFile = writeBinFile . fn2fp
mWriteFilePS = writeAtomicFilePS . fn2fp
mCreateDirectory = createDirectory . fn2fp
mCreateFile f = do exf <- mDoesFileExist f
if exf then fail $ "File '"++fn2fp f++"' already exists!"
else do exd <- mDoesDirectoryExist f
if exd then fail $ "File '"++fn2fp f++"' already exists!"
else mWriteFilePS f nilPS
mRemoveFile f = do let fp = fn2fp f
x <- readFilePS fp
when (not $ nullPS x) $
fail $ "Cannot remove non-empty file "++fp
removeFile fp
mRemoveDirectory = removeDirectory . fn2fp
mRename a b = catchJust ioErrors
(renameDirectory x y `mplus` renameFile x y)
-- We need to catch does not exist errors, since older
-- versions of darcs allowed users to rename nonexistent
-- files. :(
(\e -> if isDoesNotExistError e
then return ()
else ioError e)
where x = fn2fp a
y = fn2fp b
class Monad m => TolerantMonad m where
warning :: IO () -> m ()
runIO :: m a -> IO a
runTM :: IO a -> m a
newtype TolerantIO a = TIO { runTolerantly :: IO a }
instance TolerantMonad TolerantIO where
warning io = TIO $ io `catch` \e -> putStrLn $ "Warning: " ++ prettyException e
runIO (TIO io) = io
runTM io = TIO io
newtype SilentIO a = SIO { runSilently :: IO a }
instance TolerantMonad SilentIO where
warning io = SIO $ io `catch` \_ -> return ()
runIO (SIO io) = io
runTM io = SIO io
-- 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.
instance Monad TolerantIO where
f >>= g = runTM $ runIO f >>= runIO . g
f >> g = runTM $ runIO f >> runIO g
fail s = runTM $ fail s
return x = runTM $ return x
instance Monad SilentIO where
f >>= g = runTM $ runIO f >>= runIO . g
f >> g = runTM $ runIO f >> runIO g
fail s = runTM $ fail s
return x = runTM $ return x
instance MonadPlus TolerantIO where
mzero = runTM mzero
mplus a b = runTM (mplus (runIO a) (runIO b))
instance MonadPlus SilentIO where
mzero = runTM mzero
mplus a b = runTM (mplus (runIO a) (runIO b))
instance ReadableDirectory TolerantIO where
mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d
mDoesFileExist f = runTM $ mDoesFileExist f
mInCurrentDirectory i j = runTM $ mInCurrentDirectory i (runIO j)
mGetDirectoryContents = runTM mGetDirectoryContents
mReadBinFile f = runTM $ mReadBinFile f
mReadFilePS f = runTM $ mReadFilePS f
instance ReadableDirectory SilentIO where
mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d
mDoesFileExist f = runTM $ mDoesFileExist f
mInCurrentDirectory i j = runTM $ mInCurrentDirectory i (runIO j)
mGetDirectoryContents = runTM mGetDirectoryContents
mReadBinFile f = runTM $ mReadBinFile f
mReadFilePS f = runTM $ mReadFilePS f
instance WriteableDirectory TolerantIO where
mWithCurrentDirectory = mInCurrentDirectory
mSetFileExecutable f e = warning $ mSetFileExecutable f e
mWriteBinFile f s = warning $ mWriteBinFile f s
mWriteFilePS f s = warning $ mWriteFilePS f s
mCreateFile f = warning $ backup f >> mWriteFilePS f nilPS
mCreateDirectory d = warning $ backup d >> mCreateDirectory d
mRemoveFile f = warning $ mRemoveFile f
mRemoveDirectory d = warning $ catchJust ioErrors
(mRemoveDirectory d)
(\e ->
if "(Directory not empty)" `isSuffixOf` show e
then ioError $ userError $
"Not deleting " ++ fn2fp d ++ " because it is not empty."
else ioError $ userError $
"Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)
mRename a b = warning $ catchJust ioErrors
(let do_backup = if (map toLower x == map toLower y)
then backupByCopying y -- avoid making the original vanish
else backupByRenaming y
in do_backup >> mRename a b)
(\e -> case () of
_ | isPermissionError e -> ioError $ userError $
couldNotRename ++ "."
| isDoesNotExistError e -> ioError $ userError $
couldNotRename ++ " because " ++ x ++ " does not exist."
| otherwise -> ioError e
)
where
x = fn2fp a
y = fn2fp b
couldNotRename = "Could not rename " ++ x ++ " to " ++ y
instance WriteableDirectory SilentIO where
mWithCurrentDirectory = mInCurrentDirectory
mSetFileExecutable f e = warning $ mSetFileExecutable f e
mWriteBinFile f s = warning $ mWriteBinFile f s
mWriteFilePS f s = warning $ mWriteFilePS f s
mCreateFile f = warning $ backup f >> mWriteFilePS f nilPS
mCreateDirectory d = warning $ backup d >> mCreateDirectory d
mRemoveFile f = warning $ mRemoveFile f
mRemoveDirectory d = warning $ catchJust ioErrors
(mRemoveDirectory d)
(\e ->
if "(Directory not empty)" `isSuffixOf` show e
then ioError $ userError $
"Not deleting " ++ fn2fp d ++ " because it is not empty."
else ioError $ userError $
"Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)
mRename a b = warning $ catchJust ioErrors
(let do_backup = if (map toLower x == map toLower y)
then backupByCopying y -- avoid making the original vanish
else backupByRenaming y
in do_backup >> mRename a b)
(\e -> case () of
_ | isPermissionError e -> ioError $ userError $
couldNotRename ++ "."
| isDoesNotExistError e -> ioError $ userError $
couldNotRename ++ " because " ++ x ++ " does not exist."
| otherwise -> ioError e
)
where
x = fn2fp a
y = fn2fp b
couldNotRename = "Could not rename " ++ x ++ " to " ++ y
backup :: FileName -> IO ()
backup f = backupByRenaming $ fn2fp f
\end{code}
\end{comment}
\end{document}