{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

-- | Mutagen's main testing loop.
module Test.Mutagen.Test.Loop
  ( -- * Test loop
    loop
  )
where

import Control.Monad (void, when)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Function ((&))
import System.Random (split)
import Test.Mutagen.Config
  ( DebugMode (..)
  , EvaluationOrder (..)
  , LazyPruningMode (..)
  )
import Test.Mutagen.Fragment.Store (storeFragments)
import Test.Mutagen.Lazy (withLazyIO)
import Test.Mutagen.Mutation (Pos)
import Test.Mutagen.Property
  ( Args
  , Result (..)
  , protectProp
  , resultException
  , resultExpect
  , unProp
  , pattern Discarded
  , pattern Failed
  , pattern Passed
  )
import Test.Mutagen.Report
  ( Report (..)
  )
import Test.Mutagen.Test.Queue
  ( MutationBatch (..)
  , MutationCandidate (..)
  , createOrInheritMutationBatch
  , dequeueNextMutationCandidate
  , enqueueMutationCandidate
  , mutationQueueSize
  , nextMutation
  )
import Test.Mutagen.Test.State
  ( MutagenState (..)
  , computeSize
  , incMutantKindCounter
  , incNumBoring
  , incNumDiscarded
  , incNumFailed
  , incNumGenerated
  , incNumInteresting
  , incNumMutatedFromDiscarded
  , incNumMutatedFromPassed
  , incNumPassed
  , incNumTestsSinceLastInteresting
  , incNumTraceStoreResets
  , nextCounterexamplePath
  , resetNumTestsSinceLastInteresting
  , setAutoResetAfter
  , setCurrentGenSize
  , setDiscardedQueue
  , setExpect
  , setNextSeed
  , setPassedQueue
  , setRandomMutations
  , timedOut
  , updateFragmentStore
  , updatePassedQueue
  )
import Test.Mutagen.Test.Terminal
  ( MonadTerminal (..)
  , pretty
  , printBatchStatus
  , printGlobalStats
  , printShortStats
  )
import Test.Mutagen.Tracer.Store (STraceBackend (..), TraceStoreImpl (..))
import Test.Mutagen.Tracer.Trace (Trace (..), truncateTrace, withTrace)
import Test.QuickCheck.Gen (unGen)

{-------------------------------------------------------------------------------
-- * The main test loop
-------------------------------------------------------------------------------}

-- | Constraint alias for monads that can run Mutagen tests.
type MonadMutagen m = (MonadIO m, MonadTerminal m)

-- | The entry point to Mutagen's main testing loop.
--
-- The state machine switches back and forth between 'loop' and 'newTest',
-- until one of the terminal conditions is met.
loop :: (MonadMutagen m) => MutagenState -> m Report
loop :: forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
loop MutagenState
st
  -- We reached the max number of tests
  -- ==> either success or expected failure did not occur
  | MutagenState -> Int
stNumPassed MutagenState
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= MutagenState -> Int
stMaxSuccess MutagenState
st =
      case (MutagenState -> Bool
stExpect MutagenState
st, MutagenState -> Bool
stKeepGoing MutagenState
st) of
        (Bool
_, Bool
True) -> MutagenState -> m Report
forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
success MutagenState
st -- keepGoing always returns success
        (Bool
True, Bool
_) -> MutagenState -> m Report
forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
success MutagenState
st -- property holds as expected
        (Bool
False, Bool
_) -> MutagenState -> m Report
forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
noExpectedFailure MutagenState
st -- expected failure did not occur
        -- We discarded too many tests
        -- ==> give up
  | MutagenState -> Int
stNumDiscarded MutagenState
st
      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= MutagenState -> Int
stMaxDiscardRatio MutagenState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (MutagenState -> Int
stNumPassed MutagenState
st) (MutagenState -> Int
stMaxSuccess MutagenState
st)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (MutagenState -> Bool
stKeepGoing MutagenState
st) =
      MutagenState -> String -> m Report
forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> String -> m Report
giveUp MutagenState
st String
"too many discarded tests"
  -- Time to check if the time budget has been exceeded
  -- ==> if so, either success or give up depending on 'stKeepGoing'
  -- ==> otherwise, continue testing
  | (MutagenState -> Int
stNumPassed MutagenState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MutagenState -> Int
stNumDiscarded MutagenState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MutagenState -> Int
stNumFailed MutagenState
st) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
100 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = do
      timeout <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MutagenState -> IO Bool
timedOut MutagenState
st)
      case (timeout, stKeepGoing st) of
        (Bool
True, Bool
True) -> MutagenState -> m Report
forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
success MutagenState
st
        (Bool
True, Bool
False) -> MutagenState -> String -> m Report
forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> String -> m Report
giveUp MutagenState
st String
"timeout"
        (Bool, Bool)
_ -> MutagenState -> m Report
forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
newTest MutagenState
st
  -- There has been a long time since we enqueued anything interesting and
  -- both mutation queues are empty
  -- ==> reset the trace logs to free memory
  -- ==> double the number of random mutations
  -- ==> double the auto-reset threshold
  -- ==> continue testing
  | Just Int
threshold <- MutagenState -> Maybe Int
stAutoResetAfter MutagenState
st
  , MutagenState -> Int
stNumTestsSinceLastInteresting MutagenState
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
threshold
  , MutationQueue -> Int
mutationQueueSize (MutagenState -> MutationQueue
stPassedQueue MutagenState
st) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
  , MutationQueue -> Int
mutationQueueSize (MutagenState -> MutationQueue
stDiscardedQueue MutagenState
st) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = do
      MutagenState
-> (forall (trace :: TraceBackend).
    TraceStoreImpl trace =>
    TraceStore trace -> m ())
-> m ()
forall r.
MutagenState
-> (forall (trace :: TraceBackend).
    TraceStoreImpl trace =>
    TraceStore trace -> r)
-> r
withPassedTraceStore MutagenState
st (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (TraceStore trace -> IO ()) -> TraceStore trace -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceStore trace -> IO ()
forall (trace :: TraceBackend).
TraceStoreImpl trace =>
TraceStore trace -> IO ()
resetTraceStore)
      MutagenState
-> (forall (trace :: TraceBackend).
    TraceStoreImpl trace =>
    TraceStore trace -> m ())
-> m ()
forall r.
MutagenState
-> (forall (trace :: TraceBackend).
    TraceStoreImpl trace =>
    TraceStore trace -> r)
-> r
withDiscardedTraceStore MutagenState
st (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (TraceStore trace -> IO ()) -> TraceStore trace -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceStore trace -> IO ()
forall (trace :: TraceBackend).
TraceStoreImpl trace =>
TraceStore trace -> IO ()
resetTraceStore)
      let st' :: MutagenState
st' =
            MutagenState
st
              MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& Maybe Int -> MutagenState -> MutagenState
setAutoResetAfter ((Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutagenState -> Maybe Int
stAutoResetAfter MutagenState
st))
              MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& Int -> MutagenState -> MutagenState
setRandomMutations (MutagenState -> Int
stRandomMutations MutagenState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
              MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutagenState -> MutagenState
incNumTraceStoreResets
              MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutagenState -> MutagenState
resetNumTestsSinceLastInteresting
      MutagenState -> m Report
forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
newTest MutagenState
st'
  -- Nothing new under the sun
  -- ==> continue testing
  | Bool
otherwise =
      MutagenState -> m Report
forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
newTest MutagenState
st

-- | Select the next test case, run it, and process the result.
newTest :: (MonadMutagen m) => MutagenState -> m Report
newTest :: forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
newTest MutagenState
st0 = do
  -- NOTE: using 'stN' to avoid bugs related to tildes in the helpers below
  -- 1. pick a new test case
  (args, parent, st1) <- MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
pickNextTestCase MutagenState
st0
  -- 2. run the test case
  (result, st2) <- runTestCase args parent st1
  -- 3. check the test result and report a counterexample or continue
  case result of
    Result
Failed -> MutagenState -> Args -> Result -> m Report
onFailed MutagenState
st2 Args
args Result
result
    Result
_ -> MutagenState -> Args -> Result -> m Report
onSuccessOrDiscarded MutagenState
st2 Args
args Result
result
  where
    -- What to do with a successful or discarded test case
    onSuccessOrDiscarded :: MutagenState -> Args -> Result -> m Report
onSuccessOrDiscarded MutagenState
st Args
_args Result
result = do
      MutagenState -> m ()
forall {m :: * -> *}.
(MonadIO m, MonadTerminal m) =>
MutagenState -> m ()
printStats MutagenState
st
      DebugMode -> Result -> m ()
stopOnDebugMode (MutagenState -> DebugMode
stDebug MutagenState
st) Result
result
      MutagenState -> m Report
forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
loop MutagenState
st
    -- What to do with a failed test case
    onFailed :: MutagenState -> Args -> Result -> m Report
onFailed MutagenState
st Args
args Result
result = do
      let st' :: MutagenState
st' = MutagenState
st MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutagenState -> MutagenState
incNumFailed
      MutagenState -> Args -> Result -> m ()
forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> Args -> Result -> m ()
reportCounterexample MutagenState
st' Args
args Result
result
      MutagenState -> m ()
forall {m :: * -> *}.
(MonadIO m, MonadTerminal m) =>
MutagenState -> m ()
printStats MutagenState
st'
      DebugMode -> Result -> m ()
stopOnDebugMode (MutagenState -> DebugMode
stDebug MutagenState
st') Result
result
      MutagenState -> Args -> m Report
forall {m :: * -> *}.
(MonadTerminal m, MonadIO m) =>
MutagenState -> Args -> m Report
stopOrKeepGoing MutagenState
st' Args
args
    -- Stop execution if in debug mode
    stopOnDebugMode :: DebugMode -> Result -> m ()
stopOnDebugMode DebugMode
debugMode Result
res =
      case DebugMode
debugMode of
        DebugMode
StopOnPassed | Result
Passed <- Result
res -> m ()
awaitForUserInput
        DebugMode
AlwaysStop -> m ()
awaitForUserInput
        DebugMode
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    awaitForUserInput :: m ()
awaitForUserInput = do
      String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Press enter to continue ..."
      m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getLine)
    -- Print global statistics depending on the verbosity
    printStats :: MutagenState -> m ()
printStats MutagenState
st
      | MutagenState -> Bool
stChatty MutagenState
st = MutagenState -> m ()
forall {m :: * -> *}.
(MonadIO m, MonadTerminal m) =>
MutagenState -> m ()
printGlobalStats MutagenState
st
      | Bool
otherwise = MutagenState -> m ()
forall (m :: * -> *). MonadTerminal m => MutagenState -> m ()
printShortStats MutagenState
st
    -- Stop or continue after a failed test case
    stopOrKeepGoing :: MutagenState -> Args -> m Report
stopOrKeepGoing MutagenState
st Args
args
      -- Check if we should keep going
      | MutagenState -> Bool
stKeepGoing MutagenState
st = do
          String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message
            (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Failed "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (MutagenState -> Int
stNumFailed MutagenState
st)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" times, keeping going..."
          MutagenState -> m Report
forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
loop MutagenState
st
      -- Check if this was an expected failure and mask the report as success
      | Bool -> Bool
not (MutagenState -> Bool
stExpect MutagenState
st) =
          MutagenState -> m Report
forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
success MutagenState
st
      -- Otherwise, report the counterexample
      | Bool
otherwise =
          MutagenState -> Args -> m Report
forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> Args -> m Report
counterexample MutagenState
st Args
args

-- | Report a found counterexample.
reportCounterexample
  :: (MonadMutagen m)
  => MutagenState
  -> Args
  -> Result
  -> m ()
reportCounterexample :: forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> Args -> Result -> m ()
reportCounterexample MutagenState
st Args
args Result
result = do
  String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Found counterexample!"
  Args -> m ()
forall a. Show a => a -> m ()
forall (m :: * -> *) a. (MonadTerminal m, Show a) => a -> m ()
pretty Args
args
  String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Reason of failure:"
  case Result -> Maybe String
resultReason Result
result of
    Just String
failureReason -> String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
failureReason
    Maybe String
Nothing -> String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"assertion failed"
  case Result -> Maybe AnException
resultException Result
result of
    Just AnException
exc -> do
      String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"The exception was:"
      String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message (AnException -> String
forall a. Show a => a -> String
show AnException
exc)
    Maybe AnException
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  case MutagenState -> Maybe String
nextCounterexamplePath MutagenState
st of
    Just String
path -> do
      String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Saving counterexample to: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
path (Args -> String
forall a. Show a => a -> String
show Args
args)
    Maybe String
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- * Terminal states

-- | All tests passed successfully.
success :: (MonadMutagen m) => MutagenState -> m Report
success :: forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
success MutagenState
st = do
  String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Done testing"
  Report -> m Report
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    Success
      { numPassed :: Int
numPassed = MutagenState -> Int
stNumPassed MutagenState
st
      , numDiscarded :: Int
numDiscarded = MutagenState -> Int
stNumDiscarded MutagenState
st
      , numFailed :: Int
numFailed = MutagenState -> Int
stNumFailed MutagenState
st
      }

-- | Found a counterexample!
counterexample :: (MonadMutagen m) => MutagenState -> Args -> m Report
counterexample :: forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> Args -> m Report
counterexample MutagenState
st Args
args = do
  String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message
    (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Property falsified after "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (MutagenState -> Int
stNumPassed MutagenState
st)
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" passed tests and "
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (MutagenState -> Int
stNumDiscarded MutagenState
st)
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" discarded tests."
  Report -> m Report
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    Counterexample
      { numPassed :: Int
numPassed = MutagenState -> Int
stNumPassed MutagenState
st
      , numDiscarded :: Int
numDiscarded = MutagenState -> Int
stNumDiscarded MutagenState
st
      , failingArgs :: Args
failingArgs = Args
args
      }

-- | Too many discarded tests.
giveUp :: (MonadMutagen m) => MutagenState -> String -> m Report
giveUp :: forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> String -> m Report
giveUp MutagenState
st String
gaveUpReason = do
  String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Gave up: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
gaveUpReason
  Report -> m Report
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    GaveUp
      { reason :: String
reason = String
gaveUpReason
      , numPassed :: Int
numPassed = MutagenState -> Int
stNumPassed MutagenState
st
      , numDiscarded :: Int
numDiscarded = MutagenState -> Int
stNumDiscarded MutagenState
st
      }

-- | Expected failure did not occur.
noExpectedFailure :: (MonadMutagen m) => MutagenState -> m Report
noExpectedFailure :: forall (m :: * -> *). MonadMutagen m => MutagenState -> m Report
noExpectedFailure MutagenState
st = do
  String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Expected failure did not occur!"
  Report -> m Report
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    NoExpectedFailure
      { numPassed :: Int
numPassed = MutagenState -> Int
stNumPassed MutagenState
st
      , numDiscarded :: Int
numDiscarded = MutagenState -> Int
stNumDiscarded MutagenState
st
      }

-- ** Running tests

-- Select a new test, mutating and existing interesting one or generating a
-- brand new otherwise.
pickNextTestCase
  :: (MonadMutagen m)
  => MutagenState
  -> m (Args, Maybe (MutationBatch Args), MutagenState)
pickNextTestCase :: forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
pickNextTestCase MutagenState
st
  -- We can run a mutation of an interesting succesful test case
  | MutationQueue -> Int
mutationQueueSize (MutagenState -> MutationQueue
stPassedQueue MutagenState
st) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
mutateFromPassed MutagenState
st
  -- We can run a mutation of an interesting discarded test case
  | MutationQueue -> Int
mutationQueueSize (MutagenState -> MutationQueue
stDiscardedQueue MutagenState
st) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
mutateFromDiscarded MutagenState
st
  -- Only choice left is to generate a brand new test
  | Bool
otherwise = MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
generateNewTest MutagenState
st

-- | Generate a brand new test case.
generateNewTest
  :: (MonadMutagen m)
  => MutagenState
  -> m (Args, Maybe (MutationBatch Args), MutagenState)
generateNewTest :: forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
generateNewTest MutagenState
st = do
  -- First we compute an appropriate generation size
  let size :: Int
size = MutagenState -> Int
computeSize MutagenState
st
  -- Then we randomly generate a lazily evaluated test
  let (QCGen
rnd1, QCGen
rnd2) = QCGen -> (QCGen, QCGen)
forall g. RandomGen g => g -> (g, g)
split (MutagenState -> QCGen
stNextSeed MutagenState
st)
  let args :: Args
args = Gen Args -> QCGen -> Int -> Args
forall a. Gen a -> QCGen -> Int -> a
unGen (MutagenState -> Gen Args
stArgsGen MutagenState
st) QCGen
rnd1 Int
size
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MutagenState -> Bool
stChatty MutagenState
st) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Generated test case"
    Args -> m ()
forall a. Show a => a -> m ()
forall (m :: * -> *) a. (MonadTerminal m, Show a) => a -> m ()
pretty Args
args
  -- Put the new random seed in the state
  let st' :: MutagenState
st' =
        MutagenState
st
          MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& QCGen -> MutagenState -> MutagenState
setNextSeed QCGen
rnd2
          MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& Int -> MutagenState -> MutagenState
setCurrentGenSize Int
size
          MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutagenState -> MutagenState
incNumGenerated
  (Args, Maybe (MutationBatch Args), MutagenState)
-> m (Args, Maybe (MutationBatch Args), MutagenState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Args
args, Maybe (MutationBatch Args)
forall a. Maybe a
Nothing, MutagenState
st')

-- | Mutate a test case from the passed queue.
mutateFromPassed
  :: (MonadMutagen m)
  => MutagenState
  -> m (Args, Maybe (MutationBatch Args), MutagenState)
mutateFromPassed :: forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
mutateFromPassed MutagenState
st = do
  let (Int
prio, MutationCandidate Args
candidate, MutationQueue
rest) = MutationQueue -> (Int, MutationCandidate Args, MutationQueue)
dequeueNextMutationCandidate (MutagenState -> MutationQueue
stPassedQueue MutagenState
st)
  next <- IO (Maybe (Args, MutantKind, MutationBatch Args))
-> m (Maybe (Args, MutantKind, MutationBatch Args))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Args, MutantKind, MutationBatch Args))
 -> m (Maybe (Args, MutantKind, MutationBatch Args)))
-> IO (Maybe (Args, MutantKind, MutationBatch Args))
-> m (Maybe (Args, MutantKind, MutationBatch Args))
forall a b. (a -> b) -> a -> b
$ FragmentStore
-> MutationBatch Args
-> IO (Maybe (Args, MutantKind, MutationBatch Args))
forall a.
Mutable a =>
FragmentStore
-> MutationBatch a -> IO (Maybe (a, MutantKind, MutationBatch a))
nextMutation (MutagenState -> FragmentStore
stFragmentStore MutagenState
st) (MutationCandidate Args -> MutationBatch Args
forall args. MutationCandidate args -> MutationBatch args
mcBatch MutationCandidate Args
candidate)
  case next of
    Maybe (Args, MutantKind, MutationBatch Args)
Nothing -> do
      let st' :: MutagenState
st' = MutagenState
st MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutationQueue -> MutagenState -> MutagenState
setPassedQueue MutationQueue
rest
      MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
pickNextTestCase MutagenState
st'
    Just (Args
args, MutantKind
kind, MutationBatch Args
batch) -> do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MutagenState -> Bool
stChatty MutagenState
st) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Mutating from passed test case:"
        Args -> m ()
forall a. Show a => a -> m ()
forall (m :: * -> *) a. (MonadTerminal m, Show a) => a -> m ()
pretty (MutationCandidate Args -> Args
forall args. MutationCandidate args -> args
mcArgs MutationCandidate Args
candidate)
        String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Mutated test case:"
        Args -> m ()
forall a. Show a => a -> m ()
forall (m :: * -> *) a. (MonadTerminal m, Show a) => a -> m ()
pretty Args
args
        MutationBatch Args -> m ()
forall (m :: * -> *). MonadTerminal m => MutationBatch Args -> m ()
printBatchStatus MutationBatch Args
batch
      let st' :: MutagenState
st' =
            MutagenState
st
              MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutationQueue -> MutagenState -> MutagenState
setPassedQueue
                (Int -> MutationCandidate Args -> MutationQueue -> MutationQueue
enqueueMutationCandidate Int
prio MutationCandidate Args
candidate{mcBatch = batch} MutationQueue
rest)
              MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutantKind -> MutagenState -> MutagenState
incMutantKindCounter MutantKind
kind
              MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutagenState -> MutagenState
incNumMutatedFromPassed
      (Args, Maybe (MutationBatch Args), MutagenState)
-> m (Args, Maybe (MutationBatch Args), MutagenState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Args
args, MutationBatch Args -> Maybe (MutationBatch Args)
forall a. a -> Maybe a
Just MutationBatch Args
batch, MutagenState
st')

-- | Mutate a test case from the discarded queue.
mutateFromDiscarded
  :: (MonadMutagen m)
  => MutagenState
  -> m (Args, Maybe (MutationBatch Args), MutagenState)
mutateFromDiscarded :: forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
mutateFromDiscarded MutagenState
st = do
  let (Int
prio, MutationCandidate Args
candidate, MutationQueue
rest) = MutationQueue -> (Int, MutationCandidate Args, MutationQueue)
dequeueNextMutationCandidate (MutagenState -> MutationQueue
stDiscardedQueue MutagenState
st)
  next <- IO (Maybe (Args, MutantKind, MutationBatch Args))
-> m (Maybe (Args, MutantKind, MutationBatch Args))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Args, MutantKind, MutationBatch Args))
 -> m (Maybe (Args, MutantKind, MutationBatch Args)))
-> IO (Maybe (Args, MutantKind, MutationBatch Args))
-> m (Maybe (Args, MutantKind, MutationBatch Args))
forall a b. (a -> b) -> a -> b
$ FragmentStore
-> MutationBatch Args
-> IO (Maybe (Args, MutantKind, MutationBatch Args))
forall a.
Mutable a =>
FragmentStore
-> MutationBatch a -> IO (Maybe (a, MutantKind, MutationBatch a))
nextMutation (MutagenState -> FragmentStore
stFragmentStore MutagenState
st) (MutationCandidate Args -> MutationBatch Args
forall args. MutationCandidate args -> MutationBatch args
mcBatch MutationCandidate Args
candidate)
  case next of
    Maybe (Args, MutantKind, MutationBatch Args)
Nothing -> do
      let st' :: MutagenState
st' = MutagenState
st MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutationQueue -> MutagenState -> MutagenState
setDiscardedQueue MutationQueue
rest
      MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
forall (m :: * -> *).
MonadMutagen m =>
MutagenState -> m (Args, Maybe (MutationBatch Args), MutagenState)
pickNextTestCase MutagenState
st'
    Just (Args
args, MutantKind
kind, MutationBatch Args
batch) -> do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MutagenState -> Bool
stChatty MutagenState
st) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Mutating from discarded test case:"
        Args -> m ()
forall a. Show a => a -> m ()
forall (m :: * -> *) a. (MonadTerminal m, Show a) => a -> m ()
pretty (MutationCandidate Args -> Args
forall args. MutationCandidate args -> args
mcArgs MutationCandidate Args
candidate)
        String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Mutated test case:"
        Args -> m ()
forall a. Show a => a -> m ()
forall (m :: * -> *) a. (MonadTerminal m, Show a) => a -> m ()
pretty Args
args
        MutationBatch Args -> m ()
forall (m :: * -> *). MonadTerminal m => MutationBatch Args -> m ()
printBatchStatus MutationBatch Args
batch
      let st' :: MutagenState
st' =
            MutagenState
st
              MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutationQueue -> MutagenState -> MutagenState
setDiscardedQueue
                (Int -> MutationCandidate Args -> MutationQueue -> MutationQueue
enqueueMutationCandidate Int
prio MutationCandidate Args
candidate{mcBatch = batch} MutationQueue
rest)
              MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutantKind -> MutagenState -> MutagenState
incMutantKindCounter MutantKind
kind
              MutagenState -> (MutagenState -> MutagenState) -> MutagenState
forall a b. a -> (a -> b) -> b
& MutagenState -> MutagenState
incNumMutatedFromDiscarded
      (Args, Maybe (MutationBatch Args), MutagenState)
-> m (Args, Maybe (MutationBatch Args), MutagenState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Args
args, MutationBatch Args -> Maybe (MutationBatch Args)
forall a. a -> Maybe a
Just MutationBatch Args
batch, MutagenState
st')

-- | Run a test case and update the internal state accordingly.
runTestCase
  :: (MonadMutagen m)
  => Args
  -- ^ Test case
  -> Maybe (MutationBatch Args)
  -- ^ Parent mutation batch
  -> MutagenState
  -- ^ Current state
  -> m (Result, MutagenState)
runTestCase :: forall (m :: * -> *).
MonadMutagen m =>
Args
-> Maybe (MutationBatch Args)
-> MutagenState
-> m (Result, MutagenState)
runTestCase Args
args Maybe (MutationBatch Args)
parent MutagenState
st = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MutagenState -> Bool
stChatty MutagenState
st) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Running test case..."
  -- Run the test case
  (result, trace, evaluatedPos) <- IO (Result, Trace, Maybe [Pos]) -> m (Result, Trace, Maybe [Pos])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result, Trace, Maybe [Pos]) -> m (Result, Trace, Maybe [Pos]))
-> IO (Result, Trace, Maybe [Pos])
-> m (Result, Trace, Maybe [Pos])
forall a b. (a -> b) -> a -> b
$ MutagenState -> Args -> IO (Result, Trace, Maybe [Pos])
execPropRunner MutagenState
st Args
args
  when (stChatty st) $ do
    case evaluatedPos of
      Just [Pos]
pos -> do
        String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Evaluated subexpressions:"
        [Pos] -> m ()
forall a. Show a => a -> m ()
forall (m :: * -> *) a. (MonadTerminal m, Show a) => a -> m ()
pretty [Pos]
pos
      Maybe [Pos]
Nothing -> do
        () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- lazy prunning is disabled
        -- Print the trace of the mutated test case
    message "Test case trace:"
    pretty (unTrace trace)
  -- Extract property modifiers
  let addPropertyModifiers =
        Bool -> MutagenState -> MutagenState
setExpect (Result -> Bool
resultExpect Result
result)
  -- Inspect the test result
  case result of
    -- Boom!
    Result
Failed -> do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MutagenState -> Bool
stChatty MutagenState
st) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Test result: FAILED"
      -- Report the counterexample
      (Result, MutagenState) -> m (Result, MutagenState)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( Result
result
        , MutagenState -> MutagenState
addPropertyModifiers MutagenState
st
        )
    -- Test passed, lotta work to do now
    Result
Passed -> do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MutagenState -> Bool
stChatty MutagenState
st) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Test result: PASSED"
      -- Save the trace in the corresponding trace store
      (new, prio) <- IO (Int, Int) -> m (Int, Int)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MutagenState -> Trace -> IO (Int, Int)
savePassedTraceWithPrio MutagenState
st Trace
trace)
      -- Evaluate whether the test case was interesting or not depending on
      -- whether it added new trace nodes or not
      let interesting = Int
new Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      -- From here, we will update the internal state for the next iteration
      -- depending on whether the test case was interesting or not
      st' <-
        if interesting
          then do
            when (stChatty st) $ do
              message "Test case was interesting!"
            let candidate = Trace -> Maybe [Pos] -> Bool -> MutationCandidate Args
createMutationCandidate Trace
trace Maybe [Pos]
evaluatedPos Bool
True
            return
              $ st
                & storeFragmentsIfStoreIsEnabled args
                & enqueuePassedCandidate prio candidate
                & incNumInteresting
                & resetNumTestsSinceLastInteresting
          else do
            return
              $ st
                & incNumBoring
                & incNumTestsSinceLastInteresting
      -- Finally, return the updated state and apply other updates
      return
        ( result
        , st'
            & addPropertyModifiers
            & incNumPassed
        )
    -- Test discarded, lotta work to do here too
    Result
Discarded -> do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MutagenState -> Bool
stChatty MutagenState
st) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        String -> m ()
forall (m :: * -> *). MonadTerminal m => String -> m ()
message String
"Test result: DISCARDED"
      -- Save the trace in the corresponding trace log
      (new, prio) <- IO (Int, Int) -> m (Int, Int)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MutagenState -> Trace -> IO (Int, Int)
saveDiscardedTraceWithPrio MutagenState
st Trace
trace)
      -- Evaluate whether the test case was interesting or not
      --
      -- NOTE: in this case, we only consider discarded test cases interesting
      -- if its parent test case, i.e., the one it was mutated from, also
      -- passed the property and was not discarded.
      let interesting = Int
new Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool
-> (MutationBatch Args -> Bool)
-> Maybe (MutationBatch Args)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False MutationBatch Args -> Bool
forall args. MutationBatch args -> Bool
mbTestPassed Maybe (MutationBatch Args)
parent
      when (stChatty st && interesting) $ do
        message "Test case was interesting!"
      -- As above, here we also update the internal state depending on whether
      -- the test case was interesting or not
      st' <-
        if interesting
          then do
            let candidate = Trace -> Maybe [Pos] -> Bool -> MutationCandidate Args
createMutationCandidate Trace
trace Maybe [Pos]
evaluatedPos Bool
False
            return
              $ st
                & storeFragmentsIfStoreIsEnabled args
                & enqueueDiscardedCandidate prio candidate
                & incNumInteresting
                & resetNumTestsSinceLastInteresting
          else do
            return
              $ st
                & incNumBoring
                & incNumTestsSinceLastInteresting
      -- Finally, return the updated state and apply other updates
      return
        ( result
        , st'
            & addPropertyModifiers
            & incNumDiscarded
        )
  where
    -- Create a mutation candidate from extracted runtime data
    createMutationCandidate :: Trace -> Maybe [Pos] -> Bool -> MutationCandidate Args
createMutationCandidate Trace
trace Maybe [Pos]
evaluatedPos Bool
isPassed =
      Args -> Trace -> MutationBatch Args -> MutationCandidate Args
forall args.
args -> Trace -> MutationBatch args -> MutationCandidate args
MutationCandidate
        Args
args
        Trace
trace
        ( MutationOrder
-> Int
-> Int
-> Int
-> Int
-> Args
-> Maybe (MutationBatch Args)
-> Maybe [Pos]
-> Bool
-> MutationBatch Args
createOrInheritMutationBatch
            (MutagenState -> MutationOrder
stMutationOrder MutagenState
st)
            (MutagenState -> Int
stRandomMutations MutagenState
st)
            (MutagenState -> Int
stMaxGenSize MutagenState
st)
            (MutagenState -> Int
stRandomFragments MutagenState
st)
            (MutagenState -> Int
stMaxMutationDepth MutagenState
st)
            Args
args
            Maybe (MutationBatch Args)
parent
            Maybe [Pos]
evaluatedPos
            Bool
isPassed
        )
    -- Enqueue a candidate into the passed queue
    enqueuePassedCandidate :: Int -> MutationCandidate Args -> MutagenState -> MutagenState
enqueuePassedCandidate Int
prio MutationCandidate Args
candidate =
      (MutationQueue -> MutationQueue) -> MutagenState -> MutagenState
updatePassedQueue
        ( Int -> MutationCandidate Args -> MutationQueue -> MutationQueue
enqueueMutationCandidate
            Int
prio
            MutationCandidate Args
candidate
        )
    -- Enqueue a candidate into the discarded queue
    enqueueDiscardedCandidate :: Int -> MutationCandidate Args -> MutagenState -> MutagenState
enqueueDiscardedCandidate Int
prio MutationCandidate Args
candidate =
      (MutationQueue -> MutationQueue) -> MutagenState -> MutagenState
updatePassedQueue
        ( Int -> MutationCandidate Args -> MutationQueue -> MutationQueue
enqueueMutationCandidate
            Int
prio
            MutationCandidate Args
candidate
        )
    -- Store fragments if the fragment store is enabled
    storeFragmentsIfStoreIsEnabled :: a -> MutagenState -> MutagenState
storeFragmentsIfStoreIsEnabled a
args' MutagenState
st'
      | MutagenState -> Bool
stUseFragments MutagenState
st' =
          (FragmentStore -> FragmentStore) -> MutagenState -> MutagenState
updateFragmentStore
            (FragmentTypeFilter -> a -> FragmentStore -> FragmentStore
forall a.
Fragmentable a =>
FragmentTypeFilter -> a -> FragmentStore -> FragmentStore
storeFragments (MutagenState -> FragmentTypeFilter
stFilterFragments MutagenState
st') a
args')
            MutagenState
st'
      | Bool
otherwise =
          MutagenState
st'

-- ** IO helpers

-- | Execute a test and capture:
--   * The test result (passed, discarded, failed)
--   * The (possibly truncated) execution trace in the program it traversed
--   * The positions of the evaluated subexpressions of the input, in the order
--     that they need to be mutated (only when lazy pruning is enabled).
execPropRunner :: MutagenState -> Args -> IO (Result, Trace, Maybe [Pos])
execPropRunner :: MutagenState -> Args -> IO (Result, Trace, Maybe [Pos])
execPropRunner MutagenState
st Args
args
  | LazyPruning EvaluationOrder
order <- MutagenState -> LazyPruningMode
stLazyPruning MutagenState
st = do
      (evaluated, (result, trace)) <- (Args -> IO (Result, Trace)) -> Args -> IO ([Pos], (Result, Trace))
forall a b. Lazy a => (a -> IO b) -> a -> IO ([Pos], b)
withLazyIO (IO Result -> IO (Result, Trace)
forall a. IO a -> IO (a, Trace)
withTrace (IO Result -> IO (Result, Trace))
-> (Args -> IO Result) -> Args -> IO (Result, Trace)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> IO Result
runProp) Args
args
      return
        ( result
        , truncateTraceIfNeeded trace
        , Just (withMutationOrder order evaluated)
        )
  | Bool
otherwise = do
      (result, trace) <- IO Result -> IO (Result, Trace)
forall a. IO a -> IO (a, Trace)
withTrace (Args -> IO Result
runProp Args
args)
      return
        ( result
        , truncateTraceIfNeeded trace
        , Nothing
        )
  where
    runProp :: Args -> IO Result
runProp = Prop -> IO Result
unProp (Prop -> IO Result) -> (Args -> Prop) -> Args -> IO Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prop -> Prop
protectProp (Prop -> Prop) -> (Args -> Prop) -> Args -> Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutagenState -> Args -> Prop
stPropRunner MutagenState
st
    withMutationOrder :: EvaluationOrder -> [a] -> [a]
withMutationOrder EvaluationOrder
order =
      case EvaluationOrder
order of
        EvaluationOrder
Forward -> [a] -> [a]
forall a. a -> a
id
        EvaluationOrder
Backward -> [a] -> [a]
forall a. [a] -> [a]
reverse
    truncateTraceIfNeeded :: Trace -> Trace
truncateTraceIfNeeded Trace
trace =
      Trace -> (Int -> Trace) -> Maybe Int -> Trace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Trace
trace ((Int -> Trace -> Trace) -> Trace -> Int -> Trace
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Trace -> Trace
truncateTrace Trace
trace) (MutagenState -> Maybe Int
stMaxTraceLength MutagenState
st)

-- | Save a discarded trace and return the number of new nodes added and its
-- the priority associated to its corresponding test case.
savePassedTraceWithPrio :: MutagenState -> Trace -> IO (Int, Int)
savePassedTraceWithPrio :: MutagenState -> Trace -> IO (Int, Int)
savePassedTraceWithPrio MutagenState
st Trace
tr =
  case MutagenState
st of
    MutagenState{stTraceBackend :: ()
stTraceBackend = STraceBackend trace
SBitmap, stPassedTraceStore :: ()
stPassedTraceStore = TraceStore trace
store} -> do
      new <- Trace -> TraceStore trace -> IO (SaveTraceResult trace)
forall (trace :: TraceBackend).
TraceStoreImpl trace =>
Trace -> TraceStore trace -> IO (SaveTraceResult trace)
saveTrace Trace
tr TraceStore trace
store
      let prio = MutagenState -> Int
stNumTracingNodes MutagenState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
new
      return (new, prio)
    MutagenState{stTraceBackend :: ()
stTraceBackend = STraceBackend trace
STree, stPassedTraceStore :: ()
stPassedTraceStore = TraceStore trace
store} -> do
      (new, depth) <- Trace -> TraceStore trace -> IO (SaveTraceResult trace)
forall (trace :: TraceBackend).
TraceStoreImpl trace =>
Trace -> TraceStore trace -> IO (SaveTraceResult trace)
saveTrace Trace
tr TraceStore trace
store
      let prio = Int
depth
      return (new, prio)

-- | Save a discarded trace and return the number of new nodes added and its
-- the priority associated to its corresponding test case.
saveDiscardedTraceWithPrio :: MutagenState -> Trace -> IO (Int, Int)
saveDiscardedTraceWithPrio :: MutagenState -> Trace -> IO (Int, Int)
saveDiscardedTraceWithPrio MutagenState
st Trace
tr =
  case MutagenState
st of
    MutagenState{stTraceBackend :: ()
stTraceBackend = STraceBackend trace
SBitmap, stDiscardedTraceStore :: ()
stDiscardedTraceStore = TraceStore trace
store} -> do
      new <- Trace -> TraceStore trace -> IO (SaveTraceResult trace)
forall (trace :: TraceBackend).
TraceStoreImpl trace =>
Trace -> TraceStore trace -> IO (SaveTraceResult trace)
saveTrace Trace
tr TraceStore trace
store
      let prio = MutagenState -> Int
stNumTracingNodes MutagenState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
new
      return (new, prio)
    MutagenState{stTraceBackend :: ()
stTraceBackend = STraceBackend trace
STree, stDiscardedTraceStore :: ()
stDiscardedTraceStore = TraceStore trace
store} -> do
      (new, depth) <- Trace -> TraceStore trace -> IO (SaveTraceResult trace)
forall (trace :: TraceBackend).
TraceStoreImpl trace =>
Trace -> TraceStore trace -> IO (SaveTraceResult trace)
saveTrace Trace
tr TraceStore trace
store
      let prio = Int
depth
      return (new, prio)

-- | Run a computation using the passed trace store.
withPassedTraceStore
  :: MutagenState
  -> (forall trace. (TraceStoreImpl trace) => TraceStore trace -> r)
  -> r
withPassedTraceStore :: forall r.
MutagenState
-> (forall (trace :: TraceBackend).
    TraceStoreImpl trace =>
    TraceStore trace -> r)
-> r
withPassedTraceStore MutagenState
st forall (trace :: TraceBackend).
TraceStoreImpl trace =>
TraceStore trace -> r
k =
  case MutagenState
st of MutagenState{stPassedTraceStore :: ()
stPassedTraceStore = TraceStore trace
store} -> TraceStore trace -> r
forall (trace :: TraceBackend).
TraceStoreImpl trace =>
TraceStore trace -> r
k TraceStore trace
store

-- | Run a computation using the discarded trace store.
withDiscardedTraceStore
  :: MutagenState
  -> (forall trace. (TraceStoreImpl trace) => TraceStore trace -> r)
  -> r
withDiscardedTraceStore :: forall r.
MutagenState
-> (forall (trace :: TraceBackend).
    TraceStoreImpl trace =>
    TraceStore trace -> r)
-> r
withDiscardedTraceStore MutagenState
st forall (trace :: TraceBackend).
TraceStoreImpl trace =>
TraceStore trace -> r
k =
  case MutagenState
st of MutagenState{stDiscardedTraceStore :: ()
stDiscardedTraceStore = TraceStore trace
store} -> TraceStore trace -> r
forall (trace :: TraceBackend).
TraceStoreImpl trace =>
TraceStore trace -> r
k TraceStore trace
store