--  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 )
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, putWarning, amInHashedRepository
    )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
    ( DarcsFlag, verbosity, umask, useIndex
    , useCache, compress, diffAlgorithm, quiet
    )
import Darcs.UI.Options
    ( DarcsOption, (^), oid
    , odesc, ocheck, defaultFlags, (?)
    )
import qualified Darcs.UI.Options.All as O

import Darcs.Repository.Flags ( UpdatePending (..) )
import Darcs.Repository.Paths ( indexPath )
import Darcs.Repository.Repair
    ( replayRepository, checkIndex, replayRepositoryInTemp
    , RepositoryConsistency(..)
    )
import Darcs.Repository
    ( Repository, withRepository, readRecorded, RepoJob(..)
    , withRepoLock, replacePristine, repoCache
    )
import qualified Darcs.Repository.Hashed as HashedRepo
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Repository.Diff( treeDiff )

import Darcs.Patch ( RepoPatch, PrimOf, displayPatch )
import Darcs.Patch.Witnesses.Ordered ( FL(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )

import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.Tree ( Tree, expand )
import Darcs.Util.Tree.Hashed ( darcsUpdateHashes )


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.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
repair :: DarcsCommand
repair = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath) -> [Flag] -> [String] -> IO ())
-> ([Flag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [Flag] -> [String] -> IO [String])
-> ([Flag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr Flag]
-> [DarcsOptDescr Flag]
-> [Flag]
-> ([Flag] -> [String])
-> DarcsCommand
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
    , [DarcsOptDescr Flag]
[Flag]
[Flag] -> [String]
commandCheckOptions :: [Flag] -> [String]
commandDefaults :: [Flag]
commandAdvancedOptions :: [DarcsOptDescr Flag]
commandBasicOptions :: [DarcsOptDescr Flag]
commandCheckOptions :: [Flag] -> [String]
commandDefaults :: [Flag]
commandBasicOptions :: [DarcsOptDescr Flag]
commandAdvancedOptions :: [DarcsOptDescr Flag]
..
    }
  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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
allOpts = OptSpec
  DarcsOptDescr
  Flag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> DryRun
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  Flag
  a
  (Maybe String -> UseIndex -> DiffAlgorithm -> DryRun -> a)
basicOpts OptSpec
  DarcsOptDescr
  Flag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> DryRun
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe String
      -> UseIndex
      -> DiffAlgorithm
      -> DryRun
      -> Maybe StdCmdAction
      -> Verbosity
      -> UMask
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UMask -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> 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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [Flag])
-> [Flag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  Flag
  [Flag]
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> DryRun
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [Flag])
forall a.
DarcsOption
  a
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> DryRun
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
allOpts
    commandCheckOptions :: [Flag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  Flag
  Any
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> DryRun
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> DryRun
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
allOpts

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

repairCmd :: [DarcsFlag] -> IO ()
repairCmd :: [Flag] -> IO ()
repairCmd [Flag]
opts
  | DryRun -> Bool
forall a. YesNo a => a -> Bool
O.yes (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 =
    DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdatePending -> 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) UpdatePending
YesUpdatePending (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 rt p wR wU wR
repo -> 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
repo
        (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
$ \RepositoryConsistency rt p wR
state ->
        case RepositoryConsistency rt p wR
state of
          RepositoryConsistency rt p wR
RepositoryConsistent ->
            [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"The repository is already consistent, no changes made."
          BrokenPristine Tree IO
tree -> do
            [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"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
repo Tree IO
tree
          BrokenPatches Tree IO
tree PatchSet rt p Origin wR
newps -> do
            [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"Writing out repaired patches..."
            Cache -> Compression -> PatchSet rt p Origin wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX.
RepoPatch p =>
Cache -> Compression -> PatchSet rt p Origin wX -> IO ()
HashedRepo.writeTentativeInventory (Repository rt p wR wU wR -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wR
repo) (PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [Flag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts) PatchSet rt p Origin wR
newps
            Repository rt p wR wU wR -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> Compression -> IO ()
HashedRepo.finalizeTentativeChanges Repository rt p wR wU wR
repo (PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [Flag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [Flag]
opts)
            [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"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
repo Tree IO
tree
      Bool
index_ok <- Repository rt p wR wU wR -> Bool -> IO Bool
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> Bool -> IO Bool
checkIndex Repository rt p wR wU wR
repo ([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."

-- |check is an alias for repair, with implicit DryRun flag.
check :: DarcsCommand
check :: DarcsCommand
check = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath) -> [Flag] -> [String] -> IO ())
-> ([Flag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [Flag] -> [String] -> IO [String])
-> ([Flag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr Flag]
-> [DarcsOptDescr Flag]
-> [Flag]
-> ([Flag] -> [String])
-> DarcsCommand
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
[DarcsOptDescr Flag]
[Flag]
[Flag] -> [String]
forall (d :: * -> *) f. [d f]
commandDescription :: String
commandCheckOptions :: [Flag] -> [String]
commandDefaults :: [Flag]
commandBasicOptions :: [DarcsOptDescr Flag]
commandAdvancedOptions :: forall (d :: * -> *) f. [d f]
commandCheckOptions :: [Flag] -> [String]
commandDefaults :: [Flag]
commandAdvancedOptions :: [DarcsOptDescr Flag]
commandBasicOptions :: [DarcsOptDescr Flag]
commandDescription :: String
..
    }
  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
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
allOpts = DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
DarcsOption a (Maybe String -> UseIndex -> DiffAlgorithm -> a)
basicOpts DarcsOption
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe String
      -> UseIndex
      -> DiffAlgorithm
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> 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
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [Flag])
-> [Flag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  Flag
  [Flag]
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [Flag])
forall a.
DarcsOption
  a
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
allOpts
    commandCheckOptions :: [Flag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  Flag
  Any
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> UseIndex
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
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 () -> 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 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
      RepositoryConsistency rt p wR
RepositoryConsistent -> do
        [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"The repository is consistent!"
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      BrokenPristine 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 Tree IO
newpris PatchSet rt p Origin wR
_ -> 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
"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.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> 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
"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 Int
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 [Flag]
opts Repository rt p wR wU wT
repository Tree IO
newpris = do
  [Flag] -> Doc -> IO ()
putInfo [Flag]
opts Doc
"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 (Tree IO) -> (Tree IO -> IO (Tree IO)) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand IO (Tree IO) -> (Tree IO -> IO (Tree IO)) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsUpdateHashes))
      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
    Maybe (Tree IO)
Nothing -> do
      [Flag] -> Doc -> IO ()
putWarning [Flag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
"Unable to read the recorded state, try repair."
    Just 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
        FL (PrimOf p) wR wX
NilFL -> Doc
"Nothing"
        FL (PrimOf p) wR wX
patch -> FL (PrimOf p) wR wX -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimOf p) wR wX
patch