-- 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 #-}

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

import Control.Exception ( IOException, SomeException, catch )
import Control.Monad ( unless )
import qualified Data.ByteString as B ( empty, null, readFile )
import Data.Char ( toLower )
import Data.List ( isSuffixOf )
import System.Directory
    ( createDirectory
    , doesDirectoryExist
    , doesFileExist
    , removeDirectory
    , removeFile
    , renamePath
    )
import System.IO ( hPutStrLn, stderr )
import System.IO.Error ( catchIOError, isDoesNotExistError, isPermissionError )

import Darcs.Prelude

import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) )
import Darcs.Patch.Info ( displayPatchInfo )
import Darcs.Patch.MonadProgress ( MonadProgress(..), ProgressAction(..) )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )
import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL )
import Darcs.Repository.Prefs ( changePrefval )
import Darcs.Util.Exception ( prettyException )
import Darcs.Util.External ( backupByCopying, backupByRenaming )
import Darcs.Util.Lock ( writeAtomicFilePS )
import Darcs.Util.Path ( AnchoredPath, anchorPath )
import Darcs.Util.Printer ( hPutDocLn, renderString )
import Darcs.Util.Printer ( text, ($$) )
import Darcs.Util.Progress ( beginTedious, endTedious, finishedOneIO, tediousSize )
import Darcs.Util.Tree ( Tree )

applyPatches :: (MonadProgress m, ApplyMonad (ApplyState p) m, Apply p)
             => FL (PatchInfoAnd rt p) wX wY -> m ()
applyPatches :: FL (PatchInfoAnd rt p) wX wY -> m ()
applyPatches FL (PatchInfoAnd rt p) wX wY
ps = String -> [ProgressAction m ()] -> m ()
forall (m :: * -> *).
MonadProgress m =>
String -> [ProgressAction m ()] -> m ()
runProgressActions String
"Applying patch" ((forall wW wZ. PatchInfoAnd rt p wW wZ -> ProgressAction m ())
-> FL (PatchInfoAnd rt p) wX wY -> [ProgressAction m ()]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. PatchInfoAnd rt p wW wZ -> ProgressAction m ()
forall (p :: * -> * -> *) (m :: * -> *) (rt :: RepoType) wA wB.
(Apply p, ApplyMonad (ApplyState p) m) =>
PatchInfoAndG rt p wA wB -> ProgressAction m ()
doApply FL (PatchInfoAnd rt p) wX wY
ps)
  where
    doApply :: PatchInfoAndG rt p wA wB -> ProgressAction m ()
doApply PatchInfoAndG rt p wA wB
hp = ProgressAction :: forall (m :: * -> *) a. m a -> Doc -> Doc -> ProgressAction m a
ProgressAction { paAction :: m ()
paAction = p wA wB -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply (PatchInfoAndG rt p wA wB -> p wA wB
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully PatchInfoAndG rt p wA wB
hp)
                                , paMessage :: Doc
paMessage = PatchInfo -> Doc
displayPatchInfo (PatchInfoAndG rt p wA wB -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAndG rt p wA wB
hp)
                                , paOnError :: Doc
paOnError = String -> Doc
text String
"Unapplicable patch:" Doc -> Doc -> Doc
$$
                                              PatchInfo -> Doc
displayPatchInfo (PatchInfoAndG rt p wA wB -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAndG rt p wA wB
hp)
                                }

ap2fp :: AnchoredPath -> FilePath
ap2fp :: AnchoredPath -> String
ap2fp = String -> AnchoredPath -> String
anchorPath String
""

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 String
_ [] = () -> DefaultIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  runProgressActions String
what [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 ProgressAction DefaultIO b
item =
            do String -> String -> IO ()
finishedOneIO String
what (Doc -> String
renderString (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` \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 :: AnchoredPath -> DefaultIO Bool
mDoesDirectoryExist = IO Bool -> DefaultIO Bool
forall a. IO a -> DefaultIO a
DefaultIO (IO Bool -> DefaultIO Bool)
-> (AnchoredPath -> IO Bool) -> AnchoredPath -> DefaultIO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
doesDirectoryExist (String -> IO Bool)
-> (AnchoredPath -> String) -> AnchoredPath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> String
ap2fp
    mChangePref :: String -> String -> String -> DefaultIO ()
mChangePref String
a String
b 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 :: AnchoredPath
-> (ByteString -> DefaultIO ByteString) -> DefaultIO ()
mModifyFilePS AnchoredPath
f 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 (AnchoredPath -> String
ap2fp AnchoredPath
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 (AnchoredPath -> String
ap2fp AnchoredPath
f)
    mCreateDirectory :: AnchoredPath -> DefaultIO ()
mCreateDirectory = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ())
-> (AnchoredPath -> IO ()) -> AnchoredPath -> DefaultIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
createDirectory (String -> IO ())
-> (AnchoredPath -> String) -> AnchoredPath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> String
ap2fp
    mCreateFile :: AnchoredPath -> DefaultIO ()
mCreateFile AnchoredPath
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 (AnchoredPath -> String
ap2fp AnchoredPath
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
$ String
"File '"String -> String -> String
forall a. [a] -> [a] -> [a]
++AnchoredPath -> String
ap2fp AnchoredPath
fString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' already exists!"
                              else do Bool
exd <- String -> IO Bool
doesDirectoryExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
ap2fp AnchoredPath
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
$ String
"File '"String -> String -> String
forall a. [a] -> [a] -> [a]
++AnchoredPath -> String
ap2fp AnchoredPath
fString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' already exists!"
                                             else String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (AnchoredPath -> String
ap2fp AnchoredPath
f) ByteString
B.empty
    mRemoveFile :: AnchoredPath -> DefaultIO ()
mRemoveFile AnchoredPath
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 = AnchoredPath -> String
ap2fp AnchoredPath
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
$ String
"Cannot remove non-empty file "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fp
                       String -> IO ()
removeFile String
fp
    mRemoveDirectory :: AnchoredPath -> DefaultIO ()
mRemoveDirectory = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ())
-> (AnchoredPath -> IO ()) -> AnchoredPath -> DefaultIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeDirectory (String -> IO ())
-> (AnchoredPath -> String) -> AnchoredPath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> String
ap2fp
    mRename :: AnchoredPath -> AnchoredPath -> DefaultIO ()
mRename AnchoredPath
a AnchoredPath
b = IO () -> DefaultIO ()
forall a. IO a -> DefaultIO a
DefaultIO (IO () -> DefaultIO ()) -> IO () -> DefaultIO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renamePath String
x String
y
      where x :: String
x = AnchoredPath -> String
ap2fp AnchoredPath
a
            y :: String
y = AnchoredPath -> String
ap2fp AnchoredPath
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 () -> 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` \SomeException
e -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Warning: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
prettyException SomeException
e
    runIO :: TolerantIO a -> IO a
runIO (TIO 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 () -> 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 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
action =
  IO a -> (IOError -> IO a) -> IO a
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError (DefaultIO a -> IO a
forall a. DefaultIO a -> IO a
runDefaultIO DefaultIO a
action) ((IOError -> IO a) -> IO a) -> (IOError -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \IOError
e ->
    String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"Cannot apply some patch:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++IOError -> String
forall a. Show a => a -> String
show IOError
eString -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"\nYou may want to run 'darcs check' to find out if there are broken"String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"\npatches in your repo, and perhaps 'darcs repair' to fix them."

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

instance TolerantMonad m => ApplyMonadTree (TolerantWrapper m) where
    mDoesDirectoryExist :: AnchoredPath -> TolerantWrapper m Bool
mDoesDirectoryExist AnchoredPath
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
$ AnchoredPath -> DefaultIO Bool
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m Bool
mDoesDirectoryExist AnchoredPath
d
    mReadFilePS :: AnchoredPath -> TolerantWrapper m ByteString
mReadFilePS AnchoredPath
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
$ AnchoredPath -> DefaultIO ByteString
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> m ByteString
mReadFilePS AnchoredPath
f
    mChangePref :: String -> String -> String -> TolerantWrapper m ()
mChangePref String
a String
b 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 :: AnchoredPath
-> (ByteString -> TolerantWrapper m ByteString)
-> TolerantWrapper m ()
mModifyFilePS AnchoredPath
f 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
$ AnchoredPath
-> (ByteString -> DefaultIO ByteString) -> DefaultIO ()
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> (ByteString -> m ByteString) -> m ()
mModifyFilePS AnchoredPath
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 :: AnchoredPath -> TolerantWrapper m ()
mCreateFile AnchoredPath
f = IO () -> TolerantWrapper m ()
forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning (IO () -> TolerantWrapper m ()) -> IO () -> TolerantWrapper m ()
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> IO ()
backup AnchoredPath
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 (AnchoredPath -> DefaultIO ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateFile AnchoredPath
f)
    mCreateDirectory :: AnchoredPath -> TolerantWrapper m ()
mCreateDirectory AnchoredPath
d = IO () -> TolerantWrapper m ()
forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning (IO () -> TolerantWrapper m ()) -> IO () -> TolerantWrapper m ()
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> IO ()
backup AnchoredPath
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 (AnchoredPath -> DefaultIO ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateDirectory AnchoredPath
d)
    mRemoveFile :: AnchoredPath -> TolerantWrapper m ()
mRemoveFile AnchoredPath
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 (AnchoredPath -> DefaultIO ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mRemoveFile AnchoredPath
f)
    mRemoveDirectory :: AnchoredPath -> TolerantWrapper m ()
mRemoveDirectory AnchoredPath
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 (AnchoredPath -> DefaultIO ()
forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mRemoveDirectory AnchoredPath
d))
                                 (\(IOError
e :: IOException) ->
                                   if String
"(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
$
                                            String
"Not deleting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
ap2fp AnchoredPath
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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
$
                                            String
"Not deleting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
ap2fp AnchoredPath
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" because:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
e)
    mRename :: AnchoredPath -> AnchoredPath -> TolerantWrapper m ()
mRename AnchoredPath
a AnchoredPath
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 (AnchoredPath -> String
ap2fp AnchoredPath
b) -- avoid making the original vanish
                                           else String -> IO ()
backupByRenaming (AnchoredPath -> String
ap2fp AnchoredPath
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 (AnchoredPath -> AnchoredPath -> DefaultIO ()
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> AnchoredPath -> m ()
mRename AnchoredPath
a AnchoredPath
b))
                          (\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]
++ String
"."
                                   | 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]
++ String
" because " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not exist."
                                   | Bool
otherwise -> IOError -> IO ()
forall a. IOError -> IO a
ioError IOError
e
                          )
       where
        x :: String
x = AnchoredPath -> String
ap2fp AnchoredPath
a
        y :: String
y = AnchoredPath -> String
ap2fp AnchoredPath
b
        couldNotRename :: String
couldNotRename = String
"Could not rename " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y

backup :: AnchoredPath -> IO ()
backup :: AnchoredPath -> IO ()
backup AnchoredPath
f = String -> IO ()
backupByRenaming (AnchoredPath -> String
ap2fp AnchoredPath
f)