module Darcs.UI.Commands.Test
(
test
) where
import Prelude ()
import Darcs.Prelude hiding ( init )
import Control.Exception ( catch, IOException )
import Control.Monad( when )
import System.Process ( system )
import System.Exit ( ExitCode(..), exitWith )
import System.IO ( hFlush, stdout )
import Darcs.Util.Tree( Tree )
import Darcs.UI.Commands
( DarcsCommand(..), withStdOpts
, nodefaults
, putInfo
, amInHashedRepository )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags ( DarcsFlag, useCache, verbosity )
import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Patch.PatchInfoAnd ( hopefully )
import Darcs.Repository (
readRepo
, withRepository
, RepoJob(..)
, withRecorded
, setScriptsExecutablePatches
, setScriptsExecutable
)
import Darcs.Patch.Witnesses.Ordered
( RL(..)
, (:>)(..)
, (+<+)
, reverseRL
, splitAtRL
, lengthRL
, mapRL
, mapFL
, mapRL_RL
)
import Darcs.Patch.ApplyMonad ( ApplyMonad )
import Darcs.Patch.Apply ( Apply, ApplyState )
import Darcs.Patch.Inspect ( PatchInspect )
import Darcs.Patch.Invert ( Invert )
import Darcs.Patch ( RepoPatch
, apply
, description
, invert
)
import Darcs.Patch.Named.Wrapped ( WrappedNamed )
import Darcs.Patch.Set ( patchSet2RL )
import Darcs.Util.Printer ( putDocLn
, text
)
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault )
import Darcs.Repository.Test ( getTest )
import Darcs.Util.Lock
( withTempDir
, withPermDir
)
testDescription :: String
testDescription = "Run tests and search for the patch that introduced a bug."
testHelp :: String
testHelp =
unlines
[ "Run test on the current recorded state of the repository. Given no"
,"arguments, it uses the default repository test (see `darcs setpref`)."
,"Given one argument, it treats it as a test command."
,"Given two arguments, the first is an initialization command and the"
,"second is the test (meaning the exit code of the first command is not"
,"taken into account to determine success of the test)."
,"If given the `--linear` or `--bisect` flags, it tries to find the most"
,"recent version in the repository which passes a test."
,""
,"`--linear` does linear search starting from head, and moving away"
,"from head. This strategy is best when the test runs very quickly"
,"or the patch you're seeking is near the head."
,""
,"`--bisect` does binary search. This strategy is best when the test"
,"runs very slowly or the patch you're seeking is likely to be in"
,"the repository's distant past."
,""
,"`--backoff` starts searching from head, skipping further and further"
,"into the past until the test succeeds. It then does a binary search"
,"on a subset of those skipped patches. This strategy works well unless"
,"the patch you're seeking is in the repository's distant past."
,""
,"Under the assumption that failure is monotonous, `--linear` and"
,"`--bisect` produce the same result. (Monotonous means that when moving"
,"away from head, the test result changes only once from \"fail\" to"
,"\"ok\".) If failure is not monotonous, any one of the patches that"
,"break the test is found at random."
]
test :: DarcsCommand [DarcsFlag]
test = DarcsCommand
{ commandProgramName = "darcs"
, commandName = "test"
, commandHelp = testHelp
, commandDescription = testDescription
, commandExtraArgs = -1
, commandExtraArgHelp = ["[[INITIALIZATION]", "COMMAND]"]
, commandCommand = testCommand
, commandPrereq = amInHashedRepository
, commandCompleteArgs = noArgs
, commandArgdefaults = nodefaults
, commandAdvancedOptions = odesc testAdvancedOpts
, commandBasicOptions = odesc testBasicOpts
, commandDefaults = defaultFlags testOpts
, commandCheckOptions = ocheck testOpts
, commandParseOptions = onormalise testOpts
}
where
testBasicOpts = O.testStrategy ^ O.leaveTestDir ^ O.repoDir
testAdvancedOpts = O.setScriptsExecutable
testOpts = testBasicOpts `withStdOpts` testAdvancedOpts
type Strategy = forall rt p wX wY
. (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree)
=> [DarcsFlag]
-> IO ExitCode
-> ExitCode
-> RL (WrappedNamed rt p) wX wY
-> IO ()
testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
testCommand _ opts args =
withRepository (useCache ? opts) $ RepoJob $ \repository -> do
patches <- readRepo repository
(init,testCmd) <- case args of
[] ->
do t <- getTest (verbosity ? opts)
return (return ExitSuccess, t)
[cmd] ->
do putStrLn $ "Using test command:\n"++cmd
return (return ExitSuccess, system cmd)
[init,cmd] ->
do putStrLn $ "Using initialization command:\n"++init
putStrLn $ "Using test command:\n"++cmd
return (system init, system cmd)
_ -> fail "Test expects zero to two arguments."
let wd = case O.leaveTestDir ? opts of
O.YesLeaveTestDir -> withPermDir
O.NoLeaveTestDir -> withTempDir
withRecorded repository (wd "testing") $ \_ -> do
when (O.yes (O.setScriptsExecutable ? opts)) setScriptsExecutable
_ <- init
putInfo opts $ text "Running test...\n"
testResult <- testCmd
let track = chooseStrategy (O.testStrategy ? opts)
track opts testCmd testResult (mapRL_RL hopefully . patchSet2RL $ patches)
chooseStrategy :: O.TestStrategy -> Strategy
chooseStrategy O.Bisect = trackBisect
chooseStrategy O.Linear = trackLinear
chooseStrategy O.Backoff = trackBackoff
chooseStrategy O.Once = oneTest
oneTest :: Strategy
oneTest opts _ ExitSuccess _ = putInfo opts $ text "Test ran successfully.\n"
oneTest opts _ testResult _ = do
putInfo opts $ text "Test failed!\n"
exitWith testResult
trackLinear :: Strategy
trackLinear _ _ ExitSuccess _ = putStrLn "Success!"
trackLinear opts testCmd (ExitFailure _) (ps:<:p) = do
let ip = invert p
safeApply ip
when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches ip
putStrLn "Trying without the patch:"
putDocLn $ description ip
hFlush stdout
testResult <- testCmd
trackLinear opts testCmd testResult ps
trackLinear _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!"
trackBackoff :: Strategy
trackBackoff _ _ ExitSuccess NilRL = putStrLn "Success!"
trackBackoff _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!"
trackBackoff _ _ ExitSuccess _ = putStrLn "Test does not fail on head."
trackBackoff opts testCmd (ExitFailure _) ps =
trackNextBackoff opts testCmd 4 ps
trackNextBackoff :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree)
=> [DarcsFlag]
-> IO ExitCode
-> Int
-> RL (WrappedNamed rt p) wY wZ
-> IO ()
trackNextBackoff _ _ _ NilRL = putStrLn "Noone passed the test!"
trackNextBackoff opts testCmd n ahead
| n >= lengthRL ahead = initialBisect opts testCmd ahead
trackNextBackoff opts testCmd n ahead = do
putStrLn $ "Skipping " ++ show n ++ " patches..."
hFlush stdout
case splitAtRL n ahead of
( ahead' :> skipped' ) -> do
unapplyRL skipped'
when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches skipped'
testResult <- testCmd
case testResult of
ExitFailure _ ->
trackNextBackoff opts testCmd (2*n) ahead'
ExitSuccess -> do
applyRL skipped'
initialBisect opts testCmd skipped'
trackBisect :: Strategy
trackBisect _ _ ExitSuccess NilRL = putStrLn "Success!"
trackBisect _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!"
trackBisect _ _ ExitSuccess _ = putStrLn "Test does not fail on head."
trackBisect opts testCmd (ExitFailure _) ps =
initialBisect opts testCmd ps
initialBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree)
=> [DarcsFlag]
-> IO ExitCode
-> RL (WrappedNamed rt p) wX wY
-> IO ()
initialBisect opts testCmd ps =
trackNextBisect opts currProg testCmd BisectRight (patchTreeFromRL ps)
where
maxProg = 1 + round ((logBase 2 $ fromIntegral $ lengthRL ps) :: Double)
currProg = (1, maxProg) :: BisectState
data PatchTree p wX wY where
Leaf :: p wX wY -> PatchTree p wX wY
Fork :: PatchTree p wY wZ -> PatchTree p wX wY -> PatchTree p wX wZ
data BisectDir = BisectLeft | BisectRight deriving Show
type BisectState = (Int, Int)
patchTreeFromRL :: RL p wX wY -> PatchTree p wX wY
patchTreeFromRL (NilRL :<: l) = Leaf l
patchTreeFromRL xs = case splitAtRL (lengthRL xs `div` 2) xs of
(r :> l) -> Fork (patchTreeFromRL l) (patchTreeFromRL r)
patchTree2RL :: PatchTree p wX wY -> RL p wX wY
patchTree2RL (Leaf p) = NilRL :<: p
patchTree2RL (Fork l r) = patchTree2RL r +<+ patchTree2RL l
trackNextBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree)
=> [DarcsFlag]
-> BisectState
-> IO ExitCode
-> BisectDir
-> PatchTree (WrappedNamed rt p) wX wY
-> IO ()
trackNextBisect opts (dnow, dtotal) testCmd 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
testResult <- testCmd
case testResult of
ExitSuccess -> trackNextBisect opts (dnow+1, dtotal) testCmd
BisectLeft l
_ -> trackNextBisect opts (dnow+1, dtotal) testCmd
BisectRight r
trackNextBisect _ _ _ _ (Leaf p) = do
putStrLn "Last recent patch that fails the test (assuming monotony in the given range):"
putDocLn (description p)
jumpHalfOnRight :: (Invert p, Apply p, PatchInspect p,
ApplyMonad (ApplyState p) DefaultIO)
=> [DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight opts l = do unapplyRL ps
when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches ps
where ps = patchTree2RL l
jumpHalfOnLeft :: (Apply p, PatchInspect p,
ApplyMonad (ApplyState p) DefaultIO)
=> [DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnLeft opts r = do applyRL p
when (O.yes (O.setScriptsExecutable ? opts)) $ setScriptsExecutablePatches p
where p = patchTree2RL r
applyRL :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
=> RL p wX wY -> IO ()
applyRL patches = sequence_ (mapFL safeApply (reverseRL patches))
unapplyRL :: (Invert p, Apply p, ApplyMonad (ApplyState p) DefaultIO)
=> RL p wX wY -> IO ()
unapplyRL patches = sequence_ (mapRL (safeApply . invert) patches)
safeApply :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
=> p wX wY -> IO ()
safeApply p = runDefault (apply p) `catch` \(msg :: IOException) -> fail $ "Bad patch:\n" ++ show msg