--  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 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 is an alias for repair, with implicit DryRun flag.
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!"