--  Copyright (C) 2002-2005 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

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

-- | Functions defining a strategy for executing a test
type Strategy = forall rt p wX wY
               . (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree)
              => [DarcsFlag]
              -> IO ExitCode  -- ^ test command
              -> 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

-- | test only the last recorded state
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

-- | linear search (with --linear)
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!"

-- | exponential backoff search (with --backoff)
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 -- ^ number of patches to skip
                 -> RL (WrappedNamed rt p) wY wZ -- ^ patches not yet skipped
                 -> 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'  -- offending patch is one of these
                    [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' -- bisect to find it

-- | binary search (with --bisect)
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

-- | Bisect Patch Tree
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

-- | Direction of Bisect trackdown
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

-- | Progress of Bisect
type BisectState = (Int, Int)

-- | Create Bisect PatchTree from the RL
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)

-- | Convert PatchTree back to RL
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

-- | Iterate the Patch Tree
trackNextBisect :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO, ApplyState p ~ Tree)
                => [DarcsFlag]
                -> BisectState
                -> IO ExitCode -- ^ test command
                -> 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  -- move in temporary repo
    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  -- within given direction
  ExitCode
testResult <- IO ExitCode
testCmd -- execute test on repo
  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  -- continue left  (to the present)
    _           -> [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 -- continue right (to the past)
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