--  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 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 (String -> Doc) -> String -> Doc
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 :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
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 = 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
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (TestStrategy
   -> LeaveTestDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (TestStrategy
   -> LeaveTestDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
testOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (TestStrategy
   -> LeaveTestDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> 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
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
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 = 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
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
testOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (TestStrategy
   -> LeaveTestDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (TestStrategy
   -> LeaveTestDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (SetScriptsExecutable
      -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (TestStrategy
      -> LeaveTestDir
      -> Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> SetScriptsExecutable
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (SetScriptsExecutable
   -> UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall a.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
testAdvancedOpts

data TestResult = Success | Failure Int

data SearchTypeResult = AssumedMonotony | WasLinear

data StrategyResult p =
    StrategySuccess -- the initial run of the test passed
  | NoPasses
  | PassesOnHead
  | Blame SearchTypeResult (Sealed2 (Named p))
  -- these two are just for oneTest
  | RunSuccess
  | RunFailed Int

-- | Functions defining a strategy for executing a test
type Strategy = forall p wX wY
               . (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)
              => [DarcsFlag]
              -> IO TestResult  -- ^ test command
              -> 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 =
 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 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
  (IO ExitCode
init,IO TestResult
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 TestResult) -> IO (IO ExitCode, IO TestResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess, ExitCode -> TestResult
exitCodeToTestResult (ExitCode -> TestResult) -> IO ExitCode -> IO TestResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ExitCode
t)
    [String
cmd] ->
      do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Using test command:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cmd
         (IO ExitCode, IO TestResult) -> IO (IO ExitCode, IO TestResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess, ExitCode -> TestResult
exitCodeToTestResult (ExitCode -> TestResult) -> IO ExitCode -> IO TestResult
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"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
$ String
"Using test command:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cmd
         (IO ExitCode, IO TestResult) -> IO (IO ExitCode, IO TestResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO ExitCode
system String
init, ExitCode -> TestResult
exitCodeToTestResult (ExitCode -> TestResult) -> IO ExitCode -> IO TestResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ExitCode
system String
cmd)
    [String]
_ -> String -> IO (IO ExitCode, IO TestResult)
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 PrimDarcsOption LeaveTestDir -> [DarcsFlag] -> LeaveTestDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
            LeaveTestDir
O.YesLeaveTestDir -> String -> (AbsolutePath -> IO a) -> IO a
forall a. String -> (AbsolutePath -> IO a) -> IO a
withPermDir
            LeaveTestDir
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 String
"testing") ((AbsolutePath -> IO ()) -> IO ())
-> (AbsolutePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
_ -> 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 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 PrimDarcsOption TestStrategy -> [DarcsFlag] -> TestStrategy
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    StrategyResult p
result <- [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) Origin wR
-> IO (StrategyResult p)
forall wX wY.
[DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
track [DarcsFlag]
opts IO TestResult
testCmd TestResult
testResult ((forall wW wY. PatchInfoAnd rt p wW wY -> Named p wW wY)
-> RL (PatchInfoAnd rt p) Origin wR -> RL (Named 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 -> Named p wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully (RL (PatchInfoAnd rt p) Origin wR -> RL (Named p) Origin wR)
-> (PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR)
-> PatchSet rt p Origin wR
-> RL (Named 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 (Named p) Origin wR)
-> PatchSet rt p Origin wR -> RL (Named p) Origin wR
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" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
extraText String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":")
        Doc -> IO ()
putDocLn (Named p wX wY -> Doc
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 (Doc -> IO ()) -> Doc -> IO ()
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 (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Test failed!\n"
        ExitCode -> IO ()
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 = [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
Strategy
trackBisect
chooseStrategy TestStrategy
O.Linear = [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
Strategy
trackLinear
chooseStrategy TestStrategy
O.Backoff = [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
Strategy
trackBackoff
chooseStrategy TestStrategy
O.Once = [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
Strategy
oneTest

-- | test only the last recorded state
oneTest :: Strategy
oneTest :: [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
oneTest [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
RunSuccess
oneTest [DarcsFlag]
_ IO TestResult
_ (Failure Int
n)  RL (Named p) wX wY
_ = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return (StrategyResult p -> IO (StrategyResult p))
-> StrategyResult p -> IO (StrategyResult p)
forall a b. (a -> b) -> a -> b
$ Int -> StrategyResult p
forall (p :: * -> * -> *). Int -> StrategyResult p
RunFailed Int
n

-- | linear search (with --linear)
trackLinear :: Strategy
trackLinear :: [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
trackLinear [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
StrategySuccess
trackLinear [DarcsFlag]
_ IO TestResult
_ (Failure Int
_) RL (Named p) wX wY
NilRL = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackLinear [DarcsFlag]
opts IO TestResult
testCmd (Failure Int
_) RL (Named p) wX wY
ps = [DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
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 :: [DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
trackNextLinear [DarcsFlag]
_ IO TestResult
_ RL (Named p) wX wY
NilRL = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackNextLinear [DarcsFlag]
opts IO TestResult
testCmd (RL (Named p) wX wY
ps:<:Named p wY wY
p) = do
    Named p wY wY -> IO ()
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeUnapply Named p wY 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
$ Named p wY wY -> IO ()
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 (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Named p wY wY -> Doc
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 -> StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return (StrategyResult p -> IO (StrategyResult p))
-> StrategyResult p -> IO (StrategyResult p)
forall a b. (a -> b) -> a -> b
$ SearchTypeResult -> Sealed2 (Named p) -> StrategyResult p
forall (p :: * -> * -> *).
SearchTypeResult -> Sealed2 (Named p) -> StrategyResult p
Blame SearchTypeResult
WasLinear (Sealed2 (Named p) -> StrategyResult p)
-> Sealed2 (Named p) -> StrategyResult p
forall a b. (a -> b) -> a -> b
$ Named p wY wY -> Sealed2 (Named p)
forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
Sealed2 Named p wY wY
p
        Failure Int
_ -> [DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
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

-- | exponential backoff search (with --backoff)
trackBackoff :: Strategy
trackBackoff :: [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
trackBackoff [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
NilRL = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
StrategySuccess
trackBackoff [DarcsFlag]
_ IO TestResult
_ (Failure Int
_) RL (Named p) wX wY
NilRL = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackBackoff [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
PassesOnHead
trackBackoff [DarcsFlag]
opts IO TestResult
testCmd (Failure Int
_) RL (Named p) wX wY
ps =
    [DarcsFlag]
-> IO TestResult
-> Int
-> RL (Named p) wX wY
-> IO (StrategyResult p)
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 -- ^ number of patches to skip
                 -> RL (Named p) wY wZ -- ^ patches not yet skipped
                 -> IO (StrategyResult p)
trackNextBackoff :: [DarcsFlag]
-> IO TestResult
-> Int
-> RL (Named p) wY wZ
-> IO (StrategyResult p)
trackNextBackoff [DarcsFlag]
_ IO TestResult
_ Int
_ RL (Named p) wY wZ
NilRL = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackNextBackoff [DarcsFlag]
opts IO TestResult
testCmd Int
n RL (Named p) wY wZ
ahead
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= RL (Named p) wY wZ -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (Named p) wY wZ
ahead = [DarcsFlag]
-> IO TestResult -> RL (Named p) wY wZ -> IO (StrategyResult p)
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"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]
++ String
" patches..."
    Handle -> IO ()
hFlush Handle
stdout
    case Int
-> RL (Named p) wY wZ -> (:>) (RL (Named p)) (RL (Named p)) wY wZ
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
            RL (Named p) wZ wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
unapplyRL RL (Named 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 (Named p) wZ wZ -> IO ()
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
_ ->
                    [DarcsFlag]
-> IO TestResult
-> Int
-> RL (Named p) wY wZ
-> IO (StrategyResult p)
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
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) RL (Named p) wY wZ
ahead'
                TestResult
Success -> do
                    RL (Named p) wZ wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
applyRL RL (Named p) wZ wZ
skipped'  -- offending patch is one of these
                    [DarcsFlag]
-> IO TestResult -> RL (Named p) wZ wZ -> IO (StrategyResult p)
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' -- bisect to find it

-- | binary search (with --bisect)
trackBisect :: Strategy
trackBisect :: [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
trackBisect [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
NilRL = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
StrategySuccess
trackBisect [DarcsFlag]
_ IO TestResult
_ (Failure Int
_) RL (Named p) wX wY
NilRL = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackBisect [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return StrategyResult p
forall (p :: * -> * -> *). StrategyResult p
PassesOnHead
trackBisect [DarcsFlag]
opts IO TestResult
testCmd (Failure Int
_) RL (Named p) wX wY
ps =
    [DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
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 :: [DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
initialBisect [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wX wY
ps =
    [DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
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 (RL (Named p) wX wY -> PatchTree (Named p) wX wY
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 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 Double
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 (Named p) wX wY -> Int
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

-- | 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 BisectProgress = (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 (RL p wX wY
NilRL :<: 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 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` Int
2) RL p wX wY
xs of
                       (RL p wX wZ
r :> 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 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 PatchTree p wY wY
l 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)
                => [DarcsFlag]
                -> BisectProgress
                -> IO TestResult -- ^ test command
                -> BisectDir
                -> PatchTree (Named p) wX wY
                -> IO (StrategyResult p)
trackNextBisect :: [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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"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 -> 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]
++ String
" sequences...\n"
  Handle -> IO ()
hFlush Handle
stdout
  case BisectDir
dir of
    BisectDir
BisectRight -> [DarcsFlag] -> PatchTree (Named p) wY wY -> IO ()
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  -- move in temporary repo
    BisectDir
BisectLeft  -> [DarcsFlag] -> PatchTree (Named 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 (Named p) wX wY
r  -- within given direction
  TestResult
testResult <- IO TestResult
testCmd -- execute test on repo
  case TestResult
testResult of
    TestResult
Success -> [DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wY wY
-> IO (StrategyResult p)
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
dnowInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
dtotal) IO TestResult
testCmd
                               BisectDir
BisectLeft PatchTree (Named p) wY wY
l  -- continue left  (to the present)
    TestResult
_       -> [DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
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
dnowInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
dtotal) IO TestResult
testCmd
                               BisectDir
BisectRight PatchTree (Named p) wX wY
r -- continue right (to the past)
trackNextBisect [DarcsFlag]
_ BisectProgress
_ IO TestResult
_ BisectDir
_ (Leaf Named p wX wY
p) = StrategyResult p -> IO (StrategyResult p)
forall (m :: * -> *) a. Monad m => a -> m a
return (SearchTypeResult -> Sealed2 (Named p) -> StrategyResult p
forall (p :: * -> * -> *).
SearchTypeResult -> Sealed2 (Named p) -> StrategyResult p
Blame SearchTypeResult
AssumedMonotony (Named p wX wY -> Sealed2 (Named p)
forall (a :: * -> * -> *) wX wY. a wX 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 :: [DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight [DarcsFlag]
opts PatchTree p wX wY
l = do RL p wX wY -> IO ()
forall (p :: * -> * -> *) wX wY.
(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 [DarcsFlag]
opts 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   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 :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
           => RL p wX wY -> IO ()
unapplyRL :: RL p wX wY -> IO ()
unapplyRL 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 forall wW wZ. p wW wZ -> IO ()
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 :: p wX wY -> IO ()
safeApply 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
$ String
"Bad patch:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
msg

safeUnapply :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
            => p wX wY -> IO ()
safeUnapply :: p wX wY -> IO ()
safeUnapply 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 ()
unapply 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
$ String
"Bad patch:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
msg