--  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 forall a b. (a -> b) -> a -> b
$
 [String] -> String
unlines
 [ String
"Run test on the current recorded state of the repository.  Given no"
  ,String
"arguments, it uses the default repository test (see `darcs setpref`)."
  ,String
"Given one argument, it treats it as a test command."
  ,String
"Given two arguments, the first is an initialization command and the"
  ,String
"second is the test (meaning the exit code of the first command is not"
  ,String
"taken into account to determine success of the test)."
  ,String
"If given the `--linear` or `--bisect` flags, it tries to find the most"
  ,String
"recent version in the repository which passes a test."
  ,String
""
  ,String
"`--linear` does linear search starting from head, and moving away"
  ,String
"from head. This strategy is best when the test runs very quickly"
  ,String
"or the patch you're seeking is near the head."
  ,String
""
  ,String
"`--bisect` does binary search.  This strategy is best when the test"
  ,String
"runs very slowly or the patch you're seeking is likely to be in"
  ,String
"the repository's distant past."
  ,String
""
  ,String
"`--backoff` starts searching from head, skipping further and further"
  ,String
"into the past until the test succeeds.  It then does a binary search"
  ,String
"on a subset of those skipped patches.  This strategy works well unless"
  ,String
"the patch you're seeking is in the repository's distant past."
  ,String
""
  ,String
"Under the assumption that failure is monotonous, `--linear` and"
  ,String
"`--bisect` produce the same result.  (Monotonous means that when moving"
  ,String
"away from head, the test result changes only once from \"fail\" to"
  ,String
"\"ok\".)  If failure is not monotonous, any one of the patches that"
  ,String
"break the test is found at random."
 ]

test :: DarcsCommand
test :: DarcsCommand
test = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"test"
    , commandHelp :: Doc
commandHelp = Doc
testHelp
    , commandDescription :: String
commandDescription = String
testDescription
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[[INITIALIZATION]", String
"COMMAND]"]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
testCommand
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
testAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
  a
  (TestStrategy
   -> LeaveTestDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
testOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
  a
  (TestStrategy
   -> LeaveTestDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
testOpts
    }
  where
    testBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts = PrimDarcsOption TestStrategy
O.testStrategy forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption LeaveTestDir
O.leaveTestDir forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe String)
O.repoDir
    testAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
testAdvancedOpts = forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable
    testOpts :: DarcsOption
  a
  (TestStrategy
   -> LeaveTestDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
testOpts = forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (TestStrategy -> LeaveTestDir -> Maybe String -> a)
testBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
testAdvancedOpts

data TestResult = Success | Failure Int

data SearchTypeResult = AssumedMonotony | WasLinear

data StrategyResult p =
    StrategySuccess -- 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 =
 forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$ forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
  PatchSet rt p Origin wR
patches <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repository
  (IO ExitCode
init,IO TestResult
testCmd) <- case [String]
args of
    [] ->
      do IO ExitCode
t <- Verbosity -> IO (IO ExitCode)
getTest (PrimDarcsOption Verbosity
verbosity forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess, ExitCode -> TestResult
exitCodeToTestResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ExitCode
t)
    [String
cmd] ->
      do String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Using test command:\n"forall a. [a] -> [a] -> [a]
++String
cmd
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess, ExitCode -> TestResult
exitCodeToTestResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ExitCode
system String
cmd)
    [String
init,String
cmd] ->
      do String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Using initialization command:\n"forall a. [a] -> [a] -> [a]
++String
init
         String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Using test command:\n"forall a. [a] -> [a] -> [a]
++String
cmd
         forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO ExitCode
system String
init, ExitCode -> TestResult
exitCodeToTestResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ExitCode
system String
cmd)
    [String]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Test expects zero to two arguments."
  let wd :: String -> (AbsolutePath -> IO a) -> IO a
wd = case PrimDarcsOption LeaveTestDir
O.leaveTestDir forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
            LeaveTestDir
O.YesLeaveTestDir -> forall a. String -> (AbsolutePath -> IO a) -> IO a
withPermDir
            LeaveTestDir
O.NoLeaveTestDir -> forall a. String -> (AbsolutePath -> IO a) -> IO a
withTempDir
  forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT
-> ((AbsolutePath -> IO a) -> IO a)
-> (AbsolutePath -> IO a)
-> IO a
withRecorded Repository rt p wR wU wR
repository (forall a. String -> (AbsolutePath -> IO a) -> IO a
wd String
"testing") forall a b. (a -> b) -> a -> b
$ \AbsolutePath
_ -> do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. YesNo a => a -> Bool
O.yes (forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) IO ()
setScriptsExecutable
    ExitCode
_ <- IO ExitCode
init
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Running test...\n"
    TestResult
testResult <- IO TestResult
testCmd
    let track :: [DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
track = TestStrategy -> Strategy
chooseStrategy (PrimDarcsOption TestStrategy
O.testStrategy forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    StrategyResult p
result <- forall {wX} {wY}.
[DarcsFlag]
-> IO TestResult
-> TestResult
-> RL (Named p) wX wY
-> IO (StrategyResult p)
track [DarcsFlag]
opts IO TestResult
testCmd TestResult
testResult (forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ
mapRL_RL forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR
patches)
    case StrategyResult p
result of
      StrategyResult p
StrategySuccess -> String -> IO ()
putStrLn String
"Success!"
      StrategyResult p
NoPasses -> String -> IO ()
putStrLn String
"Noone passed the test!"
      StrategyResult p
PassesOnHead -> String -> IO ()
putStrLn String
"Test does not fail on head."
      Blame SearchTypeResult
searchTypeResult (Sealed2 Named p wX wY
p) -> do
        let extraText :: String
extraText =
              case SearchTypeResult
searchTypeResult of
                SearchTypeResult
AssumedMonotony -> String
" (assuming monotony in the given range)"
                SearchTypeResult
WasLinear -> String
""
        String -> IO ()
putStrLn (String
"Last recent patch that fails the test" forall a. [a] -> [a] -> [a]
++ String
extraText forall a. [a] -> [a] -> [a]
++ String
":")
        Doc -> IO ()
putDocLn (forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description Named p wX wY
p)
      StrategyResult p
RunSuccess -> [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Test ran successfully.\n"
      RunFailed Int
n -> do
        [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Test failed!\n"
        forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
n)

exitCodeToTestResult :: ExitCode -> TestResult
exitCodeToTestResult :: ExitCode -> TestResult
exitCodeToTestResult ExitCode
ExitSuccess = TestResult
Success
exitCodeToTestResult (ExitFailure Int
n) = Int -> TestResult
Failure Int
n

chooseStrategy :: O.TestStrategy -> Strategy
chooseStrategy :: TestStrategy -> Strategy
chooseStrategy TestStrategy
O.Bisect = Strategy
trackBisect
chooseStrategy TestStrategy
O.Linear = Strategy
trackLinear
chooseStrategy TestStrategy
O.Backoff = Strategy
trackBackoff
chooseStrategy TestStrategy
O.Once = Strategy
oneTest

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

-- | linear search (with --linear)
trackLinear :: Strategy
trackLinear :: Strategy
trackLinear [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
StrategySuccess
trackLinear [DarcsFlag]
_ IO TestResult
_ (Failure Int
_) RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackLinear [DarcsFlag]
opts IO TestResult
testCmd (Failure Int
_) RL (Named p) wX wY
ps = forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
trackNextLinear [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wX wY
ps

trackNextLinear
    :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)
    => [DarcsFlag]
    -> IO TestResult
    -> RL (Named p) wX wY
    -> IO (StrategyResult p)
trackNextLinear :: forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
trackNextLinear [DarcsFlag]
_ IO TestResult
_ RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackNextLinear [DarcsFlag]
opts IO TestResult
testCmd (RL (Named p) wX wY
ps:<:Named p wY wY
p) = do
    forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeUnapply Named p wY wY
p
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. YesNo a => a -> Bool
O.yes (forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches Named p wY wY
p
    String -> IO ()
putStrLn String
"Trying without the patch:"
    Doc -> IO ()
putDocLn forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description Named p wY wY
p
    Handle -> IO ()
hFlush Handle
stdout
    TestResult
testResult <- IO TestResult
testCmd
    case TestResult
testResult of
        TestResult
Success -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *).
SearchTypeResult -> Sealed2 (Named p) -> StrategyResult p
Blame SearchTypeResult
WasLinear forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wY wY. a wY wY -> Sealed2 a
Sealed2 Named p wY wY
p
        Failure Int
_ -> forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
trackNextLinear [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wX wY
ps

-- | exponential backoff search (with --backoff)
trackBackoff :: Strategy
trackBackoff :: Strategy
trackBackoff [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
StrategySuccess
trackBackoff [DarcsFlag]
_ IO TestResult
_ (Failure Int
_) RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackBackoff [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
PassesOnHead
trackBackoff [DarcsFlag]
opts IO TestResult
testCmd (Failure Int
_) RL (Named p) wX wY
ps =
    forall (p :: * -> * -> *) wY wZ.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult
-> Int
-> RL (Named p) wY wZ
-> IO (StrategyResult p)
trackNextBackoff [DarcsFlag]
opts IO TestResult
testCmd Int
4 RL (Named p) wX wY
ps

trackNextBackoff :: (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)
                 => [DarcsFlag]
                 -> IO TestResult
                 -> Int -- ^ number of patches to skip
                 -> RL (Named p) wY wZ -- ^ patches not yet skipped
                 -> IO (StrategyResult p)
trackNextBackoff :: forall (p :: * -> * -> *) wY wZ.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult
-> Int
-> RL (Named p) wY wZ
-> IO (StrategyResult p)
trackNextBackoff [DarcsFlag]
_ IO TestResult
_ Int
_ RL (Named p) wY wZ
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackNextBackoff [DarcsFlag]
opts IO TestResult
testCmd Int
n RL (Named p) wY wZ
ahead
    | Int
n forall a. Ord a => a -> a -> Bool
>= forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (Named p) wY wZ
ahead = forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
initialBisect [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wY wZ
ahead
trackNextBackoff [DarcsFlag]
opts IO TestResult
testCmd Int
n RL (Named p) wY wZ
ahead = do
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Skipping " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" patches..."
    Handle -> IO ()
hFlush Handle
stdout
    case forall (a :: * -> * -> *) wX wZ.
Int -> RL a wX wZ -> (:>) (RL a) (RL a) wX wZ
splitAtRL Int
n RL (Named p) wY wZ
ahead of
        ( RL (Named p) wY wZ
ahead' :> RL (Named p) wZ wZ
skipped' ) -> do
            forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
unapplyRL RL (Named p) wZ wZ
skipped'
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. YesNo a => a -> Bool
O.yes (forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches RL (Named p) wZ wZ
skipped'
            TestResult
testResult <- IO TestResult
testCmd
            case TestResult
testResult of
                Failure Int
_ ->
                    forall (p :: * -> * -> *) wY wZ.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult
-> Int
-> RL (Named p) wY wZ
-> IO (StrategyResult p)
trackNextBackoff [DarcsFlag]
opts IO TestResult
testCmd (Int
2forall a. Num a => a -> a -> a
*Int
n) RL (Named p) wY wZ
ahead'
                TestResult
Success -> do
                    forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
applyRL RL (Named p) wZ wZ
skipped'  -- offending patch is one of these
                    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 :: Strategy
trackBisect [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
StrategySuccess
trackBisect [DarcsFlag]
_ IO TestResult
_ (Failure Int
_) RL (Named p) wX wY
NilRL = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
NoPasses
trackBisect [DarcsFlag]
_ IO TestResult
_ TestResult
Success RL (Named p) wX wY
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall (p :: * -> * -> *). StrategyResult p
PassesOnHead
trackBisect [DarcsFlag]
opts IO TestResult
testCmd (Failure Int
_) RL (Named p) wX wY
ps =
    forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
initialBisect [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wX wY
ps

initialBisect ::  (RepoPatch p, ApplyMonad (ApplyState p) DefaultIO)
              => [DarcsFlag]
              -> IO TestResult
              -> RL (Named p) wX wY
              -> IO (StrategyResult p)
initialBisect :: forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> IO TestResult -> RL (Named p) wX wY -> IO (StrategyResult p)
initialBisect [DarcsFlag]
opts IO TestResult
testCmd RL (Named p) wX wY
ps =
    forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
trackNextBisect [DarcsFlag]
opts BisectProgress
currProg IO TestResult
testCmd BisectDir
BisectRight (forall (p :: * -> * -> *) wX wY. RL p wX wY -> PatchTree p wX wY
patchTreeFromRL RL (Named p) wX wY
ps)
  where
    maxProg :: Int
maxProg  = Int
1 forall a. Num a => a -> a -> a
+ forall a b. (RealFrac a, Integral b) => a -> b
round ((forall a. Floating a => a -> a -> a
logBase Double
2 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (Named p) wX wY
ps) :: Double)
    currProg :: BisectProgress
currProg = (Int
1, Int
maxProg) :: BisectProgress

-- | 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 -> ShowS
[BisectDir] -> ShowS
BisectDir -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BisectDir] -> ShowS
$cshowList :: [BisectDir] -> ShowS
show :: BisectDir -> String
$cshow :: BisectDir -> String
showsPrec :: Int -> BisectDir -> ShowS
$cshowsPrec :: Int -> BisectDir -> ShowS
Show

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

-- | Create Bisect PatchTree from the RL
patchTreeFromRL :: RL p wX wY -> PatchTree p wX wY
patchTreeFromRL :: forall (p :: * -> * -> *) wX wY. RL p wX wY -> PatchTree p wX wY
patchTreeFromRL (RL p wX wY
NilRL :<: p wY wY
l) = forall (p :: * -> * -> *) wX wY. p wX wY -> PatchTree p wX wY
Leaf p wY wY
l
patchTreeFromRL RL p wX wY
xs = case forall (a :: * -> * -> *) wX wZ.
Int -> RL a wX wZ -> (:>) (RL a) (RL a) wX wZ
splitAtRL (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL p wX wY
xs forall a. Integral a => a -> a -> a
`div` Int
2) RL p wX wY
xs of
                       (RL p wX wZ
r :> RL p wZ wY
l) -> forall (p :: * -> * -> *) wY wZ wX.
PatchTree p wY wZ -> PatchTree p wX wY -> PatchTree p wX wZ
Fork (forall (p :: * -> * -> *) wX wY. RL p wX wY -> PatchTree p wX wY
patchTreeFromRL RL p wZ wY
l) (forall (p :: * -> * -> *) wX wY. RL p wX wY -> PatchTree p wX wY
patchTreeFromRL RL p wX wZ
r)

-- | Convert PatchTree back to RL
patchTree2RL :: PatchTree p wX wY -> RL p wX wY
patchTree2RL :: forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL (Leaf p wX wY
p)   = forall (a :: * -> * -> *) wX. RL a wX wX
NilRL forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: p wX wY
p
patchTree2RL (Fork PatchTree p wY wY
l PatchTree p wX wY
r) = forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL PatchTree p wX wY
r forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> RL a wY wZ -> RL a wX wZ
+<+ forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL PatchTree p wY wY
l

-- | 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 :: forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
trackNextBisect [DarcsFlag]
opts (Int
dnow, Int
dtotal) IO TestResult
testCmd BisectDir
dir (Fork PatchTree (Named p) wY wY
l PatchTree (Named p) wX wY
r) = do
  String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ String
"Trying " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
dnow forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
dtotal forall a. [a] -> [a] -> [a]
++ String
" sequences...\n"
  Handle -> IO ()
hFlush Handle
stdout
  case BisectDir
dir of
    BisectDir
BisectRight -> forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight [DarcsFlag]
opts PatchTree (Named p) wY wY
l  -- move in temporary repo
    BisectDir
BisectLeft  -> forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnLeft  [DarcsFlag]
opts PatchTree (Named p) wX wY
r  -- within given direction
  TestResult
testResult <- IO TestResult
testCmd -- execute test on repo
  case TestResult
testResult of
    TestResult
Success -> forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
trackNextBisect [DarcsFlag]
opts (Int
dnowforall a. Num a => a -> a -> a
+Int
1, Int
dtotal) IO TestResult
testCmd
                               BisectDir
BisectLeft PatchTree (Named p) wY wY
l  -- continue left  (to the present)
    TestResult
_       -> forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag]
-> BisectProgress
-> IO TestResult
-> BisectDir
-> PatchTree (Named p) wX wY
-> IO (StrategyResult p)
trackNextBisect [DarcsFlag]
opts (Int
dnowforall a. Num a => a -> a -> a
+Int
1, Int
dtotal) IO TestResult
testCmd
                               BisectDir
BisectRight PatchTree (Named p) wX wY
r -- continue right (to the past)
trackNextBisect [DarcsFlag]
_ BisectProgress
_ IO TestResult
_ BisectDir
_ (Leaf Named p wX wY
p) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: * -> * -> *).
SearchTypeResult -> Sealed2 (Named p) -> StrategyResult p
Blame SearchTypeResult
AssumedMonotony (forall (a :: * -> * -> *) wY wY. a wY wY -> Sealed2 a
Sealed2 Named p wX wY
p))

jumpHalfOnRight :: (Apply p, PatchInspect p,
                    ApplyMonad (ApplyState p) DefaultIO)
                => [DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight :: forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnRight [DarcsFlag]
opts PatchTree p wX wY
l = do forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
unapplyRL RL p wX wY
ps
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. YesNo a => a -> Bool
O.yes (forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches RL p wX wY
ps
  where ps :: RL p wX wY
ps = forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL PatchTree p wX wY
l

jumpHalfOnLeft :: (Apply p, PatchInspect p,
                   ApplyMonad (ApplyState p) DefaultIO)
               => [DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnLeft :: forall (p :: * -> * -> *) wX wY.
(Apply p, PatchInspect p, ApplyMonad (ApplyState p) DefaultIO) =>
[DarcsFlag] -> PatchTree p wX wY -> IO ()
jumpHalfOnLeft [DarcsFlag]
opts PatchTree p wX wY
r = do forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
applyRL RL p wX wY
p
                           forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. YesNo a => a -> Bool
O.yes (forall {a}.
PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
O.setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches RL p wX wY
p

  where p :: RL p wX wY
p = forall (p :: * -> * -> *) wX wY. PatchTree p wX wY -> RL p wX wY
patchTree2RL PatchTree p wX wY
r

applyRL :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
        => RL p wX wY -> IO ()
applyRL :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
applyRL   RL p wX wY
patches = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeApply (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL p wX wY
patches))

unapplyRL :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
           => RL p wX wY -> IO ()
unapplyRL :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
RL p wX wY -> IO ()
unapplyRL RL p wX wY
patches = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeUnapply RL p wX wY
patches)

safeApply :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
          => p wX wY -> IO ()
safeApply :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeApply p wX wY
p = forall a. DefaultIO a -> IO a
runDefault (forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
p) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
msg :: IOException) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Bad patch:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
msg

safeUnapply :: (Apply p, ApplyMonad (ApplyState p) DefaultIO)
            => p wX wY -> IO ()
safeUnapply :: forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) DefaultIO) =>
p wX wY -> IO ()
safeUnapply p wX wY
p = forall a. DefaultIO a -> IO a
runDefault (forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply p wX wY
p) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
msg :: IOException) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Bad patch:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
msg