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 :: 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) wX wY
orig [] = FL (PatchInfoAnd rt a) wX wY
orig
replaceInFL FL (PatchInfoAnd rt a) wX wY
NilFL [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
_ = 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 <- forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WPatchInfo wA wB
winfo PatchInfoAnd rt a wX wY
o 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
cforall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: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
oforall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: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 :: 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
_ Compression
_ FL (PatchInfoAnd rt p) Origin wR
NilFL = forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
beginTedious [Char]
k
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> IO ()
tediousSize [Char]
k forall a b. (a -> b) -> a -> b
$ 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) <- forall wW wZ.
FL (PatchInfoAnd rt p) wW wZ
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
aaf FL (PatchInfoAnd rt p) Origin wR
psin
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
endTedious [Char]
k
       FL (PatchInfoAnd rt p) Origin wR
orig <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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
       forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall wW wZ.
FL (PatchInfoAnd rt p) wW wZ
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
aaf FL (PatchInfoAnd rt p) wW wZ
NilFL = 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' <- 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 forall (p :: * -> * -> *) wX wY. Check p => p wX wY -> Maybe Doc
isInconsistent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p wW wY
p of
              Just Doc
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn Doc
err
              Maybe Doc
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            let !winfp :: WPatchInfo wW wY
winfp = 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.
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
renderString forall a b. (a -> b) -> a -> b
$
              PatchInfo -> Doc
displayPatchInfo forall a b. (a -> b) -> a -> b
$ forall wA wB. WPatchInfo wA wB -> PatchInfo
unWPatchInfo WPatchInfo wW wY
winfp
            ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
ps', Bool
restok) <- 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 -> 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) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                [Char] -> IO ()
putStrLn [Char]
e
                PatchInfoAnd rt p wW wY
p' <- forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> [Char]
repoLocation Repository rt p wR wU wT
r) forall a b. (a -> b) -> a -> b
$
                  forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
Cache
-> Compression
-> PatchInfoAnd rt p wX wY
-> IO (PatchInfoAnd rt p wX wY)
writeAndReadPatch (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
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
Sealed2 (WPatchInfo wW wY
winfp forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY.
a1 wX wY -> a2 wX wY -> (:||:) a1 a2 wX wY
:||: PatchInfoAnd rt p wW wY
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 :: 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
repository =
    do Doc -> IO ()
putVerbose forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Checking that patch names are unique..."
       PatchSet rt p Origin wR
r <- 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 forall a. Ord a => [a] -> Maybe a
hasDuplicate forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Just PatchInfo
pinf -> do Doc -> IO ()
putInfo forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Error! Duplicate patch name:"
                         Doc -> IO ()
putInfo forall a b. (a -> b) -> a -> b
$ PatchInfo -> Doc
displayPatchInfo PatchInfo
pinf
                         forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Duplicate patches found."

hasDuplicate :: Ord a => [a] -> Maybe a
hasDuplicate :: forall a. Ord a => [a] -> Maybe a
hasDuplicate [a]
li = forall {a}. Eq a => [a] -> Maybe a
hd forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [a]
li
    where hd :: [a] -> Maybe a
hd [a
_] = forall a. Maybe a
Nothing
          hd [] = forall a. Maybe a
Nothing
          hd (a
x1:a
x2:[a]
xs) | a
x1 forall a. Eq a => a -> a -> Bool
== a
x2 = forall a. a -> Maybe a
Just a
x1
                        | Bool
otherwise = [a] -> Maybe a
hd (a
x2forall 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' :: 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
whereToReplay' Repository rt p wR wU wT
repo Compression
compr Verbosity
verbosity = do
  let whereToReplay :: [Char]
whereToReplay = forall a. FilePathLike a => a -> [Char]
toFilePath AbsolutePath
whereToReplay'
      putVerbose :: Doc -> IO ()
putVerbose Doc
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity forall a. Eq a => a -> a -> Bool
== Verbosity
Verbose) forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn Doc
s
      putInfo :: Doc -> IO ()
putInfo Doc
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity
verbosity forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet) forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn Doc
s
  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 forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Reading recorded state..."
  Tree IO
pris <-
    (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
repo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsUpdateHashes)
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
    \(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *). Tree m
emptyTree
  Doc -> IO ()
putVerbose forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Applying patches..."
  PatchSet rt p Origin wR
patches <- 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 = 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 = 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) <- forall a. TreeIO a -> Tree IO -> [Char] -> IO (a, Tree IO)
hashedTreeIO TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
repair forall (m :: * -> *). Tree m
emptyTree [Char]
whereToReplay
  [Char] -> IO ()
debugMessage [Char]
"Done fixing broken patches..."
  let newpatches :: PatchSet rt p Origin wR
newpatches = forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p Origin wY
PatchSet forall (a :: * -> * -> *) wX. RL a wX wX
NilRL (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 <- forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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))
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PrimOf p) wR wX
diff
              forall a. IO a -> IO a -> IO a
`catchall` 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?
  forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
is_same Bool -> Bool -> Bool
&& Bool
patches_ok
     then forall (rt :: RepoType) (p :: * -> * -> *) wX.
RepositoryConsistency rt p wX
RepositoryConsistent
     else if Bool
patches_ok
            then forall (rt :: RepoType) (p :: * -> * -> *) wX.
Tree IO -> RepositoryConsistency rt p wX
BrokenPristine Tree IO
newpris
            else 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 :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanupRepositoryReplay Repository rt p wR wU wT
r = do
  let c :: Cache
c = 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]
"."
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf) forall a b. (a -> b) -> a -> b
$
         [Char] -> IO ()
removeDirectoryRecursive forall a b. (a -> b) -> a -> b
$ [Char]
darcsdir forall a. [a] -> [a] -> [a]
++ [Char]
"/pristine.hashed"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf) forall a b. (a -> b) -> a -> b
$ do
       Maybe PristineHash
current <- 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 forall a b. (a -> b) -> a -> b
$ 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 :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
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.
  -}
  forall a. [Char] -> (AbsolutePath -> IO a) -> IO a
withDelayedDir [Char]
"darcs-check" forall a b. (a -> b) -> a -> b
$ \AbsolutePath
tmpDir -> do
    [Char] -> IO ()
setCurrentDirectory [Char]
repodir
    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 :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
(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
dflag Repository rt p wR wU wT
r Compression
compr Verbosity
verb RepositoryConsistency rt p wR -> IO a
f =
  IO a
run forall a b. IO a -> IO b -> IO a
`finally` 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 forall a b. (a -> b) -> a -> b
$ [Char]
darcsdir [Char] -> [Char] -> [Char]
</> [Char]
"pristine.hashed"
            AbsolutePath
hashedPristine <- [Char] -> IO AbsolutePath
ioAbsolute forall a b. (a -> b) -> a -> b
$ [Char]
darcsdir [Char] -> [Char] -> [Char]
</> [Char]
"pristine.hashed"
            RepositoryConsistency rt p wR
st <- 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 :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> *) (m :: * -> *) (n :: * -> *).
FilterTree t m =>
Tree n -> t m -> t m
restrict Tree IO
pristine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Tree IO)
readPlainTree [Char]
"."
  Tree IO
working_hashed <- 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
_) <- forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
index ]
      working_paths :: [AnchoredPath]
working_paths = [ AnchoredPath
p | (AnchoredPath
p, TreeItem IO
_) <- forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
working ]
      index_extra :: [AnchoredPath]
index_extra = [AnchoredPath]
index_paths forall a. Eq a => [a] -> [a] -> [a]
\\ [AnchoredPath]
working_paths
      working_extra :: [AnchoredPath]
working_extra = [AnchoredPath]
working_paths 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, forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i1, forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i2)
      gethashes a
p (Just TreeItem m
i1) Maybe (TreeItem m)
Nothing   = (a
p, 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, forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i2)
      gethashes a
p   Maybe (TreeItem m)
Nothing Maybe (TreeItem m)
Nothing   = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Bad case at " forall a. [a] -> [a] -> [a]
++ 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) <- forall (m :: * -> *) a.
(AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a)
-> Tree m -> Tree m -> [a]
zipTrees 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 forall a. Eq a => a -> a -> Bool
/= Hash
h2]

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