module Darcs.UI.Commands.Test
(
test
) where
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.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, 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.Witnesses.Sealed ( Sealed2(..) )
import Darcs.Patch.ApplyMonad ( ApplyMonad )
import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Inspect ( PatchInspect )
import Darcs.Patch ( RepoPatch
, description
)
import Darcs.Patch.Named ( Named )
import Darcs.Patch.Set ( patchSet2RL )
import Darcs.Util.Printer ( Doc, 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 :: String
testDescription = String
"Run tests and search for the patch that introduced a bug."
testHelp :: Doc
testHelp :: Doc
testHelp = String -> Doc
text forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"Run test on the current recorded state of the repository. Given no"
,String
"arguments, it uses the default repository test (see `darcs setpref`)."
,String
"Given one argument, it treats it as a test command."
,String
"Given two arguments, the first is an initialization command and the"
,String
"second is the test (meaning the exit code of the first command is not"
,String
"taken into account to determine success of the test)."
,String
"If given the `--linear` or `--bisect` flags, it tries to find the most"
,String
"recent version in the repository which passes a test."
,String
""
,String
"`--linear` does linear search starting from head, and moving away"
,String
"from head. This strategy is best when the test runs very quickly"
,String
"or the patch you're seeking is near the head."
,String
""
,String
"`--bisect` does binary search. This strategy is best when the test"
,String
"runs very slowly or the patch you're seeking is likely to be in"
,String
"the repository's distant past."
,String
""
,String
"`--backoff` starts searching from head, skipping further and further"
,String
"into the past until the test succeeds. It then does a binary search"
,String
"on a subset of those skipped patches. This strategy works well unless"
,String
"the patch you're seeking is in the repository's distant past."
,String
""
,String
"Under the assumption that failure is monotonous, `--linear` and"
,String
"`--bisect` produce the same result. (Monotonous means that when moving"
,String
"away from head, the test result changes only once from \"fail\" to"
,String
"\"ok\".) If failure is not monotonous, any one of the patches that"
,String
"break the test is found at random."
]
test :: DarcsCommand
test :: DarcsCommand
test = DarcsCommand
{ commandProgramName :: String
commandProgramName = String
"darcs"
, commandName :: String
commandName = String
"test"
, commandHelp :: Doc
commandHelp = Doc
testHelp
, commandDescription :: String
commandDescription = String
testDescription
, commandExtraArgs :: Int
commandExtraArgs = -Int
1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[[INITIALIZATION]", String
"COMMAND]"]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
testCommand
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
testAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
testOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
a
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
testOpts
}
where
testBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts = PrimDarcsOption TestStrategy
O.testStrategy forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption LeaveTestDir
O.leaveTestDir forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe String)
O.repoDir
testAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
testAdvancedOpts = forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable
testOpts :: DarcsOption
a
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
testOpts = forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
testAdvancedOpts
data TestResult = Success | Failure Int
data SearchTypeResult = AssumedMonotony | WasLinear
data StrategyResult p =
StrategySuccess
| NoPasses
| PassesOnHead
| Blame SearchTypeResult (Sealed2 (Named p))
| RunSuccess
| RunFailed Int
type Strategy = forall p wX wY
. (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)
=> [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
testCommand (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
args =
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$ forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
PatchSet rt p Origin wR
patches <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repository
(IO ExitCode
init,IO TestResult
testCmd) <- case [String]
args of
[] ->
do IO ExitCode
t <- Verbosity -> IO (IO ExitCode)
getTest (PrimDarcsOption Verbosity
verbosity forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess, ExitCode -> TestResult
exitCodeToTestResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ExitCode
t)
[String
cmd] ->
do String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Using test command:\n"forall a. [a] -> [a] -> [a]
++String
cmd
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess, ExitCode -> TestResult
exitCodeToTestResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ExitCode
system String
cmd)
[String
init,String
cmd] ->
do String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Using initialization command:\n"forall a. [a] -> [a] -> [a]
++String
init
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Using test command:\n"forall a. [a] -> [a] -> [a]
++String
cmd
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO ExitCode
system String
init, ExitCode -> TestResult
exitCodeToTestResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ExitCode
system String
cmd)
[String]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Test expects zero to two arguments."
let wd :: String -> (AbsolutePath -> IO a) -> IO a
wd = case PrimDarcsOption LeaveTestDir
O.leaveTestDir forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
LeaveTestDir
O.YesLeaveTestDir -> forall a. String -> (AbsolutePath -> IO a) -> IO a
withPermDir
LeaveTestDir
O.NoLeaveTestDir -> forall a. String -> (AbsolutePath -> IO a) -> IO a
withTempDir
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT
-> ((AbsolutePath -> IO a) -> IO a)
-> (AbsolutePath -> IO a)
-> IO a
withRecorded Repository rt p wR wU wR
repository (forall a. String -> (AbsolutePath -> IO a) -> IO a
wd String
"testing") forall a b. (a -> b) -> a -> b
$ \AbsolutePath
_ -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. YesNo a => a -> Bool
O.yes (forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) IO ()
setScriptsExecutable
ExitCode
_ <- IO ExitCode
init
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Running test...\n"
TestResult
testResult <- IO TestResult
testCmd
let track :: [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
track = TestStrategy -> Strategy
chooseStrategy (PrimDarcsOption TestStrategy
O.testStrategy forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
StrategyResult p
result <- forall {wX} {wY}.
[DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
track [DarcsFlag]
opts IO TestResult
testCmd TestResult
testResult (forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ
mapRL_RL forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR
patches)
case StrategyResult p
result of
StrategyResult p
StrategySuccess -> String -> IO ()
putStrLn String
"Success!"
StrategyResult p
NoPasses -> String -> IO ()
putStrLn String
"Noone passed the test!"
StrategyResult p
PassesOnHead -> String -> IO ()
putStrLn String
"Test does not fail on head."
Blame SearchTypeResult
searchTypeResult (Sealed2 Named p wX wY
p) -> do
let extraText :: String
extraText =
case SearchTypeResult
searchTypeResult of
SearchTypeResult
AssumedMonotony -> String
" (assuming monotony in the given range)"
SearchTypeResult
WasLinear -> String
""
String -> IO ()
putStrLn (String
"Last recent patch that fails the test" forall a. [a] -> [a] -> [a]
++ String
extraText forall a. [a] -> [a] -> [a]
++ String
":")
Doc -> IO ()
putDocLn (forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description Named p wX wY
p)
StrategyResult p
RunSuccess -> [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Test ran successfully.\n"
RunFailed Int
n -> do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Test failed!\n"
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
n)
exitCodeToTestResult :: ExitCode -> TestResult
exitCodeToTestResult :: ExitCode -> TestResult
exitCodeToTestResult ExitCode
ExitSuccess = TestResult
Success
exitCodeToTestResult (ExitFailure Int
n) = Int -> TestResult
Failure Int
n
chooseStrategy :: O.TestStrategy -> Strategy
chooseStrategy :: TestStrategy -> Strategy
chooseStrategy TestStrategy
O.Bisect = Strategy
trackBisect
chooseStrategy TestStrategy
O.Linear = Strategy
trackLinear
chooseStrategy TestStrategy
O.Backoff = Strategy
trackBackoff
chooseStrategy TestStrategy
O.Once = Strategy
oneTest
oneTest :: Strategy
oneTest :: Strategy
oneTest [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
RunSuccess
oneTest [DarcsFlag]
_ IO TestResult
_ (Failure Int
n) RL (Named p) wX wY
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *). Int -> StrategyResult p
RunFailed Int
n
trackLinear :: Strategy
trackLinear :: Strategy
trackLinear [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
StrategySuccess
trackLinear [DarcsFlag]
_ IO TestResult
_ (Failure Int
_) RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackLinear [DarcsFlag]
opts IO TestResult
testCmd (Failure Int
_) RL (Named p) wX wY
ps = forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
trackNextLinear [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wX wY
ps
trackNextLinear
:: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)
=> [DarcsFlag]
-> IO TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
trackNextLinear :: forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
trackNextLinear [DarcsFlag]
_ IO TestResult
_ RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackNextLinear [DarcsFlag]
opts IO TestResult
testCmd (RL (Named p) wX wY
ps:<:Named p wY wY
p) = do
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeUnapply Named p wY wY
p
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. YesNo a => a -> Bool
O.yes (forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches Named p wY wY
p
String -> IO ()
putStrLn String
"Trying without the patch:"
Doc -> IO ()
putDocLn forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description Named p wY wY
p
Handle -> IO ()
hFlush Handle
stdout
TestResult
testResult <- IO TestResult
testCmd
case TestResult
testResult of
TestResult
Success -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *).
SearchTypeResult -> Sealed2 (Named p) -> StrategyResult p
Blame SearchTypeResult
WasLinear forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wY wY. a wY wY -> Sealed2 a
Sealed2 Named p wY wY
p
Failure Int
_ -> forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
trackNextLinear [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wX wY
ps
trackBackoff :: Strategy
trackBackoff :: Strategy
trackBackoff [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
StrategySuccess
trackBackoff [DarcsFlag]
_ IO TestResult
_ (Failure Int
_) RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackBackoff [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
PassesOnHead
trackBackoff [DarcsFlag]
opts IO TestResult
testCmd (Failure Int
_) RL (Named p) wX wY
ps =
forall (p :: * -> * -> *) wY wZ.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult
-> Int
-> RL (Named p) wY wZ
-> IO (StrategyResult p)
trackNextBackoff [DarcsFlag]
opts IO TestResult
testCmd Int
4 RL (Named p) wX wY
ps
trackNextBackoff :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)
=> [DarcsFlag]
-> IO TestResult
-> Int
-> RL (Named p) wY wZ
-> IO (StrategyResult p)
trackNextBackoff :: forall (p :: * -> * -> *) wY wZ.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult
-> Int
-> RL (Named p) wY wZ
-> IO (StrategyResult p)
trackNextBackoff [DarcsFlag]
_ IO TestResult
_ Int
_ RL (Named p) wY wZ
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackNextBackoff [DarcsFlag]
opts IO TestResult
testCmd Int
n RL (Named p) wY wZ
ahead
| Int
n forall a. Ord a => a -> a -> Bool
>= forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (Named p) wY wZ
ahead = forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
initialBisect [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wY wZ
ahead
trackNextBackoff [DarcsFlag]
opts IO TestResult
testCmd Int
n RL (Named p) wY wZ
ahead = do
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Skipping " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" patches..."
Handle -> IO ()
hFlush Handle
stdout
case forall (a :: * -> * -> *) wX wZ.
Int -> RL a wX wZ -> (:>) (RL a) (RL a) wX wZ
splitAtRL Int
n RL (Named p) wY wZ
ahead of
( RL (Named p) wY wZ
ahead' :> RL (Named p) wZ wZ
skipped' ) -> do
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
unapplyRL RL (Named p) wZ wZ
skipped'
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. YesNo a => a -> Bool
O.yes (forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches RL (Named p) wZ wZ
skipped'
TestResult
testResult <- IO TestResult
testCmd
case TestResult
testResult of
Failure Int
_ ->
forall (p :: * -> * -> *) wY wZ.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult
-> Int
-> RL (Named p) wY wZ
-> IO (StrategyResult p)
trackNextBackoff [DarcsFlag]
opts IO TestResult
testCmd (Int
2forall a. Num a => a -> a -> a
*Int
n) RL (Named p) wY wZ
ahead'
TestResult
Success -> do
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
applyRL RL (Named p) wZ wZ
skipped'
forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
initialBisect [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wZ wZ
skipped'
trackBisect :: Strategy
trackBisect :: Strategy
trackBisect [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
StrategySuccess
trackBisect [DarcsFlag]
_ IO TestResult
_ (Failure Int
_) RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackBisect [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
PassesOnHead
trackBisect [DarcsFlag]
opts IO TestResult
testCmd (Failure Int
_) RL (Named p) wX wY
ps =
forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
initialBisect [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wX wY
ps
initialBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)
=> [DarcsFlag]
-> IO TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
initialBisect :: forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
initialBisect [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wX wY
ps =
forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
trackNextBisect [DarcsFlag]
opts BisectProgress
currProg IO TestResult
testCmd BisectDir
BisectRight (forall (p :: * -> * -> *) wX wY. RL p wX wY -> PatchTree p wX wY
patchTreeFromRL RL (Named p) wX wY
ps)
where
maxProg :: Int
maxProg = Int
1 forall a. Num a => a -> a -> a
+ forall a b. (RealFrac a, Integral b) => a -> b
round ((forall a. Floating a => a -> a -> a
logBase Double
2 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (Named p) wX wY
ps) :: Double)
currProg :: BisectProgress
currProg = (Int
1, Int
maxProg) :: BisectProgress
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 Int -> BisectDir -> ShowS
[BisectDir] -> ShowS
BisectDir -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BisectDir] -> ShowS
$cshowList :: [BisectDir] -> ShowS
show :: BisectDir -> String
$cshow :: BisectDir -> String
showsPrec :: Int -> BisectDir -> ShowS
$cshowsPrec :: Int -> BisectDir -> ShowS
Show
type BisectProgress = (Int, Int)
patchTreeFromRL :: RL p wX wY -> PatchTree p wX wY
patchTreeFromRL :: forall (p :: * -> * -> *) wX wY. RL p wX wY -> PatchTree p wX wY
patchTreeFromRL (RL p wX wY
NilRL :<: p wY wY
l) = forall (p :: * -> * -> *) wX wY. p wX wY -> PatchTree p wX wY
Leaf p wY wY
l
patchTreeFromRL RL p wX wY
xs = case forall (a :: * -> * -> *) wX wZ.
Int -> RL a wX wZ -> (:>) (RL a) (RL a) wX wZ
splitAtRL (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL p wX wY
xs forall a. Integral a => a -> a -> a
`div` Int
2) RL p wX wY
xs of
(RL p wX wZ
r :> RL p wZ wY
l) -> forall (p :: * -> * -> *) wY wZ wX.
PatchTree p wY wZ -> PatchTree p wX wY -> PatchTree p wX wZ
Fork (forall (p :: * -> * -> *) wX wY. RL p wX wY -> PatchTree p wX wY
patchTreeFromRL RL p wZ wY
l) (forall (p :: * -> * -> *) wX wY. RL p wX wY -> PatchTree p wX wY
patchTreeFromRL RL p wX wZ
r)
patchTree2RL :: PatchTree p wX wY -> RL p wX wY
patchTree2RL :: forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL (Leaf p wX wY
p) = forall (a :: * -> * -> *) wX. RL a wX wX
NilRL forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: p wX wY
p
patchTree2RL (Fork PatchTree p wY wY
l PatchTree p wX wY
r) = forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL PatchTree p wX wY
r forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> RL a wY wZ -> RL a wX wZ
+<+ forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL PatchTree p wY wY
l
trackNextBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)
=> [DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
trackNextBisect :: forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
trackNextBisect [DarcsFlag]
opts (Int
dnow, Int
dtotal) IO TestResult
testCmd BisectDir
dir (Fork PatchTree (Named p) wY wY
l PatchTree (Named p) wX wY
r) = do
String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"Trying " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
dnow forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
dtotal forall a. [a] -> [a] -> [a]
++ String
" sequences...\n"
Handle -> IO ()
hFlush Handle
stdout
case BisectDir
dir of
BisectDir
BisectRight -> forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight [DarcsFlag]
opts PatchTree (Named p) wY wY
l
BisectDir
BisectLeft -> forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnLeft [DarcsFlag]
opts PatchTree (Named p) wX wY
r
TestResult
testResult <- IO TestResult
testCmd
case TestResult
testResult of
TestResult
Success -> forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
trackNextBisect [DarcsFlag]
opts (Int
dnowforall a. Num a => a -> a -> a
+Int
1, Int
dtotal) IO TestResult
testCmd
BisectDir
BisectLeft PatchTree (Named p) wY wY
l
TestResult
_ -> forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
trackNextBisect [DarcsFlag]
opts (Int
dnowforall a. Num a => a -> a -> a
+Int
1, Int
dtotal) IO TestResult
testCmd
BisectDir
BisectRight PatchTree (Named p) wX wY
r
trackNextBisect [DarcsFlag]
_ BisectProgress
_ IO TestResult
_ BisectDir
_ (Leaf Named p wX wY
p) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: * -> * -> *).
SearchTypeResult -> Sealed2 (Named p) -> StrategyResult p
Blame SearchTypeResult
AssumedMonotony (forall (a :: * -> * -> *) wY wY. a wY wY -> Sealed2 a
Sealed2 Named p wX wY
p))
jumpHalfOnRight :: (Apply p, PatchInspect p,
ApplyMonad (ApplyState p) DefaultIO)
=> [DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight :: forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight [DarcsFlag]
opts PatchTree p wX wY
l = do forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
unapplyRL RL p wX wY
ps
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. YesNo a => a -> Bool
O.yes (forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches RL p wX wY
ps
where ps :: RL p wX wY
ps = forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL PatchTree p wX wY
l
jumpHalfOnLeft :: (Apply p, PatchInspect p,
ApplyMonad (ApplyState p) DefaultIO)
=> [DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnLeft :: forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnLeft [DarcsFlag]
opts PatchTree p wX wY
r = do forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
applyRL RL p wX wY
p
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. YesNo a => a -> Bool
O.yes (forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches RL p wX wY
p
where p :: RL p wX wY
p = forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL PatchTree p wX wY
r
applyRL :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
=> RL p wX wY -> IO ()
applyRL :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
applyRL RL p wX wY
patches = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeApply (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL p wX wY
patches))
unapplyRL :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
=> RL p wX wY -> IO ()
unapplyRL :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
unapplyRL RL p wX wY
patches = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeUnapply RL p wX wY
patches)
safeApply :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
=> p wX wY -> IO ()
safeApply :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeApply p wX wY
p = forall a. DefaultIO a -> IO a
runDefault (forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
p) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
msg :: IOException) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Bad patch:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
msg
safeUnapply :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
=> p wX wY -> IO ()
safeUnapply :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeUnapply p wX wY
p = forall a. DefaultIO a -> IO a
runDefault (forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply p wX wY
p) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
msg :: IOException) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Bad patch:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
msg