% 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.
\darcsCommand{check}
\begin{code}
module Darcs.Commands.Check ( check ) where
import Control.Monad ( when )
import Control.Applicative( (<$>) )
import System.Exit ( ExitCode(..), exitWith )
import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo )
import Darcs.Arguments ( DarcsFlag(Quiet),
partialCheck, notest, testByDefault,
leaveTestDir, workingRepoDir, ignoretimes
)
import Darcs.Flags(willIgnoreTimes)
import Darcs.Repository.Repair( replayRepository, checkIndex
, RepositoryConsistency(..) )
import Darcs.Repository ( Repository, amInRepository, withRepository,
testRecorded, readRecorded )
import Darcs.Patch ( RepoPatch, showPatch )
import Darcs.Witnesses.Ordered ( FL(..) )
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Diff( treeDiff )
import Printer ( text, ($$), (<+>) )
checkDescription :: String
checkDescription = "Check the repository for consistency."
checkHelp :: String
checkHelp =
"This command verifies that the patches in the repository, when applied\n" ++
"successively to an empty tree, result in the pristine tree. If not,\n" ++
"the differences are printed and Darcs exits unsucessfully (with a\n" ++
"non-zero exit status).\n" ++
"\n" ++
"If the repository is in darcs-1 format and has a checkpoint, you can\n" ++
"use the --partial option to start checking from the latest checkpoint.\n" ++
"This is the default for partial darcs-1 repositories; the --complete\n" ++
"option to forces a full check.\n" ++
"\n" ++
"If a regression test is defined (see `darcs setpref') it will be run\n" ++
"by `darcs check'. Use the --no-test option to disable this.\n"
check :: DarcsCommand
check = DarcsCommand {commandName = "check",
commandHelp = checkHelp,
commandDescription = checkDescription,
commandExtraArgs = 0,
commandExtraArgHelp = [],
commandCommand = checkCmd,
commandPrereq = amInRepository,
commandGetArgPossibilities = return [],
commandArgdefaults = nodefaults,
commandAdvancedOptions = [],
commandBasicOptions = [partialCheck,
notest,
leaveTestDir,
workingRepoDir,
ignoretimes
]}
checkCmd :: [DarcsFlag] -> [String] -> IO ()
checkCmd opts _ = withRepository opts (check' opts)
check' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()
check' opts repository = do
failed <- replayRepository repository (testByDefault opts) $ \ state -> do
case state of
RepositoryConsistent -> do
putInfo opts $ text "The repository is consistent!"
testRecorded repository
return False
BrokenPristine newpris -> do
brokenPristine newpris
return True
BrokenPatches newpris _ -> do
brokenPristine newpris
putInfo opts $ text "Found broken patches."
return True
bad_index <- case willIgnoreTimes opts of
False -> not <$> checkIndex repository (Quiet `elem` opts)
True -> return False
when bad_index $ putInfo opts $ text "Bad index."
exitWith $ if failed || bad_index then ExitFailure 1 else ExitSuccess
where
brokenPristine newpris = do
putInfo opts $ text "Looks like we have a difference..."
mc <- readRecorded repository
ftf <- filetypeFunction
diff <- treeDiff ftf newpris mc
putInfo opts $ case diff of
NilFL -> text "Nothing"
patch -> text "Difference: " <+> showPatch patch
putInfo opts $ text ""
$$ text "Inconsistent repository!"
\end{code}
%% FIXME: this should go in "common options" or something, since
%% commands like record and amend-record also run the test command.
\input{Darcs/Test.lhs}