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 :: String
testDescription = "Run tests and search for the patch that introduced a bug."
testHelp :: String
testHelp :: String
testHelp =
[String] -> String
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 [DarcsFlag]
test = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
-> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
{ commandProgramName :: String
commandProgramName = "darcs"
, commandName :: String
commandName = "test"
, commandHelp :: String
commandHelp = String
testHelp
, commandDescription :: String
commandDescription = String
testDescription
, commandExtraArgs :: Int
commandExtraArgs = -1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = ["[[INITIALIZATION]", "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 = OptSpec DarcsOptDescr DarcsFlag Any (SetScriptsExecutable -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (SetScriptsExecutable -> Any)
forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
testAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(TestStrategy -> LeaveTestDir -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
DarcsOptDescr
DarcsFlag
Any
(TestStrategy -> LeaveTestDir -> Maybe String -> Any)
forall a.
OptSpec
DarcsOptDescr
DarcsFlag
a
(TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> a)
testOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
DarcsOptDescr
DarcsFlag
Any
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> a)
testOpts
, commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> a)
testOpts
}
where
testBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts = PrimOptSpec
DarcsOptDescr
DarcsFlag
(LeaveTestDir -> Maybe String -> a)
TestStrategy
PrimDarcsOption TestStrategy
O.testStrategy PrimOptSpec
DarcsOptDescr
DarcsFlag
(LeaveTestDir -> Maybe String -> a)
TestStrategy
-> OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> a)
(LeaveTestDir -> Maybe String -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> a)
(TestStrategy -> LeaveTestDir -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> a)
(LeaveTestDir -> Maybe String -> a)
PrimDarcsOption LeaveTestDir
O.leaveTestDir OptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> a)
(TestStrategy -> LeaveTestDir -> Maybe String -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
a
(TestStrategy -> LeaveTestDir -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
PrimDarcsOption (Maybe String)
O.repoDir
testAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
testAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable
testOpts :: DarcsOption
a
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> a)
testOpts = OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> a)
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> a)
forall a.
OptSpec
DarcsOptDescr
DarcsFlag
a
(TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> a)
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> a)
-> DarcsOption
(UseCache -> HooksConfig -> a)
(SetScriptsExecutable -> UseCache -> HooksConfig -> a)
-> DarcsOption
a
(TestStrategy
-> LeaveTestDir
-> Maybe String
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> SetScriptsExecutable
-> UseCache
-> HooksConfig
-> a)
forall b c a.
DarcsOption
(Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
(UseCache -> HooksConfig -> a)
(SetScriptsExecutable -> UseCache -> HooksConfig -> a)
forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
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 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
testCommand _ opts :: [DarcsFlag]
opts args :: [String]
args =
UseCache -> RepoJob () -> IO ()
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
PatchSet rt p Origin wR
patches <- Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
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
(init :: IO ExitCode
init,testCmd :: IO ExitCode
testCmd) <- case [String]
args of
[] ->
do IO ExitCode
t <- Verbosity -> IO (IO ExitCode)
getTest (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(IO ExitCode, IO ExitCode) -> IO (IO ExitCode, IO ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess, IO ExitCode
t)
[cmd :: String
cmd] ->
do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Using test command:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cmd
(IO ExitCode, IO ExitCode) -> IO (IO ExitCode, IO ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess, String -> IO ExitCode
system String
cmd)
[init :: String
init,cmd :: String
cmd] ->
do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Using initialization command:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
init
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Using test command:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cmd
(IO ExitCode, IO ExitCode) -> IO (IO ExitCode, IO ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO ExitCode
system String
init, String -> IO ExitCode
system String
cmd)
_ -> String -> IO (IO ExitCode, IO ExitCode)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Test expects zero to two arguments."
let wd :: String -> (AbsolutePath -> IO a) -> IO a
wd = case PrimDarcsOption LeaveTestDir
O.leaveTestDir PrimDarcsOption LeaveTestDir -> [DarcsFlag] -> LeaveTestDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
O.YesLeaveTestDir -> String -> (AbsolutePath -> IO a) -> IO a
forall a. String -> (AbsolutePath -> IO a) -> IO a
withPermDir
O.NoLeaveTestDir -> String -> (AbsolutePath -> IO a) -> IO a
forall a. String -> (AbsolutePath -> IO a) -> IO a
withTempDir
Repository rt p wR wU wR
-> ((AbsolutePath -> IO ()) -> IO ())
-> (AbsolutePath -> IO ())
-> IO ()
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 (String -> (AbsolutePath -> IO ()) -> IO ()
forall a. String -> (AbsolutePath -> IO a) -> IO a
wd "testing") ((AbsolutePath -> IO ()) -> IO ())
-> (AbsolutePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \_ -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetScriptsExecutable -> Bool
forall a. YesNo a => a -> Bool
O.yes (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable)
-> [DarcsFlag] -> 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 (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Running test...\n"
ExitCode
testResult <- IO ExitCode
testCmd
let track :: [DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
track = TestStrategy -> Strategy
chooseStrategy (PrimDarcsOption TestStrategy
O.testStrategy PrimDarcsOption TestStrategy -> [DarcsFlag] -> TestStrategy
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
[DarcsFlag]
-> IO ExitCode
-> ExitCode
-> RL (WrappedNamed rt p) Origin wR
-> IO ()
forall (rt :: RepoType) wX wY.
[DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
track [DarcsFlag]
opts IO ExitCode
testCmd ExitCode
testResult ((forall wW wY. PatchInfoAnd rt p wW wY -> WrappedNamed rt p wW wY)
-> RL (PatchInfoAnd rt p) Origin wR
-> RL (WrappedNamed rt p) Origin wR
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 wW wY. PatchInfoAnd rt p wW wY -> WrappedNamed rt p wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully (RL (PatchInfoAnd rt p) Origin wR
-> RL (WrappedNamed rt p) Origin wR)
-> (PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR)
-> PatchSet rt p Origin wR
-> RL (WrappedNamed rt p) Origin wR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL (PatchSet rt p Origin wR -> RL (WrappedNamed rt p) Origin wR)
-> PatchSet rt p Origin wR -> RL (WrappedNamed rt p) Origin wR
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR
patches)
chooseStrategy :: O.TestStrategy -> Strategy
chooseStrategy :: TestStrategy -> Strategy
chooseStrategy O.Bisect = [DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
Strategy
trackBisect
chooseStrategy O.Linear = [DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
Strategy
trackLinear
chooseStrategy O.Backoff = [DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
Strategy
trackBackoff
chooseStrategy O.Once = [DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
Strategy
oneTest
oneTest :: Strategy
oneTest :: [DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
oneTest opts :: [DarcsFlag]
opts _ ExitSuccess _ = [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Test ran successfully.\n"
oneTest opts :: [DarcsFlag]
opts _ testResult :: ExitCode
testResult _ = do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Test failed!\n"
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
testResult
trackLinear :: Strategy
trackLinear :: [DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
trackLinear _ _ ExitSuccess _ = String -> IO ()
putStrLn "Success!"
trackLinear opts :: [DarcsFlag]
opts testCmd :: IO ExitCode
testCmd (ExitFailure _) (ps :: RL (WrappedNamed rt p) wX wY
ps:<:p :: WrappedNamed rt p wY wY
p) = do
let ip :: WrappedNamed rt p wY wY
ip = WrappedNamed rt p wY wY -> WrappedNamed rt p wY wY
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert WrappedNamed rt p wY wY
p
WrappedNamed rt p wY wY -> IO ()
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeApply WrappedNamed rt p wY wY
ip
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetScriptsExecutable -> Bool
forall a. YesNo a => a -> Bool
O.yes (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable)
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ WrappedNamed rt p wY wY -> IO ()
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches WrappedNamed rt p wY wY
ip
String -> IO ()
putStrLn "Trying without the patch:"
Doc -> IO ()
putDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ WrappedNamed rt p wY wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description WrappedNamed rt p wY wY
ip
Handle -> IO ()
hFlush Handle
stdout
ExitCode
testResult <- IO ExitCode
testCmd
[DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
Strategy
trackLinear [DarcsFlag]
opts IO ExitCode
testCmd ExitCode
testResult RL (WrappedNamed rt p) wX wY
ps
trackLinear _ _ (ExitFailure _) NilRL = String -> IO ()
putStrLn "Noone passed the test!"
trackBackoff :: Strategy
trackBackoff :: [DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
trackBackoff _ _ ExitSuccess NilRL = String -> IO ()
putStrLn "Success!"
trackBackoff _ _ (ExitFailure _) NilRL = String -> IO ()
putStrLn "Noone passed the test!"
trackBackoff _ _ ExitSuccess _ = String -> IO ()
putStrLn "Test does not fail on head."
trackBackoff opts :: [DarcsFlag]
opts testCmd :: IO ExitCode
testCmd (ExitFailure _) ps :: RL (WrappedNamed rt p) wX wY
ps =
[DarcsFlag]
-> IO ExitCode -> Int -> RL (WrappedNamed rt p) wX wY -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wY wZ.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO,
ApplyState p ~ Tree) =>
[DarcsFlag]
-> IO ExitCode -> Int -> RL (WrappedNamed rt p) wY wZ -> IO ()
trackNextBackoff [DarcsFlag]
opts IO ExitCode
testCmd 4 RL (WrappedNamed rt p) wX wY
ps
trackNextBackoff :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree)
=> [DarcsFlag]
-> IO ExitCode
-> Int
-> RL (WrappedNamed rt p) wY wZ
-> IO ()
trackNextBackoff :: [DarcsFlag]
-> IO ExitCode -> Int -> RL (WrappedNamed rt p) wY wZ -> IO ()
trackNextBackoff _ _ _ NilRL = String -> IO ()
putStrLn "Noone passed the test!"
trackNextBackoff opts :: [DarcsFlag]
opts testCmd :: IO ExitCode
testCmd n :: Int
n ahead :: RL (WrappedNamed rt p) wY wZ
ahead
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= RL (WrappedNamed rt p) wY wZ -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (WrappedNamed rt p) wY wZ
ahead = [DarcsFlag] -> IO ExitCode -> RL (WrappedNamed rt p) wY wZ -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO,
ApplyState p ~ Tree) =>
[DarcsFlag] -> IO ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
initialBisect [DarcsFlag]
opts IO ExitCode
testCmd RL (WrappedNamed rt p) wY wZ
ahead
trackNextBackoff opts :: [DarcsFlag]
opts testCmd :: IO ExitCode
testCmd n :: Int
n ahead :: RL (WrappedNamed rt p) wY wZ
ahead = do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Skipping " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ " patches..."
Handle -> IO ()
hFlush Handle
stdout
case Int
-> RL (WrappedNamed rt p) wY wZ
-> (:>) (RL (WrappedNamed rt p)) (RL (WrappedNamed rt p)) wY wZ
forall (a :: * -> * -> *) wX wZ.
Int -> RL a wX wZ -> (:>) (RL a) (RL a) wX wZ
splitAtRL Int
n RL (WrappedNamed rt p) wY wZ
ahead of
( ahead' :: RL (WrappedNamed rt p) wY wZ
ahead' :> skipped' :: RL (WrappedNamed rt p) wZ wZ
skipped' ) -> do
RL (WrappedNamed rt p) wZ wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
(Invert p, Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
unapplyRL RL (WrappedNamed rt p) wZ wZ
skipped'
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetScriptsExecutable -> Bool
forall a. YesNo a => a -> Bool
O.yes (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable)
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RL (WrappedNamed rt p) wZ wZ -> IO ()
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches RL (WrappedNamed rt p) wZ wZ
skipped'
ExitCode
testResult <- IO ExitCode
testCmd
case ExitCode
testResult of
ExitFailure _ ->
[DarcsFlag]
-> IO ExitCode -> Int -> RL (WrappedNamed rt p) wY wZ -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wY wZ.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO,
ApplyState p ~ Tree) =>
[DarcsFlag]
-> IO ExitCode -> Int -> RL (WrappedNamed rt p) wY wZ -> IO ()
trackNextBackoff [DarcsFlag]
opts IO ExitCode
testCmd (2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) RL (WrappedNamed rt p) wY wZ
ahead'
ExitSuccess -> do
RL (WrappedNamed rt p) wZ wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
applyRL RL (WrappedNamed rt p) wZ wZ
skipped'
[DarcsFlag] -> IO ExitCode -> RL (WrappedNamed rt p) wZ wZ -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO,
ApplyState p ~ Tree) =>
[DarcsFlag] -> IO ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
initialBisect [DarcsFlag]
opts IO ExitCode
testCmd RL (WrappedNamed rt p) wZ wZ
skipped'
trackBisect :: Strategy
trackBisect :: [DarcsFlag]
-> IO ExitCode -> ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
trackBisect _ _ ExitSuccess NilRL = String -> IO ()
putStrLn "Success!"
trackBisect _ _ (ExitFailure _) NilRL = String -> IO ()
putStrLn "Noone passed the test!"
trackBisect _ _ ExitSuccess _ = String -> IO ()
putStrLn "Test does not fail on head."
trackBisect opts :: [DarcsFlag]
opts testCmd :: IO ExitCode
testCmd (ExitFailure _) ps :: RL (WrappedNamed rt p) wX wY
ps =
[DarcsFlag] -> IO ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO,
ApplyState p ~ Tree) =>
[DarcsFlag] -> IO ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
initialBisect [DarcsFlag]
opts IO ExitCode
testCmd RL (WrappedNamed rt p) wX wY
ps
initialBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree)
=> [DarcsFlag]
-> IO ExitCode
-> RL (WrappedNamed rt p) wX wY
-> IO ()
initialBisect :: [DarcsFlag] -> IO ExitCode -> RL (WrappedNamed rt p) wX wY -> IO ()
initialBisect opts :: [DarcsFlag]
opts testCmd :: IO ExitCode
testCmd ps :: RL (WrappedNamed rt p) wX wY
ps =
[DarcsFlag]
-> BisectState
-> IO ExitCode
-> BisectDir
-> PatchTree (WrappedNamed rt p) wX wY
-> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO,
ApplyState p ~ Tree) =>
[DarcsFlag]
-> BisectState
-> IO ExitCode
-> BisectDir
-> PatchTree (WrappedNamed rt p) wX wY
-> IO ()
trackNextBisect [DarcsFlag]
opts BisectState
currProg IO ExitCode
testCmd BisectDir
BisectRight (RL (WrappedNamed rt p) wX wY -> PatchTree (WrappedNamed rt p) wX wY
forall (p :: * -> * -> *) wX wY. RL p wX wY -> PatchTree p wX wY
patchTreeFromRL RL (WrappedNamed rt p) wX wY
ps)
where
maxProg :: Int
maxProg = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round ((Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase 2 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ RL (WrappedNamed rt p) wX wY -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (WrappedNamed rt p) wX wY
ps) :: Double)
currProg :: BisectState
currProg = (1, Int
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 Int -> BisectDir -> String -> String
[BisectDir] -> String -> String
BisectDir -> String
(Int -> BisectDir -> String -> String)
-> (BisectDir -> String)
-> ([BisectDir] -> String -> String)
-> Show BisectDir
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [BisectDir] -> String -> String
$cshowList :: [BisectDir] -> String -> String
show :: BisectDir -> String
$cshow :: BisectDir -> String
showsPrec :: Int -> BisectDir -> String -> String
$cshowsPrec :: Int -> BisectDir -> String -> String
Show
type BisectState = (Int, Int)
patchTreeFromRL :: RL p wX wY -> PatchTree p wX wY
patchTreeFromRL :: RL p wX wY -> PatchTree p wX wY
patchTreeFromRL (NilRL :<: l :: p wY wY
l) = p wY wY -> PatchTree p wY wY
forall (p :: * -> * -> *) wX wY. p wX wY -> PatchTree p wX wY
Leaf p wY wY
l
patchTreeFromRL xs :: RL p wX wY
xs = case Int -> RL p wX wY -> (:>) (RL p) (RL p) wX wY
forall (a :: * -> * -> *) wX wZ.
Int -> RL a wX wZ -> (:>) (RL a) (RL a) wX wZ
splitAtRL (RL p wX wY -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL p wX wY
xs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2) RL p wX wY
xs of
(r :: RL p wX wZ
r :> l :: RL p wZ wY
l) -> PatchTree p wZ wY -> PatchTree p wX wZ -> PatchTree p wX wY
forall (p :: * -> * -> *) wY wZ wX.
PatchTree p wY wZ -> PatchTree p wX wY -> PatchTree p wX wZ
Fork (RL p wZ wY -> PatchTree p wZ wY
forall (p :: * -> * -> *) wX wY. RL p wX wY -> PatchTree p wX wY
patchTreeFromRL RL p wZ wY
l) (RL p wX wZ -> PatchTree p wX wZ
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 :: PatchTree p wX wY -> RL p wX wY
patchTree2RL (Leaf p :: p wX wY
p) = RL p wX wX
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL RL p wX wX -> p wX wY -> RL p wX wY
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: p wX wY
p
patchTree2RL (Fork l :: PatchTree p wY wY
l r :: PatchTree p wX wY
r) = PatchTree p wX wY -> RL p wX wY
forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL PatchTree p wX wY
r RL p wX wY -> RL p wY wY -> RL p wX wY
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> RL a wY wZ -> RL a wX wZ
+<+ PatchTree p wY wY -> RL p wY wY
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, ApplyState p ~ Tree)
=> [DarcsFlag]
-> BisectState
-> IO ExitCode
-> BisectDir
-> PatchTree (WrappedNamed rt p) wX wY
-> IO ()
trackNextBisect :: [DarcsFlag]
-> BisectState
-> IO ExitCode
-> BisectDir
-> PatchTree (WrappedNamed rt p) wX wY
-> IO ()
trackNextBisect opts :: [DarcsFlag]
opts (dnow :: Int
dnow, dtotal :: Int
dtotal) testCmd :: IO ExitCode
testCmd dir :: BisectDir
dir (Fork l :: PatchTree (WrappedNamed rt p) wY wY
l r :: PatchTree (WrappedNamed rt p) wX wY
r) = do
String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Trying " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dnow String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dtotal String -> String -> String
forall a. [a] -> [a] -> [a]
++ " sequences...\n"
Handle -> IO ()
hFlush Handle
stdout
case BisectDir
dir of
BisectRight -> [DarcsFlag] -> PatchTree (WrappedNamed rt p) wY wY -> IO ()
forall (p :: * -> * -> *) wX wY.
(Invert p, Apply p, PatchInspect p,
ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight [DarcsFlag]
opts PatchTree (WrappedNamed rt p) wY wY
l
BisectLeft -> [DarcsFlag] -> PatchTree (WrappedNamed rt p) wX wY -> IO ()
forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnLeft [DarcsFlag]
opts PatchTree (WrappedNamed rt p) wX wY
r
ExitCode
testResult <- IO ExitCode
testCmd
case ExitCode
testResult of
ExitSuccess -> [DarcsFlag]
-> BisectState
-> IO ExitCode
-> BisectDir
-> PatchTree (WrappedNamed rt p) wY wY
-> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO,
ApplyState p ~ Tree) =>
[DarcsFlag]
-> BisectState
-> IO ExitCode
-> BisectDir
-> PatchTree (WrappedNamed rt p) wX wY
-> IO ()
trackNextBisect [DarcsFlag]
opts (Int
dnowInt -> Int -> Int
forall a. Num a => a -> a -> a
+1, Int
dtotal) IO ExitCode
testCmd
BisectDir
BisectLeft PatchTree (WrappedNamed rt p) wY wY
l
_ -> [DarcsFlag]
-> BisectState
-> IO ExitCode
-> BisectDir
-> PatchTree (WrappedNamed rt p) wX wY
-> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO,
ApplyState p ~ Tree) =>
[DarcsFlag]
-> BisectState
-> IO ExitCode
-> BisectDir
-> PatchTree (WrappedNamed rt p) wX wY
-> IO ()
trackNextBisect [DarcsFlag]
opts (Int
dnowInt -> Int -> Int
forall a. Num a => a -> a -> a
+1, Int
dtotal) IO ExitCode
testCmd
BisectDir
BisectRight PatchTree (WrappedNamed rt p) wX wY
r
trackNextBisect _ _ _ _ (Leaf p :: WrappedNamed rt p wX wY
p) = do
String -> IO ()
putStrLn "Last recent patch that fails the test (assuming monotony in the given range):"
Doc -> IO ()
putDocLn (WrappedNamed rt p wX wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description WrappedNamed rt p wX wY
p)
jumpHalfOnRight :: (Invert p, Apply p, PatchInspect p,
ApplyMonad (ApplyState p) DefaultIO)
=> [DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight :: [DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight opts :: [DarcsFlag]
opts l :: PatchTree p wX wY
l = do RL p wX wY -> IO ()
forall (p :: * -> * -> *) wX wY.
(Invert p, Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
unapplyRL RL p wX wY
ps
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetScriptsExecutable -> Bool
forall a. YesNo a => a -> Bool
O.yes (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable)
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RL p wX wY -> IO ()
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches RL p wX wY
ps
where ps :: RL p wX wY
ps = PatchTree p wX wY -> RL p wX wY
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 :: [DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnLeft opts :: [DarcsFlag]
opts r :: PatchTree p wX wY
r = do RL p wX wY -> IO ()
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
applyRL RL p wX wY
p
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetScriptsExecutable -> Bool
forall a. YesNo a => a -> Bool
O.yes (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable (forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable)
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RL p wX wY -> IO ()
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches RL p wX wY
p
where p :: RL p wX wY
p = PatchTree p wX wY -> RL p wX wY
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 :: RL p wX wY -> IO ()
applyRL patches :: RL p wX wY
patches = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ((forall wW wZ. p wW wZ -> IO ()) -> FL p wX wY -> [IO ()]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. p wW wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeApply (RL p wX wY -> FL p wX wY
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL p wX wY
patches))
unapplyRL :: (Invert p, Apply p, ApplyMonad (ApplyState p) DefaultIO)
=> RL p wX wY -> IO ()
unapplyRL :: RL p wX wY -> IO ()
unapplyRL patches :: RL p wX wY
patches = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ((forall wW wZ. p wW wZ -> IO ()) -> RL p wX wY -> [IO ()]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL (p wZ wW -> IO ()
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeApply (p wZ wW -> IO ()) -> (p wW wZ -> p wZ wW) -> p wW wZ -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p wW wZ -> p wZ wW
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert) RL p wX wY
patches)
safeApply :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
=> p wX wY -> IO ()
safeApply :: p wX wY -> IO ()
safeApply p :: p wX wY
p = DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefault (p wX wY -> DefaultIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
p) IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
msg :: IOException) -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Bad patch:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
msg