--  Copyright (C) 2002-2005 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Repair ( repair, check ) where

import Darcs.Prelude

import Control.Monad ( when, unless, void )
import Data.Maybe ( isJust )
import System.IO.Error ( catchIOError )
import System.Exit ( exitFailure )
import System.Directory( renameFile )
import System.FilePath ( (<.>) )

import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts, nodefaults
    , putInfo, putVerbose, putWarning, amInHashedRepository
    )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
    ( DarcsFlag, verbosity, umask, useIndex
    , useCache, diffAlgorithm, quiet
    )
import Darcs.UI.Options ( DarcsOption, oid, (?), (^) )
import qualified Darcs.UI.Options.All as O

import Darcs.Repository.Paths ( indexPath )
import Darcs.Repository.Repair
    ( replayRepository, checkIndex, replayRepositoryInTemp
    , RepositoryConsistency(..)
    )
import Darcs.Repository
    ( withRepository, RepoJob(..)
    , withRepoLock, writePristine
    , finalizeRepositoryChanges
    )
import Darcs.Repository.Hashed ( writeTentativeInventory )
import Darcs.Repository.Pending ( setTentativePending )

import Darcs.Patch ( displayPatch )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )

import Darcs.Util.Printer ( Doc, text, ($$) )


repairDescription :: String
repairDescription :: String
repairDescription = String
"Repair a corrupted repository."

repairHelp :: Doc
repairHelp :: Doc
repairHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
  String
"The `darcs repair` command attempts to fix corruption in the current\n\
  \repository.\n\
  \It works by successively applying all patches in the repository to an\n\
  \empty tree, each time checking that the patch can be cleanly applied\n\
  \to the current pristine tree. If we detect a problem, we try to repair\n\
  \the patch. Finally we compare the existing pristine with the newly\n\
  \reconstructed one and if they differ, replace the existing one.\n\
  \Any problem encountered is reported.\n\
  \The flag `--dry-run` makes this operation read-only and causes it to\n\
  \exit unsuccessfully (with a non-zero exit status) in case any problems\n\
  \are enountered.\n"

commonBasicOpts :: DarcsOption a
                   (Maybe String -> O.DiffAlgorithm -> a)
commonBasicOpts :: forall a. DarcsOption a (Maybe String -> DiffAlgorithm -> a)
commonBasicOpts = PrimOptSpec DarcsOptDescr Flag (DiffAlgorithm -> a) (Maybe String)
PrimDarcsOption (Maybe String)
O.repoDir PrimOptSpec DarcsOptDescr Flag (DiffAlgorithm -> a) (Maybe String)
-> OptSpec DarcsOptDescr Flag a (DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr Flag a (Maybe String -> DiffAlgorithm -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr Flag a (DiffAlgorithm -> a)
PrimDarcsOption DiffAlgorithm
O.diffAlgorithm

repair :: DarcsCommand
repair :: DarcsCommand
repair = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"repair"
    , commandHelp :: Doc
commandHelp = Doc
repairHelp
    , commandDescription :: String
commandDescription = String
repairDescription
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [Flag] -> [String] -> IO ()
commandCommand = ([Flag] -> IO ())
-> (AbsolutePath, AbsolutePath) -> [Flag] -> [String] -> IO ()
forall b d a c. (b -> d) -> a -> b -> c -> d
withFpsAndArgs [Flag] -> IO ()
repairCmd
    , commandPrereq :: [Flag] -> IO (Either String ())
commandPrereq = [Flag] -> IO (Either String ())
amInHashedRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath) -> [Flag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath) -> [Flag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [Flag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [Flag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , CommandOptions
commandOptions :: CommandOptions
commandOptions :: CommandOptions
..
    }
  where
    basicOpts :: OptSpec
  DarcsOptDescr Flag a (Maybe String -> DiffAlgorithm -> DryRun -> a)
basicOpts = DarcsOption
  (DryRun -> a) (Maybe String -> DiffAlgorithm -> DryRun -> a)
forall a. DarcsOption a (Maybe String -> DiffAlgorithm -> a)
commonBasicOpts DarcsOption
  (DryRun -> a) (Maybe String -> DiffAlgorithm -> DryRun -> a)
-> OptSpec DarcsOptDescr Flag a (DryRun -> a)
-> OptSpec
     DarcsOptDescr Flag a (Maybe String -> DiffAlgorithm -> DryRun -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr Flag a (DryRun -> a)
PrimDarcsOption DryRun
O.dryRun
    advancedOpts :: PrimOptSpec DarcsOptDescr Flag a UMask
advancedOpts = PrimOptSpec DarcsOptDescr Flag a UMask
PrimDarcsOption UMask
O.umask
    allOpts :: CommandOptions
allOpts = OptSpec
  DarcsOptDescr
  Flag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [Flag])
  (Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [Flag])
forall {a}.
OptSpec
  DarcsOptDescr Flag a (Maybe String -> DiffAlgorithm -> DryRun -> a)
basicOpts OptSpec
  DarcsOptDescr
  Flag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [Flag])
  (Maybe String
   -> DiffAlgorithm
   -> DryRun
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [Flag])
-> DarcsOption
     (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [Flag])
     (UMask
      -> UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [Flag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [Flag]) b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [Flag])
  (UMask
   -> UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [Flag])
PrimDarcsOption UMask
advancedOpts
    commandOptions :: CommandOptions
commandOptions = CommandOptions
allOpts

withFpsAndArgs :: (b -> d) -> a -> b -> c -> d
withFpsAndArgs :: forall b d a c. (b -> d) -> a -> b -> c -> d
withFpsAndArgs b -> d
cmd a
_ b
opts c
_ = b -> d
cmd b
opts

maybeDo :: Monad m => Maybe t -> (t -> m ()) -> m ()
maybeDo :: forall (m :: * -> *) t. Monad m => Maybe t -> (t -> m ()) -> m ()
maybeDo (Just t
x) t -> m ()
f = t -> m ()
f t
x
maybeDo Maybe t
Nothing t -> m ()
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

repairCmd :: [DarcsFlag] -> IO ()
repairCmd :: [Flag] -> IO ()
repairCmd [Flag]
opts
  | DryRun -> Bool
forall a. YesNo a => a -> Bool
O.yes (PrimOptSpec DarcsOptDescr Flag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [Flag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) = [Flag] -> IO ()
checkCmd [Flag]
opts
  | Bool
otherwise =
    UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr Flag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [Flag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) (PrimOptSpec DarcsOptDescr Flag a UMask
PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [Flag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
    TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RW p wU wR
repo -> do
      Bool
bad_replay <- DiffAlgorithm
-> Repository 'RW p wU wR
-> Verbosity
-> (RepositoryConsistency p wR -> IO Bool)
-> IO Bool
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
        (PrimOptSpec DarcsOptDescr Flag a DiffAlgorithm
PrimDarcsOption DiffAlgorithm
diffAlgorithm PrimDarcsOption DiffAlgorithm -> [Flag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts)
        Repository 'RW p wU wR
repo
        (PrimOptSpec DarcsOptDescr Flag a Verbosity
PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [Flag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) ((RepositoryConsistency p wR -> IO Bool) -> IO Bool)
-> (RepositoryConsistency p wR -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \RepositoryConsistency {Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
Maybe (Sealed (FL (PrimOf p) wR))
Maybe (PatchSet p Origin wR)
fixedPristine :: Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
fixedPatches :: Maybe (PatchSet p Origin wR)
fixedPending :: Maybe (Sealed (FL (PrimOf p) wR))
fixedPristine :: forall (p :: * -> * -> *) wR.
RepositoryConsistency p wR
-> Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
fixedPatches :: forall (p :: * -> * -> *) wR.
RepositoryConsistency p wR -> Maybe (PatchSet p Origin wR)
fixedPending :: forall (p :: * -> * -> *) wR.
RepositoryConsistency p wR -> Maybe (Sealed (FL (PrimOf p) wR))
..} -> do
          Maybe (PatchSet p Origin wR)
-> (PatchSet p Origin wR -> IO ()) -> IO ()
forall (m :: * -> *) t. Monad m => Maybe t -> (t -> m ()) -> m ()
maybeDo Maybe (PatchSet p Origin wR)
fixedPatches ((PatchSet p Origin wR -> IO ()) -> IO ())
-> (PatchSet p Origin wR -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PatchSet p Origin wR
ps -> do
            [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"Writing out repaired patches..."
            Repository 'RW p wU wR -> PatchSet p Origin wR -> IO ()
forall (p :: * -> * -> *) wU wR wX.
RepoPatch p =>
Repository 'RW p wU wR -> PatchSet p Origin wX -> IO ()
writeTentativeInventory Repository 'RW p wU wR
repo PatchSet p Origin wR
ps
          Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
-> ((Tree IO, Sealed (FL (PrimOf p) wR)) -> IO ()) -> IO ()
forall (m :: * -> *) t. Monad m => Maybe t -> (t -> m ()) -> m ()
maybeDo Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
fixedPristine (((Tree IO, Sealed (FL (PrimOf p) wR)) -> IO ()) -> IO ())
-> ((Tree IO, Sealed (FL (PrimOf p) wR)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Tree IO
tree, Sealed FL (PrimOf p) wR wX
diff) -> do
            [Flag] -> Doc -> IO ()
putVerbose [Flag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"Pristine differences:" Doc -> Doc -> Doc
$$ FL (PrimOf p) wR wX -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimOf p) wR wX
diff
            [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"Fixing pristine tree..."
            IO PristineHash -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO PristineHash -> IO ()) -> IO PristineHash -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RW p wU wR -> Tree IO -> IO PristineHash
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Tree IO -> IO PristineHash
writePristine Repository 'RW p wU wR
repo Tree IO
tree
          Maybe (Sealed (FL (PrimOf p) wR))
-> (Sealed (FL (PrimOf p) wR) -> IO ()) -> IO ()
forall (m :: * -> *) t. Monad m => Maybe t -> (t -> m ()) -> m ()
maybeDo Maybe (Sealed (FL (PrimOf p) wR))
fixedPending ((Sealed (FL (PrimOf p) wR) -> IO ()) -> IO ())
-> (Sealed (FL (PrimOf p) wR) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Sealed FL (PrimOf p) wR wX
pend) -> do
            [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"Writing out repaired pending..."
            Repository 'RW p wU wR -> FL (PrimOf p) wR wX -> IO ()
forall (p :: * -> * -> *) wU wR wP.
RepoPatch p =>
Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
setTentativePending Repository 'RW p wU wR
repo FL (PrimOf p) wR wX
pend
          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
$ Maybe (PatchSet p Origin wR) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (PatchSet p Origin wR)
fixedPatches Bool -> Bool -> Bool
|| Maybe (Tree IO, Sealed (FL (PrimOf p) wR)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
fixedPristine Bool -> Bool -> Bool
|| Maybe (Sealed (FL (PrimOf p) wR)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Sealed (FL (PrimOf p) wR))
fixedPending
      Bool
index_ok <- Repository 'RW p wU wR -> Bool -> IO Bool
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> Bool -> IO Bool
checkIndex Repository 'RW p wU wR
repo ([Flag] -> Bool
quiet [Flag]
opts)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
index_ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> String -> IO ()
renameFile String
indexPath (String
indexPath String -> String -> String
<.> String
"bad")
        [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"Bad index discarded."
      if Bool
bad_replay Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
index_ok
        then IO (Repository 'RO p wU wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository 'RO p wU wR) -> IO ())
-> IO (Repository 'RO p wU wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
finalizeRepositoryChanges Repository 'RW p wU wR
repo (PrimOptSpec DarcsOptDescr Flag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [Flag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts)
        else [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"The repository is already consistent, no changes made."

-- |check is an alias for repair, with implicit DryRun flag.
check :: DarcsCommand
check :: DarcsCommand
check = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"check"
    , commandHelp :: Doc
commandHelp = Doc
"See `darcs repair` for details."
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [Flag] -> [String] -> IO ()
commandCommand = ([Flag] -> IO ())
-> (AbsolutePath, AbsolutePath) -> [Flag] -> [String] -> IO ()
forall b d a c. (b -> d) -> a -> b -> c -> d
withFpsAndArgs [Flag] -> IO ()
checkCmd
    , commandPrereq :: [Flag] -> IO (Either String ())
commandPrereq = [Flag] -> IO (Either String ())
amInHashedRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath) -> [Flag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath) -> [Flag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [Flag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [Flag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , String
CommandOptions
commandDescription :: String
commandOptions :: CommandOptions
commandOptions :: CommandOptions
commandDescription :: String
..
    }
  where
    basicOpts :: DarcsOption a (Maybe String -> DiffAlgorithm -> a)
basicOpts = DarcsOption a (Maybe String -> DiffAlgorithm -> a)
forall a. DarcsOption a (Maybe String -> DiffAlgorithm -> a)
commonBasicOpts
    advancedOpts :: OptSpec d f a a
advancedOpts = OptSpec d f a a
forall (d :: * -> *) f a. OptSpec d f a a
oid
    allOpts :: CommandOptions
allOpts = DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [Flag])
  (Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [Flag])
forall a. DarcsOption a (Maybe String -> DiffAlgorithm -> a)
basicOpts DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [Flag])
  (Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [Flag])
-> DarcsOption
     (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [Flag])
     (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [Flag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [Flag]) b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [Flag])
  (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [Flag])
forall (d :: * -> *) f a. OptSpec d f a a
advancedOpts
    commandOptions :: CommandOptions
commandOptions = CommandOptions
allOpts
    commandDescription :: String
commandDescription = String
"Alias for `darcs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand -> String
commandName DarcsCommand
repair String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" --dry-run'."

checkCmd :: [DarcsFlag] -> IO ()
checkCmd :: [Flag] -> IO ()
checkCmd [Flag]
opts = UseCache -> RepoJob 'RO () -> IO ()
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository (PrimOptSpec DarcsOptDescr Flag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [Flag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) (RepoJob 'RO () -> IO ()) -> RepoJob 'RO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RO () -> RepoJob 'RO ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RO () -> RepoJob 'RO ())
-> TreePatchJob 'RO () -> RepoJob 'RO ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RO p wU wR
repository -> do
  RepositoryConsistency {Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
Maybe (Sealed (FL (PrimOf p) wR))
Maybe (PatchSet p Origin wR)
fixedPristine :: forall (p :: * -> * -> *) wR.
RepositoryConsistency p wR
-> Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
fixedPatches :: forall (p :: * -> * -> *) wR.
RepositoryConsistency p wR -> Maybe (PatchSet p Origin wR)
fixedPending :: forall (p :: * -> * -> *) wR.
RepositoryConsistency p wR -> Maybe (Sealed (FL (PrimOf p) wR))
fixedPristine :: Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
fixedPatches :: Maybe (PatchSet p Origin wR)
fixedPending :: Maybe (Sealed (FL (PrimOf p) wR))
..} <-
    DiffAlgorithm
-> Repository 'RO p wU wR
-> Verbosity
-> IO (RepositoryConsistency p wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> Repository rt p wU wR
-> Verbosity
-> IO (RepositoryConsistency p wR)
replayRepositoryInTemp (PrimOptSpec DarcsOptDescr Flag a DiffAlgorithm
PrimDarcsOption DiffAlgorithm
diffAlgorithm PrimDarcsOption DiffAlgorithm -> [Flag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) Repository 'RO p wU wR
repository (PrimOptSpec DarcsOptDescr Flag a Verbosity
PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [Flag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts)
  Maybe (PatchSet p Origin wR)
-> (PatchSet p Origin wR -> IO ()) -> IO ()
forall (m :: * -> *) t. Monad m => Maybe t -> (t -> m ()) -> m ()
maybeDo Maybe (PatchSet p Origin wR)
fixedPatches ((PatchSet p Origin wR -> IO ()) -> IO ())
-> (PatchSet p Origin wR -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PatchSet p Origin wR
_ ->
    [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"Found broken patches."
  Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
-> ((Tree IO, Sealed (FL (PrimOf p) wR)) -> IO ()) -> IO ()
forall (m :: * -> *) t. Monad m => Maybe t -> (t -> m ()) -> m ()
maybeDo Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
fixedPristine (((Tree IO, Sealed (FL (PrimOf p) wR)) -> IO ()) -> IO ())
-> ((Tree IO, Sealed (FL (PrimOf p) wR)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Tree IO
_, Sealed FL (PrimOf p) wR wX
diff) -> do
    [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"Found broken pristine tree."
    [Flag] -> Doc -> IO ()
putVerbose [Flag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"Differences:" Doc -> Doc -> Doc
$$ FL (PrimOf p) wR wX -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimOf p) wR wX
diff
  Maybe (Sealed (FL (PrimOf p) wR))
-> (Sealed (FL (PrimOf p) wR) -> IO ()) -> IO ()
forall (m :: * -> *) t. Monad m => Maybe t -> (t -> m ()) -> m ()
maybeDo Maybe (Sealed (FL (PrimOf p) wR))
fixedPending ((Sealed (FL (PrimOf p) wR) -> IO ()) -> IO ())
-> (Sealed (FL (PrimOf p) wR) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Sealed (FL (PrimOf p) wR)
_ ->
    [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"Found broken pending."
  Bool
bad_index <-
    if PrimOptSpec DarcsOptDescr Flag a UseIndex
PrimDarcsOption UseIndex
useIndex PrimDarcsOption UseIndex -> [Flag] -> UseIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts UseIndex -> UseIndex -> Bool
forall a. Eq a => a -> a -> Bool
== UseIndex
O.IgnoreIndex
      then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      else
        Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          Repository 'RO p wU wR -> Bool -> IO Bool
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> Bool -> IO Bool
checkIndex Repository 'RO p wU wR
repository ([Flag] -> Bool
quiet [Flag]
opts) IO Bool -> (IOError -> IO Bool) -> IO Bool
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
e -> do
            [Flag] -> Doc -> IO ()
putWarning [Flag]
opts (Doc
"Warning, cannot access the index:" Doc -> Doc -> Doc
$$ String -> Doc
text (IOError -> String
forall a. Show a => a -> String
show IOError
e))
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bad_index (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"Bad index."
  if Maybe (PatchSet p Origin wR) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (PatchSet p Origin wR)
fixedPatches Bool -> Bool -> Bool
|| Maybe (Tree IO, Sealed (FL (PrimOf p) wR)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Tree IO, Sealed (FL (PrimOf p) wR))
fixedPristine Bool -> Bool -> Bool
|| Maybe (Sealed (FL (PrimOf p) wR)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Sealed (FL (PrimOf p) wR))
fixedPending Bool -> Bool -> Bool
|| Bool
bad_index
    then IO ()
forall a. IO a
exitFailure
    else [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"The repository is consistent!"