{-# 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 )
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 }
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
}
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
class Monad m => TestRunner m where
type ApplyPatchReqs m (p :: * -> * -> *) :: Constraint
type DisplayPatchReqs m (p :: * -> * -> *) :: Constraint
writeMsg :: String -> m wX wX ()
mentionPatch :: DisplayPatchReqs m p => p wA wB -> m wX wX ()
applyPatch :: ApplyPatchReqs m p => p wX wY -> m wX wY ()
unapplyPatch :: ApplyPatchReqs m p => p wX wY -> m wY wX ()
getCurrentTestResult :: m wX wX (TestResult wX)
finishedTesting :: a -> m wX TestingDone a
type TestRunnerPatchReqs m p =
(
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)
data TestResult wX
= Testable (TestResultValid wX)
| Untestable
data TestResultValid wX
= Success
| Failure (TestFailure wX)
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))
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)
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)
data StrategyResultRaw patches =
NoPasses
| NoFailureOnHead
| Blame patches
| RunSuccess
| RunFailed Int
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))
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
}
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
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
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
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"
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
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 ->
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
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)
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)
type StrategyDone m p wY = forall a . WithResult m p a -> m wY TestingDone a
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
type Strategy
= forall m p wOlder wNewer
. TestablePatch m p
=> TestResult wNewer
-> RL p wOlder wNewer
-> StrategyDone m p wNewer
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
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
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
$
(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
$
(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
where
assumedMonotony :: String
assumedMonotony = String
" (assuming monotony in the given range)"
wasLinear :: String
wasLinear = String
""
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
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
trackNextLinear
:: TestablePatch m p
=> FL p wY wZ
-> RL p wX wY
-> 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
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
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
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
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)
trackBackoff :: Strategy
trackBackoff :: Strategy
trackBackoff (Testable (Failure TestFailure wNewer
tf)) RL p wOlder wNewer
ps =
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
trackNextBackoff
:: TestablePatch m p
=> TestFailure wNewer
-> Int
-> RL (PatchSeq p) wOlder wNewer
-> StrategyDone m p wNewer
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
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
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'
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
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
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
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
joinT :: RL (PatchSeq p) wA wB -> PatchSeq p wB wC -> RL (PatchSeq p) wA wC
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
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
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
type BisectProgress = (Int, Int)
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
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
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
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)
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
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
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)
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)
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)"
(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
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)
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
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)
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)"