-- 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 :: forall (m :: * -> *) (p :: * -> * -> *) (rt :: RepoType) wX wY.
(MonadProgress m, ApplyMonad (ApplyState p) m, Apply p) =>
FL (PatchInfoAnd rt p) wX wY -> m ()
applyPatches FL (PatchInfoAnd rt p) wX wY
ps = forall (m :: * -> *).
MonadProgress m =>
String -> [ProgressAction m ()] -> m ()
runProgressActions String
"Applying patch" (forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL 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 { paAction :: m ()
paAction = forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply (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 (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 (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 { forall a. DefaultIO a -> IO a
runDefaultIO :: IO a }
    deriving (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
<$ :: forall a b. a -> DefaultIO b -> DefaultIO a
$c<$ :: forall a b. a -> DefaultIO b -> DefaultIO a
fmap :: forall a b. (a -> b) -> DefaultIO a -> DefaultIO b
$cfmap :: forall a b. (a -> b) -> DefaultIO a -> DefaultIO b
Functor, Functor DefaultIO
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
<* :: forall a b. DefaultIO a -> DefaultIO b -> DefaultIO a
$c<* :: forall a b. DefaultIO a -> DefaultIO b -> DefaultIO a
*> :: forall a b. DefaultIO a -> DefaultIO b -> DefaultIO b
$c*> :: forall a b. DefaultIO a -> DefaultIO b -> DefaultIO b
liftA2 :: forall a b c.
(a -> b -> c) -> DefaultIO a -> DefaultIO b -> DefaultIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> DefaultIO a -> DefaultIO b -> DefaultIO c
<*> :: forall a b. DefaultIO (a -> b) -> DefaultIO a -> DefaultIO b
$c<*> :: forall a b. DefaultIO (a -> b) -> DefaultIO a -> DefaultIO b
pure :: forall a. a -> DefaultIO a
$cpure :: forall a. a -> DefaultIO a
Applicative, Applicative DefaultIO
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 :: forall a. a -> DefaultIO a
$creturn :: forall a. a -> DefaultIO a
>> :: forall a b. DefaultIO a -> DefaultIO b -> DefaultIO b
$c>> :: forall a b. DefaultIO a -> DefaultIO b -> DefaultIO b
>>= :: forall a b. DefaultIO a -> (a -> DefaultIO b) -> DefaultIO b
$c>>= :: forall a b. DefaultIO a -> (a -> DefaultIO b) -> DefaultIO b
Monad)

instance MonadProgress DefaultIO where
  runProgressActions :: String -> [ProgressAction DefaultIO ()] -> DefaultIO ()
runProgressActions String
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  runProgressActions String
what [ProgressAction DefaultIO ()]
items = forall a. IO a -> DefaultIO a
DefaultIO forall a b. (a -> b) -> a -> b
$ do
    do String -> IO ()
beginTedious String
what
       String -> Int -> IO ()
tediousSize String
what (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ProgressAction DefaultIO ()]
items)
       forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a}. ProgressAction DefaultIO a -> IO a
go [ProgressAction DefaultIO ()]
items
       String -> IO ()
endTedious String
what
    where go :: ProgressAction DefaultIO a -> IO a
go ProgressAction DefaultIO a
item =
            do String -> String -> IO ()
finishedOneIO String
what (Doc -> String
renderString forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ProgressAction m a -> Doc
paMessage ProgressAction DefaultIO a
item)
               forall a. DefaultIO a -> IO a
runDefaultIO (forall (m :: * -> *) a. ProgressAction m a -> m a
paAction ProgressAction DefaultIO a
item) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e ->
                 do Handle -> Doc -> IO ()
hPutDocLn Handle
stderr forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ProgressAction m a -> Doc
paOnError ProgressAction DefaultIO a
item
                    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 = forall a. IO a -> DefaultIO a
DefaultIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
doesDirectoryExist 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 = forall a. IO a -> DefaultIO a
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 = forall a. IO a -> DefaultIO a
DefaultIO forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile (AnchoredPath -> String
ap2fp AnchoredPath
f) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. DefaultIO a -> IO a
runDefaultIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> DefaultIO ByteString
j forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (AnchoredPath -> String
ap2fp AnchoredPath
f)
    mCreateDirectory :: AnchoredPath -> DefaultIO ()
mCreateDirectory = forall a. IO a -> DefaultIO a
DefaultIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
createDirectory forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> String
ap2fp
    mCreateFile :: AnchoredPath -> DefaultIO ()
mCreateFile AnchoredPath
f = forall a. IO a -> DefaultIO a
DefaultIO forall a b. (a -> b) -> a -> b
$
                    do Bool
exf <- String -> IO Bool
doesFileExist (AnchoredPath -> String
ap2fp AnchoredPath
f)
                       if Bool
exf then forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"File '"forall a. [a] -> [a] -> [a]
++AnchoredPath -> String
ap2fp AnchoredPath
fforall a. [a] -> [a] -> [a]
++String
"' already exists!"
                              else do Bool
exd <- String -> IO Bool
doesDirectoryExist forall a b. (a -> b) -> a -> b
$ AnchoredPath -> String
ap2fp AnchoredPath
f
                                      if Bool
exd then forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"File '"forall a. [a] -> [a] -> [a]
++AnchoredPath -> String
ap2fp AnchoredPath
fforall a. [a] -> [a] -> [a]
++String
"' already exists!"
                                             else forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (AnchoredPath -> String
ap2fp AnchoredPath
f) ByteString
B.empty
    mRemoveFile :: AnchoredPath -> DefaultIO ()
mRemoveFile AnchoredPath
f = forall a. IO a -> DefaultIO a
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
                       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
x) forall a b. (a -> b) -> a -> b
$
                            forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Cannot remove non-empty file "forall a. [a] -> [a] -> [a]
++String
fp
                       String -> IO ()
removeFile String
fp
    mRemoveDirectory :: AnchoredPath -> DefaultIO ()
mRemoveDirectory = forall a. IO a -> DefaultIO a
DefaultIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeDirectory forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> String
ap2fp
    mRename :: AnchoredPath -> AnchoredPath -> DefaultIO ()
mRename AnchoredPath
a AnchoredPath
b = forall a. IO a -> DefaultIO a
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 { forall a. TolerantIO a -> IO a
runTIO :: IO a }
    deriving (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
<$ :: forall a b. a -> TolerantIO b -> TolerantIO a
$c<$ :: forall a b. a -> TolerantIO b -> TolerantIO a
fmap :: forall a b. (a -> b) -> TolerantIO a -> TolerantIO b
$cfmap :: forall a b. (a -> b) -> TolerantIO a -> TolerantIO b
Functor, Functor TolerantIO
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
<* :: forall a b. TolerantIO a -> TolerantIO b -> TolerantIO a
$c<* :: forall a b. TolerantIO a -> TolerantIO b -> TolerantIO a
*> :: forall a b. TolerantIO a -> TolerantIO b -> TolerantIO b
$c*> :: forall a b. TolerantIO a -> TolerantIO b -> TolerantIO b
liftA2 :: forall a b c.
(a -> b -> c) -> TolerantIO a -> TolerantIO b -> TolerantIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> TolerantIO a -> TolerantIO b -> TolerantIO c
<*> :: forall a b. TolerantIO (a -> b) -> TolerantIO a -> TolerantIO b
$c<*> :: forall a b. TolerantIO (a -> b) -> TolerantIO a -> TolerantIO b
pure :: forall a. a -> TolerantIO a
$cpure :: forall a. a -> TolerantIO a
Applicative, Applicative TolerantIO
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 :: forall a. a -> TolerantIO a
$creturn :: forall a. a -> TolerantIO a
>> :: forall a b. TolerantIO a -> TolerantIO b -> TolerantIO b
$c>> :: forall a b. TolerantIO a -> TolerantIO b -> TolerantIO b
>>= :: forall a b. TolerantIO a -> (a -> TolerantIO b) -> TolerantIO b
$c>>= :: forall a b. TolerantIO a -> (a -> TolerantIO b) -> TolerantIO b
Monad)

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

newtype SilentIO a = SIO { forall a. SilentIO a -> IO a
runSIO :: IO a }
    deriving (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
<$ :: forall a b. a -> SilentIO b -> SilentIO a
$c<$ :: forall a b. a -> SilentIO b -> SilentIO a
fmap :: forall a b. (a -> b) -> SilentIO a -> SilentIO b
$cfmap :: forall a b. (a -> b) -> SilentIO a -> SilentIO b
Functor, Functor SilentIO
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
<* :: forall a b. SilentIO a -> SilentIO b -> SilentIO a
$c<* :: forall a b. SilentIO a -> SilentIO b -> SilentIO a
*> :: forall a b. SilentIO a -> SilentIO b -> SilentIO b
$c*> :: forall a b. SilentIO a -> SilentIO b -> SilentIO b
liftA2 :: forall a b c.
(a -> b -> c) -> SilentIO a -> SilentIO b -> SilentIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> SilentIO a -> SilentIO b -> SilentIO c
<*> :: forall a b. SilentIO (a -> b) -> SilentIO a -> SilentIO b
$c<*> :: forall a b. SilentIO (a -> b) -> SilentIO a -> SilentIO b
pure :: forall a. a -> SilentIO a
$cpure :: forall a. a -> SilentIO a
Applicative, Applicative SilentIO
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 :: forall a. a -> SilentIO a
$creturn :: forall a. a -> SilentIO a
>> :: forall a b. SilentIO a -> SilentIO b -> SilentIO b
$c>> :: forall a b. SilentIO a -> SilentIO b -> SilentIO b
>>= :: forall a b. SilentIO a -> (a -> SilentIO b) -> SilentIO b
$c>>= :: forall a b. SilentIO a -> (a -> SilentIO b) -> SilentIO b
Monad)

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

newtype TolerantWrapper m a = TolerantWrapper { forall (m :: * -> *) a. TolerantWrapper m a -> m a
runTolerantWrapper :: m a }
    deriving (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
<$ :: forall a b. a -> TolerantWrapper m b -> TolerantWrapper m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> TolerantWrapper m b -> TolerantWrapper m a
fmap :: forall a b. (a -> b) -> TolerantWrapper m a -> TolerantWrapper m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TolerantWrapper m a -> TolerantWrapper m b
Functor, 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
<* :: forall a b.
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
*> :: forall a b.
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 :: forall a b c.
(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
<*> :: forall a b.
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 :: forall a. a -> TolerantWrapper m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> TolerantWrapper m a
Applicative, 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 :: forall a. a -> TolerantWrapper m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> TolerantWrapper m a
>> :: forall a b.
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
>>= :: forall a 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
Monad, IO () -> TolerantWrapper m ()
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 :: forall a. IO a -> TolerantWrapper m a
$crunTM :: forall (m :: * -> *) a.
TolerantMonad m =>
IO a -> TolerantWrapper m a
runIO :: forall a. 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 ()
TolerantMonad)

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

-- | Apply patches, ignoring all errors
runSilently :: TolerantWrapper SilentIO a -> IO a
runSilently :: forall a. TolerantWrapper SilentIO a -> IO a
runSilently = forall a. SilentIO a -> IO a
runSIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. DefaultIO a -> IO a
runDefault DefaultIO a
action =
  forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError (forall a. DefaultIO a -> IO a
runDefaultIO DefaultIO a
action) forall a b. (a -> b) -> a -> b
$ \IOError
e ->
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Cannot apply some patch:\n"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show IOError
eforall a. [a] -> [a] -> [a]
++
      String
"\nYou may want to run 'darcs check' to find out if there are broken"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 = forall (m :: * -> *) a. TolerantMonad m => IO a -> m a
runTM forall a b. (a -> b) -> a -> b
$ forall a. DefaultIO a -> IO a
runDefaultIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m Bool
mDoesDirectoryExist AnchoredPath
d
    mReadFilePS :: AnchoredPath -> TolerantWrapper m ByteString
mReadFilePS AnchoredPath
f = forall (m :: * -> *) a. TolerantMonad m => IO a -> m a
runTM forall a b. (a -> b) -> a -> b
$ forall a. DefaultIO a -> IO a
runDefaultIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> m ByteString
mReadFilePS AnchoredPath
f
    mChangePref :: String -> String -> String -> TolerantWrapper m ()
mChangePref String
a String
b String
c = forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning forall a b. (a -> b) -> a -> b
$ forall a. DefaultIO a -> IO a
runDefaultIO forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning forall a b. (a -> b) -> a -> b
$ forall a. DefaultIO a -> IO a
runDefaultIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> (ByteString -> m ByteString) -> m ()
mModifyFilePS AnchoredPath
f (forall a. IO a -> DefaultIO a
DefaultIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. TolerantMonad m => m a -> IO a
runIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> TolerantWrapper m ByteString
j)
    mCreateFile :: AnchoredPath -> TolerantWrapper m ()
mCreateFile AnchoredPath
f = forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning forall a b. (a -> b) -> a -> b
$ AnchoredPath -> IO ()
backup AnchoredPath
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. DefaultIO a -> IO a
runDefaultIO (forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateFile AnchoredPath
f)
    mCreateDirectory :: AnchoredPath -> TolerantWrapper m ()
mCreateDirectory AnchoredPath
d = forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning forall a b. (a -> b) -> a -> b
$ AnchoredPath -> IO ()
backup AnchoredPath
d forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. DefaultIO a -> IO a
runDefaultIO (forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mCreateDirectory AnchoredPath
d)
    mRemoveFile :: AnchoredPath -> TolerantWrapper m ()
mRemoveFile AnchoredPath
f = forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning forall a b. (a -> b) -> a -> b
$ forall a. DefaultIO a -> IO a
runDefaultIO (forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mRemoveFile AnchoredPath
f)
    mRemoveDirectory :: AnchoredPath -> TolerantWrapper m ()
mRemoveDirectory AnchoredPath
d = forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
                                 (forall a. DefaultIO a -> IO a
runDefaultIO (forall (m :: * -> *). ApplyMonadTree m => AnchoredPath -> m ()
mRemoveDirectory AnchoredPath
d))
                                 (\(IOError
e :: IOException) ->
                                   if String
"(Directory not empty)" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` forall a. Show a => a -> String
show IOError
e
                                   then forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$ String -> IOError
userError forall a b. (a -> b) -> a -> b
$
                                            String
"Not deleting " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
ap2fp AnchoredPath
d forall a. [a] -> [a] -> [a]
++ String
" because it is not empty."
                                   else forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$ String -> IOError
userError forall a b. (a -> b) -> a -> b
$
                                            String
"Not deleting " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
ap2fp AnchoredPath
d forall a. [a] -> [a] -> [a]
++ String
" because:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOError
e)
    mRename :: AnchoredPath -> AnchoredPath -> TolerantWrapper m ()
mRename AnchoredPath
a AnchoredPath
b = forall (m :: * -> *). TolerantMonad m => IO () -> m ()
warning forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
                          (let do_backup :: IO ()
do_backup = if forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x forall a. Eq a => a -> a -> Bool
== 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. DefaultIO a -> IO a
runDefaultIO (forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> AnchoredPath -> m ()
mRename AnchoredPath
a AnchoredPath
b))
                          (\IOError
e -> case () of
                                 ()
_ | IOError -> Bool
isPermissionError IOError
e -> forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$ String -> IOError
userError forall a b. (a -> b) -> a -> b
$
                                       String
couldNotRename forall a. [a] -> [a] -> [a]
++ String
"."
                                   | IOError -> Bool
isDoesNotExistError IOError
e -> forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$ String -> IOError
userError forall a b. (a -> b) -> a -> b
$
                                       String
couldNotRename forall a. [a] -> [a] -> [a]
++ String
" because " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
" does not exist."
                                   | Bool
otherwise -> 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 " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
" to " forall a. [a] -> [a] -> [a]
++ String
y

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