module Darcs.Commands.TrackDown ( trackdown ) where
import Prelude hiding ( init )
import System.Exit ( ExitCode(..) )
import System.Cmd ( system )
import System.IO ( hFlush, stdout )
import Control.Monad( when )
import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable, Bisect), workingRepoDir, bisect,
setScriptsExecutableOption, makeScriptsExecutable )
import Darcs.Patch.PatchInfoAnd ( hopefully )
import Darcs.Repository ( amInHashedRepository, readRepo, withRepoReadLock, RepoJob(..), withRecorded,
setScriptsExecutable )
import Darcs.Witnesses.Ordered ( RL(..), (:<)(..), (+<+),
reverseRL, splitAtRL, lengthRL, mapRL, mapFL, mapRL_RL )
import Darcs.Patch.Conflict ( Conflict )
import Darcs.Patch.FileHunk ( IsHunk )
import Darcs.Patch.ApplyMonad ( ApplyMonad )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Format ( PatchListFormat )
import Darcs.Patch.Patchy ( Patchy, Invert, Apply, ShowPatch )
import Darcs.Patch ( RepoPatch, Named, description, apply, invert )
import Darcs.Patch.Set ( newset2RL )
import Printer ( putDocLn )
import Darcs.Test ( getTest )
import Darcs.Lock ( withTempDir )
import Storage.Hashed.Tree( Tree )
#include "gadts.h"
trackdownDescription :: String
trackdownDescription = "Locate the most recent version lacking an error."
trackdownHelp :: String
trackdownHelp =
"Trackdown tries to find the most recent version in the repository which\n"++
"passes a test. Given no arguments, it uses the default repository test.\n"++
"Given one argument, it treats it as a test command. Given two arguments,\n"++
"the first is an initialization command with is run only once, and the\n"++
"second is the test command.\n\n"++
"Without the --bisect option, trackdown does linear search starting from head,\n"++
"and moving away from head. With the --bisect option, it does binary search.\n\n"++
"Under the assumption that failure is monotonous, trackdown produces\n"++
"the same result with and without --bisect. (Monotonous means that when\n"++
"moving away from head, the test result changes only once from \"fail\" to \"ok\".)\n"++
"If failure is not monotonous, any one of the patches that break the test is\n"++
"found at random."
trackdown :: DarcsCommand
trackdown = DarcsCommand {commandProgramName = "darcs",
commandName = "trackdown",
commandHelp = trackdownHelp,
commandDescription = trackdownDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["[[INITIALIZATION]",
"COMMAND]"],
commandCommand = trackdownCmd,
commandPrereq = amInHashedRepository,
commandGetArgPossibilities = return [],
commandArgdefaults = nodefaults,
commandAdvancedOptions = [setScriptsExecutableOption],
commandBasicOptions = [workingRepoDir, bisect]}
trackdownCmd :: [DarcsFlag] -> [String] -> IO ()
trackdownCmd opts args = withRepoReadLock opts $ RepoJob $ \repository -> do
patches <- readRepo repository
(init,test) <- case args of
[] ->
do t <- getTest opts
return (return ExitSuccess, t)
[cmd] ->
do putStrLn $ "Tracking down command:\n"++cmd
return $ (return ExitSuccess, system cmd)
[init,cmd] ->
do putStrLn $ "Initializing with command:\n"++init
putStrLn $ "Tracking down command:\n"++cmd
return $ (system init, system cmd)
_ -> fail "Trackdown expects zero to two arguments."
withRecorded repository (withTempDir "trackingdown") $ \_ -> do
when (SetScriptsExecutable `elem` opts) setScriptsExecutable
_ <- init
(if Bisect `elem` opts
then trackBisect
else trackNextLinear) opts test (mapRL_RL hopefully . newset2RL $ patches)
trackNextLinear :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)
=> [DarcsFlag] -> IO ExitCode -> RL (Named p) C(x y) -> IO ()
trackNextLinear opts test (p:<:ps) = do
test_result <- test
if test_result == ExitSuccess
then putStrLn "Success!"
else do apply (invert p) `catch` \e -> fail ("Bad patch:\n" ++ show e)
makeScriptsExecutable opts (invert p)
putStrLn "Trying without the patch:"
putDocLn $ description $ invert p
hFlush stdout
trackNextLinear opts test ps
trackNextLinear _opts test NilRL = do
test_result <- test
if test_result == ExitSuccess
then putStrLn "Success!"
else putStrLn "Noone passed the test!"
trackBisect :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p))
=> [DarcsFlag] -> IO ExitCode -> RL p C(x y) -> IO ()
trackBisect _ test NilRL = do
test_result <- test
if test_result == ExitSuccess
then putStrLn "Success!"
else putStrLn "Noone passed the test!"
trackBisect opts test ps = do
test_result <- test
if test_result == ExitSuccess
then putStrLn ("Test does not fail on head.")
else trackNextBisect opts curr_prog test BisectRight (patchTreeFromRL ps)
where
curr_prog = (1, 1 + round ((logBase 2 $ fromIntegral $ lengthRL ps) :: Double)) :: (Int,Int)
data PatchTree p C(x y) where
Leaf :: p C(x y) -> PatchTree p C(x y)
Fork :: PatchTree p C(y z) -> PatchTree p C(x y) -> PatchTree p C(x z)
data BisectDir = BisectLeft | BisectRight deriving Show
type BisectState = (Int, Int)
patchTreeFromRL :: (Patchy p) => RL p C(x y) -> PatchTree p C(x y)
patchTreeFromRL (l :<: NilRL) = Leaf l
patchTreeFromRL xs = case splitAtRL (lengthRL xs `div` 2) xs of
(l :< r) -> Fork (patchTreeFromRL l) (patchTreeFromRL r)
patchTree2RL :: (Patchy p) => PatchTree p C(x y) -> RL p C(x y)
patchTree2RL (Leaf p) = p :<: NilRL
patchTree2RL (Fork l r) = (patchTree2RL l) +<+ (patchTree2RL r)
trackNextBisect :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p))
=> [DarcsFlag] -> BisectState -> IO ExitCode -> BisectDir -> PatchTree p C(x y) -> IO ()
trackNextBisect opts (dnow, dtotal) test dir (Fork l r) = do
putStr ("Trying " ++ show dnow ++ "/" ++ show dtotal ++ " sequences...\n")
hFlush stdout
case dir of
BisectRight -> jumpHalfOnRight opts l
BisectLeft -> jumpHalfOnLeft opts r
test_result <- test
case test_result of
ExitSuccess -> trackNextBisect opts (dnow+1, dtotal) test BisectLeft l
_ -> trackNextBisect opts (dnow+1, dtotal) test BisectRight r
trackNextBisect _ _ _ _ (Leaf p) = do
putStrLn ("Last recent patch that fails the test (assuming monotony in the given range):")
putDocLn (description p)
jumpHalfOnRight :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p)) => [DarcsFlag] -> PatchTree p C(x y) -> IO ()
jumpHalfOnRight opts l = unapplyRL ps >> makeScriptsExecutable opts ps
where ps = patchTree2RL l
jumpHalfOnLeft :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p)) => [DarcsFlag] -> PatchTree p C(x y) -> IO ()
jumpHalfOnLeft opts r = applyRL p >> makeScriptsExecutable opts p
where p = patchTree2RL r
applyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad IO (ApplyState p)) => RL p C(x y) -> IO ()
applyRL patches = sequence_ (mapFL safeApply (reverseRL $ patches))
unapplyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad IO (ApplyState p)) => RL p C(x y) -> IO ()
unapplyRL patches = sequence_ (mapRL (safeApply . invert) patches)
safeApply :: (Invert p, ShowPatch p, Apply p, ApplyMonad IO (ApplyState p)) => p C(x y) -> IO ()
safeApply p = apply p `catch` (\msg -> fail ("Bad patch (during trackdown --bisect):\n" ++ show msg))