src/Darcs/Commands/Check.lhs

   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 \subsection{darcs check}
  19 \begin{code}
  20 module Darcs.Commands.Check ( check ) where
  21 import Control.Monad ( when, unless )
  22 import System.Exit ( ExitCode(..), exitWith )
  23
  24 import Darcs.Commands ( DarcsCommand(..), nodefaults )
  25 import Darcs.Arguments ( DarcsFlag( Quiet, NoTest ),
  26                         partial_check, notest,
  27                         leave_test_dir, working_repo_dir,
  28                       )
  29 import Darcs.Repository.Repair( replayRepository, cleanupRepositoryReplay,
  30                               RepositoryConsistency(..), CanRepair(..) )
  31 import Darcs.Repository ( Repository, amInRepository, withRepository, ($-), slurp_recorded,
  32                           testTentative )
  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 \end{code}
  39
  40 \options{check}
  41
  42 \haskell{check_description}
  43 \begin{code}
  44 check_description :: String
  45 check_description = "Check the repository for consistency."
  46 \end{code}
  47 Check verifies that the patches stored in the repository, when successively
  48 applied to an empty tree, properly recreate the stored pristine tree.
  49
  50 \begin{options}
  51 --complete, --partial
  52 \end{options}
  53
  54 If you have a checkpoint of the repository (as is the case if you got the
  55 repository originally using \verb!darcs get --partial!), by default
  56 \verb'darcs check'
  57 will only verify the contents since the most recent checkpoint.  You can
  58 change this behavior using the \verb!--complete! flag.
  59
  60 \begin{code}
  61 check_help :: String
  62 check_help =
  63  "Check verifies that the patches stored in the repository, when successively\n"++
  64  "applied to an empty tree, properly recreate the stored pristine tree.\n"
  65 \end{code}
  66
  67 \begin{code}
  68 check :: DarcsCommand
  69 check = DarcsCommand {command_name = "check",
  70                       command_help = check_help,
  71                       command_description = check_description,
  72                       command_extra_args = 0,
  73                       command_extra_arg_help = [],
  74                       command_command = check_cmd,
  75                       command_prereq = amInRepository,
  76                       command_get_arg_possibilities = return [],
  77                       command_argdefaults = nodefaults,
  78                       command_advanced_options = [],
  79                       command_basic_options = [partial_check,
  80                                               notest,
  81                                               leave_test_dir,
  82                                               working_repo_dir
  83                                              ]}
  84 \end{code}
  85
  86 \begin{code}
  87 check_cmd :: [DarcsFlag] -> [String] -> IO ()
  88 check_cmd opts _ = withRepository opts $- \repo -> check' repo opts
  89
  90 check' :: (RepoPatch p) => Repository p -> [DarcsFlag] -> IO ()
  91 check' repository opts = do
  92     let putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s
  93     state <- replayRepository CannotRepair repository opts
  94     case state of
  95       RepositoryConsistent -> do
  96         putInfo $ text "The repository is consistent!"
  97         unless (NoTest `elem` opts) $ testTentative repository
  98         done ExitSuccess
  99       RepositoryInconsistent newpris -> do
 100               putInfo $ text "Looks like we have a difference..."
 101               mc <- slurp_recorded repository
 102               ftf <- filetype_function
 103               putInfo $ case unsafeDiff opts ftf newpris mc of
 104                         NilFL -> text "Nothing"
 105                         patch -> text "Difference: " <+> showPatch patch
 106               putInfo $ text ""
 107                      $$ text "Inconsistent repository!"
 108               done $ ExitFailure 1
 109     where done r = do cleanupRepositoryReplay repository
 110                       exitWith r
 111 \end{code}
 112
 113 \input{Darcs/Test.lhs}
 114
 115 \begin{options}
 116 --no-test
 117 \end{options}
 118
 119 If you just want to check the consistency of your repository without
 120 running the test, you can call darcs check with the \verb!--no-test!
 121 option.
 122