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, makePatchname )
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
    result <- case PatchSet p Origin wR
s of
      PatchSet RL (Tagged p) Origin wX
ts RL (PatchInfoAnd p) wX wR
ps -> do
        (ts', 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)
        (ps', ps_ok) <- applyAndFixPatches (reverseRL ps)
        return (PatchSet (reverseFL ts') (reverseFL ps'), ts_ok && ps_ok)
    liftIO $ endTedious k
    return 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
      (ps', 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)
      (ts', ts_ok) <- applyAndFixTagged ts
      return (Tagged (reverseFL ps') t Nothing :>: ts', ps_ok && 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
      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 isInconsistent . hopefully $ 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 ()
      liftIO $ finishedOneIO k $ show $ makePatchname $ info p
      (ps', ps_ok) <- applyAndFixPatches ps
      case 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 -> 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) Doc -> Doc -> Doc
$$ String -> Doc
text String
e
            -- FIXME While this is okay semantically, it means we can't
            -- run darcs check in a read-only repo
            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'
            return (p'' :>: ps', 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..."
  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 hasDuplicate $ mapFL info $ patchSet2FL 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
  pris <-
    (readPristine repo >>= expand >>= darcsUpdateHashes)
    `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

  putVerbose $ text "Checking content of recorded patches..."
  ((newpatches, patches_ok), newpris) <-
    hashedTreeIO (applyAndFixPatchSet repo patches) emptyTree cache

  putVerbose $ text "Checking pristine..."
  ftf <- filetypeFunction
  pristine_diff <- unFreeLeft `fmap` treeDiff dflag ftf pris newpris
  let 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

  putVerbose $ text "Checking pending patch..."
  Sealed pend <- readPending repo
  maybe_newpend <- fst <$> hashedTreeIO (applyAndTryToFix pend) newpris cache
  (newpend, pending_ok) <- convertFixed pend maybe_newpend

  return $ RepositoryConsistency
    { fixedPristine = if pristine_ok then Nothing else Just (newpris, pristine_diff)
    , fixedPatches = if patches_ok then Nothing else Just newpatches
    , fixedPending = if pending_ok then Nothing else Just (Sealed 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
  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.
  -}
  withDelayedDir "darcs-check" $ \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
  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
  job 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
  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
  pristine <- expand =<< readPristineAndPending repo
  working <- expand =<< restrict pristine <$> readPlainTree "."
  working_hashed <- darcsUpdateHashes working
  let 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
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_paths [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
forall a. Eq a => [a] -> [a] -> [a]
\\ [AnchoredPath]
working_paths
      working_extra = [AnchoredPath]
working_paths [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
forall a. Eq a => [a] -> [a] -> [a]
\\ [AnchoredPath]
index_paths
      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)
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]
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] -> 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 ]
  unless (quiet || null index_extra) $
         putStrLn $ "Extra items in index!\n" ++ format index_extra
  unless (quiet || null working_extra) $
         putStrLn $ "Missing items in index!\n" ++ format working_extra
  unless (quiet || null mismatches) $
         putStrLn $ "Hash mismatch(es)!\n" ++ mismatches_disp
  return $ null index_extra && null working_extra && null mismatches