module Darcs.Repository.Repair ( replayRepository, checkIndex,
                                 replayRepositoryInTemp,
                                 RepositoryConsistency(..) )
       where

import Darcs.Prelude

import Control.Monad ( when, unless )
import Control.Monad.Trans ( liftIO )
import Control.Exception ( catch, finally, IOException )
import Data.Maybe ( catMaybes )
import Data.List ( sort, (\\) )
import System.Directory
    ( createDirectoryIfMissing
    , getCurrentDirectory
    , removeDirectoryRecursive
    , setCurrentDirectory
    )
import System.FilePath ( (</>) )
import Darcs.Util.Path( anchorPath, AbsolutePath, ioAbsolute, toFilePath )
import Darcs.Patch.PatchInfoAnd
    ( PatchInfoAnd
    , WPatchInfo
    , compareWPatchInfo
    , hopefully
    , info
    , unWPatchInfo
    , winfo
    )

import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), RL(..), lengthFL, reverseFL,
    mapRL, nullFL, (:||:)(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), unFreeLeft )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Repair ( Repair(applyAndTryToFix) )
import Darcs.Patch.Info ( displayPatchInfo )
import Darcs.Patch.Set ( Origin, PatchSet(..), patchSet2FL, patchSet2RL )
import Darcs.Patch ( RepoPatch, IsRepoType, PrimOf, isInconsistent )

import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) )
import Darcs.Repository.Diff( treeDiff )
import Darcs.Repository.Flags ( Verbosity(..), Compression, DiffAlgorithm )
import Darcs.Repository.Format
    ( identifyRepoFormat
    , RepoProperty ( HashedInventory )
    , formatHas
    )
import Darcs.Repository.HashedIO ( cleanHashdir )
import Darcs.Repository.Hashed ( readRepo, writeAndReadPatch )
import Darcs.Repository.InternalTypes ( Repository, repoCache, repoLocation )
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Repository.Pristine ( readHashedPristineRoot )
import Darcs.Repository.State
    ( readRecorded
    , readIndex
    , readRecordedAndPending
    )

import Darcs.Util.Progress
    ( beginTedious
    , debugMessage
    , endTedious
    , finishedOneIO
    , tediousSize
    )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Lock( withDelayedDir )
import Darcs.Util.Printer ( Doc, putDocLn, text, renderString )

import Darcs.Util.Hash( Hash(NoHash), encodeBase16 )
import Darcs.Util.Tree( Tree, emptyTree, list, restrict, expand, itemHash, zipTrees )
import Darcs.Util.Tree.Monad( TreeIO )
import Darcs.Util.Tree.Hashed( darcsUpdateHashes, hashedTreeIO )
import Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Index( treeFromIndex )

import qualified Data.ByteString.Char8 as BC

replaceInFL :: FL (PatchInfoAnd rt a) wX wY
            -> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
            -> FL (PatchInfoAnd rt a) wX wY
replaceInFL :: FL (PatchInfoAnd rt a) wX wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wX wY
replaceInFL FL (PatchInfoAnd rt a) wX wY
orig [] = FL (PatchInfoAnd rt a) wX wY
orig
replaceInFL FL (PatchInfoAnd rt a) wX wY
NilFL [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
_ = [Char] -> FL (PatchInfoAnd rt a) wX wY
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible case"
replaceInFL (PatchInfoAnd rt a wX wY
o:>:FL (PatchInfoAnd rt a) wY wY
orig) ch :: [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
ch@(Sealed2 (WPatchInfo wX wY
o':||:PatchInfoAnd rt a wX wY
c):[Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
ch_rest)
    | EqCheck (wX, wY) (wX, wY)
IsEq <- PatchInfoAnd rt a wX wY -> WPatchInfo wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WPatchInfo wA wB
winfo PatchInfoAnd rt a wX wY
o WPatchInfo wX wY -> WPatchInfo wX wY -> EqCheck (wX, wY) (wX, wY)
forall wA wB wC wD.
WPatchInfo wA wB -> WPatchInfo wC wD -> EqCheck (wA, wB) (wC, wD)
`compareWPatchInfo` WPatchInfo wX wY
o' = PatchInfoAnd rt a wX wY
cPatchInfoAnd rt a wX wY
-> FL (PatchInfoAnd rt a) wY wY -> FL (PatchInfoAnd rt a) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL (PatchInfoAnd rt a) wY wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wY wY
forall (rt :: RepoType) (a :: * -> * -> *) wX wY.
FL (PatchInfoAnd rt a) wX wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wX wY
replaceInFL FL (PatchInfoAnd rt a) wY wY
orig [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
ch_rest
    | Bool
otherwise = PatchInfoAnd rt a wX wY
oPatchInfoAnd rt a wX wY
-> FL (PatchInfoAnd rt a) wY wY -> FL (PatchInfoAnd rt a) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL (PatchInfoAnd rt a) wY wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wY wY
forall (rt :: RepoType) (a :: * -> * -> *) wX wY.
FL (PatchInfoAnd rt a) wX wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wX wY
replaceInFL FL (PatchInfoAnd rt a) wY wY
orig [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
ch

applyAndFix
  :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wR wU wT
  -> Compression
  -> FL (PatchInfoAnd rt p) Origin wR
  -> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
applyAndFix :: Repository rt p wR wU wT
-> Compression
-> FL (PatchInfoAnd rt p) Origin wR
-> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
applyAndFix Repository rt p wR wU wT
_ Compression
_ FL (PatchInfoAnd rt p) Origin wR
NilFL = (FL (PatchInfoAnd rt p) Origin Origin, Bool)
-> RWST
     (TreeEnv IO)
     ()
     (TreeState IO)
     IO
     (FL (PatchInfoAnd rt p) Origin Origin, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PatchInfoAnd rt p) Origin Origin
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL, Bool
True)
applyAndFix Repository rt p wR wU wT
r Compression
compr FL (PatchInfoAnd rt p) Origin wR
psin =
    do IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ())
-> IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
beginTedious [Char]
k
       IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ())
-> IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> IO ()
tediousSize [Char]
k (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd rt p) Origin wR -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchInfoAnd rt p) Origin wR
psin
       ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
repaired, Bool
ok) <- FL (PatchInfoAnd rt p) Origin wR
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
forall wW wZ.
FL (PatchInfoAnd rt p) wW wZ
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
aaf FL (PatchInfoAnd rt p) Origin wR
psin
       IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ())
-> IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
endTedious [Char]
k
       FL (PatchInfoAnd rt p) Origin wR
orig <- IO (FL (PatchInfoAnd rt p) Origin wR)
-> RWST
     (TreeEnv IO)
     ()
     (TreeState IO)
     IO
     (FL (PatchInfoAnd rt p) Origin wR)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FL (PatchInfoAnd rt p) Origin wR)
 -> RWST
      (TreeEnv IO)
      ()
      (TreeState IO)
      IO
      (FL (PatchInfoAnd rt p) Origin wR))
-> IO (FL (PatchInfoAnd rt p) Origin wR)
-> RWST
     (TreeEnv IO)
     ()
     (TreeState IO)
     IO
     (FL (PatchInfoAnd rt p) Origin wR)
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR -> FL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL (PatchSet rt p Origin wR -> FL (PatchInfoAnd rt p) Origin wR)
-> IO (PatchSet rt p Origin wR)
-> IO (FL (PatchInfoAnd rt p) Origin wR)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
r
       (FL (PatchInfoAnd rt p) Origin wR, Bool)
-> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PatchInfoAnd rt p) Origin wR
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
-> FL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (a :: * -> * -> *) wX wY.
FL (PatchInfoAnd rt a) wX wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wX wY
replaceInFL FL (PatchInfoAnd rt p) Origin wR
orig [Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
repaired, Bool
ok)
    where k :: [Char]
k = [Char]
"Replaying patch"
          aaf :: FL (PatchInfoAnd rt p) wW wZ
              -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
          aaf :: FL (PatchInfoAnd rt p) wW wZ
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
aaf FL (PatchInfoAnd rt p) wW wZ
NilFL = ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Bool
True)
          aaf (PatchInfoAnd rt p wW wY
p:>:FL (PatchInfoAnd rt p) wY wZ
ps) = do
            Maybe ([Char], PatchInfoAnd rt p wW wY)
mp' <- PatchInfoAnd rt p wW wY
-> RWST
     (TreeEnv IO)
     ()
     (TreeState IO)
     IO
     (Maybe ([Char], PatchInfoAnd rt p wW wY))
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Repair p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m (Maybe ([Char], p wX wY))
applyAndTryToFix PatchInfoAnd rt p wW wY
p
            case Named p wW wY -> Maybe Doc
forall (p :: * -> * -> *) wX wY. Check p => p wX wY -> Maybe Doc
isInconsistent (Named p wW wY -> Maybe Doc)
-> (PatchInfoAnd rt p wW wY -> Named p wW wY)
-> PatchInfoAnd rt p wW wY
-> Maybe Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p wW wY -> Named p wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully (PatchInfoAnd rt p wW wY -> Maybe Doc)
-> PatchInfoAnd rt p wW wY -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p wW wY
p of
              Just Doc
err -> IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ())
-> IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn Doc
err
              Maybe Doc
Nothing -> () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            let !winfp :: WPatchInfo wW wY
winfp = PatchInfoAnd rt p wW wY -> WPatchInfo wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WPatchInfo wA wB
winfo PatchInfoAnd rt p wW wY
p -- assure that 'p' can be garbage collected.
            IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ())
-> IO () -> RWST (TreeEnv IO) () (TreeState IO) IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
renderString (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$
              PatchInfo -> Doc
displayPatchInfo (PatchInfo -> Doc) -> PatchInfo -> Doc
forall a b. (a -> b) -> a -> b
$ WPatchInfo wW wY -> PatchInfo
forall wA wB. WPatchInfo wA wB -> PatchInfo
unWPatchInfo WPatchInfo wW wY
winfp
            ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
ps', Bool
restok) <- FL (PatchInfoAnd rt p) wY wZ
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
forall wW wZ.
FL (PatchInfoAnd rt p) wW wZ
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
aaf FL (PatchInfoAnd rt p) wY wZ
ps
            case Maybe ([Char], PatchInfoAnd rt p wW wY)
mp' of
              Maybe ([Char], PatchInfoAnd rt p wW wY)
Nothing -> ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
ps', Bool
restok)
              Just ([Char]
e,PatchInfoAnd rt p wW wY
pp) -> IO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
 -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool))
-> IO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
forall a b. (a -> b) -> a -> b
$ do
                [Char] -> IO ()
putStrLn [Char]
e
                PatchInfoAnd rt p wW wY
p' <- [Char]
-> IO (PatchInfoAnd rt p wW wY) -> IO (PatchInfoAnd rt p wW wY)
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (Repository rt p wR wU wT -> [Char]
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> [Char]
repoLocation Repository rt p wR wU wT
r) (IO (PatchInfoAnd rt p wW wY) -> IO (PatchInfoAnd rt p wW wY))
-> IO (PatchInfoAnd rt p wW wY) -> IO (PatchInfoAnd rt p wW wY)
forall a b. (a -> b) -> a -> b
$
                  Cache
-> Compression
-> PatchInfoAnd rt p wW wY
-> IO (PatchInfoAnd rt p wW wY)
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
Cache
-> Compression
-> PatchInfoAnd rt p wX wY
-> IO (PatchInfoAnd rt p wX wY)
writeAndReadPatch (Repository rt p wR wU wT -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wT
r) Compression
compr PatchInfoAnd rt p wW wY
pp
                ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
-> IO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((:||:) WPatchInfo (PatchInfoAnd rt p) wW wY
-> Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)
forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
Sealed2 (WPatchInfo wW wY
winfp WPatchInfo wW wY
-> PatchInfoAnd rt p wW wY
-> (:||:) WPatchInfo (PatchInfoAnd rt p) wW wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY.
a1 wX wY -> a2 wX wY -> (:||:) a1 a2 wX wY
:||: PatchInfoAnd rt p wW wY
p')Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
forall a. a -> [a] -> [a]
:[Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
ps', Bool
False)

data RepositoryConsistency rt p wX =
    RepositoryConsistent
  | BrokenPristine (Tree IO)
  | BrokenPatches (Tree IO) (PatchSet rt p Origin wX)

checkUniqueness :: (IsRepoType rt, RepoPatch p)
                => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO ()
checkUniqueness :: (Doc -> IO ())
-> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO ()
checkUniqueness Doc -> IO ()
putVerbose Doc -> IO ()
putInfo Repository rt p wR wU wT
repository =
    do Doc -> IO ()
putVerbose (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Checking that patch names are unique..."
       PatchSet rt p Origin wR
r <- Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
repository
       case [PatchInfo] -> Maybe PatchInfo
forall a. Ord a => [a] -> Maybe a
hasDuplicate ([PatchInfo] -> Maybe PatchInfo) -> [PatchInfo] -> Maybe PatchInfo
forall a b. (a -> b) -> a -> b
$ (forall wW wZ. PatchInfoAnd rt p wW wZ -> PatchInfo)
-> RL (PatchInfoAnd rt p) Origin wR -> [PatchInfo]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL forall wW wZ. PatchInfoAnd rt p wW wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info (RL (PatchInfoAnd rt p) Origin wR -> [PatchInfo])
-> RL (PatchInfoAnd rt p) Origin wR -> [PatchInfo]
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wR
r of
         Maybe PatchInfo
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Just PatchInfo
pinf -> do Doc -> IO ()
putInfo (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Error! Duplicate patch name:"
                         Doc -> IO ()
putInfo (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ PatchInfo -> Doc
displayPatchInfo PatchInfo
pinf
                         [Char] -> IO ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Duplicate patches found."

hasDuplicate :: Ord a => [a] -> Maybe a
hasDuplicate :: [a] -> Maybe a
hasDuplicate [a]
li = [a] -> Maybe a
forall a. Eq a => [a] -> Maybe a
hd ([a] -> Maybe a) -> [a] -> Maybe a
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
li
    where hd :: [a] -> Maybe a
hd [a
_] = Maybe a
forall a. Maybe a
Nothing
          hd [] = Maybe a
forall a. Maybe a
Nothing
          hd (a
x1:a
x2:[a]
xs) | a
x1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x2 = a -> Maybe a
forall a. a -> Maybe a
Just a
x1
                        | Bool
otherwise = [a] -> Maybe a
hd (a
x2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)

replayRepository'
  :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
  => DiffAlgorithm
  -> AbsolutePath
  -> Repository rt p wR wU wT
  -> Compression
  -> Verbosity
  -> IO (RepositoryConsistency rt p wR)
replayRepository' :: DiffAlgorithm
-> AbsolutePath
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
replayRepository' DiffAlgorithm
dflag AbsolutePath
whereToReplay' Repository rt p wR wU wT
repo Compression
compr Verbosity
verbosity = do
  let whereToReplay :: [Char]
whereToReplay = AbsolutePath -> [Char]
forall a. FilePathLike a => a -> [Char]
toFilePath AbsolutePath
whereToReplay'
      putVerbose :: Doc -> IO ()
putVerbose Doc
s = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn Doc
s
      putInfo :: Doc -> IO ()
putInfo Doc
s = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn Doc
s
  (Doc -> IO ())
-> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
(Doc -> IO ())
-> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO ()
checkUniqueness Doc -> IO ()
putVerbose Doc -> IO ()
putInfo Repository rt p wR wU wT
repo
  Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
False [Char]
whereToReplay
  Doc -> IO ()
putVerbose (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Reading recorded state..."
  Tree IO
pris <-
    (Repository rt p wR wU wT -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
repo IO (Tree IO) -> (Tree IO -> IO (Tree IO)) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand IO (Tree IO) -> (Tree IO -> IO (Tree IO)) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsUpdateHashes)
    IO (Tree IO) -> (IOException -> IO (Tree IO)) -> IO (Tree IO)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
    \(IOException
_ :: IOException) -> Tree IO -> IO (Tree IO)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
forall (m :: * -> *). Tree m
emptyTree
  Doc -> IO ()
putVerbose (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Applying patches..."
  PatchSet rt p Origin wR
patches <- Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
repo
  [Char] -> IO ()
debugMessage [Char]
"Fixing any broken patches..."
  let psin :: FL (PatchInfoAnd rt p) Origin wR
psin = PatchSet rt p Origin wR -> FL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin wR
patches
      repair :: TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
repair = Repository rt p wR wU wT
-> Compression
-> FL (PatchInfoAnd rt p) Origin wR
-> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Compression
-> FL (PatchInfoAnd rt p) Origin wR
-> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
applyAndFix Repository rt p wR wU wT
repo Compression
compr FL (PatchInfoAnd rt p) Origin wR
psin

  ((FL (PatchInfoAnd rt p) Origin wR
ps, Bool
patches_ok), Tree IO
newpris) <- TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
-> Tree IO
-> [Char]
-> IO ((FL (PatchInfoAnd rt p) Origin wR, Bool), Tree IO)
forall a. TreeIO a -> Tree IO -> [Char] -> IO (a, Tree IO)
hashedTreeIO TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
repair Tree IO
forall (m :: * -> *). Tree m
emptyTree [Char]
whereToReplay
  [Char] -> IO ()
debugMessage [Char]
"Done fixing broken patches..."
  let newpatches :: PatchSet rt p Origin wR
newpatches = RL (Tagged rt p) Origin Origin
-> RL (PatchInfoAnd rt p) Origin wR -> PatchSet rt p Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p Origin wY
PatchSet RL (Tagged rt p) Origin Origin
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL (FL (PatchInfoAnd rt p) Origin wR
-> RL (PatchInfoAnd rt p) Origin wR
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd rt p) Origin wR
ps)

  [Char] -> IO ()
debugMessage [Char]
"Checking pristine against slurpy"
  [Char] -> FileType
ftf <- IO ([Char] -> FileType)
filetypeFunction
  Bool
is_same <- do Sealed FL (PrimOf p) wR wX
diff <- FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wR)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft (FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wR))
-> IO (FreeLeft (FL (PrimOf p))) -> IO (Sealed (FL (PrimOf p) wR))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DiffAlgorithm
-> ([Char] -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL (PrimOf p)))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
       (prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> ([Char] -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
dflag [Char] -> FileType
ftf Tree IO
pris Tree IO
newpris
                  :: IO (Sealed (FL (PrimOf p) wR))
                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wR wX -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PrimOf p) wR wX
diff
              IO Bool -> IO Bool -> IO Bool
forall a. IO a -> IO a -> IO a
`catchall` Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  -- TODO is the latter condition needed? Does a broken patch imply pristine
  -- difference? Why, or why not?
  RepositoryConsistency rt p wR -> IO (RepositoryConsistency rt p wR)
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
is_same Bool -> Bool -> Bool
&& Bool
patches_ok
     then RepositoryConsistency rt p wR
forall (rt :: RepoType) (p :: * -> * -> *) wX.
RepositoryConsistency rt p wX
RepositoryConsistent
     else if Bool
patches_ok
            then Tree IO -> RepositoryConsistency rt p wR
forall (rt :: RepoType) (p :: * -> * -> *) wX.
Tree IO -> RepositoryConsistency rt p wX
BrokenPristine Tree IO
newpris
            else Tree IO -> PatchSet rt p Origin wR -> RepositoryConsistency rt p wR
forall (rt :: RepoType) (p :: * -> * -> *) wX.
Tree IO -> PatchSet rt p Origin wX -> RepositoryConsistency rt p wX
BrokenPatches Tree IO
newpris PatchSet rt p Origin wR
newpatches)

cleanupRepositoryReplay :: Repository rt p wR wU wT -> IO ()
cleanupRepositoryReplay :: Repository rt p wR wU wT -> IO ()
cleanupRepositoryReplay Repository rt p wR wU wT
r = do
  let c :: Cache
c = Repository rt p wR wU wT -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wT
r
  RepoFormat
rf <- [Char] -> IO RepoFormat
identifyRepoFormat [Char]
"."
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         [Char] -> IO ()
removeDirectoryRecursive ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
darcsdir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/pristine.hashed"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
       Maybe PristineHash
current <- Repository rt p wR wU wT -> IO (Maybe PristineHash)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Maybe PristineHash)
readHashedPristineRoot Repository rt p wR wU wT
r
       Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir Cache
c HashedDir
HashedPristineDir ([PristineHash] -> IO ()) -> [PristineHash] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Maybe PristineHash] -> [PristineHash]
forall a. [Maybe a] -> [a]
catMaybes [Maybe PristineHash
current]

replayRepositoryInTemp
  :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
  => DiffAlgorithm
  -> Repository rt p wR wU wT
  -> Compression
  -> Verbosity
  -> IO (RepositoryConsistency rt p wR)
replayRepositoryInTemp :: DiffAlgorithm
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
replayRepositoryInTemp DiffAlgorithm
dflag Repository rt p wR wU wT
r Compression
compr Verbosity
verb = do
  [Char]
repodir <- IO [Char]
getCurrentDirectory
  {- The reason we use withDelayedDir here, instead of withTempDir, is that
  replayRepository' may return a new pristine that is read from the 
  temporary location and reading a Tree is done using lazy ByteStrings (for
  file contents). Then we check if there is a difference to our stored
  pristine, but when there are differences the check may terminate early
  and not all of the new pristine was read/evaluated. This may then cause
  does-not-exist-failures later on when the tree is evaluated further.
  -}
  [Char]
-> (AbsolutePath -> IO (RepositoryConsistency rt p wR))
-> IO (RepositoryConsistency rt p wR)
forall a. [Char] -> (AbsolutePath -> IO a) -> IO a
withDelayedDir [Char]
"darcs-check" ((AbsolutePath -> IO (RepositoryConsistency rt p wR))
 -> IO (RepositoryConsistency rt p wR))
-> (AbsolutePath -> IO (RepositoryConsistency rt p wR))
-> IO (RepositoryConsistency rt p wR)
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
tmpDir -> do
    [Char] -> IO ()
setCurrentDirectory [Char]
repodir
    DiffAlgorithm
-> AbsolutePath
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> AbsolutePath
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
replayRepository' DiffAlgorithm
dflag AbsolutePath
tmpDir Repository rt p wR wU wT
r Compression
compr Verbosity
verb

replayRepository
  :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
  => DiffAlgorithm
  -> Repository rt p wR wU wT
  -> Compression
  -> Verbosity
  -> (RepositoryConsistency rt p wR -> IO a)
  -> IO a
replayRepository :: DiffAlgorithm
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> (RepositoryConsistency rt p wR -> IO a)
-> IO a
replayRepository DiffAlgorithm
dflag Repository rt p wR wU wT
r Compression
compr Verbosity
verb RepositoryConsistency rt p wR -> IO a
f =
  IO a
run IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` Repository rt p wR wU wT -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanupRepositoryReplay Repository rt p wR wU wT
r
    where run :: IO a
run = do
            Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
False ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
darcsdir [Char] -> [Char] -> [Char]
</> [Char]
"pristine.hashed"
            AbsolutePath
hashedPristine <- [Char] -> IO AbsolutePath
ioAbsolute ([Char] -> IO AbsolutePath) -> [Char] -> IO AbsolutePath
forall a b. (a -> b) -> a -> b
$ [Char]
darcsdir [Char] -> [Char] -> [Char]
</> [Char]
"pristine.hashed"
            RepositoryConsistency rt p wR
st <- DiffAlgorithm
-> AbsolutePath
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> AbsolutePath
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
replayRepository' DiffAlgorithm
dflag AbsolutePath
hashedPristine Repository rt p wR wU wT
r Compression
compr Verbosity
verb
            RepositoryConsistency rt p wR -> IO a
f RepositoryConsistency rt p wR
st

checkIndex
  :: (RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wR wU wR
  -> Bool
  -> IO Bool
checkIndex :: Repository rt p wR wU wR -> Bool -> IO Bool
checkIndex Repository rt p wR wU wR
repo Bool
quiet = do
  Tree IO
index <- Index -> IO (Tree IO)
treeFromIndex (Index -> IO (Tree IO)) -> IO Index -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Repository rt p wR wU wR -> IO Index
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Index
readIndex Repository rt p wR wU wR
repo
  Tree IO
pristine <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Repository rt p wR wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO)
readRecordedAndPending Repository rt p wR wU wR
repo
  Tree IO
working <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tree IO -> Tree IO -> Tree IO
forall (t :: (* -> *) -> *) (m :: * -> *) (n :: * -> *).
FilterTree t m =>
Tree n -> t m -> t m
restrict Tree IO
pristine (Tree IO -> Tree IO) -> IO (Tree IO) -> IO (Tree IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Tree IO)
readPlainTree [Char]
"."
  Tree IO
working_hashed <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsUpdateHashes Tree IO
working
  let index_paths :: [AnchoredPath]
index_paths = [ AnchoredPath
p | (AnchoredPath
p, TreeItem IO
_) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
index ]
      working_paths :: [AnchoredPath]
working_paths = [ AnchoredPath
p | (AnchoredPath
p, TreeItem IO
_) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
working ]
      index_extra :: [AnchoredPath]
index_extra = [AnchoredPath]
index_paths [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
forall a. Eq a => [a] -> [a] -> [a]
\\ [AnchoredPath]
working_paths
      working_extra :: [AnchoredPath]
working_extra = [AnchoredPath]
working_paths [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
forall a. Eq a => [a] -> [a] -> [a]
\\ [AnchoredPath]
index_paths
      gethashes :: a -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> (a, Hash, Hash)
gethashes a
p (Just TreeItem m
i1) (Just TreeItem m
i2) = (a
p, TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i1, TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i2)
      gethashes a
p (Just TreeItem m
i1) Maybe (TreeItem m)
Nothing   = (a
p, TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i1, Hash
NoHash)
      gethashes a
p   Maybe (TreeItem m)
Nothing (Just TreeItem m
i2) = (a
p,      Hash
NoHash, TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i2)
      gethashes a
p   Maybe (TreeItem m)
Nothing Maybe (TreeItem m)
Nothing   = [Char] -> (a, Hash, Hash)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (a, Hash, Hash)) -> [Char] -> (a, Hash, Hash)
forall a b. (a -> b) -> a -> b
$ [Char]
"Bad case at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
p
      mismatches :: [(AnchoredPath, Hash, Hash)]
mismatches =
        [(AnchoredPath, Hash, Hash)
miss | miss :: (AnchoredPath, Hash, Hash)
miss@(AnchoredPath
_, Hash
h1, Hash
h2) <- (AnchoredPath
 -> Maybe (TreeItem IO)
 -> Maybe (TreeItem IO)
 -> (AnchoredPath, Hash, Hash))
-> Tree IO -> Tree IO -> [(AnchoredPath, Hash, Hash)]
forall (m :: * -> *) a.
(AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a)
-> Tree m -> Tree m -> [a]
zipTrees AnchoredPath
-> Maybe (TreeItem IO)
-> Maybe (TreeItem IO)
-> (AnchoredPath, Hash, Hash)
forall a (m :: * -> *) (m :: * -> *).
Show a =>
a -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> (a, Hash, Hash)
gethashes Tree IO
index Tree IO
working_hashed, Hash
h1 Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
/= Hash
h2]

      format :: [AnchoredPath] -> [Char]
format [AnchoredPath]
paths = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> [Char]) -> [AnchoredPath] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char])
-> (AnchoredPath -> [Char]) -> AnchoredPath -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> AnchoredPath -> [Char]
anchorPath [Char]
"") [AnchoredPath]
paths
      mismatches_disp :: [Char]
mismatches_disp = [[Char]] -> [Char]
unlines [ [Char] -> AnchoredPath -> [Char]
anchorPath [Char]
"" AnchoredPath
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    [Char]
"\n    index: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack (Hash -> ByteString
encodeBase16 Hash
h1) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                    [Char]
"\n  working: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack (Hash -> ByteString
encodeBase16 Hash
h2)
                                  | (AnchoredPath
p, Hash
h1, Hash
h2) <- [(AnchoredPath, Hash, Hash)]
mismatches ]
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
quiet Bool -> Bool -> Bool
|| [AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
index_extra) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Extra items in index!\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [AnchoredPath] -> [Char]
format [AnchoredPath]
index_extra
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
quiet Bool -> Bool -> Bool
|| [AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
working_extra) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Missing items in index!\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [AnchoredPath] -> [Char]
format [AnchoredPath]
working_extra
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
quiet Bool -> Bool -> Bool
|| [(AnchoredPath, Hash, Hash)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(AnchoredPath, Hash, Hash)]
mismatches) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Hash mismatch(es)!\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mismatches_disp
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ [AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
index_extra Bool -> Bool -> Bool
&& [AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
working_extra Bool -> Bool -> Bool
&& [(AnchoredPath, Hash, Hash)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(AnchoredPath, Hash, Hash)]
mismatches