1 %  Copyright (C) 2002-2005 David Roundy
    2 %
    3 %  This program is free software; you can redistribute it and/or modify
    4 %  it under the terms of the GNU General Public License as published by
    5 %  the Free Software Foundation; either version 2, or (at your option)
    6 %  any later version.
    7 %
    8 %  This program is distributed in the hope that it will be useful,
    9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
   10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   11 %  GNU General Public License for more details.
   12 %
   13 %  You should have received a copy of the GNU General Public License
   14 %  along with this program; see the file COPYING.  If not, write to
   15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   16 %  Boston, MA 02110-1301, USA.
   17 
   18 \darcsCommand{check}
   19 \begin{code}
   20 module Darcs.Commands.Check ( check ) where
   21 import Control.Monad ( when )
   22 import System.Exit ( ExitCode(..), exitWith )
   23 
   24 import Darcs.Commands ( DarcsCommand(..), nodefaults )
   25 import Darcs.Arguments ( DarcsFlag( Quiet ),
   26                         partial_check, notest, testByDefault,
   27                         leave_test_dir, working_repo_dir,
   28                       )
   29 import Darcs.Repository.Repair( replayRepository,
   30                               RepositoryConsistency(..) )
   31 import Darcs.Repository ( Repository, amInRepository, withRepository, slurp_recorded,
   32                           testRecorded )
   33 import Darcs.Patch ( RepoPatch, showPatch )
   34 import Darcs.Ordered ( FL(..) )
   35 import Darcs.Diff ( unsafeDiff )
   36 import Darcs.Repository.Prefs ( filetype_function )
   37 import Printer ( putDocLn, text, ($$), (<+>) )
   38 
   39 check_description :: String
   40 check_description = "Check the repository for consistency."
   41 
   42 check_help :: String
   43 check_help =
   44  "This command verifies that the patches in the repository, when applied\n" ++
   45  "successively to an empty tree, result in the pristine tree.  If not,\n" ++
   46  "the differences are printed and Darcs exits unsucessfully (with a\n" ++
   47  "non-zero exit status).\n" ++
   48  "\n" ++
   49  "If the repository is in darcs-1 format and has a checkpoint, you can\n" ++
   50  "use the --partial option to start checking from the latest checkpoint.\n" ++
   51  "This is the default for partial darcs-1 repositories; the --complete\n" ++
   52  "option to forces a full check.\n" ++
   53  "\n" ++
   54  "If a regression test is defined (see `darcs setpref') it will be run\n" ++
   55  "by `darcs check'.  Use the --no-test option to disable this.\n"
   56 
   57 check :: DarcsCommand
   58 check = DarcsCommand {command_name = "check",
   59                       command_help = check_help,
   60                       command_description = check_description,
   61                       command_extra_args = 0,
   62                       command_extra_arg_help = [],
   63                       command_command = check_cmd,
   64                       command_prereq = amInRepository,
   65                       command_get_arg_possibilities = return [],
   66                       command_argdefaults = nodefaults,
   67                       command_advanced_options = [],
   68                       command_basic_options = [partial_check,
   69                                               notest,
   70                                               leave_test_dir,
   71                                               working_repo_dir
   72                                              ]}
   73 
   74 check_cmd :: [DarcsFlag] -> [String] -> IO ()
   75 check_cmd opts _ = withRepository opts (check' opts)
   76 
   77 check' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()
   78 check' opts repository = do
   79     replayRepository repository (testByDefault opts) $ \ state -> do
   80       case state of
   81         RepositoryConsistent -> do
   82           putInfo $ text "The repository is consistent!"
   83           testRecorded repository
   84           exitWith ExitSuccess
   85         BrokenPristine newpris -> do
   86           brokenPristine newpris
   87           exitWith $ ExitFailure 1
   88         BrokenPatches newpris _ -> do
   89           brokenPristine newpris
   90           putInfo $ text "Found broken patches."
   91           exitWith $ ExitFailure 1
   92    where 
   93      brokenPristine newpris = do
   94          putInfo $ text "Looks like we have a difference..."
   95          mc <- slurp_recorded repository
   96          ftf <- filetype_function
   97          putInfo $ case unsafeDiff opts ftf newpris mc of
   98                         NilFL -> text "Nothing"
   99                         patch -> text "Difference: " <+> showPatch patch
  100          putInfo $ text ""
  101                      $$ text "Inconsistent repository!"
  102      putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s
  103 
  104 \end{code}
  105 %% FIXME: this should go in "common options" or something, since
  106 %% commands like record and amend-record also run the test command.
  107 \input{Darcs/Test.lhs}