-- Copyright (C) 2002-2005,2007 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-missing-methods #-}
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

module Darcs.Repository.ApplyPatches
    ( applyPatches
    , runTolerantly
    , runSilently
    , DefaultIO, runDefault
    ) where

import Prelude hiding ( Applicative )
import Control.Exception ( catch, SomeException, IOException )
import Data.Char ( toLower )
import Data.List ( isSuffixOf )
import System.IO ( stderr )
import System.IO.Error ( isDoesNotExistError, isPermissionError )
import Control.Monad ( unless, mplus )
import Control.Applicative (Applicative)
import System.Directory ( createDirectory,
                          removeDirectory, removeFile,
                          renameFile, renameDirectory,
                          doesDirectoryExist, doesFileExist
                        )

import Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTree(..) )
import Darcs.Patch.ApplyPatches ( applyPatches )
import Darcs.Patch.MonadProgress ( MonadProgress(..), ProgressAction(..) )
import Darcs.Repository.Prefs( changePrefval )
import Darcs.Util.Lock ( writeAtomicFilePS )

import Darcs.Util.Exception ( prettyException )
import Darcs.Util.Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )
import Darcs.Util.Printer ( hPutDocLn )
import Darcs.Util.Printer.Color ( showDoc )
import Darcs.Util.External ( backupByCopying, backupByRenaming )
import Darcs.Util.Path ( FileName, fn2fp )
import qualified Data.ByteString as B (empty, null, readFile)

import Darcs.Util.Tree( Tree )

newtype DefaultIO a = DefaultIO { DefaultIO a -> IO a
runDefaultIO :: IO a }
    deriving (a -> DefaultIO b -> DefaultIO a
(a -> b) -> DefaultIO a -> DefaultIO b
(forall a b. (a -> b) -> DefaultIO a -> DefaultIO b)
-> (forall a b. a -> DefaultIO b -> DefaultIO a)
-> Functor DefaultIO
forall a b. a -> DefaultIO b -> DefaultIO a
forall a b. (a -> b) -> DefaultIO a -> DefaultIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DefaultIO b -> DefaultIO a
$c<$ :: forall a b. a -> DefaultIO b -> DefaultIO a
fmap :: (a -> b) -> DefaultIO a -> DefaultIO b
$cfmap :: forall a b. (a -> b) -> DefaultIO a -> DefaultIO b
Functor, Functor DefaultIO
a -> DefaultIO a
Functor DefaultIO =>
(forall a. a -> DefaultIO a)
-> (forall a b. DefaultIO (a -> b) -> DefaultIO a -> DefaultIO b)
-> (forall a b c.
    (a -> b -> c) -> DefaultIO a -> DefaultIO b -> DefaultIO c)
-> (forall a b. DefaultIO a -> DefaultIO b -> DefaultIO b)
-> (forall a b. DefaultIO a -> DefaultIO b -> DefaultIO a)
-> Applicative DefaultIO
DefaultIO a -> DefaultIO b -> DefaultIO b
DefaultIO a -> DefaultIO b -> DefaultIO a
DefaultIO (a -> b) -> DefaultIO a -> DefaultIO b
(a -> b -> c) -> DefaultIO a -> DefaultIO b -> DefaultIO c
forall a. a -> DefaultIO a
forall a b. DefaultIO a -> DefaultIO b -> DefaultIO a
forall a b. DefaultIO a -> DefaultIO b -> DefaultIO b
forall a b. DefaultIO (a -> b) -> DefaultIO a -> DefaultIO b
forall a b c.
(a -> b -> c) -> DefaultIO a -> DefaultIO b -> DefaultIO c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: DefaultIO a -> DefaultIO b -> DefaultIO a
$c<* :: forall a b. DefaultIO a -> DefaultIO b -> DefaultIO a
*> :: DefaultIO a -> DefaultIO b -> DefaultIO b
$c*> :: forall a b. DefaultIO a -> DefaultIO b -> DefaultIO b
liftA2 :: (a -> b -> c) -> DefaultIO a -> DefaultIO b -> DefaultIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> DefaultIO a -> DefaultIO b -> DefaultIO c
<*> :: DefaultIO (a -> b) -> DefaultIO a -> DefaultIO b
$c<*> :: forall a b. DefaultIO (a -> b) -> DefaultIO a -> DefaultIO b
pure :: a -> DefaultIO a
$cpure :: forall a. a -> DefaultIO a
$cp1Applicative :: Functor DefaultIO
Applicative, Applicative DefaultIO
a -> DefaultIO a
Applicative DefaultIO =>
(forall a b. DefaultIO a -> (a -> DefaultIO b) -> DefaultIO b)
-> (forall a b. DefaultIO a -> DefaultIO b -> DefaultIO b)
-> (forall a. a -> DefaultIO a)
-> Monad DefaultIO
DefaultIO a -> (a -> DefaultIO b) -> DefaultIO b
DefaultIO a -> DefaultIO b -> DefaultIO b
forall a. a -> DefaultIO a
forall a b. DefaultIO a -> DefaultIO b -> DefaultIO b
forall a b. DefaultIO a -> (a -> DefaultIO b) -> DefaultIO b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> DefaultIO a
$creturn :: forall a. a -> DefaultIO a
>> :: DefaultIO a -> DefaultIO b -> DefaultIO b
$c>> :: forall a b. DefaultIO a -> DefaultIO b -> DefaultIO b
>>= :: DefaultIO a -> (a -> DefaultIO b) -> DefaultIO b
$c>>= :: forall a b. DefaultIO a -> (a -> DefaultIO b) -> DefaultIO b
$cp1Monad :: Applicative DefaultIO
Monad)

instance MonadProgress DefaultIO where
  runProgressActions :: String -> [ProgressAction DefaultIO ()] -> DefaultIO ()
runProgressActions _ [] = () -> DefaultIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  runProgressActions what :: String
what items :: [ProgressAction DefaultIO ()]
items = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ()) -> IO () -> DefaultIO ()
forall a b. (a -> b) -> a -> b
$ do
    do String -> IO ()
beginTedious String
what
       String -> Int -> IO ()
tediousSize String
what ([ProgressAction DefaultIO ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ProgressAction DefaultIO ()]
items)
       (ProgressAction DefaultIO () -> IO ())
-> [ProgressAction DefaultIO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ProgressAction DefaultIO () -> IO ()
forall b. ProgressAction DefaultIO b -> IO b
go [ProgressAction DefaultIO ()]
items
       String -> IO ()
endTedious String
what
    where go :: ProgressAction DefaultIO b -> IO b
go item :: ProgressAction DefaultIO b
item =
            do String -> String -> IO ()
finishedOneIO String
what (Doc -> String
showDoc (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ ProgressAction DefaultIO b -> Doc
forall (m :: * -> *) a. ProgressAction m a -> Doc
paMessage ProgressAction DefaultIO b
item)
               DefaultIO b -> IO b
forall a. DefaultIO a -> IO a
runDefaultIO (ProgressAction DefaultIO b -> DefaultIO b
forall (m :: * -> *) a. ProgressAction m a -> m a
paAction ProgressAction DefaultIO b
item) IO b -> (IOError -> IO b) -> IO b
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \e :: IOError
e ->
                 do Handle -> Doc -> IO ()
hPutDocLn Handle
stderr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgressAction DefaultIO b -> Doc
forall (m :: * -> *) a. ProgressAction m a -> Doc
paOnError ProgressAction DefaultIO b
item
                    IOError -> IO b
forall a. IOError -> IO a
ioError IOError
e

instance ApplyMonad Tree DefaultIO where
    type ApplyMonadBase DefaultIO = IO

instance ApplyMonadTree DefaultIO where
    mDoesDirectoryExist :: FileName -> DefaultIO Bool
mDoesDirectoryExist = IO Bool -> DefaultIO Bool
forall a. IO a -> DefaultIO a
DefaultIO (IO Bool -> DefaultIO Bool)
-> (FileName -> IO Bool) -> FileName -> DefaultIO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
doesDirectoryExist (String -> IO Bool) -> (FileName -> String) -> FileName -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileName -> String
fn2fp
    mChangePref :: String -> String -> String -> DefaultIO ()
mChangePref a :: String
a b :: String
b c :: String
c = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ()) -> IO () -> DefaultIO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> IO ()
changePrefval String
a String
b String
c
    mModifyFilePS :: FileName -> (ByteString -> DefaultIO ByteString) -> DefaultIO ()
mModifyFilePS f :: FileName
f j :: ByteString -> DefaultIO ByteString
j = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ()) -> IO () -> DefaultIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile (FileName -> String
fn2fp FileName
f) IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DefaultIO ByteString -> IO ByteString
forall a. DefaultIO a -> IO a
runDefaultIO (DefaultIO ByteString -> IO ByteString)
-> (ByteString -> DefaultIO ByteString)
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DefaultIO ByteString
j IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (FileName -> String
fn2fp FileName
f)
    mCreateDirectory :: FileName -> DefaultIO ()
mCreateDirectory = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ())
-> (FileName -> IO ()) -> FileName -> DefaultIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
createDirectory (String -> IO ()) -> (FileName -> String) -> FileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileName -> String
fn2fp
    mCreateFile :: FileName -> DefaultIO ()
mCreateFile f :: FileName
f = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ()) -> IO () -> DefaultIO ()
forall a b. (a -> b) -> a -> b
$
                    do Bool
exf <- String -> IO Bool
doesFileExist (FileName -> String
fn2fp FileName
f)
                       if Bool
exf then String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "File '"String -> String -> String
forall a. [a] -> [a] -> [a]
++FileName -> String
fn2fp FileName
fString -> String -> String
forall a. [a] -> [a] -> [a]
++"' already exists!"
                              else do Bool
exd <- String -> IO Bool
doesDirectoryExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ FileName -> String
fn2fp FileName
f
                                      if Bool
exd then String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "File '"String -> String -> String
forall a. [a] -> [a] -> [a]
++FileName -> String
fn2fp FileName
fString -> String -> String
forall a. [a] -> [a] -> [a]
++"' already exists!"
                                             else String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (FileName -> String
fn2fp FileName
f) ByteString
B.empty
    mRemoveFile :: FileName -> DefaultIO ()
mRemoveFile f :: FileName
f = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ()) -> IO () -> DefaultIO ()
forall a b. (a -> b) -> a -> b
$
                    do let fp :: String
fp = FileName -> String
fn2fp FileName
f
                       ByteString
x <- String -> IO ByteString
B.readFile String
fp
                       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
x) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Cannot remove non-empty file "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fp
                       String -> IO ()
removeFile String
fp
    mRemoveDirectory :: FileName -> DefaultIO ()
mRemoveDirectory = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ())
-> (FileName -> IO ()) -> FileName -> DefaultIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeDirectory (String -> IO ()) -> (FileName -> String) -> FileName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileName -> String
fn2fp
    mRename :: FileName -> FileName -> DefaultIO ()
mRename a :: FileName
a b :: FileName
b = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ()) -> IO () -> DefaultIO ()
forall a b. (a -> b) -> a -> b
$
                  IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
                  (String -> String -> IO ()
renameDirectory String
x String
y IO () -> IO () -> IO ()
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> String -> IO ()
renameFile String
x String
y)
                  -- We need to catch does not exist errors, since older
                  -- versions of darcs allowed users to rename nonexistent
                  -- files.  :(
                  (\e :: IOError
e -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOError -> Bool
isDoesNotExistError IOError
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> IO ()
forall a. IOError -> IO a
ioError IOError
e)
      where x :: String
x = FileName -> String
fn2fp FileName
a
            y :: String
y = FileName -> String
fn2fp FileName
b

class (Functor m, Monad m) => TolerantMonad m where
    warning :: IO () -> m ()
    runIO :: m a -> IO a
    runTM :: IO a -> m a

newtype TolerantIO a = TIO { TolerantIO a -> IO a
runTIO :: IO a }
    deriving (a -> TolerantIO b -> TolerantIO a
(a -> b) -> TolerantIO a -> TolerantIO b
(forall a b. (a -> b) -> TolerantIO a -> TolerantIO b)
-> (forall a b. a -> TolerantIO b -> TolerantIO a)
-> Functor TolerantIO
forall a b. a -> TolerantIO b -> TolerantIO a
forall a b. (a -> b) -> TolerantIO a -> TolerantIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TolerantIO b -> TolerantIO a
$c<$ :: forall a b. a -> TolerantIO b -> TolerantIO a
fmap :: (a -> b) -> TolerantIO a -> TolerantIO b
$cfmap :: forall a b. (a -> b) -> TolerantIO a -> TolerantIO b
Functor, Functor TolerantIO
a -> TolerantIO a
Functor TolerantIO =>
(forall a. a -> TolerantIO a)
-> (forall a b.
    TolerantIO (a -> b) -> TolerantIO a -> TolerantIO b)
-> (forall a b c.
    (a -> b -> c) -> TolerantIO a -> TolerantIO b -> TolerantIO c)
-> (forall a b. TolerantIO a -> TolerantIO b -> TolerantIO b)
-> (forall a b. TolerantIO a -> TolerantIO b -> TolerantIO a)
-> Applicative TolerantIO
TolerantIO a -> TolerantIO b -> TolerantIO b
TolerantIO a -> TolerantIO b -> TolerantIO a
TolerantIO (a -> b) -> TolerantIO a -> TolerantIO b
(a -> b -> c) -> TolerantIO a -> TolerantIO b -> TolerantIO c
forall a. a -> TolerantIO a
forall a b. TolerantIO a -> TolerantIO b -> TolerantIO a
forall a b. TolerantIO a -> TolerantIO b -> TolerantIO b
forall a b. TolerantIO (a -> b) -> TolerantIO a -> TolerantIO b
forall a b c.
(a -> b -> c) -> TolerantIO a -> TolerantIO b -> TolerantIO c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: TolerantIO a -> TolerantIO b -> TolerantIO a
$c<* :: forall a b. TolerantIO a -> TolerantIO b -> TolerantIO a
*> :: TolerantIO a -> TolerantIO b -> TolerantIO b
$c*> :: forall a b. TolerantIO a -> TolerantIO b -> TolerantIO b
liftA2 :: (a -> b -> c) -> TolerantIO a -> TolerantIO b -> TolerantIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> TolerantIO a -> TolerantIO b -> TolerantIO c
<*> :: TolerantIO (a -> b) -> TolerantIO a -> TolerantIO b
$c<*> :: forall a b. TolerantIO (a -> b) -> TolerantIO a -> TolerantIO b
pure :: a -> TolerantIO a
$cpure :: forall a. a -> TolerantIO a
$cp1Applicative :: Functor TolerantIO
Applicative, Applicative TolerantIO
a -> TolerantIO a
Applicative TolerantIO =>
(forall a b. TolerantIO a -> (a -> TolerantIO b) -> TolerantIO b)
-> (forall a b. TolerantIO a -> TolerantIO b -> TolerantIO b)
-> (forall a. a -> TolerantIO a)
-> Monad TolerantIO
TolerantIO a -> (a -> TolerantIO b) -> TolerantIO b
TolerantIO a -> TolerantIO b -> TolerantIO b
forall a. a -> TolerantIO a
forall a b. TolerantIO a -> TolerantIO b -> TolerantIO b
forall a b. TolerantIO a -> (a -> TolerantIO b) -> TolerantIO b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> TolerantIO a
$creturn :: forall a. a -> TolerantIO a
>> :: TolerantIO a -> TolerantIO b -> TolerantIO b
$c>> :: forall a b. TolerantIO a -> TolerantIO b -> TolerantIO b
>>= :: TolerantIO a -> (a -> TolerantIO b) -> TolerantIO b
$c>>= :: forall a b. TolerantIO a -> (a -> TolerantIO b) -> TolerantIO b
$cp1Monad :: Applicative TolerantIO
Monad)

instance TolerantMonad TolerantIO where
    warning :: IO () -> TolerantIO ()
warning io :: IO ()
io = IO () -> TolerantIO ()
forall a. IO a -> TolerantIO a
TIO (IO () -> TolerantIO ()) -> IO () -> TolerantIO ()
forall a b. (a -> b) -> a -> b
$ IO ()
io IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \e :: SomeException
e -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Warning: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
prettyException SomeException
e
    runIO :: TolerantIO a -> IO a
runIO (TIO io :: IO a
io) = IO a
io
    runTM :: IO a -> TolerantIO a
runTM = IO a -> TolerantIO a
forall a. IO a -> TolerantIO a
TIO

newtype SilentIO a = SIO { SilentIO a -> IO a
runSIO :: IO a }
    deriving (a -> SilentIO b -> SilentIO a
(a -> b) -> SilentIO a -> SilentIO b
(forall a b. (a -> b) -> SilentIO a -> SilentIO b)
-> (forall a b. a -> SilentIO b -> SilentIO a) -> Functor SilentIO
forall a b. a -> SilentIO b -> SilentIO a
forall a b. (a -> b) -> SilentIO a -> SilentIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SilentIO b -> SilentIO a
$c<$ :: forall a b. a -> SilentIO b -> SilentIO a
fmap :: (a -> b) -> SilentIO a -> SilentIO b
$cfmap :: forall a b. (a -> b) -> SilentIO a -> SilentIO b
Functor, Functor SilentIO
a -> SilentIO a
Functor SilentIO =>
(forall a. a -> SilentIO a)
-> (forall a b. SilentIO (a -> b) -> SilentIO a -> SilentIO b)
-> (forall a b c.
    (a -> b -> c) -> SilentIO a -> SilentIO b -> SilentIO c)
-> (forall a b. SilentIO a -> SilentIO b -> SilentIO b)
-> (forall a b. SilentIO a -> SilentIO b -> SilentIO a)
-> Applicative SilentIO
SilentIO a -> SilentIO b -> SilentIO b
SilentIO a -> SilentIO b -> SilentIO a
SilentIO (a -> b) -> SilentIO a -> SilentIO b
(a -> b -> c) -> SilentIO a -> SilentIO b -> SilentIO c
forall a. a -> SilentIO a
forall a b. SilentIO a -> SilentIO b -> SilentIO a
forall a b. SilentIO a -> SilentIO b -> SilentIO b
forall a b. SilentIO (a -> b) -> SilentIO a -> SilentIO b
forall a b c.
(a -> b -> c) -> SilentIO a -> SilentIO b -> SilentIO c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: SilentIO a -> SilentIO b -> SilentIO a
$c<* :: forall a b. SilentIO a -> SilentIO b -> SilentIO a
*> :: SilentIO a -> SilentIO b -> SilentIO b
$c*> :: forall a b. SilentIO a -> SilentIO b -> SilentIO b
liftA2 :: (a -> b -> c) -> SilentIO a -> SilentIO b -> SilentIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> SilentIO a -> SilentIO b -> SilentIO c
<*> :: SilentIO (a -> b) -> SilentIO a -> SilentIO b
$c<*> :: forall a b. SilentIO (a -> b) -> SilentIO a -> SilentIO b
pure :: a -> SilentIO a
$cpure :: forall a. a -> SilentIO a
$cp1Applicative :: Functor SilentIO
Applicative, Applicative SilentIO
a -> SilentIO a
Applicative SilentIO =>
(forall a b. SilentIO a -> (a -> SilentIO b) -> SilentIO b)
-> (forall a b. SilentIO a -> SilentIO b -> SilentIO b)
-> (forall a. a -> SilentIO a)
-> Monad SilentIO
SilentIO a -> (a -> SilentIO b) -> SilentIO b
SilentIO a -> SilentIO b -> SilentIO b
forall a. a -> SilentIO a
forall a b. SilentIO a -> SilentIO b -> SilentIO b
forall a b. SilentIO a -> (a -> SilentIO b) -> SilentIO b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SilentIO a
$creturn :: forall a. a -> SilentIO a
>> :: SilentIO a -> SilentIO b -> SilentIO b
$c>> :: forall a b. SilentIO a -> SilentIO b -> SilentIO b
>>= :: SilentIO a -> (a -> SilentIO b) -> SilentIO b
$c>>= :: forall a b. SilentIO a -> (a -> SilentIO b) -> SilentIO b
$cp1Monad :: Applicative SilentIO
Monad)

instance TolerantMonad SilentIO where
    warning :: IO () -> SilentIO ()
warning io :: IO ()
io = IO () -> SilentIO ()
forall a. IO a -> SilentIO a
SIO (IO () -> SilentIO ()) -> IO () -> SilentIO ()
forall a b. (a -> b) -> a -> b
$ IO ()
io IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_ :: SomeException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    runIO :: SilentIO a -> IO a
runIO (SIO io :: IO a
io) = IO a
io
    runTM :: IO a -> SilentIO a
runTM = IO a -> SilentIO a
forall a. IO a -> SilentIO a
SIO

newtype TolerantWrapper m a = TolerantWrapper { TolerantWrapper m a -> m a
runTolerantWrapper :: m a }
    deriving (a -> TolerantWrapper m b -> TolerantWrapper m a
(a -> b) -> TolerantWrapper m a -> TolerantWrapper m b
(forall a b.
 (a -> b) -> TolerantWrapper m a -> TolerantWrapper m b)
-> (forall a b. a -> TolerantWrapper m b -> TolerantWrapper m a)
-> Functor (TolerantWrapper m)
forall a b. a -> TolerantWrapper m b -> TolerantWrapper m a
forall a b. (a -> b) -> TolerantWrapper m a -> TolerantWrapper m b
forall (m :: * -> *) a b.
Functor m =>
a -> TolerantWrapper m b -> TolerantWrapper m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TolerantWrapper m a -> TolerantWrapper m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TolerantWrapper m b -> TolerantWrapper m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> TolerantWrapper m b -> TolerantWrapper m a
fmap :: (a -> b) -> TolerantWrapper m a -> TolerantWrapper m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TolerantWrapper m a -> TolerantWrapper m b
Functor, Functor (TolerantWrapper m)
a -> TolerantWrapper m a
Functor (TolerantWrapper m) =>
(forall a. a -> TolerantWrapper m a)
-> (forall a b.
    TolerantWrapper m (a -> b)
    -> TolerantWrapper m a -> TolerantWrapper m b)
-> (forall a b c.
    (a -> b -> c)
    -> TolerantWrapper m a
    -> TolerantWrapper m b
    -> TolerantWrapper m c)
-> (forall a b.
    TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b)
-> (forall a b.
    TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m a)
-> Applicative (TolerantWrapper m)
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m a
TolerantWrapper m (a -> b)
-> TolerantWrapper m a -> TolerantWrapper m b
(a -> b -> c)
-> TolerantWrapper m a
-> TolerantWrapper m b
-> TolerantWrapper m c
forall a. a -> TolerantWrapper m a
forall a b.
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m a
forall a b.
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b
forall a b.
TolerantWrapper m (a -> b)
-> TolerantWrapper m a -> TolerantWrapper m b
forall a b c.
(a -> b -> c)
-> TolerantWrapper m a
-> TolerantWrapper m b
-> TolerantWrapper m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (TolerantWrapper m)
forall (m :: * -> *) a. Applicative m => a -> TolerantWrapper m a
forall (m :: * -> *) a b.
Applicative m =>
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m a
forall (m :: * -> *) a b.
Applicative m =>
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b
forall (m :: * -> *) a b.
Applicative m =>
TolerantWrapper m (a -> b)
-> TolerantWrapper m a -> TolerantWrapper m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> TolerantWrapper m a
-> TolerantWrapper m b
-> TolerantWrapper m c
<* :: TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m a
*> :: TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b
liftA2 :: (a -> b -> c)
-> TolerantWrapper m a
-> TolerantWrapper m b
-> TolerantWrapper m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> TolerantWrapper m a
-> TolerantWrapper m b
-> TolerantWrapper m c
<*> :: TolerantWrapper m (a -> b)
-> TolerantWrapper m a -> TolerantWrapper m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
TolerantWrapper m (a -> b)
-> TolerantWrapper m a -> TolerantWrapper m b
pure :: a -> TolerantWrapper m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> TolerantWrapper m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (TolerantWrapper m)
Applicative, Applicative (TolerantWrapper m)
a -> TolerantWrapper m a
Applicative (TolerantWrapper m) =>
(forall a b.
 TolerantWrapper m a
 -> (a -> TolerantWrapper m b) -> TolerantWrapper m b)
-> (forall a b.
    TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b)
-> (forall a. a -> TolerantWrapper m a)
-> Monad (TolerantWrapper m)
TolerantWrapper m a
-> (a -> TolerantWrapper m b) -> TolerantWrapper m b
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b
forall a. a -> TolerantWrapper m a
forall a b.
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b
forall a b.
TolerantWrapper m a
-> (a -> TolerantWrapper m b) -> TolerantWrapper m b
forall (m :: * -> *). Monad m => Applicative (TolerantWrapper m)
forall (m :: * -> *) a. Monad m => a -> TolerantWrapper m a
forall (m :: * -> *) a b.
Monad m =>
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b
forall (m :: * -> *) a b.
Monad m =>
TolerantWrapper m a
-> (a -> TolerantWrapper m b) -> TolerantWrapper m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> TolerantWrapper m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> TolerantWrapper m a
>> :: TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
TolerantWrapper m a -> TolerantWrapper m b -> TolerantWrapper m b
>>= :: TolerantWrapper m a
-> (a -> TolerantWrapper m b) -> TolerantWrapper m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
TolerantWrapper m a
-> (a -> TolerantWrapper m b) -> TolerantWrapper m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (TolerantWrapper m)
Monad, Monad (TolerantWrapper m)
Functor (TolerantWrapper m)
(Functor (TolerantWrapper m), Monad (TolerantWrapper m)) =>
(IO () -> TolerantWrapper m ())
-> (forall a. TolerantWrapper m a -> IO a)
-> (forall a. IO a -> TolerantWrapper m a)
-> TolerantMonad (TolerantWrapper m)
IO a -> TolerantWrapper m a
IO () -> TolerantWrapper m ()
TolerantWrapper m a -> IO a
forall a. IO a -> TolerantWrapper m a
forall a. TolerantWrapper m a -> IO a
forall (m :: * -> *).
(Functor m, Monad m) =>
(IO () -> m ())
-> (forall a. m a -> IO a)
-> (forall a. IO a -> m a)
-> TolerantMonad m
forall (m :: * -> *). TolerantMonad m => Monad (TolerantWrapper m)
forall (m :: * -> *).
TolerantMonad m =>
Functor (TolerantWrapper m)
forall (m :: * -> *).
TolerantMonad m =>
IO () -> TolerantWrapper m ()
forall (m :: * -> *) a.
TolerantMonad m =>
IO a -> TolerantWrapper m a
forall (m :: * -> *) a.
TolerantMonad m =>
TolerantWrapper m a -> IO a
runTM :: IO a -> TolerantWrapper m a
$crunTM :: forall (m :: * -> *) a.
TolerantMonad m =>
IO a -> TolerantWrapper m a
runIO :: TolerantWrapper m a -> IO a
$crunIO :: forall (m :: * -> *) a.
TolerantMonad m =>
TolerantWrapper m a -> IO a
warning :: IO () -> TolerantWrapper m ()
$cwarning :: forall (m :: * -> *).
TolerantMonad m =>
IO () -> TolerantWrapper m ()
$cp2TolerantMonad :: forall (m :: * -> *). TolerantMonad m => Monad (TolerantWrapper m)
$cp1TolerantMonad :: forall (m :: * -> *).
TolerantMonad m =>
Functor (TolerantWrapper m)
TolerantMonad)

-- | Apply patches, emitting warnings if there are any IO errors
runTolerantly :: TolerantWrapper TolerantIO a -> IO a
runTolerantly :: TolerantWrapper TolerantIO a -> IO a
runTolerantly = TolerantIO a -> IO a
forall a. TolerantIO a -> IO a
runTIO (TolerantIO a -> IO a)
-> (TolerantWrapper TolerantIO a -> TolerantIO a)
-> TolerantWrapper TolerantIO a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TolerantWrapper TolerantIO a -> TolerantIO a
forall (m :: * -> *) a. TolerantWrapper m a -> m a
runTolerantWrapper

-- | Apply patches, ignoring all errors
runSilently :: TolerantWrapper SilentIO a -> IO a
runSilently :: TolerantWrapper SilentIO a -> IO a
runSilently = SilentIO a -> IO a
forall a. SilentIO a -> IO a
runSIO (SilentIO a -> IO a)
-> (TolerantWrapper SilentIO a -> SilentIO a)
-> TolerantWrapper SilentIO a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TolerantWrapper SilentIO a -> SilentIO a
forall (m :: * -> *) a. TolerantWrapper m a -> m a
runTolerantWrapper

-- | The default mode of applying patches: fail if the directory is not
-- as we expect
runDefault :: DefaultIO a -> IO a
runDefault :: DefaultIO a -> IO a
runDefault = DefaultIO a -> IO a
forall a. DefaultIO a -> IO a
runDefaultIO

instance TolerantMonad m => ApplyMonad Tree (TolerantWrapper m) where
    type ApplyMonadBase (TolerantWrapper m) = IO

instance TolerantMonad m => ApplyMonadTree (TolerantWrapper m) where
    mDoesDirectoryExist :: FileName -> TolerantWrapper m Bool
mDoesDirectoryExist d :: FileName
d = IO Bool -> TolerantWrapper m Bool
forall (m :: * -> *) a. TolerantMonad m => IO a -> m a
runTM (IO Bool -> TolerantWrapper m Bool)
-> IO Bool -> TolerantWrapper m Bool
forall a b. (a -> b) -> a -> b
$ DefaultIO Bool -> IO Bool
forall a. DefaultIO a -> IO a
runDefaultIO (DefaultIO Bool -> IO Bool) -> DefaultIO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FileName -> DefaultIO Bool
forall (m :: * -> *). ApplyMonadTree m => FileName -> m Bool
mDoesDirectoryExist FileName
d
    mReadFilePS :: FileName -> TolerantWrapper m ByteString
mReadFilePS f :: FileName
f = IO ByteString -> TolerantWrapper m ByteString
forall (m :: * -> *) a. TolerantMonad m => IO a -> m a
runTM (IO ByteString -> TolerantWrapper m ByteString)
-> IO ByteString -> TolerantWrapper m ByteString
forall a b. (a -> b) -> a -> b
$ DefaultIO ByteString -> IO ByteString
forall a. DefaultIO a -> IO a
runDefaultIO (DefaultIO ByteString -> IO ByteString)
-> DefaultIO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FileName -> DefaultIO ByteString
forall (m :: * -> *). ApplyMonadTree m => FileName -> m ByteString
mReadFilePS FileName
f
    mChangePref :: String -> String -> String -> TolerantWrapper m ()
mChangePref a :: String
a b :: String
b c :: String
c = IO () -> TolerantWrapper m ()
forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning (IO () -> TolerantWrapper m ()) -> IO () -> TolerantWrapper m ()
forall a b. (a -> b) -> a -> b
$ DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefaultIO (DefaultIO () -> IO ()) -> DefaultIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> DefaultIO ()
forall (m :: * -> *).
ApplyMonadTree m =>
String -> String -> String -> m ()
mChangePref String
a String
b String
c
    mModifyFilePS :: FileName
-> (ByteString -> TolerantWrapper m ByteString)
-> TolerantWrapper m ()
mModifyFilePS f :: FileName
f j :: ByteString -> TolerantWrapper m ByteString
j = IO () -> TolerantWrapper m ()
forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning (IO () -> TolerantWrapper m ()) -> IO () -> TolerantWrapper m ()
forall a b. (a -> b) -> a -> b
$ DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefaultIO (DefaultIO () -> IO ()) -> DefaultIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FileName -> (ByteString -> DefaultIO ByteString) -> DefaultIO ()
forall (m :: * -> *).
ApplyMonadTree m =>
FileName -> (ByteString -> m ByteString) -> m ()
mModifyFilePS FileName
f (IO ByteString -> DefaultIO ByteString
forall a. IO a -> DefaultIO a
DefaultIO (IO ByteString -> DefaultIO ByteString)
-> (ByteString -> IO ByteString)
-> ByteString
-> DefaultIO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TolerantWrapper m ByteString -> IO ByteString
forall (m :: * -> *) a. TolerantMonad m => m a -> IO a
runIO (TolerantWrapper m ByteString -> IO ByteString)
-> (ByteString -> TolerantWrapper m ByteString)
-> ByteString
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> TolerantWrapper m ByteString
j)
    mCreateFile :: FileName -> TolerantWrapper m ()
mCreateFile f :: FileName
f = IO () -> TolerantWrapper m ()
forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning (IO () -> TolerantWrapper m ()) -> IO () -> TolerantWrapper m ()
forall a b. (a -> b) -> a -> b
$ FileName -> IO ()
backup FileName
f IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefaultIO (FileName -> DefaultIO ()
forall (m :: * -> *). ApplyMonadTree m => FileName -> m ()
mCreateFile FileName
f)
    mCreateDirectory :: FileName -> TolerantWrapper m ()
mCreateDirectory d :: FileName
d = IO () -> TolerantWrapper m ()
forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning (IO () -> TolerantWrapper m ()) -> IO () -> TolerantWrapper m ()
forall a b. (a -> b) -> a -> b
$ FileName -> IO ()
backup FileName
d IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefaultIO (FileName -> DefaultIO ()
forall (m :: * -> *). ApplyMonadTree m => FileName -> m ()
mCreateDirectory FileName
d)
    mRemoveFile :: FileName -> TolerantWrapper m ()
mRemoveFile f :: FileName
f = IO () -> TolerantWrapper m ()
forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning (IO () -> TolerantWrapper m ()) -> IO () -> TolerantWrapper m ()
forall a b. (a -> b) -> a -> b
$ DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefaultIO (FileName -> DefaultIO ()
forall (m :: * -> *). ApplyMonadTree m => FileName -> m ()
mRemoveFile FileName
f)
    mRemoveDirectory :: FileName -> TolerantWrapper m ()
mRemoveDirectory d :: FileName
d = IO () -> TolerantWrapper m ()
forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning (IO () -> TolerantWrapper m ()) -> IO () -> TolerantWrapper m ()
forall a b. (a -> b) -> a -> b
$ IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
                                 (DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefaultIO (FileName -> DefaultIO ()
forall (m :: * -> *). ApplyMonadTree m => FileName -> m ()
mRemoveDirectory FileName
d))
                                 (\(IOError
e :: IOException) ->
                                   if "(Directory not empty)" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` IOError -> String
forall a. Show a => a -> String
show IOError
e
                                   then IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$
                                            "Not deleting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileName -> String
fn2fp FileName
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ " because it is not empty."
                                   else IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$
                                            "Not deleting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileName -> String
fn2fp FileName
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ " because:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
e)
    mRename :: FileName -> FileName -> TolerantWrapper m ()
mRename a :: FileName
a b :: FileName
b = IO () -> TolerantWrapper m ()
forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning (IO () -> TolerantWrapper m ()) -> IO () -> TolerantWrapper m ()
forall a b. (a -> b) -> a -> b
$ IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
                          (let do_backup :: IO ()
do_backup = if (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
y
                                           then String -> IO ()
backupByCopying (FileName -> String
fn2fp FileName
b) -- avoid making the original vanish
                                           else String -> IO ()
backupByRenaming (FileName -> String
fn2fp FileName
b)
                           in IO ()
do_backup IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefaultIO (FileName -> FileName -> DefaultIO ()
forall (m :: * -> *).
ApplyMonadTree m =>
FileName -> FileName -> m ()
mRename FileName
a FileName
b))
                          (\e :: IOError
e -> case () of
                                 _ | IOError -> Bool
isPermissionError IOError
e -> IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$
                                       String
couldNotRename String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
                                   | IOError -> Bool
isDoesNotExistError IOError
e -> IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$
                                       String
couldNotRename String -> String -> String
forall a. [a] -> [a] -> [a]
++ " because " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " does not exist."
                                   | Bool
otherwise -> IOError -> IO ()
forall a. IOError -> IO a
ioError IOError
e
                          )
       where
        x :: String
x = FileName -> String
fn2fp FileName
a
        y :: String
y = FileName -> String
fn2fp FileName
b
        couldNotRename :: String
couldNotRename = "Could not rename " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y

backup :: FileName -> IO ()
backup :: FileName -> IO ()
backup f :: FileName
f = String -> IO ()
backupByRenaming (FileName -> String
fn2fp FileName
f)