{-# LANGUAGE RecordWildCards #-}
module Darcs.UI.Commands.Repair ( repair, check ) where
import Prelude ()
import Darcs.Prelude
import Control.Monad ( when, unless )
import Control.Exception ( catch, IOException )
import System.Exit ( ExitCode(..), exitWith )
import System.Directory( renameFile )
import System.FilePath ( (</>) )
import Darcs.UI.Commands
( DarcsCommand(..), withStdOpts, nodefaults
, putInfo, amInHashedRepository
)
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
( DarcsFlag, verbosity, dryRun, umask, useIndex
, useCache, compress, diffAlgorithm, quiet
)
import Darcs.UI.Options
( DarcsOption, (^), oid
, odesc, ocheck, onormalise, defaultFlags, (?)
)
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdateWorking (..) )
import Darcs.Repository.Repair
( replayRepository, checkIndex, replayRepositoryInTemp
, RepositoryConsistency(..)
)
import Darcs.Repository
( Repository, withRepository, readRecorded, RepoJob(..)
, withRepoLock, replacePristine, writePatchSet
)
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Repository.Diff( treeDiff )
import Darcs.Patch ( RepoPatch, showNicely, PrimOf )
import Darcs.Patch.Witnesses.Ordered ( FL(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Printer ( text, ($$), (<+>) )
import Darcs.Util.Tree( Tree )
repairDescription :: String
repairDescription :: String
repairDescription = "Repair a corrupted repository."
repairHelp :: String
repairHelp :: String
repairHelp =
"The `darcs repair` command attempts to fix corruption in the current\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"repository. Currently it can only repair damage to the pristine tree,\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"which is where most corruption occurs.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"This command rebuilds a pristine tree by applying successively the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"patches in the repository to an empty tree.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"The flag `--dry-run` make this operation read-only, making darcs exit\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"unsuccessfully (with a non-zero exit status) if the rebuilt pristine is\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"different from the current pristine.\n"
commonBasicOpts :: DarcsOption a
(Maybe String -> O.UseIndex -> O.DiffAlgorithm -> a)
commonBasicOpts :: DarcsOption a (Maybe String -> UseIndex -> DiffAlgorithm -> a)
commonBasicOpts = PrimOptSpec
DarcsOptDescr Flag (UseIndex -> DiffAlgorithm -> a) (Maybe String)
PrimDarcsOption (Maybe String)
O.repoDir PrimOptSpec
DarcsOptDescr Flag (UseIndex -> DiffAlgorithm -> a) (Maybe String)
-> OptSpec
DarcsOptDescr
Flag
(DiffAlgorithm -> a)
(UseIndex -> DiffAlgorithm -> a)
-> OptSpec
DarcsOptDescr
Flag
(DiffAlgorithm -> a)
(Maybe String -> UseIndex -> 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
(DiffAlgorithm -> a)
(UseIndex -> DiffAlgorithm -> a)
PrimDarcsOption UseIndex
O.useIndex OptSpec
DarcsOptDescr
Flag
(DiffAlgorithm -> a)
(Maybe String -> UseIndex -> DiffAlgorithm -> a)
-> OptSpec DarcsOptDescr Flag a (DiffAlgorithm -> a)
-> DarcsOption a (Maybe String -> UseIndex -> 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 [DarcsFlag]
repair :: DarcsCommand [Flag]
repair = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
-> parsedFlags -> [String] -> IO ())
-> ([Flag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
-> [Flag] -> [String] -> IO [String])
-> ([Flag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr Flag]
-> [DarcsOptDescr Flag]
-> [Flag]
-> ([Flag] -> [String])
-> ([Flag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
{ commandProgramName :: String
commandProgramName = "darcs"
, commandName :: String
commandName = "repair"
, commandHelp :: String
commandHelp = String
repairHelp
, commandDescription :: String
commandDescription = String
repairDescription
, commandExtraArgs :: Int
commandExtraArgs = 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
, ..
}
where
basicOpts :: OptSpec
DarcsOptDescr
Flag
a
(Maybe String -> UseIndex -> DiffAlgorithm -> DryRun -> a)
basicOpts = DarcsOption
(DryRun -> a)
(Maybe String -> UseIndex -> DiffAlgorithm -> DryRun -> a)
forall a.
DarcsOption a (Maybe String -> UseIndex -> DiffAlgorithm -> a)
commonBasicOpts DarcsOption
(DryRun -> a)
(Maybe String -> UseIndex -> DiffAlgorithm -> DryRun -> a)
-> OptSpec DarcsOptDescr Flag a (DryRun -> a)
-> OptSpec
DarcsOptDescr
Flag
a
(Maybe String -> UseIndex -> 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 :: DarcsOption
a
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
allOpts = OptSpec
DarcsOptDescr
Flag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
forall a.
OptSpec
DarcsOptDescr
Flag
a
(Maybe String -> UseIndex -> DiffAlgorithm -> DryRun -> a)
basicOpts OptSpec
DarcsOptDescr
Flag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
-> DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
a
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
forall b c a.
DarcsOption
(Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
PrimDarcsOption UMask
advancedOpts
commandAdvancedOptions :: [DarcsOptDescr Flag]
commandAdvancedOptions = OptSpec DarcsOptDescr Flag Any (UMask -> Any)
-> [DarcsOptDescr Flag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr Flag Any (UMask -> Any)
PrimDarcsOption UMask
advancedOpts
commandBasicOptions :: [DarcsOptDescr Flag]
commandBasicOptions = OptSpec
DarcsOptDescr
Flag
Any
(Maybe String -> UseIndex -> DiffAlgorithm -> DryRun -> Any)
-> [DarcsOptDescr Flag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
DarcsOptDescr
Flag
Any
(Maybe String -> UseIndex -> DiffAlgorithm -> DryRun -> Any)
forall a.
OptSpec
DarcsOptDescr
Flag
a
(Maybe String -> UseIndex -> DiffAlgorithm -> DryRun -> a)
basicOpts
commandDefaults :: [Flag]
commandDefaults = OptSpec
DarcsOptDescr
Flag
[Flag]
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [Flag])
-> [Flag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
DarcsOptDescr
Flag
[Flag]
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [Flag])
forall a.
DarcsOption
a
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
allOpts
commandCheckOptions :: [Flag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
Flag
Any
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> Any)
-> [Flag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
DarcsOptDescr
Flag
Any
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
allOpts
commandParseOptions :: [Flag] -> [Flag]
commandParseOptions = OptSpec
DarcsOptDescr
Flag
[Flag]
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [Flag])
-> [Flag] -> [Flag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
DarcsOptDescr
Flag
[Flag]
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [Flag])
forall a.
DarcsOption
a
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> DryRun
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
allOpts
withFpsAndArgs :: (b -> d) -> a -> b -> c -> d
withFpsAndArgs :: (b -> d) -> a -> b -> c -> d
withFpsAndArgs cmd :: b -> d
cmd _ opts :: b
opts _ = b -> d
cmd b
opts
repairCmd :: [DarcsFlag] -> IO ()
repairCmd :: [Flag] -> IO ()
repairCmd opts :: [Flag]
opts = case PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [Flag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts of
O.YesDryRun -> [Flag] -> IO ()
checkCmd [Flag]
opts
O.NoDryRun ->
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
O.NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [Flag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [Flag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts)
(RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
DiffAlgorithm
-> Repository rt p wR wU wR
-> Compression
-> Verbosity
-> (RepositoryConsistency rt p wR -> IO ())
-> IO ()
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 (PrimDarcsOption DiffAlgorithm
diffAlgorithm PrimDarcsOption DiffAlgorithm -> [Flag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) Repository rt p wR wU wR
repository (PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [Flag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [Flag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) ((RepositoryConsistency rt p wR -> IO ()) -> IO ())
-> (RepositoryConsistency rt p wR -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \state :: RepositoryConsistency rt p wR
state ->
case RepositoryConsistency rt p wR
state of
RepositoryConsistent ->
String -> IO ()
putStrLn "The repository is already consistent, no changes made."
BrokenPristine tree :: Tree IO
tree -> do
String -> IO ()
putStrLn "Fixing pristine tree..."
Repository rt p wR wU wR -> Tree IO -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Tree IO -> IO ()
replacePristine Repository rt p wR wU wR
repository Tree IO
tree
BrokenPatches tree :: Tree IO
tree newps :: PatchSet rt p Origin wR
newps -> do
String -> IO ()
putStrLn "Writing out repaired patches..."
Repository rt p Any Any Any
_ <- PatchSet rt p Origin wR
-> UseCache -> IO (Repository rt p Any Any Any)
forall (rt :: RepoType) (p :: * -> * -> *) wX wR wU wT.
(IsRepoType rt, RepoPatch p) =>
PatchSet rt p Origin wX
-> UseCache -> IO (Repository rt p wR wU wT)
writePatchSet PatchSet rt p Origin wR
newps (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [Flag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts)
String -> IO ()
putStrLn "Fixing pristine tree..."
Repository rt p wR wU wR -> Tree IO -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Tree IO -> IO ()
replacePristine Repository rt p wR wU wR
repository Tree IO
tree
Bool
index_ok <- Repository rt p wR wU wR -> Bool -> IO Bool
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> Bool -> IO Bool
checkIndex Repository rt p wR wU wR
repository ([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
darcsdir String -> String -> String
</> "index") (String
darcsdir String -> String -> String
</> "index.bad")
String -> IO ()
putStrLn "Bad index discarded."
check :: DarcsCommand [DarcsFlag]
check :: DarcsCommand [Flag]
check = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
-> parsedFlags -> [String] -> IO ())
-> ([Flag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
-> [Flag] -> [String] -> IO [String])
-> ([Flag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr Flag]
-> [DarcsOptDescr Flag]
-> [Flag]
-> ([Flag] -> [String])
-> ([Flag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
{ commandProgramName :: String
commandProgramName = "darcs"
, commandName :: String
commandName = "check"
, commandHelp :: String
commandHelp = "See `darcs repair` for details."
, commandExtraArgs :: Int
commandExtraArgs = 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
, ..
}
where
basicOpts :: DarcsOption a (Maybe String -> UseIndex -> DiffAlgorithm -> a)
basicOpts = DarcsOption a (Maybe String -> UseIndex -> DiffAlgorithm -> a)
forall a.
DarcsOption a (Maybe String -> UseIndex -> 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 :: DarcsOption
a
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
allOpts = DarcsOption
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
forall a.
DarcsOption a (Maybe String -> UseIndex -> DiffAlgorithm -> a)
basicOpts DarcsOption
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
-> DarcsOption
(UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
-> DarcsOption
a
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
forall b c a.
DarcsOption
(Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
(UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
forall (d :: * -> *) f a. OptSpec d f a a
advancedOpts
commandAdvancedOptions :: [d f]
commandAdvancedOptions = OptSpec d f Any Any -> [d f]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec d f Any Any
forall (d :: * -> *) f a. OptSpec d f a a
advancedOpts
commandBasicOptions :: [DarcsOptDescr Flag]
commandBasicOptions = OptSpec
DarcsOptDescr
Flag
Any
(Maybe String -> UseIndex -> DiffAlgorithm -> Any)
-> [DarcsOptDescr Flag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
DarcsOptDescr
Flag
Any
(Maybe String -> UseIndex -> DiffAlgorithm -> Any)
forall a.
DarcsOption a (Maybe String -> UseIndex -> DiffAlgorithm -> a)
basicOpts
commandDefaults :: [Flag]
commandDefaults = OptSpec
DarcsOptDescr
Flag
[Flag]
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [Flag])
-> [Flag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
DarcsOptDescr
Flag
[Flag]
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [Flag])
forall a.
DarcsOption
a
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
allOpts
commandCheckOptions :: [Flag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
Flag
Any
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> Any)
-> [Flag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
DarcsOptDescr
Flag
Any
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
allOpts
commandParseOptions :: [Flag] -> [Flag]
commandParseOptions = OptSpec
DarcsOptDescr
Flag
[Flag]
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [Flag])
-> [Flag] -> [Flag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
DarcsOptDescr
Flag
[Flag]
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> [Flag])
forall a.
DarcsOption
a
(Maybe String
-> UseIndex
-> DiffAlgorithm
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UseCache
-> HooksConfig
-> a)
allOpts
commandDescription :: String
commandDescription = "Alias for `darcs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand [Flag] -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand [Flag]
repair String -> String -> String
forall a. [a] -> [a] -> [a]
++ " --dry-run'."
checkCmd :: [DarcsFlag] -> IO ()
checkCmd :: [Flag] -> IO ()
checkCmd opts :: [Flag]
opts = UseCache -> RepoJob () -> IO ()
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [Flag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
RepositoryConsistency rt p wR
state <- DiffAlgorithm
-> Repository rt p wR wU wR
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
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 (PrimDarcsOption DiffAlgorithm
diffAlgorithm PrimDarcsOption DiffAlgorithm -> [Flag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) Repository rt p wR wU wR
repository (PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [Flag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [Flag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts)
Bool
failed <-
case RepositoryConsistency rt p wR
state of
RepositoryConsistent -> do
[Flag] -> Doc -> IO ()
putInfo [Flag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "The repository is consistent!"
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
BrokenPristine newpris :: Tree IO
newpris -> do
[Flag] -> Repository rt p wR wU wR -> Tree IO -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
RepoPatch p =>
[Flag] -> Repository rt p wR wU wT -> Tree IO -> IO ()
brokenPristine [Flag]
opts Repository rt p wR wU wR
repository Tree IO
newpris
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
BrokenPatches newpris :: Tree IO
newpris _ -> do
[Flag] -> Repository rt p wR wU wR -> Tree IO -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
RepoPatch p =>
[Flag] -> Repository rt p wR wU wT -> Tree IO -> IO ()
brokenPristine [Flag]
opts Repository rt p wR wU wR
repository Tree IO
newpris
[Flag] -> Doc -> IO ()
putInfo [Flag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Found broken patches."
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Bool
bad_index <- if 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 (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
<$> Repository rt p wR wU wR -> Bool -> IO Bool
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> Bool -> IO Bool
checkIndex Repository rt p wR wU wR
repository ([Flag] -> Bool
quiet [Flag]
opts)
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 -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Bad index."
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
failed Bool -> Bool -> Bool
|| Bool
bad_index then Int -> ExitCode
ExitFailure 1 else ExitCode
ExitSuccess
brokenPristine
:: forall rt p wR wU wT . (RepoPatch p)
=> [DarcsFlag] -> Repository rt p wR wU wT -> Tree IO -> IO ()
brokenPristine :: [Flag] -> Repository rt p wR wU wT -> Tree IO -> IO ()
brokenPristine opts :: [Flag]
opts repository :: Repository rt p wR wU wT
repository newpris :: Tree IO
newpris = do
[Flag] -> Doc -> IO ()
putInfo [Flag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Looks like we have a difference..."
Maybe (Tree IO)
mc' <- (Tree IO -> Maybe (Tree IO)
forall a. a -> Maybe a
Just (Tree IO -> Maybe (Tree IO))
-> IO (Tree IO) -> IO (Maybe (Tree IO))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Repository rt p wR wU wT -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
repository) IO (Maybe (Tree IO))
-> (IOException -> IO (Maybe (Tree IO))) -> IO (Maybe (Tree IO))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> Maybe (Tree IO) -> IO (Maybe (Tree IO))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tree IO)
forall a. Maybe a
Nothing)
case Maybe (Tree IO)
mc' of
Nothing -> do
[Flag] -> Doc -> IO ()
putInfo [Flag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "cannot compute that difference, try repair"
[Flag] -> Doc -> IO ()
putInfo [Flag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "" Doc -> Doc -> Doc
$$ String -> Doc
text "Inconsistent repository"
Just mc :: Tree IO
mc -> do
String -> FileType
ftf <- IO (String -> FileType)
filetypeFunction
Sealed (diff :: FL (PrimOf p) wR wR2)
<- FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wR)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft (FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wR))
-> IO (FreeLeft (FL (PrimOf p))) -> IO (Sealed (FL (PrimOf p) wR))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DiffAlgorithm
-> (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 (PrimDarcsOption DiffAlgorithm
diffAlgorithm PrimDarcsOption DiffAlgorithm -> [Flag] -> DiffAlgorithm
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) String -> FileType
ftf Tree IO
newpris Tree IO
mc :: IO (Sealed (FL (PrimOf p) wR))
[Flag] -> Doc -> IO ()
putInfo [Flag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ case FL (PrimOf p) wR wX
diff of
NilFL -> String -> Doc
text "Nothing"
patch :: FL (PrimOf p) wR wX
patch -> String -> Doc
text "Difference: " Doc -> Doc -> Doc
<+> FL (PrimOf p) wR wX -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
showNicely FL (PrimOf p) wR wX
patch
[Flag] -> Doc -> IO ()
putInfo [Flag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "" Doc -> Doc -> Doc
$$ String -> Doc
text "Inconsistent repository!"