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, IOException )
import Data.List ( sort, (\\) )
import System.Directory
    ( createDirectoryIfMissing
    , getCurrentDirectory
    , setCurrentDirectory
    , withCurrentDirectory
    )

import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..)
    , lengthFL
    , mapFL
    , nullFL
    , reverseFL
    , reverseRL
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft, unseal )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Repair ( Repair(applyAndTryToFix) )
import Darcs.Patch.Info ( displayPatchInfo )
import Darcs.Patch.Set ( Origin, PatchSet(..), Tagged(..), patchSet2FL )
import Darcs.Patch ( RepoPatch, PrimOf, isInconsistent )

import Darcs.Repository.Diff( treeDiff )
import Darcs.Repository.Flags ( Verbosity(..), DiffAlgorithm )
import Darcs.Repository.Hashed ( readPatches, writeAndReadPatch )
import Darcs.Repository.InternalTypes ( Repository, repoCache, repoLocation )
import Darcs.Repository.Paths ( pristineDirPath )
import Darcs.Repository.Pending ( readPending )
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Repository.State
    ( readPristine
    , readIndex
    , readPristineAndPending
    )

import Darcs.Util.Cache ( Cache, mkDirCache )
import Darcs.Util.Progress
    ( beginTedious
    , endTedious
    , finishedOneIO
    , tediousSize
    )
import Darcs.Util.Lock( withDelayedDir )
import Darcs.Util.Path( anchorPath, toFilePath )
import Darcs.Util.Printer ( putDocLn, text, renderString )
import Darcs.Util.Hash( showHash )
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 )

applyAndFixPatchSet
  :: forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wU wR
  -> PatchSet p Origin wR
  -> TreeIO (PatchSet p Origin wR, Bool)
applyAndFixPatchSet :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> PatchSet p Origin wR -> TreeIO (PatchSet p Origin wR, Bool)
applyAndFixPatchSet Repository rt p wU wR
r PatchSet p Origin wR
s = do
    IO () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RWST (DumpItem IO) () (TreeState IO) IO ())
-> IO () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
beginTedious String
k
    IO () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RWST (DumpItem IO) () (TreeState IO) IO ())
-> IO () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> IO ()
tediousSize String
k (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd p) Origin wR -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL (FL (PatchInfoAnd p) Origin wR -> Int)
-> FL (PatchInfoAnd p) Origin wR -> Int
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> FL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX
patchSet2FL PatchSet p Origin wR
s
    (PatchSet p Origin wR, Bool)
result <- case PatchSet p Origin wR
s of
      PatchSet RL (Tagged p) Origin wX
ts RL (PatchInfoAnd p) wX wR
ps -> do
        (FL (Tagged p) Origin wX
ts', Bool
ts_ok) <- FL (Tagged p) Origin wX -> TreeIO (FL (Tagged p) Origin wX, Bool)
forall wX wY.
FL (Tagged p) wX wY -> TreeIO (FL (Tagged p) wX wY, Bool)
applyAndFixTagged (RL (Tagged p) Origin wX -> FL (Tagged p) Origin wX
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (Tagged p) Origin wX
ts)
        (FL (PatchInfoAnd p) wX wR
ps', Bool
ps_ok) <- FL (PatchInfoAnd p) wX wR
-> TreeIO (FL (PatchInfoAnd p) wX wR, Bool)
forall wX wY.
FL (PatchInfoAnd p) wX wY
-> TreeIO (FL (PatchInfoAnd p) wX wY, Bool)
applyAndFixPatches (RL (PatchInfoAnd p) wX wR -> FL (PatchInfoAnd p) wX wR
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PatchInfoAnd p) wX wR
ps)
        (PatchSet p Origin wR, Bool) -> TreeIO (PatchSet p Origin wR, Bool)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RL (Tagged p) Origin wX
-> RL (PatchInfoAnd p) wX wR -> PatchSet p Origin wR
forall (p :: * -> * -> *) wX wY.
RL (Tagged p) Origin wX
-> RL (PatchInfoAnd p) wX wY -> PatchSet p Origin wY
PatchSet (FL (Tagged p) Origin wX -> RL (Tagged p) Origin wX
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (Tagged p) Origin wX
ts') (FL (PatchInfoAnd p) wX wR -> RL (PatchInfoAnd p) wX wR
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd p) wX wR
ps'), Bool
ts_ok Bool -> Bool -> Bool
&& Bool
ps_ok)
    IO () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RWST (DumpItem IO) () (TreeState IO) IO ())
-> IO () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
endTedious String
k
    (PatchSet p Origin wR, Bool) -> TreeIO (PatchSet p Origin wR, Bool)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchSet p Origin wR, Bool)
result
  where
    k :: String
k = String
"Replaying patch"
    applyAndFixTagged :: FL (Tagged p) wX wY -> TreeIO (FL (Tagged p) wX wY, Bool)
    applyAndFixTagged :: forall wX wY.
FL (Tagged p) wX wY -> TreeIO (FL (Tagged p) wX wY, Bool)
applyAndFixTagged FL (Tagged p) wX wY
NilFL = (FL (Tagged p) wX wY, Bool)
-> RWST
     (DumpItem IO) () (TreeState IO) IO (FL (Tagged p) wX wY, Bool)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (Tagged p) wX wX
FL (Tagged p) wX wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL, Bool
True)
    applyAndFixTagged (Tagged RL (PatchInfoAnd p) wX wY
ps PatchInfoAnd p wY wY
t Maybe InventoryHash
_ :>: FL (Tagged p) wY wY
ts) = do
      (FL (PatchInfoAnd p) wX wY
ps', Bool
ps_ok) <- FL (PatchInfoAnd p) wX wY
-> TreeIO (FL (PatchInfoAnd p) wX wY, Bool)
forall wX wY.
FL (PatchInfoAnd p) wX wY
-> TreeIO (FL (PatchInfoAnd p) wX wY, Bool)
applyAndFixPatches (RL (PatchInfoAnd p) wX wY -> FL (PatchInfoAnd p) wX wY
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PatchInfoAnd p) wX wY
ps)
      (FL (Tagged p) wY wY
ts', Bool
ts_ok) <- FL (Tagged p) wY wY -> TreeIO (FL (Tagged p) wY wY, Bool)
forall wX wY.
FL (Tagged p) wX wY -> TreeIO (FL (Tagged p) wX wY, Bool)
applyAndFixTagged FL (Tagged p) wY wY
ts
      (FL (Tagged p) wX wY, Bool)
-> RWST
     (DumpItem IO) () (TreeState IO) IO (FL (Tagged p) wX wY, Bool)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RL (PatchInfoAnd p) wX wY
-> PatchInfoAnd p wY wY -> Maybe InventoryHash -> Tagged p wX wY
forall (p :: * -> * -> *) wX wY wZ.
RL (PatchInfoAnd p) wX wY
-> PatchInfoAnd p wY wZ -> Maybe InventoryHash -> Tagged p wX wZ
Tagged (FL (PatchInfoAnd p) wX wY -> RL (PatchInfoAnd p) wX wY
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd p) wX wY
ps') PatchInfoAnd p wY wY
t Maybe InventoryHash
forall a. Maybe a
Nothing Tagged p wX wY -> FL (Tagged p) wY wY -> FL (Tagged p) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (Tagged p) wY wY
ts', Bool
ps_ok Bool -> Bool -> Bool
&& Bool
ts_ok)
    applyAndFixPatches
      :: FL (PatchInfoAnd p) wX wY -> TreeIO (FL (PatchInfoAnd p) wX wY, Bool)
    applyAndFixPatches :: forall wX wY.
FL (PatchInfoAnd p) wX wY
-> TreeIO (FL (PatchInfoAnd p) wX wY, Bool)
applyAndFixPatches FL (PatchInfoAnd p) wX wY
NilFL = (FL (PatchInfoAnd p) wX wY, Bool)
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (FL (PatchInfoAnd p) wX wY, Bool)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PatchInfoAnd p) wX wX
FL (PatchInfoAnd p) wX wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL, Bool
True)
    applyAndFixPatches (PatchInfoAnd p wX wY
p :>: FL (PatchInfoAnd p) wY wY
ps) = do
      Maybe (String, PatchInfoAnd p wX wY)
mp' <- PatchInfoAnd p wX wY
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (Maybe (String, PatchInfoAnd p wX wY))
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PatchInfoAnd p)) m =>
PatchInfoAndG (Named p) wX wY
-> m (Maybe (String, PatchInfoAndG (Named p) wX wY))
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Repair p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m (Maybe (String, p wX wY))
applyAndTryToFix PatchInfoAnd p wX wY
p
      case Named p wX wY -> Maybe Doc
forall wX wY. Named p wX wY -> Maybe Doc
forall (p :: * -> * -> *) wX wY. Check p => p wX wY -> Maybe Doc
isInconsistent (Named p wX wY -> Maybe Doc)
-> (PatchInfoAnd p wX wY -> Named p wX wY)
-> PatchInfoAnd p wX wY
-> Maybe Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wX wY -> Named p wX wY
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully (PatchInfoAnd p wX wY -> Maybe Doc)
-> PatchInfoAnd p wX wY -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd p wX wY
p of
        Just Doc
err -> IO () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RWST (DumpItem IO) () (TreeState IO) IO ())
-> IO () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn Doc
err
        Maybe Doc
Nothing -> () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      IO () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RWST (DumpItem IO) () (TreeState IO) IO ())
-> IO () -> RWST (DumpItem IO) () (TreeState IO) IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
finishedOneIO String
k (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ PatchInfo -> Doc
displayPatchInfo (PatchInfo -> Doc) -> PatchInfo -> Doc
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd p wX wY -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAnd p wX wY
p
      (FL (PatchInfoAnd p) wY wY
ps', Bool
ps_ok) <- FL (PatchInfoAnd p) wY wY
-> TreeIO (FL (PatchInfoAnd p) wY wY, Bool)
forall wX wY.
FL (PatchInfoAnd p) wX wY
-> TreeIO (FL (PatchInfoAnd p) wX wY, Bool)
applyAndFixPatches FL (PatchInfoAnd p) wY wY
ps
      case Maybe (String, PatchInfoAnd p wX wY)
mp' of
        Maybe (String, PatchInfoAnd p wX wY)
Nothing -> (FL (PatchInfoAnd p) wX wY, Bool)
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (FL (PatchInfoAnd p) wX wY, Bool)
forall a. a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchInfoAnd p wX wY
p PatchInfoAnd p wX wY
-> FL (PatchInfoAnd p) wY wY -> FL (PatchInfoAnd p) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd p) wY wY
ps', Bool
ps_ok)
        Just (String
e, PatchInfoAnd p wX wY
p') ->
          IO (FL (PatchInfoAnd p) wX wY, Bool)
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (FL (PatchInfoAnd p) wX wY, Bool)
forall a. IO a -> RWST (DumpItem IO) () (TreeState IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FL (PatchInfoAnd p) wX wY, Bool)
 -> RWST
      (DumpItem IO)
      ()
      (TreeState IO)
      IO
      (FL (PatchInfoAnd p) wX wY, Bool))
-> IO (FL (PatchInfoAnd p) wX wY, Bool)
-> RWST
     (DumpItem IO)
     ()
     (TreeState IO)
     IO
     (FL (PatchInfoAnd p) wX wY, Bool)
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
putStrLn String
e
            -- FIXME While this is okay semantically, it means we can't
            -- run darcs check in a read-only repo
            PatchInfoAnd p wX wY
p'' <-
              String -> IO (PatchInfoAnd p wX wY) -> IO (PatchInfoAnd p wX wY)
forall a. String -> IO a -> IO a
withCurrentDirectory (Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
r) (IO (PatchInfoAnd p wX wY) -> IO (PatchInfoAnd p wX wY))
-> IO (PatchInfoAnd p wX wY) -> IO (PatchInfoAnd p wX wY)
forall a b. (a -> b) -> a -> b
$
              Cache -> PatchInfoAnd p wX wY -> IO (PatchInfoAnd p wX wY)
forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
Cache -> PatchInfoAnd p wX wY -> IO (PatchInfoAnd p wX wY)
writeAndReadPatch (Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
r) PatchInfoAnd p wX wY
p'
            (FL (PatchInfoAnd p) wX wY, Bool)
-> IO (FL (PatchInfoAnd p) wX wY, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchInfoAnd p wX wY
p'' PatchInfoAnd p wX wY
-> FL (PatchInfoAnd p) wY wY -> FL (PatchInfoAnd p) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd p) wY wY
ps', Bool
False)

data RepositoryConsistency p wR = RepositoryConsistency
  { forall (p :: * -> * -> *) wR.
RepositoryConsistency p wR
-> Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
fixedPristine :: Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
  , forall (p :: * -> * -> *) wR.
RepositoryConsistency p wR -> Maybe (PatchSet p Origin wR)
fixedPatches :: Maybe (PatchSet p Origin wR)
  , forall (p :: * -> * -> *) wR.
RepositoryConsistency p wR -> Maybe (Sealed (FL (PrimOf p) wR))
fixedPending :: Maybe (Sealed (FL (PrimOf p) wR))
  }

hasDuplicate :: Ord a => [a] -> Maybe a
hasDuplicate :: forall a. Ord a => [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. (RepoPatch p, ApplyState p ~ Tree)
  => DiffAlgorithm
  -> Cache
  -> Repository rt p wU wR
  -> Verbosity
  -> IO (RepositoryConsistency p wR)
replayRepository' :: forall (rt :: AccessType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> Cache
-> Repository rt p wU wR
-> Verbosity
-> IO (RepositoryConsistency p wR)
replayRepository' DiffAlgorithm
dflag Cache
cache Repository rt p wU wR
repo Verbosity
verbosity = do
  let 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 ()
putVerbose (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Checking that patch names are unique..."
  PatchSet p Origin wR
patches <- Repository rt p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository rt p wU wR
repo
  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 p wW wZ -> PatchInfo)
-> FL (PatchInfoAnd p) Origin wR -> [PatchInfo]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL PatchInfoAndG (Named p) wW wZ -> PatchInfo
forall wW wZ. PatchInfoAnd p wW wZ -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info (FL (PatchInfoAnd p) Origin wR -> [PatchInfo])
-> FL (PatchInfoAnd p) Origin wR -> [PatchInfo]
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> FL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX
patchSet2FL PatchSet p Origin wR
patches of
    Maybe PatchInfo
Nothing -> () -> IO ()
forall a. a -> IO a
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
$ String -> Doc
text String
"Error! Duplicate patch name:"
      Doc -> IO ()
putInfo (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ PatchInfo -> Doc
displayPatchInfo PatchInfo
pinf
      -- FIXME repair duplicates by re-generating their salt
      String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Duplicate patches found."

  -- we have to read pristine before fixing patches as that updates pristine
  Tree IO
pris <-
    (Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository rt p wU wR
repo IO (Tree IO) -> (Tree IO -> IO (Tree IO)) -> IO (Tree IO)
forall a b. IO a -> (a -> IO b) -> IO b
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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
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
$ String -> Doc
text String
"Checking content of recorded patches..."
  ((PatchSet p Origin wR
newpatches, Bool
patches_ok), Tree IO
newpris) <-
    TreeIO (PatchSet p Origin wR, Bool)
-> Tree IO -> Cache -> IO ((PatchSet p Origin wR, Bool), Tree IO)
forall a. TreeIO a -> Tree IO -> Cache -> IO (a, Tree IO)
hashedTreeIO (Repository rt p wU wR
-> PatchSet p Origin wR -> TreeIO (PatchSet p Origin wR, Bool)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> PatchSet p Origin wR -> TreeIO (PatchSet p Origin wR, Bool)
applyAndFixPatchSet Repository rt p wU wR
repo PatchSet p Origin wR
patches) Tree IO
forall (m :: * -> *). Tree m
emptyTree Cache
cache

  Doc -> IO ()
putVerbose (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Checking pristine..."
  String -> FileType
ftf <- IO (String -> FileType)
filetypeFunction
  Sealed (FL (PrimOf p) wR)
pristine_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 a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DiffAlgorithm
-> (String -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL (PrimOf p)))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
       (prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> (String -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
dflag String -> FileType
ftf Tree IO
pris Tree IO
newpris
  let pristine_ok :: Bool
pristine_ok = (forall wX. FL (PrimOf p) wR wX -> Bool)
-> Sealed (FL (PrimOf p) wR) -> Bool
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal FL (PrimOf p) wR wX -> Bool
forall wX. FL (PrimOf p) wR wX -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL Sealed (FL (PrimOf p) wR)
pristine_diff

  Doc -> IO ()
putVerbose (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Checking pending patch..."
  Sealed FL (PrimOf p) wR wX
pend <- Repository rt p wU wR -> IO (Sealed (FL (PrimOf p) wR))
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (Sealed (FL (PrimOf p) wR))
readPending Repository rt p wU wR
repo
  Maybe (String, FL (PrimOf p) wR wX)
maybe_newpend <- (Maybe (String, FL (PrimOf p) wR wX), Tree IO)
-> Maybe (String, FL (PrimOf p) wR wX)
forall a b. (a, b) -> a
fst ((Maybe (String, FL (PrimOf p) wR wX), Tree IO)
 -> Maybe (String, FL (PrimOf p) wR wX))
-> IO (Maybe (String, FL (PrimOf p) wR wX), Tree IO)
-> IO (Maybe (String, FL (PrimOf p) wR wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeIO (Maybe (String, FL (PrimOf p) wR wX))
-> Tree IO
-> Cache
-> IO (Maybe (String, FL (PrimOf p) wR wX), Tree IO)
forall a. TreeIO a -> Tree IO -> Cache -> IO (a, Tree IO)
hashedTreeIO (FL (PrimOf p) wR wX -> TreeIO (Maybe (String, FL (PrimOf p) wR wX))
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (FL (PrimOf p))) m =>
FL (PrimOf p) wX wY -> m (Maybe (String, FL (PrimOf p) wX wY))
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Repair p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m (Maybe (String, p wX wY))
applyAndTryToFix FL (PrimOf p) wR wX
pend) Tree IO
newpris Cache
cache
  (FL (PrimOf p) wR wX
newpend, Bool
pending_ok) <- FL (PrimOf p) wR wX
-> Maybe (String, FL (PrimOf p) wR wX)
-> IO (FL (PrimOf p) wR wX, Bool)
forall a. a -> Maybe (String, a) -> IO (a, Bool)
convertFixed FL (PrimOf p) wR wX
pend Maybe (String, FL (PrimOf p) wR wX)
maybe_newpend

  RepositoryConsistency p wR -> IO (RepositoryConsistency p wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RepositoryConsistency p wR -> IO (RepositoryConsistency p wR))
-> RepositoryConsistency p wR -> IO (RepositoryConsistency p wR)
forall a b. (a -> b) -> a -> b
$ RepositoryConsistency
    { fixedPristine :: Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
fixedPristine = if Bool
pristine_ok then Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
forall a. Maybe a
Nothing else (Tree IO, Sealed (FL (PrimOf p) wR))
-> Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
forall a. a -> Maybe a
Just (Tree IO
newpris, Sealed (FL (PrimOf p) wR)
pristine_diff)
    , fixedPatches :: Maybe (PatchSet p Origin wR)
fixedPatches = if Bool
patches_ok then Maybe (PatchSet p Origin wR)
forall a. Maybe a
Nothing else PatchSet p Origin wR -> Maybe (PatchSet p Origin wR)
forall a. a -> Maybe a
Just PatchSet p Origin wR
newpatches
    , fixedPending :: Maybe (Sealed (FL (PrimOf p) wR))
fixedPending = if Bool
pending_ok then Maybe (Sealed (FL (PrimOf p) wR))
forall a. Maybe a
Nothing else Sealed (FL (PrimOf p) wR) -> Maybe (Sealed (FL (PrimOf p) wR))
forall a. a -> Maybe a
Just (FL (PrimOf p) wR wX -> Sealed (FL (PrimOf p) wR)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PrimOf p) wR wX
newpend)
    }

  where
    convertFixed :: a -> Maybe (String, a) -> IO (a, Bool)
    convertFixed :: forall a. a -> Maybe (String, a) -> IO (a, Bool)
convertFixed a
x Maybe (String, a)
Nothing = (a, Bool) -> IO (a, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, Bool
True)
    convertFixed a
_ (Just (String
e, a
x)) = do
      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
$ String -> IO ()
putStrLn String
e
      (a, Bool) -> IO (a, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, Bool
False)

replayRepositoryInTemp
  :: (RepoPatch p, ApplyState p ~ Tree)
  => DiffAlgorithm
  -> Repository rt p wU wR
  -> Verbosity
  -> IO (RepositoryConsistency p wR)
replayRepositoryInTemp :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> Repository rt p wU wR
-> Verbosity
-> IO (RepositoryConsistency p wR)
replayRepositoryInTemp DiffAlgorithm
dflag Repository rt p wU wR
r Verbosity
verb = do
  String
repodir <- IO String
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.
  -}
  String
-> (AbsolutePath -> IO (RepositoryConsistency p wR))
-> IO (RepositoryConsistency p wR)
forall a. String -> (AbsolutePath -> IO a) -> IO a
withDelayedDir String
"darcs-check" ((AbsolutePath -> IO (RepositoryConsistency p wR))
 -> IO (RepositoryConsistency p wR))
-> (AbsolutePath -> IO (RepositoryConsistency p wR))
-> IO (RepositoryConsistency p wR)
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
tmpDir -> do
    String -> IO ()
setCurrentDirectory String
repodir
    DiffAlgorithm
-> Cache
-> Repository rt p wU wR
-> Verbosity
-> IO (RepositoryConsistency p wR)
forall (rt :: AccessType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> Cache
-> Repository rt p wU wR
-> Verbosity
-> IO (RepositoryConsistency p wR)
replayRepository' DiffAlgorithm
dflag (String -> Cache
mkDirCache (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
tmpDir)) Repository rt p wU wR
r Verbosity
verb

replayRepository
  :: (RepoPatch p, ApplyState p ~ Tree)
  => DiffAlgorithm
  -> Repository rt p wU wR
  -> Verbosity
  -> (RepositoryConsistency p wR -> IO a)
  -> IO a
replayRepository :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR a.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> Repository rt p wU wR
-> Verbosity
-> (RepositoryConsistency p wR -> IO a)
-> IO a
replayRepository DiffAlgorithm
dflag Repository rt p wU wR
r Verbosity
verb RepositoryConsistency p wR -> IO a
job = do
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
pristineDirPath
  RepositoryConsistency p wR
st <- DiffAlgorithm
-> Cache
-> Repository rt p wU wR
-> Verbosity
-> IO (RepositoryConsistency p wR)
forall (rt :: AccessType) (p :: * -> * -> *) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> Cache
-> Repository rt p wU wR
-> Verbosity
-> IO (RepositoryConsistency p wR)
replayRepository' DiffAlgorithm
dflag (Repository rt p wU wR -> Cache
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache Repository rt p wU wR
r) Repository rt p wU wR
r Verbosity
verb
  RepositoryConsistency p wR -> IO a
job RepositoryConsistency p wR
st

checkIndex
  :: (RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wU wR
  -> Bool
  -> IO Bool
checkIndex :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> Bool -> IO Bool
checkIndex Repository rt p 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 wU wR -> IO Index
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO Index
readIndex Repository rt p 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 wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO)
readPristineAndPending Repository rt p 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
<$> String -> IO (Tree IO)
readPlainTree String
"."
  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, Maybe Hash, Maybe Hash)
gethashes a
p (Just TreeItem m
i1) (Just TreeItem m
i2) = (a
p, TreeItem m -> Maybe Hash
forall (m :: * -> *). TreeItem m -> Maybe Hash
itemHash TreeItem m
i1, TreeItem m -> Maybe Hash
forall (m :: * -> *). TreeItem m -> Maybe Hash
itemHash TreeItem m
i2)
      gethashes a
p (Just TreeItem m
i1) Maybe (TreeItem m)
Nothing   = (a
p, TreeItem m -> Maybe Hash
forall (m :: * -> *). TreeItem m -> Maybe Hash
itemHash TreeItem m
i1, Maybe Hash
forall a. Maybe a
Nothing)
      gethashes a
p   Maybe (TreeItem m)
Nothing (Just TreeItem m
i2) = (a
p,     Maybe Hash
forall a. Maybe a
Nothing, TreeItem m -> Maybe Hash
forall (m :: * -> *). TreeItem m -> Maybe Hash
itemHash TreeItem m
i2)
      gethashes a
p   Maybe (TreeItem m)
Nothing Maybe (TreeItem m)
Nothing   = String -> (a, Maybe Hash, Maybe Hash)
forall a. HasCallStack => String -> a
error (String -> (a, Maybe Hash, Maybe Hash))
-> String -> (a, Maybe Hash, Maybe Hash)
forall a b. (a -> b) -> a -> b
$ String
"Bad case at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
p
      mismatches :: [(AnchoredPath, Maybe Hash, Maybe Hash)]
mismatches =
        [(AnchoredPath, Maybe Hash, Maybe Hash)
miss | miss :: (AnchoredPath, Maybe Hash, Maybe Hash)
miss@(AnchoredPath
_, Maybe Hash
h1, Maybe Hash
h2) <- (AnchoredPath
 -> Maybe (TreeItem IO)
 -> Maybe (TreeItem IO)
 -> (AnchoredPath, Maybe Hash, Maybe Hash))
-> Tree IO -> Tree IO -> [(AnchoredPath, Maybe Hash, Maybe 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, Maybe Hash, Maybe Hash)
forall {a} {m :: * -> *} {m :: * -> *}.
Show a =>
a
-> Maybe (TreeItem m)
-> Maybe (TreeItem m)
-> (a, Maybe Hash, Maybe Hash)
gethashes Tree IO
index Tree IO
working_hashed, Maybe Hash
h1 Maybe Hash -> Maybe Hash -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Hash
h2]

      format :: [AnchoredPath] -> String
format [AnchoredPath]
paths = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (AnchoredPath -> String) -> AnchoredPath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AnchoredPath -> String
anchorPath String
"") [AnchoredPath]
paths
      mismatches_disp :: String
mismatches_disp = [String] -> String
unlines [ String -> AnchoredPath -> String
anchorPath String
"" AnchoredPath
p String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                    String
"\n    index: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Hash -> String
showHash Maybe Hash
h1 String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                    String
"\n  working: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Hash -> String
showHash Maybe Hash
h2
                                  | (AnchoredPath
p, Maybe Hash
h1, Maybe Hash
h2) <- [(AnchoredPath, Maybe Hash, Maybe Hash)]
mismatches ]
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
quiet Bool -> Bool -> Bool
|| [AnchoredPath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
index_extra) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Extra items in index!\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [AnchoredPath] -> String
format [AnchoredPath]
index_extra
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
quiet Bool -> Bool -> Bool
|| [AnchoredPath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
working_extra) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Missing items in index!\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [AnchoredPath] -> String
format [AnchoredPath]
working_extra
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
quiet Bool -> Bool -> Bool
|| [(AnchoredPath, Maybe Hash, Maybe Hash)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(AnchoredPath, Maybe Hash, Maybe Hash)]
mismatches) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Hash mismatch(es)!\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mismatches_disp
  Bool -> IO Bool
forall a. a -> IO a
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
index_extra Bool -> Bool -> Bool
&& [AnchoredPath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
working_extra Bool -> Bool -> Bool
&& [(AnchoredPath, Maybe Hash, Maybe Hash)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(AnchoredPath, Maybe Hash, Maybe Hash)]
mismatches