% Copyright (C) 20022005 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 021101301, USA.
\subsection{darcs check}
\begin{code}
module Darcs.Commands.Check ( check ) where
import Control.Monad ( when )
import System.Exit ( ExitCode(..), exitWith )
import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.Arguments ( DarcsFlag( Quiet ),
partial_check, notest, testByDefault,
leave_test_dir, working_repo_dir,
)
import Darcs.Repository.Repair( replayRepository,
RepositoryConsistency(..) )
import Darcs.Repository ( Repository, amInRepository, withRepository, slurp_recorded,
testRecorded )
import Darcs.Patch ( RepoPatch, showPatch )
import Darcs.Ordered ( FL(..) )
import Darcs.Diff ( unsafeDiff )
import Darcs.Repository.Prefs ( filetype_function )
import Printer ( putDocLn, text, ($$), (<+>) )
\end{code}
\options{check}
\haskell{check_description}
\begin{code}
check_description :: String
check_description = "Check the repository for consistency."
check_help :: String
check_help =
"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 {command_name = "check",
command_help = check_help,
command_description = check_description,
command_extra_args = 0,
command_extra_arg_help = [],
command_command = check_cmd,
command_prereq = amInRepository,
command_get_arg_possibilities = return [],
command_argdefaults = nodefaults,
command_advanced_options = [],
command_basic_options = [partial_check,
notest,
leave_test_dir,
working_repo_dir
]}
check_cmd :: [DarcsFlag] -> [String] -> IO ()
check_cmd opts _ = withRepository opts (check' opts)
check' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()
check' opts repository = do
replayRepository repository (testByDefault opts) $ \ state -> do
case state of
RepositoryConsistent -> do
putInfo $ text "The repository is consistent!"
testRecorded repository
exitWith ExitSuccess
BrokenPristine newpris -> do
brokenPristine newpris
exitWith $ ExitFailure 1
BrokenPatches newpris _ -> do
brokenPristine newpris
putInfo $ text "Found broken patches."
exitWith $ ExitFailure 1
where
brokenPristine newpris = do
putInfo $ text "Looks like we have a difference..."
mc <- slurp_recorded repository
ftf <- filetype_function
putInfo $ case unsafeDiff opts ftf newpris mc of
NilFL -> text "Nothing"
patch -> text "Difference: " <+> showPatch patch
putInfo $ text ""
$$ text "Inconsistent repository!"
putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s
\end{code}
%% FIXME: this should go in "common options" or something, since
%% commands like record and amendrecord also run the test command.
\input{Darcs/Test.lhs}