{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Darcs.UI.Commands.Test.Impl
    ( TestRunner(..), runStrategy
    , TestResult(..), TestResultValid(..), TestFailure(..)
    , TestingDone
    , PatchSeq(..), patchTreeToFL
    , StrategyResult, StrategyResultRaw(..)
    , explanatoryTextFor
    , runTestingEnv
    , exitCodeToTestResult
    , mkTestCmd
    , runTestable
    ) where

import Darcs.Prelude hiding ( init, Monad(..) )
import Darcs.Util.IndexedMonad

import qualified Control.Monad as Base ( Monad(..) )

import Data.Constraint ( Dict(..) )
import Data.String ( fromString )

import GHC.Exts ( Constraint )
import GHC.Show ( showSpace )

import System.Exit ( ExitCode(..) )
import System.IO ( hFlush, stdout )

import qualified Darcs.UI.Options.All as O
import Darcs.Repository ( setScriptsExecutablePatches )
import Darcs.Patch.Witnesses.Ordered
    ( RL(..)
    , FL(..)
    , (:>)(..)
    , splitAtRL
    , reverseRL
    , lengthRL
    , mapRL_RL
    , lengthFL
    , reverseFL
    , (+>+)
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )
import Darcs.Patch.Witnesses.Show
  ( Show1(..), Show2(..)
  , showsPrec2
  )
import Darcs.Patch.ApplyMonad ( ApplyMonad )
import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Commute ( Commute, commute )
import Darcs.Patch.CommuteFn ( commuterIdFL )
import Darcs.Patch.Inspect ( PatchInspect(..) )
import Darcs.Patch ( description )
import Darcs.Patch.Show ( ShowPatch )
import Darcs.Util.Printer ( putDocLn )
import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault )

-- |This type is used to track the state of the testing tree.
-- For example, 'Testing IO wX wY Int' requires that the testing
-- tree start in state 'wX', and leaves it in state 'wY'.
newtype Testing m (wX :: *) (wY :: *) a = Testing { forall {k} (m :: k -> *) wX wY (a :: k). Testing m wX wY a -> m a
unTesting :: m a }

-- |Once we've finished tracking down a test failure, we no longer care
-- about tracking the actual state of the testing tree. This witness
-- constant is never used in any patch, so once we use it for the state
-- of the testing tree, in practice we can no longer do anything more with
-- that tree.
--
-- We could also use some kind of existential or different monad type
-- to represent this, but it would make composing code with 'do' harder.
data TestingDone

type TestingIO = Testing IO

instance Base.Monad m => Monad (Testing m) where
  return :: forall a i. a -> Testing m i i a
return a
v = m a -> Testing m i i a
forall {k} (m :: k -> *) wX wY (a :: k). m a -> Testing m wX wY a
Testing (a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
Base.return a
v)
  Testing m a
m >>= :: forall i j a k b.
Testing m i j a -> (a -> Testing m j k b) -> Testing m i k b
>>= a -> Testing m j k b
f = m b -> Testing m i k b
forall {k} (m :: k -> *) wX wY (a :: k). m a -> Testing m wX wY a
Testing (m a
m m a -> (a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
Base.>>= Testing m j k b -> m b
forall {k} (m :: k -> *) wX wY (a :: k). Testing m wX wY a -> m a
unTesting (Testing m j k b -> m b) -> (a -> Testing m j k b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Testing m j k b
f)
  Testing m a
m1 >> :: forall i j a k b.
Testing m i j a -> Testing m j k b -> Testing m i k b
>> Testing m b
m2 = m b -> Testing m i k b
forall {k} (m :: k -> *) wX wY (a :: k). m a -> Testing m wX wY a
Testing (m a
m1 m a -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
Base.>> m b
m2)

instance LiftIx Testing where
  liftIx :: forall (m :: * -> *) a i. m a -> Testing m i i a
liftIx = m a -> Testing m i i a
forall {k} (m :: k -> *) wX wY (a :: k). m a -> Testing m wX wY a
Testing

data TestingParams =
  TestingParams
  { TestingParams -> SetScriptsExecutable
tpSetScriptsExecutable :: O.SetScriptsExecutable
  , TestingParams -> TestCmd
tpTestCmd :: TestCmd
  }

-- |The 'Testing' monad, augmented with configuration parameters
newtype TestingEnv m wX wY a =
  TestingEnv { forall (m :: * -> *) wX wY a.
TestingEnv m wX wY a -> ReaderT TestingParams (Testing m) wX wY a
unTestingEnv :: ReaderT TestingParams (Testing m) wX wY a }

type TestingEnvIO = TestingEnv IO

deriving instance Base.Monad m => Monad (TestingEnv m)
deriving instance Base.Monad m => MonadReader TestingParams (TestingEnv m)

instance LiftIx TestingEnv where
  liftIx :: forall (m :: * -> *) a i. m a -> TestingEnv m i i a
liftIx m a
m = ReaderT TestingParams (Testing m) i i a -> TestingEnv m i i a
forall (m :: * -> *) wX wY a.
ReaderT TestingParams (Testing m) wX wY a -> TestingEnv m wX wY a
TestingEnv ((TestingParams -> Testing m i i a)
-> ReaderT TestingParams (Testing m) i i a
forall r (m :: * -> * -> * -> *) i j a.
(r -> m i j a) -> ReaderT r m i j a
ReaderT (\TestingParams
_ -> m a -> Testing m i i a
forall (m :: * -> *) a i. m a -> Testing m i i a
forall (t :: (* -> *) -> * -> * -> * -> *) (m :: * -> *) a i.
LiftIx t =>
m a -> t m i i a
liftIx m a
m))

runTestingEnv :: TestingParams -> TestingEnv m wA TestingDone a -> m a
runTestingEnv :: forall (m :: * -> *) wA a.
TestingParams -> TestingEnv m wA TestingDone a -> m a
runTestingEnv TestingParams
args = Testing m wA TestingDone a -> m a
forall {k} (m :: k -> *) wX wY (a :: k). Testing m wX wY a -> m a
unTesting (Testing m wA TestingDone a -> m a)
-> (TestingEnv m wA TestingDone a -> Testing m wA TestingDone a)
-> TestingEnv m wA TestingDone a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TestingParams -> Testing m wA TestingDone a)
-> TestingParams -> Testing m wA TestingDone a
forall a b. (a -> b) -> a -> b
$ TestingParams
args) ((TestingParams -> Testing m wA TestingDone a)
 -> Testing m wA TestingDone a)
-> (TestingEnv m wA TestingDone a
    -> TestingParams -> Testing m wA TestingDone a)
-> TestingEnv m wA TestingDone a
-> Testing m wA TestingDone a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT TestingParams (Testing m) wA TestingDone a
-> TestingParams -> Testing m wA TestingDone a
forall r (m :: * -> * -> * -> *) i j a.
ReaderT r m i j a -> r -> m i j a
runReaderT (ReaderT TestingParams (Testing m) wA TestingDone a
 -> TestingParams -> Testing m wA TestingDone a)
-> (TestingEnv m wA TestingDone a
    -> ReaderT TestingParams (Testing m) wA TestingDone a)
-> TestingEnv m wA TestingDone a
-> TestingParams
-> Testing m wA TestingDone a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestingEnv m wA TestingDone a
-> ReaderT TestingParams (Testing m) wA TestingDone a
forall (m :: * -> *) wX wY a.
TestingEnv m wX wY a -> ReaderT TestingParams (Testing m) wX wY a
unTestingEnv

liftTesting :: Testing m wX wY a -> TestingEnv m wX wY a
liftTesting :: forall (m :: * -> *) wX wY a.
Testing m wX wY a -> TestingEnv m wX wY a
liftTesting Testing m wX wY a
m = ReaderT TestingParams (Testing m) wX wY a -> TestingEnv m wX wY a
forall (m :: * -> *) wX wY a.
ReaderT TestingParams (Testing m) wX wY a -> TestingEnv m wX wY a
TestingEnv (ReaderT TestingParams (Testing m) wX wY a -> TestingEnv m wX wY a)
-> ReaderT TestingParams (Testing m) wX wY a
-> TestingEnv m wX wY a
forall a b. (a -> b) -> a -> b
$ (TestingParams -> Testing m wX wY a)
-> ReaderT TestingParams (Testing m) wX wY a
forall r (m :: * -> * -> * -> *) i j a.
(r -> m i j a) -> ReaderT r m i j a
ReaderT ((TestingParams -> Testing m wX wY a)
 -> ReaderT TestingParams (Testing m) wX wY a)
-> (TestingParams -> Testing m wX wY a)
-> ReaderT TestingParams (Testing m) wX wY a
forall a b. (a -> b) -> a -> b
$ \TestingParams
_ -> Testing m wX wY a
m

-- |An indexed monad that can be used to run tests. 'TestingEnvIO' is
-- the only real implementation, the unit tests for testing are based on
-- mock implementations.
class Monad m => TestRunner m where
  type ApplyPatchReqs m (p :: * -> * -> *) :: Constraint
  type DisplayPatchReqs m (p :: * -> * -> *) :: Constraint

  -- |Output a message
  writeMsg :: String -> m wX wX ()

  -- |Output a message containing the name of a patch
  mentionPatch :: DisplayPatchReqs m p => p wA wB -> m wX wX ()
  
  -- |Apply a patch to the testing tree.
  applyPatch :: ApplyPatchReqs m p => p wX wY -> m wX wY ()

  -- |Unapply a patch from the testing tree
  unapplyPatch :: ApplyPatchReqs m p => p wX wY -> m wY wX ()

  -- |Get the current status (pass/skip/fail) of the testing tree,
  -- e.g. by running the test command.
  getCurrentTestResult :: m wX wX (TestResult wX)

  -- |Flag that all testing has completed.
  finishedTesting :: a -> m wX TestingDone a

type TestRunnerPatchReqs m p =
  ( -- Having to enumerate these different cases for ApplyPatchReqs is
    -- a bit ugly, but necessary because it is a type function and we
    -- don't know that ApplyPatchReqs m p => ApplyPatchReqs m (FL p), etc.
    -- In theory QuantifiedConstraints could be used to simplify this but
    -- the fact that ApplyPatchReqs is a type function makes this a bit tricky.
    ApplyPatchReqs m p, ApplyPatchReqs m (RL p), ApplyPatchReqs m (FL p)
  , ApplyPatchReqs m (PatchSeq p), ApplyPatchReqs m (RL (PatchSeq p))
  , DisplayPatchReqs m p)

type TestablePatch m p = (TestRunner m, TestRunnerPatchReqs m p, Commute p)

instance TestRunner TestingEnvIO where
  type ApplyPatchReqs TestingEnvIO p = (Apply p, ApplyMonad (ApplyState p) DefaultIO, PatchInspect p)
  type DisplayPatchReqs TestingEnvIO p = ShowPatch p

  writeMsg :: forall wX. String -> TestingEnvIO wX wX ()
writeMsg String
str = IO () -> TestingEnv IO wX wX ()
forall (m :: * -> *) a i. m a -> TestingEnv m i i a
forall (t :: (* -> *) -> * -> * -> * -> *) (m :: * -> *) a i.
LiftIx t =>
m a -> t m i i a
liftIx (String -> IO ()
putStrLn String
str IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
Base.>> Handle -> IO ()
hFlush Handle
stdout)
  mentionPatch :: forall (p :: * -> * -> *) wA wB wX.
DisplayPatchReqs TestingEnvIO p =>
p wA wB -> TestingEnvIO wX wX ()
mentionPatch p wA wB
p = IO () -> TestingEnv IO wX wX ()
forall (m :: * -> *) a i. m a -> TestingEnv m i i a
forall (t :: (* -> *) -> * -> * -> * -> *) (m :: * -> *) a i.
LiftIx t =>
m a -> t m i i a
liftIx (Doc -> IO ()
putDocLn (p wA wB -> Doc
forall wX wY. p wX wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description p wA wB
p) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
Base.>> Handle -> IO ()
hFlush Handle
stdout)

  applyPatch :: forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs TestingEnvIO p =>
p wX wY -> TestingEnvIO wX wY ()
applyPatch p wX wY
p = do
    Testing IO wX wY () -> TestingEnvIO wX wY ()
forall (m :: * -> *) wX wY a.
Testing m wX wY a -> TestingEnv m wX wY a
liftTesting (Testing IO wX wY () -> TestingEnvIO wX wY ())
-> Testing IO wX wY () -> TestingEnvIO wX wY ()
forall a b. (a -> b) -> a -> b
$ IO () -> Testing IO wX wY ()
forall {k} (m :: k -> *) wX wY (a :: k). m a -> Testing m wX wY a
Testing (IO () -> Testing IO wX wY ()) -> IO () -> Testing IO wX wY ()
forall a b. (a -> b) -> a -> b
$ DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefault (p wX wY -> DefaultIO ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
p)
    SetScriptsExecutable
opts <- (TestingParams -> SetScriptsExecutable)
-> TestingEnv IO wY wY SetScriptsExecutable
forall r (m :: * -> * -> * -> *) a i.
MonadReader r m =>
(r -> a) -> m i i a
asks TestingParams -> SetScriptsExecutable
tpSetScriptsExecutable
    Bool -> TestingEnv IO wY wY () -> TestingEnv IO wY wY ()
forall (m :: * -> * -> * -> *) i.
Monad m =>
Bool -> m i i () -> m i i ()
when (SetScriptsExecutable
opts SetScriptsExecutable -> SetScriptsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
O.YesSetScriptsExecutable) (TestingEnv IO wY wY () -> TestingEnv IO wY wY ())
-> TestingEnv IO wY wY () -> TestingEnv IO wY wY ()
forall a b. (a -> b) -> a -> b
$
      IO () -> TestingEnv IO wY wY ()
forall (m :: * -> *) a i. m a -> TestingEnv m i i a
forall (t :: (* -> *) -> * -> * -> * -> *) (m :: * -> *) a i.
LiftIx t =>
m a -> t m i i a
liftIx (IO () -> TestingEnv IO wY wY ())
-> IO () -> TestingEnv IO wY wY ()
forall a b. (a -> b) -> a -> b
$ p wX wY -> IO ()
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches p wX wY
p

  unapplyPatch :: forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs TestingEnvIO p =>
p wX wY -> TestingEnvIO wY wX ()
unapplyPatch p wX wY
p = do
    Testing IO wY wX () -> TestingEnvIO wY wX ()
forall (m :: * -> *) wX wY a.
Testing m wX wY a -> TestingEnv m wX wY a
liftTesting (Testing IO wY wX () -> TestingEnvIO wY wX ())
-> Testing IO wY wX () -> TestingEnvIO wY wX ()
forall a b. (a -> b) -> a -> b
$ IO () -> Testing IO wY wX ()
forall {k} (m :: k -> *) wX wY (a :: k). m a -> Testing m wX wY a
Testing (IO () -> Testing IO wY wX ()) -> IO () -> Testing IO wY wX ()
forall a b. (a -> b) -> a -> b
$ DefaultIO () -> IO ()
forall a. DefaultIO a -> IO a
runDefault (p wX wY -> DefaultIO ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply p wX wY
p)
    SetScriptsExecutable
opts <- (TestingParams -> SetScriptsExecutable)
-> TestingEnv IO wX wX SetScriptsExecutable
forall r (m :: * -> * -> * -> *) a i.
MonadReader r m =>
(r -> a) -> m i i a
asks TestingParams -> SetScriptsExecutable
tpSetScriptsExecutable
    Bool -> TestingEnv IO wX wX () -> TestingEnv IO wX wX ()
forall (m :: * -> * -> * -> *) i.
Monad m =>
Bool -> m i i () -> m i i ()
when (SetScriptsExecutable
opts SetScriptsExecutable -> SetScriptsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
O.YesSetScriptsExecutable) (TestingEnv IO wX wX () -> TestingEnv IO wX wX ())
-> TestingEnv IO wX wX () -> TestingEnv IO wX wX ()
forall a b. (a -> b) -> a -> b
$
      IO () -> TestingEnv IO wX wX ()
forall (m :: * -> *) a i. m a -> TestingEnv m i i a
forall (t :: (* -> *) -> * -> * -> * -> *) (m :: * -> *) a i.
LiftIx t =>
m a -> t m i i a
liftIx (IO () -> TestingEnv IO wX wX ())
-> IO () -> TestingEnv IO wX wX ()
forall a b. (a -> b) -> a -> b
$ p wX wY -> IO ()
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches p wX wY
p

  getCurrentTestResult :: forall wX. TestingEnvIO wX wX (TestResult wX)
getCurrentTestResult = do
    TestCmd
testCmd <- (TestingParams -> TestCmd) -> TestingEnv IO wX wX TestCmd
forall r (m :: * -> * -> * -> *) a i.
MonadReader r m =>
(r -> a) -> m i i a
asks TestingParams -> TestCmd
tpTestCmd
    Testing IO wX wX (TestResult wX)
-> TestingEnvIO wX wX (TestResult wX)
forall (m :: * -> *) wX wY a.
Testing m wX wY a -> TestingEnv m wX wY a
liftTesting (Testing IO wX wX (TestResult wX)
 -> TestingEnvIO wX wX (TestResult wX))
-> Testing IO wX wX (TestResult wX)
-> TestingEnvIO wX wX (TestResult wX)
forall a b. (a -> b) -> a -> b
$ TestCmd -> Testing IO wX wX (TestResult wX)
forall wX. TestCmd -> TestingIO wX wX (TestResult wX)
runTestCmd TestCmd
testCmd

  finishedTesting :: forall a wX. a -> TestingEnvIO wX TestingDone a
finishedTesting a
r = ReaderT TestingParams (Testing IO) wX TestingDone a
-> TestingEnv IO wX TestingDone a
forall (m :: * -> *) wX wY a.
ReaderT TestingParams (Testing m) wX wY a -> TestingEnv m wX wY a
TestingEnv (ReaderT TestingParams (Testing IO) wX TestingDone a
 -> TestingEnv IO wX TestingDone a)
-> ReaderT TestingParams (Testing IO) wX TestingDone a
-> TestingEnv IO wX TestingDone a
forall a b. (a -> b) -> a -> b
$ (TestingParams -> Testing IO wX TestingDone a)
-> ReaderT TestingParams (Testing IO) wX TestingDone a
forall r (m :: * -> * -> * -> *) i j a.
(r -> m i j a) -> ReaderT r m i j a
ReaderT ((TestingParams -> Testing IO wX TestingDone a)
 -> ReaderT TestingParams (Testing IO) wX TestingDone a)
-> (TestingParams -> Testing IO wX TestingDone a)
-> ReaderT TestingParams (Testing IO) wX TestingDone a
forall a b. (a -> b) -> a -> b
$ \TestingParams
_ -> IO a -> Testing IO wX TestingDone a
forall {k} (m :: k -> *) wX wY (a :: k). m a -> Testing m wX wY a
Testing (a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
Base.return a
r)

-- |The result of running a test on state 'wX' of the repository.
data TestResult wX
  = Testable (TestResultValid wX) -- ^We got a usable test result.
  | Untestable
    -- ^The test result could not be identified as either pass or fail,
    -- for example it might have been a build failure. External test
    -- scripts report this by reporting exit code 125.

-- |A usable test result, i.e. not an untestable state.
data TestResultValid wX
  = Success -- ^The test passed.
  | Failure (TestFailure wX) -- ^The test failed with the given exit code.

data TestFailure wX = TestFailure Int

exitCodeToTestResult :: ExitCode -> TestResult wX
exitCodeToTestResult :: forall {k} (wX :: k). ExitCode -> TestResult wX
exitCodeToTestResult ExitCode
ExitSuccess = TestResultValid wX -> TestResult wX
forall {k} (wX :: k). TestResultValid wX -> TestResult wX
Testable TestResultValid wX
forall {k} (wX :: k). TestResultValid wX
Success
exitCodeToTestResult (ExitFailure Int
125) = TestResult wX
forall {k} (wX :: k). TestResult wX
Untestable
exitCodeToTestResult (ExitFailure Int
n) = TestResultValid wX -> TestResult wX
forall {k} (wX :: k). TestResultValid wX -> TestResult wX
Testable (TestFailure wX -> TestResultValid wX
forall {k} (wX :: k). TestFailure wX -> TestResultValid wX
Failure (Int -> TestFailure wX
forall {k} (wX :: k). Int -> TestFailure wX
TestFailure Int
n))

-- |A 'TestCmd' runs the test on a given repository state.
data TestCmd = TestCmd (forall (wX :: *) . TestingIO wX wX (TestResult wX))

runTestCmd :: TestCmd -> TestingIO wX wX (TestResult wX)
runTestCmd :: forall wX. TestCmd -> TestingIO wX wX (TestResult wX)
runTestCmd (TestCmd forall wX. TestingIO wX wX (TestResult wX)
cmd) = TestingIO wX wX (TestResult wX)
forall wX. TestingIO wX wX (TestResult wX)
cmd

mkTestCmd :: (forall (wX :: *) . IO (TestResult wX)) -> TestCmd
mkTestCmd :: (forall wX. IO (TestResult wX)) -> TestCmd
mkTestCmd forall wX. IO (TestResult wX)
cmd = (forall wX. TestingIO wX wX (TestResult wX)) -> TestCmd
TestCmd (IO (TestResult wX) -> Testing IO wX wX (TestResult wX)
forall {k} (m :: k -> *) wX wY (a :: k). m a -> Testing m wX wY a
Testing IO (TestResult wX)
forall wX. IO (TestResult wX)
cmd)

-- |'PatchSeq' is a sequence of patches, implemented as a binary tree,
-- balanced in an arbitrary way depending on how it happened to be constructed.
-- In the 'darcs test' implementation it is used to
-- wrap up a single patch or group of patches that might be the cause of a failure.
data PatchSeq p wX wY where
  Single :: p wX wY -> PatchSeq p wX wY
  Joined :: PatchSeq p wX wY -> PatchSeq p wY wZ -> PatchSeq p wX wZ

instance Show2 p => Show (PatchSeq p wX wY) where
  showsPrec :: Int -> PatchSeq p wX wY -> ShowS
showsPrec Int
prec (Single p wX wY
p) =
    Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11) (String -> ShowS
showString String
"Darcs.UI.Commands.Test.Single " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> p wX wY -> ShowS
forall (a :: * -> * -> *) wX wY. Show2 a => Int -> a wX wY -> ShowS
showsPrec2 Int
11 p wX wY
p)
  showsPrec Int
prec (Joined PatchSeq p wX wY
p1 PatchSeq p wY wY
p2) =
    Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
              (String -> ShowS
showString String
"Darcs.UI.Commands.Test.Joined "
                 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PatchSeq p wX wY -> ShowS
forall (a :: * -> * -> *) wX wY. Show2 a => Int -> a wX wY -> ShowS
showsPrec2 Int
11 PatchSeq p wX wY
p1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PatchSeq p wY wY -> ShowS
forall (a :: * -> * -> *) wX wY. Show2 a => Int -> a wX wY -> ShowS
showsPrec2 Int
11 PatchSeq p wY wY
p2)


instance Show2 p => Show1 (PatchSeq p wX) where
  showDict1 :: forall wX. Dict (Show (PatchSeq p wX wX))
showDict1 = Dict (Show (PatchSeq p wX wX))
forall (a :: Constraint). a => Dict a
Dict

instance Show2 p => Show2 (PatchSeq p) where
  showDict2 :: forall wX wY. ShowDict (PatchSeq p wX wY)
showDict2 = Dict (Show (PatchSeq p wX wY))
forall (a :: Constraint). a => Dict a
Dict

instance Apply p => Apply (PatchSeq p) where
  type ApplyState (PatchSeq p) = ApplyState p
  apply :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PatchSeq p)) m =>
PatchSeq p wX wY -> m ()
apply (Single p wX wY
p) = p wX wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply p wX wY
p
  apply (Joined PatchSeq p wX wY
p1 PatchSeq p wY wY
p2) = PatchSeq p wX wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PatchSeq p)) m =>
PatchSeq p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchSeq p wX wY
p1 m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
Base.>> PatchSeq p wY wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PatchSeq p)) m =>
PatchSeq p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchSeq p wY wY
p2
  unapply :: forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PatchSeq p)) m =>
PatchSeq p wX wY -> m ()
unapply (Single p wX wY
p) = p wX wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState p) m =>
p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply p wX wY
p
  unapply (Joined PatchSeq p wX wY
p1 PatchSeq p wY wY
p2) = PatchSeq p wY wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PatchSeq p)) m =>
PatchSeq p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply PatchSeq p wY wY
p2 m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
Base.>> PatchSeq p wX wY -> m ()
forall (m :: * -> *) wX wY.
ApplyMonad (ApplyState (PatchSeq p)) m =>
PatchSeq p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply PatchSeq p wX wY
p1

instance PatchInspect p => PatchInspect (PatchSeq p) where
  listTouchedFiles :: forall wX wY. PatchSeq p wX wY -> [AnchoredPath]
listTouchedFiles (Single p wX wY
p) = p wX wY -> [AnchoredPath]
forall wX wY. p wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles p wX wY
p
  listTouchedFiles (Joined PatchSeq p wX wY
p1 PatchSeq p wY wY
p2) = PatchSeq p wX wY -> [AnchoredPath]
forall wX wY. PatchSeq p wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles PatchSeq p wX wY
p1 [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
forall a. [a] -> [a] -> [a]
++ PatchSeq p wY wY -> [AnchoredPath]
forall wX wY. PatchSeq p wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles PatchSeq p wY wY
p2
  hunkMatches :: forall wX wY. (ByteString -> Bool) -> PatchSeq p wX wY -> Bool
hunkMatches ByteString -> Bool
f (Single p wX wY
p) = (ByteString -> Bool) -> p wX wY -> Bool
forall wX wY. (ByteString -> Bool) -> p wX wY -> Bool
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
(ByteString -> Bool) -> p wX wY -> Bool
hunkMatches ByteString -> Bool
f p wX wY
p
  hunkMatches ByteString -> Bool
f (Joined PatchSeq p wX wY
p1 PatchSeq p wY wY
p2) = (ByteString -> Bool) -> PatchSeq p wX wY -> Bool
forall wX wY. (ByteString -> Bool) -> PatchSeq p wX wY -> Bool
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
(ByteString -> Bool) -> p wX wY -> Bool
hunkMatches ByteString -> Bool
f PatchSeq p wX wY
p1 Bool -> Bool -> Bool
|| (ByteString -> Bool) -> PatchSeq p wY wY -> Bool
forall wX wY. (ByteString -> Bool) -> PatchSeq p wX wY -> Bool
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
(ByteString -> Bool) -> p wX wY -> Bool
hunkMatches ByteString -> Bool
f PatchSeq p wY wY
p2

patchTreeToFL :: PatchSeq p wX wY -> FL p wX wY
patchTreeToFL :: forall (p :: * -> * -> *) wX wY. PatchSeq p wX wY -> FL p wX wY
patchTreeToFL PatchSeq p wX wY
t = PatchSeq p wX wY -> FL p wY wY -> FL p wX wY
forall (p :: * -> * -> *) wA wB wC.
PatchSeq p wA wB -> FL p wB wC -> FL p wA wC
go PatchSeq p wX wY
t FL p wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
  where
    go :: PatchSeq p wA wB -> FL p wB wC -> FL p wA wC
    go :: forall (p :: * -> * -> *) wA wB wC.
PatchSeq p wA wB -> FL p wB wC -> FL p wA wC
go (Single p wA wB
p) FL p wB wC
rest = p wA wB
p p wA wB -> FL p wB wC -> FL p wA wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wB wC
rest
    go (Joined PatchSeq p wA wY
p1 PatchSeq p wY wB
p2) FL p wB wC
rest = PatchSeq p wA wY -> FL p wY wC -> FL p wA wC
forall (p :: * -> * -> *) wA wB wC.
PatchSeq p wA wB -> FL p wB wC -> FL p wA wC
go PatchSeq p wA wY
p1 (PatchSeq p wY wB -> FL p wB wC -> FL p wY wC
forall (p :: * -> * -> *) wA wB wC.
PatchSeq p wA wB -> FL p wB wC -> FL p wA wC
go PatchSeq p wY wB
p2 FL p wB wC
rest)

flToPatchTree :: p wX wY -> FL p wY wZ -> PatchSeq p wX wZ
flToPatchTree :: forall (p :: * -> * -> *) wX wY wZ.
p wX wY -> FL p wY wZ -> PatchSeq p wX wZ
flToPatchTree p wX wY
p FL p wY wZ
NilFL = p wX wZ -> PatchSeq p wX wZ
forall {k} (p :: k -> k -> *) (wX :: k) (wY :: k).
p wX wY -> PatchSeq p wX wY
Single p wX wY
p wX wZ
p
flToPatchTree p wX wY
p (p wY wY
q :>: FL p wY wZ
qs) = PatchSeq p wX wY -> PatchSeq p wY wZ -> PatchSeq p wX wZ
forall {k} (p :: k -> k -> *) (wX :: k) (wY :: k) (wZ :: k).
PatchSeq p wX wY -> PatchSeq p wY wZ -> PatchSeq p wX wZ
Joined (p wX wY -> PatchSeq p wX wY
forall {k} (p :: k -> k -> *) (wX :: k) (wY :: k).
p wX wY -> PatchSeq p wX wY
Single p wX wY
p) (p wY wY -> FL p wY wZ -> PatchSeq p wY wZ
forall (p :: * -> * -> *) wX wY wZ.
p wX wY -> FL p wY wZ -> PatchSeq p wX wZ
flToPatchTree p wY wY
q FL p wY wZ
qs)

rlToPatchTree :: RL p wX wY -> p wY wZ -> PatchSeq p wX wZ
rlToPatchTree :: forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> p wY wZ -> PatchSeq p wX wZ
rlToPatchTree RL p wX wY
NilRL p wY wZ
p = p wX wZ -> PatchSeq p wX wZ
forall {k} (p :: k -> k -> *) (wX :: k) (wY :: k).
p wX wY -> PatchSeq p wX wY
Single p wX wZ
p wY wZ
p
rlToPatchTree (RL p wX wY
qs :<: p wY wY
q) p wY wZ
p = PatchSeq p wX wY -> PatchSeq p wY wZ -> PatchSeq p wX wZ
forall {k} (p :: k -> k -> *) (wX :: k) (wY :: k) (wZ :: k).
PatchSeq p wX wY -> PatchSeq p wY wZ -> PatchSeq p wX wZ
Joined (RL p wX wY -> p wY wY -> PatchSeq p wX wY
forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> p wY wZ -> PatchSeq p wX wZ
rlToPatchTree RL p wX wY
qs p wY wY
q) (p wY wZ -> PatchSeq p wY wZ
forall {k} (p :: k -> k -> *) (wX :: k) (wY :: k).
p wX wY -> PatchSeq p wX wY
Single p wY wZ
p)

-- |The result of running a test strategy.
data StrategyResultRaw patches =
    NoPasses -- ^The chosen strategy didn't find any passing states in the repository.
  | NoFailureOnHead -- ^The test didn't fail on head so there's no failure to track down.
  | Blame patches -- ^The failure was tracked down to the given patches.
  -- these two are just for oneTest
  | RunSuccess -- ^The single test run passed.
  | RunFailed Int -- ^The single test run failed with the given exit code.
  deriving (StrategyResultRaw patches -> StrategyResultRaw patches -> Bool
(StrategyResultRaw patches -> StrategyResultRaw patches -> Bool)
-> (StrategyResultRaw patches -> StrategyResultRaw patches -> Bool)
-> Eq (StrategyResultRaw patches)
forall patches.
Eq patches =>
StrategyResultRaw patches -> StrategyResultRaw patches -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall patches.
Eq patches =>
StrategyResultRaw patches -> StrategyResultRaw patches -> Bool
== :: StrategyResultRaw patches -> StrategyResultRaw patches -> Bool
$c/= :: forall patches.
Eq patches =>
StrategyResultRaw patches -> StrategyResultRaw patches -> Bool
/= :: StrategyResultRaw patches -> StrategyResultRaw patches -> Bool
Eq, Int -> StrategyResultRaw patches -> ShowS
[StrategyResultRaw patches] -> ShowS
StrategyResultRaw patches -> String
(Int -> StrategyResultRaw patches -> ShowS)
-> (StrategyResultRaw patches -> String)
-> ([StrategyResultRaw patches] -> ShowS)
-> Show (StrategyResultRaw patches)
forall patches.
Show patches =>
Int -> StrategyResultRaw patches -> ShowS
forall patches.
Show patches =>
[StrategyResultRaw patches] -> ShowS
forall patches. Show patches => StrategyResultRaw patches -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall patches.
Show patches =>
Int -> StrategyResultRaw patches -> ShowS
showsPrec :: Int -> StrategyResultRaw patches -> ShowS
$cshow :: forall patches. Show patches => StrategyResultRaw patches -> String
show :: StrategyResultRaw patches -> String
$cshowList :: forall patches.
Show patches =>
[StrategyResultRaw patches] -> ShowS
showList :: [StrategyResultRaw patches] -> ShowS
Show, (forall a b.
 (a -> b) -> StrategyResultRaw a -> StrategyResultRaw b)
-> (forall a b. a -> StrategyResultRaw b -> StrategyResultRaw a)
-> Functor StrategyResultRaw
forall a b. a -> StrategyResultRaw b -> StrategyResultRaw a
forall a b. (a -> b) -> StrategyResultRaw a -> StrategyResultRaw b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> StrategyResultRaw a -> StrategyResultRaw b
fmap :: forall a b. (a -> b) -> StrategyResultRaw a -> StrategyResultRaw b
$c<$ :: forall a b. a -> StrategyResultRaw b -> StrategyResultRaw a
<$ :: forall a b. a -> StrategyResultRaw b -> StrategyResultRaw a
Functor)

type StrategyResult p wSuccess wFailure =
  StrategyResultRaw (PatchSeq p wSuccess wFailure)

type StrategyResultSealed p =
  StrategyResultRaw (Sealed2 (PatchSeq p))

-- |'WithResult' is a continuation passed to a test strategy indicating
-- what should be done with the final result of the strategy. This for
-- example allows a post-processing "minimise blame" pass to be run.
-- The witnesses make it hard to wrap this up in a standard abstraction.
data WithResult (m :: * -> * -> * -> *) p a =
  WithResult
  { forall (m :: * -> * -> * -> *) (p :: * -> * -> *) a.
WithResult m p a
-> forall wSuccess wFailure.
   StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a
runWithResult
      :: forall wSuccess wFailure
       . StrategyResult p wSuccess wFailure
      -> m wSuccess TestingDone a
  }

-- |After a strategy has finished, untestable states might mean that it
-- was only able to assign blame to a group of patches rather than a
-- single patch. This function tries to reorder the group of patches
-- (using commutation). The hope is that a reordered sequence will reveal
-- a testable state, allowing us to cut down the group.
--
-- The type is logically
-- something like 'StrategyResult -> m StrategyResult', but is expressed
-- as a transformation of a 'WithResult' to manage the witnesses. These
-- are complicated because we want to re-use the testing tree left by the
-- strategy.
minimiseBlame :: forall m p a . TestablePatch m p => WithResult m p a -> WithResult m p a
minimiseBlame :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) a.
TestablePatch m p =>
WithResult m p a -> WithResult m p a
minimiseBlame (WithResult forall wSuccess wFailure.
StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a
finalRunner) =
  (forall wSuccess wFailure.
 StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a)
-> WithResult m p a
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) a.
(forall wSuccess wFailure.
 StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a)
-> WithResult m p a
WithResult ((forall wSuccess wFailure.
  StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a)
 -> WithResult m p a)
-> (forall wSuccess wFailure.
    StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a)
-> WithResult m p a
forall a b. (a -> b) -> a -> b
$ \StrategyResult p wSuccess wFailure
result ->
    case StrategyResult p wSuccess wFailure
result of
      Blame PatchSeq p wSuccess wFailure
p -> RL p wSuccess wSuccess
-> FL p wSuccess wFailure -> m wSuccess TestingDone a
forall wSuccess wFocus wFailure.
RL p wSuccess wFocus
-> FL p wFocus wFailure -> m wFocus TestingDone a
doMinimiseFwd RL p wSuccess wSuccess
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL (PatchSeq p wSuccess wFailure -> FL p wSuccess wFailure
forall (p :: * -> * -> *) wX wY. PatchSeq p wX wY -> FL p wX wY
patchTreeToFL PatchSeq p wSuccess wFailure
p)
      StrategyResult p wSuccess wFailure
_ -> StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a
forall wSuccess wFailure.
StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a
finalRunner StrategyResult p wSuccess wFailure
result
  where
    -- This minimisation code is a bit ad-hoc and almost certainly
    -- doesn't find every possible minimisation (which might require
    -- an exponential search). It also doesn't cache anything and
    -- therefore may do some repeated shuffling.
    
    -- The witnesses do guarantee that it is
    -- correct and the implementation is structured to guarantee
    -- termination.

    -- The overall algorithm is to work through the sequence from left
    -- to right, treating each patch in turn as a 'focus'. We then try
    -- to commute the focus with the patches to the left of it, and test
    -- each new intermediate state this produces.
    --
    -- If we do find a testable intermediate state, we can chop the sequence
    -- at that state.

    -- In 'doMinimiseFwd kept rest', 'kept' are the patches that we
    -- have looked at already, and 'rest' are the ones still to be
    -- processed.
    doMinimiseFwd
      :: RL p wSuccess wFocus
      -> FL p wFocus wFailure
      -> m wFocus TestingDone a

    doMinimiseFwd :: forall wSuccess wFocus wFailure.
RL p wSuccess wFocus
-> FL p wFocus wFailure -> m wFocus TestingDone a
doMinimiseFwd RL p wSuccess wFocus
kept (p wFocus wY
focus :>: FL p wY wFailure
rest) = do
      -- Call 'doMinimiseRev' to work on the first of the so-far-unprocessed
      -- patches. In the end 'doMinimiseRev' will call back to 'doMinimiseFwd',
      -- and either 'focus' will have been moved into 'kept' or dropped entirely
      -- because the sequence has been cut down.
      --
      -- Whilst 'kept' marks the patches that have already been visited,
      -- 'doMinimiseRev' will still try to commute them with the 'focus' patch.
      RL p wSuccess wFocus
-> (:>) (FL p) (FL p :> FL p) wFocus wFailure
-> m wFocus TestingDone a
forall wSuccess wFocus wFailure.
RL p wSuccess wFocus
-> (:>) (FL p) (FL p :> FL p) wFocus wFailure
-> m wFocus TestingDone a
doMinimiseRev RL p wSuccess wFocus
kept (p wFocus wY
focus p wFocus wY -> FL p wY wY -> FL p wFocus wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL FL p wFocus wY
-> (:>) (FL p) (FL p) wY wFailure
-> (:>) (FL p) (FL p :> FL p) wFocus wFailure
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL FL p wY wY -> FL p wY wFailure -> (:>) (FL p) (FL p) wY wFailure
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wY wFailure
rest)

    doMinimiseFwd (RL p wSuccess wY
kept :<: p wY wFocus
final) FL p wFocus wFailure
NilFL = do
      -- This unapply is only needed because WithResult
      -- is based around leaving the test tree in the 'wSuccess'
      -- state in case something else needs it.
      -- In practice no more tests will be run after we finish minimising blame,
      -- so it's wasted work.
      -- It could probably be removed by making the type of WithResult
      -- more sophisticated somehow, but it's not clear the complexity
      -- is worth it.
      RL p wSuccess wFocus -> m wFocus wSuccess ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wY wX ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wY wX ()
unapplyPatch (RL p wSuccess wY
kept RL p wSuccess wY -> p wY wFocus -> RL p wSuccess wFocus
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: p wY wFocus
final)
      StrategyResult p wSuccess wFocus -> m wSuccess TestingDone a
forall wSuccess wFailure.
StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a
finalRunner (PatchSeq p wSuccess wFocus -> StrategyResult p wSuccess wFocus
forall patches. patches -> StrategyResultRaw patches
Blame (RL p wSuccess wY -> p wY wFocus -> PatchSeq p wSuccess wFocus
forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> p wY wZ -> PatchSeq p wX wZ
rlToPatchTree RL p wSuccess wY
kept p wY wFocus
final))

    doMinimiseFwd RL p wSuccess wFocus
NilRL FL p wFocus wFailure
NilFL = String -> m wFocus TestingDone a
forall a. HasCallStack => String -> a
error String
"internal error: trying to minimise an empty sequence"

    -- In 'doMinimiseRev tocommute (focus :> ps :> qs)':
    --   - 'qs' are the patches that are yet to be processed. They will just be sent
    --     back to 'doMinimiseFwd' unless we end up dropping them entirely.
    --   - 'ps' are patches we have managed to commute with 'focus' but still produced
    --     untestable states.
    --   - 'focus' are the patches we are trying to move around to see if it helps
    --     find a testable state. It starts out as a singleton but gains more patches
    --     as commutes fail.
    --   - 'tocommute' are the patches we still need to commute with the 'focus'.
    doMinimiseRev
      :: RL p wSuccess wFocus
      -> (FL p :> FL p :> FL p) wFocus wFailure
      -> m wFocus TestingDone a

    doMinimiseRev :: forall wSuccess wFocus wFailure.
RL p wSuccess wFocus
-> (:>) (FL p) (FL p :> FL p) wFocus wFailure
-> m wFocus TestingDone a
doMinimiseRev RL p wSuccess wFocus
NilRL (FL p wFocus wZ
focus :> FL p wZ wZ
ps :> FL p wZ wFailure
qs) = do
      -- We've run out of things to commute, so pass everything that we
      -- looked at back to 'doMinimiseFwd' as the 'kept' parameter.
      let kept :: RL p wFocus wZ
kept = FL p wFocus wZ -> RL p wFocus wZ
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL (FL p wFocus wZ
focus FL p wFocus wZ -> FL p wZ wZ -> FL p wFocus wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL p wZ wZ
ps)
      RL p wFocus wZ -> m wFocus wZ ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wX wY ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wX wY ()
applyPatch RL p wFocus wZ
kept
      RL p wFocus wZ -> FL p wZ wFailure -> m wZ TestingDone a
forall wSuccess wFocus wFailure.
RL p wSuccess wFocus
-> FL p wFocus wFailure -> m wFocus TestingDone a
doMinimiseFwd RL p wFocus wZ
kept FL p wZ wFailure
qs

    doMinimiseRev (RL p wSuccess wY
tocommute :<: p wY wFocus
p) (FL p wFocus wZ
focus :> FL p wZ wZ
ps :> FL p wZ wFailure
qs) = do
      p wY wFocus -> m wFocus wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wY wX ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wY wX ()
unapplyPatch p wY wFocus
p
      case CommuteFn p p -> CommuteFn p (FL p)
forall (p1 :: * -> * -> *) (p2 :: * -> * -> *).
CommuteFn p1 p2 -> CommuteFn p1 (FL p2)
commuterIdFL (:>) p p wX wY -> Maybe ((:>) p p wX wY)
CommuteFn p p
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (p wY wFocus
p p wY wFocus -> FL p wFocus wZ -> (:>) p (FL p) wY wZ
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wFocus wZ
focus) of
        Maybe ((:>) (FL p) p wY wZ)
Nothing ->
          -- if we can't commute just attach it to the focus
          RL p wSuccess wY
-> (:>) (FL p) (FL p :> FL p) wY wFailure -> m wY TestingDone a
forall wSuccess wFocus wFailure.
RL p wSuccess wFocus
-> (:>) (FL p) (FL p :> FL p) wFocus wFailure
-> m wFocus TestingDone a
doMinimiseRev RL p wSuccess wY
tocommute (p wY wFocus
p p wY wFocus -> FL p wFocus wZ -> FL p wY wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wFocus wZ
focus FL p wY wZ
-> (:>) (FL p) (FL p) wZ wFailure
-> (:>) (FL p) (FL p :> FL p) wY wFailure
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wZ wZ
ps FL p wZ wZ -> FL p wZ wFailure -> (:>) (FL p) (FL p) wZ wFailure
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wZ wFailure
qs)
        Just (FL p wY wZ
focus' :> p wZ wZ
p') -> do
          FL p wY wZ -> m wY wZ ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wX wY ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wX wY ()
applyPatch FL p wY wZ
focus'
          TestResult wZ
testResult <- m wZ wZ (TestResult wZ)
forall wX. m wX wX (TestResult wX)
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
m wX wX (TestResult wX)
getCurrentTestResult
          case TestResult wZ
testResult of
            TestResult wZ
Untestable -> do
              -- The newly commuted state is also untestable, leave the patch we
              -- just commuted in 'ps' and keep working on the focus.
              FL p wY wZ -> m wZ wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wY wX ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wY wX ()
unapplyPatch FL p wY wZ
focus'
              RL p wSuccess wY
-> (:>) (FL p) (FL p :> FL p) wY wFailure -> m wY TestingDone a
forall wSuccess wFocus wFailure.
RL p wSuccess wFocus
-> (:>) (FL p) (FL p :> FL p) wFocus wFailure
-> m wFocus TestingDone a
doMinimiseRev RL p wSuccess wY
tocommute (FL p wY wZ
focus' FL p wY wZ
-> (:>) (FL p) (FL p) wZ wFailure
-> (:>) (FL p) (FL p :> FL p) wY wFailure
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> p wZ wZ
p' p wZ wZ -> FL p wZ wZ -> FL p wZ wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wZ wZ
ps FL p wZ wZ -> FL p wZ wFailure -> (:>) (FL p) (FL p) wZ wFailure
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wZ wFailure
qs)
            -- Since we got a result, we can chop the sequence here, we just need
            -- to decide which part to keep.
            -- The full sequence after the commute is kept ; focus' | p' ; ps ; qs
            Testable TestResultValid wZ
Success -> RL p wZ wZ
-> (:>) (FL p) (FL p :> FL p) wZ wFailure -> m wZ TestingDone a
forall wSuccess wFocus wFailure.
RL p wSuccess wFocus
-> (:>) (FL p) (FL p :> FL p) wFocus wFailure
-> m wFocus TestingDone a
doMinimiseRev RL p wZ wZ
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL (FL p wZ wZ
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL FL p wZ wZ
-> (:>) (FL p) (FL p) wZ wFailure
-> (:>) (FL p) (FL p :> FL p) wZ wFailure
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> p wZ wZ
p' p wZ wZ -> FL p wZ wZ -> FL p wZ wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wZ wZ
ps FL p wZ wZ -> FL p wZ wFailure -> (:>) (FL p) (FL p) wZ wFailure
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wZ wFailure
qs)
            Testable (Failure TestFailure wZ
_) -> do
              FL p wY wZ -> m wZ wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wY wX ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wY wX ()
unapplyPatch FL p wY wZ
focus'
              RL p wSuccess wY
-> (:>) (FL p) (FL p :> FL p) wY wZ -> m wY TestingDone a
forall wSuccess wFocus wFailure.
RL p wSuccess wFocus
-> (:>) (FL p) (FL p :> FL p) wFocus wFailure
-> m wFocus TestingDone a
doMinimiseRev RL p wSuccess wY
tocommute (FL p wY wZ
focus' FL p wY wZ
-> (:>) (FL p) (FL p) wZ wZ -> (:>) (FL p) (FL p :> FL p) wY wZ
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wZ wZ
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL FL p wZ wZ -> FL p wZ wZ -> (:>) (FL p) (FL p) wZ wZ
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wZ wZ
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)

-- |StrategyDone captures the final result of running a "test strategy" like
-- bisect, backoff, linear or once. It has a slightly complicated type because of the
-- witnesses and because we may want to run a continuation afterwards to minimise
-- the result. Essentially it is just a 'StrategyResult'.
type StrategyDone m p wY = forall a . WithResult m p a ->  m wY TestingDone a

-- |Report that the strategy has finished with the given result.
strategyDone :: StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone :: forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone StrategyResult p wSuccess wFailure
result WithResult m p a
withResult = WithResult m p a
-> forall wSuccess wFailure.
   StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) a.
WithResult m p a
-> forall wSuccess wFailure.
   StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a
runWithResult WithResult m p a
withResult StrategyResult p wSuccess wFailure
result

-- |The implementation type for a given "test strategy" like bisect, backoff, linear or once.
-- It is given a sequence of patches we might want to search inside to identify the cause of
-- a test failure, and also passed the initial testing result for the end of that sequence.
type Strategy
   = forall m p wOlder wNewer
   . TestablePatch m p
  => TestResult wNewer
  -> RL p wOlder wNewer
  -> StrategyDone m p wNewer

-- runStrategy orchestrates the whole process of isolating patches
-- triggering the failure.
runStrategy
  :: TestablePatch m p
  => O.TestStrategy
  -> O.ShrinkFailure
  -> RL p wOlder wNewer
  -> m wNewer TestingDone (StrategyResultSealed p)
runStrategy :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer.
TestablePatch m p =>
TestStrategy
-> ShrinkFailure
-> RL p wOlder wNewer
-> m wNewer TestingDone (StrategyResultSealed p)
runStrategy TestStrategy
strategy ShrinkFailure
shrinkFailure RL p wOlder wNewer
patches = do
  -- The starting point is a full patch sequence 'RL p wStart wEnd' with the
  -- testing tree in state 'wEnd'. We get the initial testing result for that
  -- state as 'Strategy' requires it.
  TestResult wNewer
testResult <- m wNewer wNewer (TestResult wNewer)
forall wX. m wX wX (TestResult wX)
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
m wX wX (TestResult wX)
getCurrentTestResult
  -- We narrow down the failure via a strategy (linear/bisect/backoff). If we
  -- find patches to blame, this has type 'Testing p wSuccess wFailure', leaving the testing
  -- tree in state 'wSuccess'.
  -- If the strategy is "one test" then the result is just success/failure.
  TestStrategy -> Strategy
chooseStrategy TestStrategy
strategy TestResult wNewer
testResult RL p wOlder wNewer
patches (WithResult m p (StrategyResultSealed p)
 -> m wNewer TestingDone (StrategyResultSealed p))
-> WithResult m p (StrategyResultSealed p)
-> m wNewer TestingDone (StrategyResultSealed p)
forall a b. (a -> b) -> a -> b
$
    -- What to do with the result of the strategy is passed as a continuation to the strategy.
    -- First we try to minimise any patches to blame, resulting in 'Testing p wSuccess2 wFailure2'.
    -- The testing tree is left in state 'wSuccess2' although we don't actually care about
    -- it any more.
    (if ShrinkFailure
shrinkFailure ShrinkFailure -> ShrinkFailure -> Bool
forall a. Eq a => a -> a -> Bool
== ShrinkFailure
O.ShrinkFailure then WithResult m p (StrategyResultSealed p)
-> WithResult m p (StrategyResultSealed p)
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) a.
TestablePatch m p =>
WithResult m p a -> WithResult m p a
minimiseBlame else WithResult m p (StrategyResultSealed p)
-> WithResult m p (StrategyResultSealed p)
forall a. a -> a
id) (WithResult m p (StrategyResultSealed p)
 -> WithResult m p (StrategyResultSealed p))
-> WithResult m p (StrategyResultSealed p)
-> WithResult m p (StrategyResultSealed p)
forall a b. (a -> b) -> a -> b
$
    -- Finally the result is wrapped up in a Sealed2 and returned.
    (forall wSuccess wFailure.
 StrategyResult p wSuccess wFailure
 -> m wSuccess TestingDone (StrategyResultSealed p))
-> WithResult m p (StrategyResultSealed p)
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) a.
(forall wSuccess wFailure.
 StrategyResult p wSuccess wFailure -> m wSuccess TestingDone a)
-> WithResult m p a
WithResult (StrategyResultSealed p
-> m wSuccess TestingDone (StrategyResultSealed p)
forall a wX. a -> m wX TestingDone a
forall (m :: * -> * -> * -> *) a wX.
TestRunner m =>
a -> m wX TestingDone a
finishedTesting (StrategyResultSealed p
 -> m wSuccess TestingDone (StrategyResultSealed p))
-> (StrategyResult p wSuccess wFailure -> StrategyResultSealed p)
-> StrategyResult p wSuccess wFailure
-> m wSuccess TestingDone (StrategyResultSealed p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatchSeq p wSuccess wFailure -> Sealed2 (PatchSeq p))
-> StrategyResult p wSuccess wFailure -> StrategyResultSealed p
forall a b. (a -> b) -> StrategyResultRaw a -> StrategyResultRaw b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatchSeq p wSuccess wFailure -> Sealed2 (PatchSeq p)
forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
Sealed2)

runTestable
  :: ( Commute p
     , TestRunner (TestingEnv m)
     , TestRunnerPatchReqs (TestingEnv m) p
     )
  => O.SetScriptsExecutable
  -> TestCmd
  -> O.TestStrategy
  -> O.ShrinkFailure
  -> RL p wStart wA
  -> m (StrategyResultSealed p)
runTestable :: forall (p :: * -> * -> *) (m :: * -> *) wStart wA.
(Commute p, TestRunner (TestingEnv m),
 TestRunnerPatchReqs (TestingEnv m) p) =>
SetScriptsExecutable
-> TestCmd
-> TestStrategy
-> ShrinkFailure
-> RL p wStart wA
-> m (StrategyResultSealed p)
runTestable SetScriptsExecutable
sse TestCmd
tcmd TestStrategy
strategy ShrinkFailure
shrinkFailure RL p wStart wA
ps =
  TestingParams
-> TestingEnv m wA TestingDone (StrategyResultSealed p)
-> m (StrategyResultSealed p)
forall (m :: * -> *) wA a.
TestingParams -> TestingEnv m wA TestingDone a -> m a
runTestingEnv (SetScriptsExecutable -> TestCmd -> TestingParams
TestingParams SetScriptsExecutable
sse TestCmd
tcmd) (TestingEnv m wA TestingDone (StrategyResultSealed p)
 -> m (StrategyResultSealed p))
-> TestingEnv m wA TestingDone (StrategyResultSealed p)
-> m (StrategyResultSealed p)
forall a b. (a -> b) -> a -> b
$ TestStrategy
-> ShrinkFailure
-> RL p wStart wA
-> TestingEnv m wA TestingDone (StrategyResultSealed p)
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer.
TestablePatch m p =>
TestStrategy
-> ShrinkFailure
-> RL p wOlder wNewer
-> m wNewer TestingDone (StrategyResultSealed p)
runStrategy TestStrategy
strategy ShrinkFailure
shrinkFailure RL p wStart wA
ps

chooseStrategy :: O.TestStrategy -> Strategy
chooseStrategy :: TestStrategy -> Strategy
chooseStrategy TestStrategy
O.Bisect = TestResult wNewer
-> RL p wOlder wNewer -> WithResult m p a -> m wNewer TestingDone a
TestResult wNewer -> RL p wOlder wNewer -> StrategyDone m p wNewer
Strategy
trackBisect
chooseStrategy TestStrategy
O.Linear = TestResult wNewer
-> RL p wOlder wNewer -> WithResult m p a -> m wNewer TestingDone a
TestResult wNewer -> RL p wOlder wNewer -> StrategyDone m p wNewer
Strategy
trackLinear
chooseStrategy TestStrategy
O.Backoff = TestResult wNewer
-> RL p wOlder wNewer -> WithResult m p a -> m wNewer TestingDone a
TestResult wNewer -> RL p wOlder wNewer -> StrategyDone m p wNewer
Strategy
trackBackoff
chooseStrategy TestStrategy
O.Once = TestResult wNewer
-> RL p wOlder wNewer -> WithResult m p a -> m wNewer TestingDone a
TestResult wNewer -> RL p wOlder wNewer -> StrategyDone m p wNewer
Strategy
oneTest

explanatoryTextFor :: O.TestStrategy -> String
explanatoryTextFor :: TestStrategy -> String
explanatoryTextFor TestStrategy
strategy =
  case TestStrategy
strategy of
    TestStrategy
O.Bisect -> String
assumedMonotony
    TestStrategy
O.Backoff -> String
assumedMonotony
    TestStrategy
O.Linear -> String
wasLinear
    TestStrategy
O.Once -> String
wasLinear -- this case won't actually be reached
  where
    -- We did a bisection type search so a given patch that causes
    -- the failure is only the most recent if there is actually only
    -- one transition from "passed" to "failed" in the repository history.
    assumedMonotony :: String
assumedMonotony = String
" (assuming monotony in the given range)"
    -- We did a linear search so the patch we found is definitely the
    -- most recent to have triggered a failure.
    wasLinear :: String
wasLinear = String
""

-- | test only the last recorded state
oneTest :: Strategy
oneTest :: Strategy
oneTest (Testable TestResultValid wNewer
Success) RL p wOlder wNewer
_ = StrategyResult p wNewer Any -> StrategyDone m p wNewer
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone StrategyResult p wNewer Any
forall patches. StrategyResultRaw patches
RunSuccess
oneTest TestResult wNewer
Untestable  RL p wOlder wNewer
_ = StrategyResult p wNewer Any -> StrategyDone m p wNewer
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone (StrategyResult p wNewer Any -> StrategyDone m p wNewer)
-> StrategyResult p wNewer Any -> StrategyDone m p wNewer
forall a b. (a -> b) -> a -> b
$ Int -> StrategyResult p wNewer Any
forall patches. Int -> StrategyResultRaw patches
RunFailed Int
125
oneTest (Testable (Failure (TestFailure Int
n)))  RL p wOlder wNewer
_ = StrategyResult p wNewer Any -> StrategyDone m p wNewer
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone (StrategyResult p wNewer Any -> StrategyDone m p wNewer)
-> StrategyResult p wNewer Any -> StrategyDone m p wNewer
forall a b. (a -> b) -> a -> b
$ Int -> StrategyResult p wNewer Any
forall patches. Int -> StrategyResultRaw patches
RunFailed Int
n

-- | linear search (with --linear)
trackLinear :: Strategy
trackLinear :: Strategy
trackLinear (Testable (Failure TestFailure wNewer
_)) RL p wOlder wNewer
ps = FL p wNewer wNewer -> RL p wOlder wNewer -> StrategyDone m p wNewer
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wY wZ wX.
TestablePatch m p =>
FL p wY wZ -> RL p wX wY -> StrategyDone m p wY
trackNextLinear FL p wNewer wNewer
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL RL p wOlder wNewer
ps
trackLinear TestResult wNewer
_ RL p wOlder wNewer
_ = StrategyResult p wNewer Any -> StrategyDone m p wNewer
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone StrategyResult p wNewer Any
forall patches. StrategyResultRaw patches
NoFailureOnHead

-- |The guts of tracking down a test failure by linear search
-- Precondition: 'wZ' is a failing state and any states
-- in the (possibly empty) range of states '[wY, wZ)' are untestable.
trackNextLinear
  :: TestablePatch m p
  => FL p wY wZ -- ^a buffer of patches that start with an untestable state
  -> RL p wX wY -- ^patches we haven't visited yet
  -> StrategyDone m p wY
trackNextLinear :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wY wZ wX.
TestablePatch m p =>
FL p wY wZ -> RL p wX wY -> StrategyDone m p wY
trackNextLinear FL p wY wZ
_ RL p wX wY
NilRL WithResult m p a
withResult = StrategyResult p wY Any -> StrategyDone m p wY
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone StrategyResult p wY Any
forall patches. StrategyResultRaw patches
NoPasses WithResult m p a
withResult
trackNextLinear FL p wY wZ
untestables (RL p wX wY
ps:<:p wY wY
p) WithResult m p a
withResult = do
  p wY wY -> m wY wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wY wX ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wY wX ()
unapplyPatch p wY wY
p
  String -> m wY wY ()
forall wX. String -> m wX wX ()
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
String -> m wX wX ()
writeMsg String
"Trying without the patch:"
  p wY wY -> m wY wY ()
forall (p :: * -> * -> *) wA wB wX.
DisplayPatchReqs m p =>
p wA wB -> m wX wX ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wA wB wX.
(TestRunner m, DisplayPatchReqs m p) =>
p wA wB -> m wX wX ()
mentionPatch p wY wY
p
  TestResult wY
testResult <- m wY wY (TestResult wY)
forall wX. m wX wX (TestResult wX)
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
m wX wX (TestResult wX)
getCurrentTestResult
  case TestResult wY
testResult of
    -- If the test passes we're done.
    Testable TestResultValid wY
Success -> StrategyResult p wY wZ -> StrategyDone m p wY
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone (PatchSeq p wY wZ -> StrategyResult p wY wZ
forall patches. patches -> StrategyResultRaw patches
Blame (p wY wY -> FL p wY wZ -> PatchSeq p wY wZ
forall (p :: * -> * -> *) wX wY wZ.
p wX wY -> FL p wY wZ -> PatchSeq p wX wZ
flToPatchTree p wY wY
p FL p wY wZ
untestables)) WithResult m p a
withResult
    -- If the test fails then we can drop the 'untestables' buffer and keep going.
    Testable (Failure TestFailure wY
_) -> FL p wY wY -> RL p wX wY -> StrategyDone m p wY
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wY wZ wX.
TestablePatch m p =>
FL p wY wZ -> RL p wX wY -> StrategyDone m p wY
trackNextLinear FL p wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL RL p wX wY
ps WithResult m p a
withResult
    -- If the state is untestable then we add to the 'untestables' buffer and keep going.
    TestResult wY
Untestable -> FL p wY wZ -> RL p wX wY -> StrategyDone m p wY
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wY wZ wX.
TestablePatch m p =>
FL p wY wZ -> RL p wX wY -> StrategyDone m p wY
trackNextLinear (p wY wY
p p wY wY -> FL p wY wZ -> FL p wY wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wY wZ
untestables) RL p wX wY
ps WithResult m p a
withResult

-- |A 'TestingState' is used to keep track of the set of patches
-- a search strategy is currently working on, split at a given point
-- with an explicit witness for that intermediate point (the 'focus'),
-- so we can connect it to the state of the testing tree.
data TestingState p wOlder wFocus wNewer where
  TestingState
    :: RL (PatchSeq p) wOlder wFocus
    -> FL (PatchSeq p) wFocus wNewer
    -> TestingState p wOlder wFocus wNewer

lengthTS :: TestingState p wX wZ wY -> Int
lengthTS :: forall (p :: * -> * -> *) wX wZ wY. TestingState p wX wZ wY -> Int
lengthTS (TestingState RL (PatchSeq p) wX wZ
ps1 FL (PatchSeq p) wZ wY
ps2) = RL (PatchSeq p) wX wZ -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (PatchSeq p) wX wZ
ps1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ FL (PatchSeq p) wZ wY -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchSeq p) wZ wY
ps2

lengthsTS :: TestingState p wX wZ wY -> (Int, Int)
lengthsTS :: forall (p :: * -> * -> *) wX wZ wY.
TestingState p wX wZ wY -> (Int, Int)
lengthsTS (TestingState RL (PatchSeq p) wX wZ
ps1 FL (PatchSeq p) wZ wY
ps2) = (FL (PatchSeq p) wZ wY -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchSeq p) wZ wY
ps2, RL (PatchSeq p) wX wZ -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (PatchSeq p) wX wZ
ps1)

-- |Exponential backoff search (with --backoff): first search backwards looking for
-- a successful state, then bisect between that successful state and the current (failed)
-- state.
trackBackoff :: Strategy
trackBackoff :: Strategy
trackBackoff (Testable (Failure TestFailure wNewer
tf)) RL p wOlder wNewer
ps =
  -- 4 is an arbitrary choice for how far to start jumping backwards
  TestFailure wNewer
-> Int -> RL (PatchSeq p) wOlder wNewer -> StrategyDone m p wNewer
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wNewer wOlder.
TestablePatch m p =>
TestFailure wNewer
-> Int -> RL (PatchSeq p) wOlder wNewer -> StrategyDone m p wNewer
trackNextBackoff TestFailure wNewer
tf Int
4 ((forall wW wY. p wW wY -> PatchSeq p wW wY)
-> RL p wOlder wNewer -> RL (PatchSeq p) wOlder wNewer
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ
mapRL_RL p wW wY -> PatchSeq p wW wY
forall wW wY. p wW wY -> PatchSeq p wW wY
forall {k} (p :: k -> k -> *) (wX :: k) (wY :: k).
p wX wY -> PatchSeq p wX wY
Single RL p wOlder wNewer
ps)
trackBackoff TestResult wNewer
_ RL p wOlder wNewer
_ = StrategyResult p wNewer Any -> StrategyDone m p wNewer
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone StrategyResult p wNewer Any
forall patches. StrategyResultRaw patches
NoFailureOnHead

-- |Precondition: the test fails at 'wNewer'.
trackNextBackoff
  :: TestablePatch m p
  => TestFailure wNewer -- ^Failure witness
  -> Int -- ^Number of patches to skip.
  -> RL (PatchSeq p) wOlder wNewer -- ^Patches not yet skipped.
  -> StrategyDone m p wNewer

-- Normal base case: we've run out of patches.
trackNextBackoff :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wNewer wOlder.
TestablePatch m p =>
TestFailure wNewer
-> Int -> RL (PatchSeq p) wOlder wNewer -> StrategyDone m p wNewer
trackNextBackoff TestFailure wNewer
_ Int
_ RL (PatchSeq p) wOlder wNewer
NilRL WithResult m p a
withResult = StrategyResult p wNewer Any -> StrategyDone m p wNewer
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone StrategyResult p wNewer Any
forall patches. StrategyResultRaw patches
NoPasses WithResult m p a
withResult

-- Edge case: if there's just one patch left then either the test
-- passes before this patch and we can blame it, or we've run out of
-- places to look for success.
trackNextBackoff TestFailure wNewer
_ Int
_ (RL (PatchSeq p) wOlder wY
NilRL :<: PatchSeq p wY wNewer
p) WithResult m p a
withResult = do
  PatchSeq p wY wNewer -> m wNewer wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wY wX ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wY wX ()
unapplyPatch PatchSeq p wY wNewer
p
  TestResult wY
testResult <- m wY wY (TestResult wY)
forall wX. m wX wX (TestResult wX)
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
m wX wX (TestResult wX)
getCurrentTestResult
  case TestResult wY
testResult of
    Testable TestResultValid wY
Success -> StrategyResult p wY wNewer -> StrategyDone m p wY
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone (PatchSeq p wY wNewer -> StrategyResult p wY wNewer
forall patches. patches -> StrategyResultRaw patches
Blame PatchSeq p wY wNewer
p) WithResult m p a
withResult
    TestResult wY
_ -> StrategyResult p wY Any -> StrategyDone m p wY
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone StrategyResult p wY Any
forall patches. StrategyResultRaw patches
NoPasses WithResult m p a
withResult

-- There's more than one patch to go.
trackNextBackoff TestFailure wNewer
tf Int
n RL (PatchSeq p) wOlder wNewer
ahead WithResult m p a
withResult = do
  case Int
-> RL (PatchSeq p) wOlder wNewer
-> (:>) (RL (PatchSeq p)) (RL (PatchSeq p)) wOlder wNewer
forall (a :: * -> * -> *) wX wZ.
Int -> RL a wX wZ -> (:>) (RL a) (RL a) wX wZ
splitAtRL Int
n RL (PatchSeq p) wOlder wNewer
ahead of
    RL (PatchSeq p) wOlder wZ
ahead' :> RL (PatchSeq p) wZ wNewer
skipped' -> do
      String -> m wNewer wNewer ()
forall wX. String -> m wX wX ()
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
String -> m wX wX ()
writeMsg (String -> m wNewer wNewer ()) -> String -> m wNewer wNewer ()
forall a b. (a -> b) -> a -> b
$ String
"Skipping " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" patches..."String -> ShowS
forall a. [a] -> [a] -> [a]
++(Int, Int) -> String
forall a. Show a => a -> String
show (RL (PatchSeq p) wZ wNewer -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (PatchSeq p) wZ wNewer
skipped', RL (PatchSeq p) wOlder wZ -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (PatchSeq p) wOlder wZ
ahead')
      RL (PatchSeq p) wZ wNewer -> m wNewer wZ ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wY wX ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wY wX ()
unapplyPatch RL (PatchSeq p) wZ wNewer
skipped'
      -- After backing off by n more patches, look for a testable state, working through the skipped
      -- patches if necessary because the current state isn't testable.
      TestResultValid wNewer
-> TestingState p wOlder wZ wNewer
-> (forall {wFocus2}.
    TestResultValid wFocus2
    -> TestingState p wOlder wFocus2 wNewer -> m wFocus2 TestingDone a)
-> m wZ TestingDone a
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wNewer wOlder
       wFocus wResult a.
TestablePatch m p =>
TestResultValid wNewer
-> TestingState p wOlder wFocus wNewer
-> (forall wFocus2.
    TestResultValid wFocus2
    -> TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wFocus wResult a
findTestableTowardsNewer (TestFailure wNewer -> TestResultValid wNewer
forall {k} (wX :: k). TestFailure wX -> TestResultValid wX
Failure TestFailure wNewer
tf) (RL (PatchSeq p) wOlder wZ
-> FL (PatchSeq p) wZ wNewer -> TestingState p wOlder wZ wNewer
forall (p :: * -> * -> *) wOlder wFocus wNewer.
RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
TestingState RL (PatchSeq p) wOlder wZ
ahead' (RL (PatchSeq p) wZ wNewer -> FL (PatchSeq p) wZ wNewer
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PatchSeq p) wZ wNewer
skipped')) ((forall {wFocus2}.
  TestResultValid wFocus2
  -> TestingState p wOlder wFocus2 wNewer -> m wFocus2 TestingDone a)
 -> m wZ TestingDone a)
-> (forall {wFocus2}.
    TestResultValid wFocus2
    -> TestingState p wOlder wFocus2 wNewer -> m wFocus2 TestingDone a)
-> m wZ TestingDone a
forall a b. (a -> b) -> a -> b
$
        \TestResultValid wFocus2
testResult (TestingState RL (PatchSeq p) wOlder wFocus2
ahead'' FL (PatchSeq p) wFocus2 wNewer
skipped'') ->
        case TestResultValid wFocus2
testResult of
          -- Another failure, keep going. Note that it's possible that
          -- findTestableTowardsNewer will have to go all the way to the end of
          -- skipped', leaving us in the same testing position as before, but
          -- the backoff count is doubled so we'll still make progress.
          Failure TestFailure wFocus2
tf2 -> TestFailure wFocus2
-> Int
-> RL (PatchSeq p) wOlder wFocus2
-> StrategyDone m p wFocus2
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wNewer wOlder.
TestablePatch m p =>
TestFailure wNewer
-> Int -> RL (PatchSeq p) wOlder wNewer -> StrategyDone m p wNewer
trackNextBackoff TestFailure wFocus2
tf2 (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
n) RL (PatchSeq p) wOlder wFocus2
ahead'' WithResult m p a
withResult
          -- Found a success state, so now we can start the bisect.
          TestResultValid wFocus2
Success -> TestingState p wFocus2 wFocus2 wNewer -> StrategyDone m p wFocus2
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wFocus
       wNewer.
TestablePatch m p =>
TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
initialBisect (RL (PatchSeq p) wFocus2 wFocus2
-> FL (PatchSeq p) wFocus2 wNewer
-> TestingState p wFocus2 wFocus2 wNewer
forall (p :: * -> * -> *) wOlder wFocus wNewer.
RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
TestingState RL (PatchSeq p) wFocus2 wFocus2
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL FL (PatchSeq p) wFocus2 wNewer
skipped'') WithResult m p a
withResult

-- |Given a patch sequence which has a valid test result at the end ('wNewer'),
-- try to find another point with a valid test result, starting from 'wFocus' and
-- jumping towards 'wNewer' if necessary.
findTestableTowardsNewer
  :: TestablePatch m p
  => TestResultValid wNewer
  -> TestingState p wOlder wFocus wNewer
  -> (forall wFocus2
       . TestResultValid wFocus2
      -> TestingState p wOlder wFocus2 wNewer
      -> m wFocus2 wResult a
     )
  -> m wFocus wResult a

findTestableTowardsNewer :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wNewer wOlder
       wFocus wResult a.
TestablePatch m p =>
TestResultValid wNewer
-> TestingState p wOlder wFocus wNewer
-> (forall wFocus2.
    TestResultValid wFocus2
    -> TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wFocus wResult a
findTestableTowardsNewer TestResultValid wNewer
newerResult ts :: TestingState p wOlder wFocus wNewer
ts@(TestingState RL (PatchSeq p) wOlder wFocus
_ FL (PatchSeq p) wFocus wNewer
NilFL) forall wFocus2.
TestResultValid wFocus2
-> TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
cont = TestResultValid wFocus
-> TestingState p wOlder wFocus wNewer -> m wFocus wResult a
forall wFocus2.
TestResultValid wFocus2
-> TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
cont TestResultValid wNewer
TestResultValid wFocus
newerResult TestingState p wOlder wFocus wNewer
ts
findTestableTowardsNewer TestResultValid wNewer
newerResult ts :: TestingState p wOlder wFocus wNewer
ts@(TestingState RL (PatchSeq p) wOlder wFocus
older (PatchSeq p wFocus wY
p :>: FL (PatchSeq p) wY wNewer
ps)) forall wFocus2.
TestResultValid wFocus2
-> TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
cont = do
  TestResult wFocus
focusResult <- m wFocus wFocus (TestResult wFocus)
forall wX. m wX wX (TestResult wX)
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
m wX wX (TestResult wX)
getCurrentTestResult
  case TestResult wFocus
focusResult of
    Testable TestResultValid wFocus
res -> TestResultValid wFocus
-> TestingState p wOlder wFocus wNewer -> m wFocus wResult a
forall wFocus2.
TestResultValid wFocus2
-> TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
cont TestResultValid wFocus
res TestingState p wOlder wFocus wNewer
ts
    TestResult wFocus
Untestable -> do
      String -> m wFocus wFocus ()
forall wX. String -> m wX wX ()
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
String -> m wX wX ()
writeMsg (String -> m wFocus wFocus ()) -> String -> m wFocus wFocus ()
forall a b. (a -> b) -> a -> b
$ String
"Found untestable state " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
show (TestingState p wOlder wFocus wNewer -> (Int, Int)
forall (p :: * -> * -> *) wX wZ wY.
TestingState p wX wZ wY -> (Int, Int)
lengthsTS TestingState p wOlder wFocus wNewer
ts)
      PatchSeq p wFocus wY -> m wFocus wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wX wY ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wX wY ()
applyPatch PatchSeq p wFocus wY
p
      let
        -- The 'wB' state is untestable, so try to attach the patches on either side of
        -- it together into the same 'PatchSeq' so we don't try it again.
        joinT :: RL (PatchSeq p) wA wB -> PatchSeq p wB wC -> RL (PatchSeq p) wA wC
        -- If we don't have any patches on the left, we can't do anything.
        joinT :: forall (p :: * -> * -> *) wA wB wC.
RL (PatchSeq p) wA wB -> PatchSeq p wB wC -> RL (PatchSeq p) wA wC
joinT RL (PatchSeq p) wA wB
NilRL PatchSeq p wB wC
x = RL (PatchSeq p) wA wA
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL RL (PatchSeq p) wA wA -> PatchSeq p wA wC -> RL (PatchSeq p) wA wC
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchSeq p wA wC
PatchSeq p wB wC
x
        -- Otherwise peel off the first patch on the left and attach it to the patch on the right.
        joinT (RL (PatchSeq p) wA wY
ys :<: PatchSeq p wY wB
y) PatchSeq p wB wC
x = RL (PatchSeq p) wA wY
ys RL (PatchSeq p) wA wY -> PatchSeq p wY wC -> RL (PatchSeq p) wA wC
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchSeq p wY wB -> PatchSeq p wB wC -> PatchSeq p wY wC
forall {k} (p :: k -> k -> *) (wX :: k) (wY :: k) (wZ :: k).
PatchSeq p wX wY -> PatchSeq p wY wZ -> PatchSeq p wX wZ
Joined PatchSeq p wY wB
y PatchSeq p wB wC
x
      TestingState p wOlder wY wNewer
-> (forall {wFocus2}.
    TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wY wResult a
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus wResult a.
TestablePatch m p =>
TestingState p wOlder wFocus wNewer
-> (forall wFocus2.
    TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wFocus wResult a
moveHalfNewer (RL (PatchSeq p) wOlder wY
-> FL (PatchSeq p) wY wNewer -> TestingState p wOlder wY wNewer
forall (p :: * -> * -> *) wOlder wFocus wNewer.
RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
TestingState (RL (PatchSeq p) wOlder wFocus
-> PatchSeq p wFocus wY -> RL (PatchSeq p) wOlder wY
forall (p :: * -> * -> *) wA wB wC.
RL (PatchSeq p) wA wB -> PatchSeq p wB wC -> RL (PatchSeq p) wA wC
joinT RL (PatchSeq p) wOlder wFocus
older PatchSeq p wFocus wY
p) FL (PatchSeq p) wY wNewer
ps) ((forall {wFocus2}.
  TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
 -> m wY wResult a)
-> (forall {wFocus2}.
    TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wY wResult a
forall a b. (a -> b) -> a -> b
$ \TestingState p wOlder wFocus2 wNewer
tsNew ->
        TestResultValid wNewer
-> TestingState p wOlder wFocus2 wNewer
-> (forall wFocus2.
    TestResultValid wFocus2
    -> TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wFocus2 wResult a
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wNewer wOlder
       wFocus wResult a.
TestablePatch m p =>
TestResultValid wNewer
-> TestingState p wOlder wFocus wNewer
-> (forall wFocus2.
    TestResultValid wFocus2
    -> TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wFocus wResult a
findTestableTowardsNewer TestResultValid wNewer
newerResult TestingState p wOlder wFocus2 wNewer
tsNew TestResultValid wFocus2
-> TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
forall wFocus2.
TestResultValid wFocus2
-> TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
cont


-- |Binary search (with --bisect): bisect from the start of the repository.
-- This strategy is a bit dubious as the test probably doesn't actually pass
-- at the start of the repository so the hope is that at some point during the
-- bisect we will come across a passing state. The two different entry points into
-- 'initialBisect' (trackBisect and trackBackoff) also complicate the set of cases
-- we have to consider.
trackBisect :: Strategy
trackBisect :: Strategy
trackBisect (Testable (Failure TestFailure wNewer
_)) RL p wOlder wNewer
ps = TestingState p wOlder wNewer wNewer -> StrategyDone m p wNewer
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wFocus
       wNewer.
TestablePatch m p =>
TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
initialBisect (RL (PatchSeq p) wOlder wNewer
-> FL (PatchSeq p) wNewer wNewer
-> TestingState p wOlder wNewer wNewer
forall (p :: * -> * -> *) wOlder wFocus wNewer.
RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
TestingState ((forall wW wY. p wW wY -> PatchSeq p wW wY)
-> RL p wOlder wNewer -> RL (PatchSeq p) wOlder wNewer
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ
mapRL_RL p wW wY -> PatchSeq p wW wY
forall wW wY. p wW wY -> PatchSeq p wW wY
forall {k} (p :: k -> k -> *) (wX :: k) (wY :: k).
p wX wY -> PatchSeq p wX wY
Single RL p wOlder wNewer
ps) FL (PatchSeq p) wNewer wNewer
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
trackBisect TestResult wNewer
_ RL p wOlder wNewer
_ = StrategyResult p wNewer Any -> StrategyDone m p wNewer
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone StrategyResult p wNewer Any
forall patches. StrategyResultRaw patches
NoFailureOnHead

-- |Progress of Bisect: current step, currently predicted total steps.
-- The total steps prediction will increase if we run into untestable states.
type BisectProgress = (Int, Int)

-- |Launch a bisect. Precondition: the test fails at 'wNewer'.
-- If called via backoff, then the test also passes at 'wOlder',
-- but there is no guarantee if bisect is called directly. 
initialBisect
  :: TestablePatch m p
  => TestingState p wOlder wFocus wNewer
  -> StrategyDone m p wFocus
initialBisect :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wFocus
       wNewer.
TestablePatch m p =>
TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
initialBisect TestingState p wOlder wFocus wNewer
ps = (Int, Int)
-> TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus.
TestablePatch m p =>
(Int, Int)
-> TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
trackNextBisect (Int, Int)
currProg TestingState p wOlder wFocus wNewer
ps
  where
    flooredLength :: Int
flooredLength = TestingState p wOlder wFocus wNewer -> Int
forall (p :: * -> * -> *) wX wZ wY. TestingState p wX wZ wY -> Int
lengthTS TestingState p wOlder wFocus wNewer
ps Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
1
    maxProg :: Int
maxProg  = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Double -> Int
forall b. Integral b => Double -> b
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
flooredLength) :: Double)
    currProg :: (Int, Int)
currProg = (Int
1, Int
maxProg) :: BisectProgress

-- |Given a testing state, work out what to do next.
-- Precondition: the test fails at 'wNewer'.
trackNextBisect
  :: forall m p wOlder wNewer wFocus
   . TestablePatch m p
  => BisectProgress
  -> TestingState p wOlder wFocus wNewer
  -> StrategyDone m p wFocus

trackNextBisect :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus.
TestablePatch m p =>
(Int, Int)
-> TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
trackNextBisect (Int, Int)
_ (TestingState RL (PatchSeq p) wOlder wFocus
NilRL FL (PatchSeq p) wFocus wNewer
NilFL) WithResult m p a
withResult = StrategyResult p wFocus Any -> StrategyDone m p wFocus
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone StrategyResult p wFocus Any
forall patches. StrategyResultRaw patches
NoPasses WithResult m p a
withResult

-- With these two cases we're down to a single patch, so either it's to blame
-- or there are no passing states found (subject to the limitations of the bisect strategy -
-- not every state was visited).
trackNextBisect (Int, Int)
_ (TestingState RL (PatchSeq p) wOlder wFocus
NilRL (PatchSeq p wFocus wY
p :>: FL (PatchSeq p) wY wNewer
NilFL)) WithResult m p a
withResult = PatchSeq p wFocus wY -> StrategyDone m p wFocus
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer.
TestablePatch m p =>
PatchSeq p wOlder wNewer -> StrategyDone m p wOlder
checkAndReturnFinalBisectResult PatchSeq p wFocus wY
p WithResult m p a
withResult
trackNextBisect (Int, Int)
_ (TestingState (RL (PatchSeq p) wOlder wY
NilRL :<: PatchSeq p wY wFocus
p) FL (PatchSeq p) wFocus wNewer
NilFL) WithResult m p a
withResult = do
  PatchSeq p wY wFocus -> m wFocus wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wY wX ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wY wX ()
unapplyPatch PatchSeq p wY wFocus
p
  PatchSeq p wY wFocus -> StrategyDone m p wY
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer.
TestablePatch m p =>
PatchSeq p wOlder wNewer -> StrategyDone m p wOlder
checkAndReturnFinalBisectResult PatchSeq p wY wFocus
p WithResult m p a
withResult

-- More than one patch left. Find the middle of the TestingState and work from that.
trackNextBisect (Int
dnow, Int
dtotal) TestingState p wOlder wFocus wNewer
ps WithResult m p a
withResult = do
  String -> m wFocus wFocus ()
forall wX. String -> m wX wX ()
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
String -> m wX wX ()
writeMsg (String -> m wFocus wFocus ()) -> String -> m wFocus wFocus ()
forall a b. (a -> b) -> a -> b
$ String
"Trying " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dnow String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dtotal String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" sequences..." String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
show (TestingState p wOlder wFocus wNewer -> (Int, Int)
forall (p :: * -> * -> *) wX wZ wY.
TestingState p wX wZ wY -> (Int, Int)
lengthsTS TestingState p wOlder wFocus wNewer
ps)
  TestingState p wOlder wFocus wNewer
-> (forall wFocus2.
    TestingState p wOlder wFocus2 wNewer -> m wFocus2 TestingDone a)
-> m wFocus TestingDone a
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus wResult a.
TestablePatch m p =>
TestingState p wOlder wFocus wNewer
-> (forall wFocus2.
    TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wFocus wResult a
moveToMiddle TestingState p wOlder wFocus wNewer
ps (\TestingState p wOlder wFocus2 wNewer
ts -> (Int, Int)
-> TestingState p wOlder wFocus2 wNewer -> StrategyDone m p wFocus2
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus.
TestablePatch m p =>
(Int, Int)
-> TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
runNextBisect (Int
dnow, Int
dtotal) TestingState p wOlder wFocus2 wNewer
ts WithResult m p a
withResult)

-- |Once we only have one patch left in bisect, we need to check that the test passes before the patch.
-- This is not guaranteed when bisect is called directly from the command-line. If we changed the UI to
-- ensure that bisect was only launched with both a passing and a failing state, we could strengthen
-- the precondition of 'initialBisect' and things it calls, and this function would be unnecessary.
-- Precondition: the test fails at 'wNewer'.
checkAndReturnFinalBisectResult
  :: TestablePatch m p
  => PatchSeq p wOlder wNewer
  -> StrategyDone m p wOlder
checkAndReturnFinalBisectResult :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer.
TestablePatch m p =>
PatchSeq p wOlder wNewer -> StrategyDone m p wOlder
checkAndReturnFinalBisectResult PatchSeq p wOlder wNewer
p WithResult m p a
withResult = do
  TestResult wOlder
testResult <- m wOlder wOlder (TestResult wOlder)
forall wX. m wX wX (TestResult wX)
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
m wX wX (TestResult wX)
getCurrentTestResult
  case TestResult wOlder
testResult of
    Testable TestResultValid wOlder
Success -> StrategyResult p wOlder wNewer -> StrategyDone m p wOlder
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone (PatchSeq p wOlder wNewer -> StrategyResult p wOlder wNewer
forall patches. patches -> StrategyResultRaw patches
Blame PatchSeq p wOlder wNewer
p) WithResult m p a
withResult
    TestResult wOlder
_ -> StrategyResult p wOlder Any -> StrategyDone m p wOlder
forall (p :: * -> * -> *) wSuccess wFailure
       (m :: * -> * -> * -> *).
StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess
strategyDone StrategyResult p wOlder Any
forall patches. StrategyResultRaw patches
NoPasses WithResult m p a
withResult

-- |The guts of bisection. Normally it will be passed an evenly split
-- 'TestingState older newer' with the focus in the middle, but if we find an
-- untestable state then we will start jumping around to find something testable.
-- Preconditions: 'older' is non-empty; the test fails at wNewer.
runNextBisect
  :: forall m p wOlder wNewer wFocus
   . TestablePatch m p
  => BisectProgress
  -> TestingState p wOlder wFocus wNewer
  -> StrategyDone m p wFocus
runNextBisect :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus.
TestablePatch m p =>
(Int, Int)
-> TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
runNextBisect (Int
dnow, Int
dtotal) (TestingState RL (PatchSeq p) wOlder wFocus
older FL (PatchSeq p) wFocus wNewer
newer) WithResult m p a
withResult = do
  TestResult wFocus
testResult <- m wFocus wFocus (TestResult wFocus)
forall wX. m wX wX (TestResult wX)
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
m wX wX (TestResult wX)
getCurrentTestResult
  case TestResult wFocus
testResult of

    -- The standard case for bisect: we have a result for the focus and we use it to pick
    -- either the left or right half.
    Testable TestResultValid wFocus
result -> do
      let doNext :: TestingState p wOlder wFocus wNewer -> m wFocus TestingDone a
doNext TestingState p wOlder wFocus wNewer
newState = (Int, Int)
-> TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus.
TestablePatch m p =>
(Int, Int)
-> TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
trackNextBisect (Int
dnowInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
dtotal) TestingState p wOlder wFocus wNewer
newState WithResult m p a
withResult
      case TestResultValid wFocus
result of
        TestResultValid wFocus
Success   -> TestingState p wFocus wFocus wNewer -> m wFocus TestingDone a
forall {wOlder} {wFocus} {wNewer}.
TestingState p wOlder wFocus wNewer -> m wFocus TestingDone a
doNext (RL (PatchSeq p) wFocus wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wFocus wFocus wNewer
forall (p :: * -> * -> *) wOlder wFocus wNewer.
RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
TestingState RL (PatchSeq p) wFocus wFocus
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL FL (PatchSeq p) wFocus wNewer
newer) -- continue left  (to the present)
        Failure TestFailure wFocus
_ -> TestingState p wOlder wFocus wFocus -> m wFocus TestingDone a
forall {wOlder} {wFocus} {wNewer}.
TestingState p wOlder wFocus wNewer -> m wFocus TestingDone a
doNext (RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wFocus
-> TestingState p wOlder wFocus wFocus
forall (p :: * -> * -> *) wOlder wFocus wNewer.
RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
TestingState RL (PatchSeq p) wOlder wFocus
older FL (PatchSeq p) wFocus wFocus
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) -- continue right (to the past)

    -- If we couldn't test the bisect state then we need to move around to try to find
    -- a testable state.
    TestResult wFocus
Untestable -> do
      String -> m wFocus wFocus ()
forall wX. String -> m wX wX ()
forall (m :: * -> * -> * -> *) wX.
TestRunner m =>
String -> m wX wX ()
writeMsg (String -> m wFocus wFocus ()) -> String -> m wFocus wFocus ()
forall a b. (a -> b) -> a -> b
$ String
"Found untestable state " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
show (TestingState p wOlder wFocus wNewer -> (Int, Int)
forall (p :: * -> * -> *) wX wZ wY.
TestingState p wX wZ wY -> (Int, Int)
lengthsTS (RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
forall (p :: * -> * -> *) wOlder wFocus wNewer.
RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
TestingState RL (PatchSeq p) wOlder wFocus
older FL (PatchSeq p) wFocus wNewer
newer))
      case (RL (PatchSeq p) wOlder wFocus
older, FL (PatchSeq p) wFocus wNewer
newer) of
        (RL (PatchSeq p) wOlder wFocus
NilRL, FL (PatchSeq p) wFocus wNewer
_) -> String -> m wFocus TestingDone a
forall a. HasCallStack => String -> a
error String
"internal error: older bisect state reached 0 patches (runNextBisect)"
        -- Although 'newer' can become empty, the precondition that the test fails at wNewer means
        -- we shouldn't get here.
        -- TODO the user might supply an unreliable test script, maybe we should deal with the NilFL
        -- case before running the test.
        (RL (PatchSeq p) wOlder wFocus
_, FL (PatchSeq p) wFocus wNewer
NilFL) -> String -> m wFocus TestingDone a
forall a. HasCallStack => String -> a
error String
"internal error: newer bisect state reached 0 patches (runNextBisect)"
        (RL (PatchSeq p) wOlder wY
older' :<: PatchSeq p wY wFocus
p1, PatchSeq p wFocus wY
p2 :>: FL (PatchSeq p) wY wNewer
newer') -> do
          PatchSeq p wFocus wY -> m wFocus wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wX wY ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wX wY ()
applyPatch PatchSeq p wFocus wY
p2
          TestingState p wOlder wY wNewer
-> (forall {wFocus2}.
    TestingState p wOlder wFocus2 wNewer -> m wFocus2 TestingDone a)
-> m wY TestingDone a
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus wResult a.
TestablePatch m p =>
TestingState p wOlder wFocus wNewer
-> (forall wFocus2.
    TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wFocus wResult a
moveHalfNewer (RL (PatchSeq p) wOlder wY
-> FL (PatchSeq p) wY wNewer -> TestingState p wOlder wY wNewer
forall (p :: * -> * -> *) wOlder wFocus wNewer.
RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
TestingState (RL (PatchSeq p) wOlder wY
older' RL (PatchSeq p) wOlder wY
-> PatchSeq p wY wY -> RL (PatchSeq p) wOlder wY
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchSeq p wY wFocus -> PatchSeq p wFocus wY -> PatchSeq p wY wY
forall {k} (p :: k -> k -> *) (wX :: k) (wY :: k) (wZ :: k).
PatchSeq p wX wY -> PatchSeq p wY wZ -> PatchSeq p wX wZ
Joined PatchSeq p wY wFocus
p1 PatchSeq p wFocus wY
p2) FL (PatchSeq p) wY wNewer
newer') ((forall {wFocus2}.
  TestingState p wOlder wFocus2 wNewer -> m wFocus2 TestingDone a)
 -> m wY TestingDone a)
-> (forall {wFocus2}.
    TestingState p wOlder wFocus2 wNewer -> m wFocus2 TestingDone a)
-> m wY TestingDone a
forall a b. (a -> b) -> a -> b
$
            \TestingState p wOlder wFocus2 wNewer
ts -> (Int, Int)
-> TestingState p wOlder wFocus2 wNewer -> StrategyDone m p wFocus2
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus.
TestablePatch m p =>
(Int, Int)
-> TestingState p wOlder wFocus wNewer -> StrategyDone m p wFocus
runNextBisect (Int
dnowInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
dtotalInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) TestingState p wOlder wFocus2 wNewer
ts WithResult m p a
withResult

-- |Given a 'TestingState older newer', move the focus to the middle of 'newer',
-- updating the testing tree to match, and call the given continuation.
moveHalfNewer
  :: forall m p wOlder wNewer wFocus wResult a
   . TestablePatch m p
  => TestingState p wOlder wFocus wNewer
  -> (forall wFocus2 . TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
  -> m wFocus wResult a

moveHalfNewer :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus wResult a.
TestablePatch m p =>
TestingState p wOlder wFocus wNewer
-> (forall wFocus2.
    TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wFocus wResult a
moveHalfNewer (TestingState RL (PatchSeq p) wOlder wFocus
older FL (PatchSeq p) wFocus wNewer
newer) forall wFocus2.
TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
f = RL (PatchSeq p) wOlder wFocus
-> (Int, FL (PatchSeq p) wFocus wNewer) -> m wFocus wResult a
forall wFocus2.
RL (PatchSeq p) wOlder wFocus2
-> (Int, FL (PatchSeq p) wFocus2 wNewer) -> m wFocus2 wResult a
doMove RL (PatchSeq p) wOlder wFocus
older (FL (PatchSeq p) wFocus wNewer -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchSeq p) wFocus wNewer
newer Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2, FL (PatchSeq p) wFocus wNewer
newer)
  where
    doMove
      :: forall wFocus2
       . RL (PatchSeq p) wOlder wFocus2
      -> (Int, FL (PatchSeq p) wFocus2 wNewer)
      -> m wFocus2 wResult a

    doMove :: forall wFocus2.
RL (PatchSeq p) wOlder wFocus2
-> (Int, FL (PatchSeq p) wFocus2 wNewer) -> m wFocus2 wResult a
doMove RL (PatchSeq p) wOlder wFocus2
ps1 (Int
0, FL (PatchSeq p) wFocus2 wNewer
ps2) = TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
forall wFocus2.
TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
f (RL (PatchSeq p) wOlder wFocus2
-> FL (PatchSeq p) wFocus2 wNewer
-> TestingState p wOlder wFocus2 wNewer
forall (p :: * -> * -> *) wOlder wFocus wNewer.
RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
TestingState RL (PatchSeq p) wOlder wFocus2
ps1 FL (PatchSeq p) wFocus2 wNewer
ps2)
    doMove RL (PatchSeq p) wOlder wFocus2
_ (Int
_, FL (PatchSeq p) wFocus2 wNewer
NilFL) = String -> m wFocus2 wResult a
forall a. HasCallStack => String -> a
error String
"impossible: exhausted newer patches (moveHalfNewer)"
    doMove RL (PatchSeq p) wOlder wFocus2
ps1 (Int
n, PatchSeq p wFocus2 wY
p :>: FL (PatchSeq p) wY wNewer
ps2) = do
      PatchSeq p wFocus2 wY -> m wFocus2 wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wX wY ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wX wY ()
applyPatch PatchSeq p wFocus2 wY
p
      RL (PatchSeq p) wOlder wY
-> (Int, FL (PatchSeq p) wY wNewer) -> m wY wResult a
forall wFocus2.
RL (PatchSeq p) wOlder wFocus2
-> (Int, FL (PatchSeq p) wFocus2 wNewer) -> m wFocus2 wResult a
doMove (RL (PatchSeq p) wOlder wFocus2
ps1 RL (PatchSeq p) wOlder wFocus2
-> PatchSeq p wFocus2 wY -> RL (PatchSeq p) wOlder wY
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchSeq p wFocus2 wY
p) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, FL (PatchSeq p) wY wNewer
ps2)

-- |Given a 'TestingState older newer', move the focus to the middle of
-- 'older +>+ newer', updating the testing tree to match, and call the given
-- continuation.
moveToMiddle
  :: forall m p wOlder wNewer wFocus wResult a
   . TestablePatch m p
  => TestingState p wOlder wFocus wNewer
  -> (forall wFocus2 . TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
  -> m wFocus wResult a

moveToMiddle :: forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wOlder wNewer
       wFocus wResult a.
TestablePatch m p =>
TestingState p wOlder wFocus wNewer
-> (forall wFocus2.
    TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)
-> m wFocus wResult a
moveToMiddle (TestingState RL (PatchSeq p) wOlder wFocus
older FL (PatchSeq p) wFocus wNewer
newer) forall wFocus2.
TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
f = (Int, RL (PatchSeq p) wOlder wFocus)
-> (Int, FL (PatchSeq p) wFocus wNewer) -> m wFocus wResult a
forall wFocus2.
(Int, RL (PatchSeq p) wOlder wFocus2)
-> (Int, FL (PatchSeq p) wFocus2 wNewer) -> m wFocus2 wResult a
doMove (RL (PatchSeq p) wOlder wFocus -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL RL (PatchSeq p) wOlder wFocus
older, RL (PatchSeq p) wOlder wFocus
older) (FL (PatchSeq p) wFocus wNewer -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchSeq p) wFocus wNewer
newer, FL (PatchSeq p) wFocus wNewer
newer)
  where
    doMove
      :: forall wFocus2
       . (Int, RL (PatchSeq p) wOlder wFocus2)
      -> (Int, FL (PatchSeq p) wFocus2 wNewer)
      -> m wFocus2 wResult a

    doMove :: forall wFocus2.
(Int, RL (PatchSeq p) wOlder wFocus2)
-> (Int, FL (PatchSeq p) wFocus2 wNewer) -> m wFocus2 wResult a
doMove (Int
len1, RL (PatchSeq p) wOlder wFocus2
ps1) (Int
len2, FL (PatchSeq p) wFocus2 wNewer
ps2) | Int -> Int
forall a. Num a => a -> a
abs (Int
len1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len2) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
forall wFocus2.
TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a
f (RL (PatchSeq p) wOlder wFocus2
-> FL (PatchSeq p) wFocus2 wNewer
-> TestingState p wOlder wFocus2 wNewer
forall (p :: * -> * -> *) wOlder wFocus wNewer.
RL (PatchSeq p) wOlder wFocus
-> FL (PatchSeq p) wFocus wNewer
-> TestingState p wOlder wFocus wNewer
TestingState RL (PatchSeq p) wOlder wFocus2
ps1 FL (PatchSeq p) wFocus2 wNewer
ps2)

    doMove (Int
len1, RL (PatchSeq p) wOlder wY
ps1 :<: PatchSeq p wY wFocus2
p1) (Int
len2, FL (PatchSeq p) wFocus2 wNewer
ps2) | Int
len1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
len2 = do
      PatchSeq p wY wFocus2 -> m wFocus2 wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wY wX ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wY wX ()
unapplyPatch PatchSeq p wY wFocus2
p1
      (Int, RL (PatchSeq p) wOlder wY)
-> (Int, FL (PatchSeq p) wY wNewer) -> m wY wResult a
forall wFocus2.
(Int, RL (PatchSeq p) wOlder wFocus2)
-> (Int, FL (PatchSeq p) wFocus2 wNewer) -> m wFocus2 wResult a
doMove (Int
len1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, RL (PatchSeq p) wOlder wY
ps1) (Int
len2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, PatchSeq p wY wFocus2
p1 PatchSeq p wY wFocus2
-> FL (PatchSeq p) wFocus2 wNewer -> FL (PatchSeq p) wY wNewer
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchSeq p) wFocus2 wNewer
ps2)

    doMove (Int
len1, RL (PatchSeq p) wOlder wFocus2
ps1) (Int
len2, PatchSeq p wFocus2 wY
p2 :>: FL (PatchSeq p) wY wNewer
ps2) = do -- len2 > len1
      PatchSeq p wFocus2 wY -> m wFocus2 wY ()
forall (p :: * -> * -> *) wX wY.
ApplyPatchReqs m p =>
p wX wY -> m wX wY ()
forall (m :: * -> * -> * -> *) (p :: * -> * -> *) wX wY.
(TestRunner m, ApplyPatchReqs m p) =>
p wX wY -> m wX wY ()
applyPatch PatchSeq p wFocus2 wY
p2
      (Int, RL (PatchSeq p) wOlder wY)
-> (Int, FL (PatchSeq p) wY wNewer) -> m wY wResult a
forall wFocus2.
(Int, RL (PatchSeq p) wOlder wFocus2)
-> (Int, FL (PatchSeq p) wFocus2 wNewer) -> m wFocus2 wResult a
doMove (Int
len1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, RL (PatchSeq p) wOlder wFocus2
ps1 RL (PatchSeq p) wOlder wFocus2
-> PatchSeq p wFocus2 wY -> RL (PatchSeq p) wOlder wY
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchSeq p wFocus2 wY
p2) (Int
len2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, FL (PatchSeq p) wY wNewer
ps2)

    -- these cases should only be reachable if the lengths get out of sync
    doMove (Int
_, RL (PatchSeq p) wOlder wFocus2
NilRL) (Int, FL (PatchSeq p) wFocus2 wNewer)
_ = String -> m wFocus2 wResult a
forall a. HasCallStack => String -> a
error String
"internal error: right bisect state reached 0 patches (moveToMiddle)"
    doMove (Int, RL (PatchSeq p) wOlder wFocus2)
_ (Int
_, FL (PatchSeq p) wFocus2 wNewer
NilFL) = String -> m wFocus2 wResult a
forall a. HasCallStack => String -> a
error String
"internal error: left bisect state reached 0 patches (moveToMiddle)"