{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Internal Mutagen testing state and state manipulation functions.
module Test.Mutagen.Test.State
  ( -- * Mutagen internal state
    MutagenState (..)
  , initMutagenState

    -- * State modifiers
  , setExpect
  , setNextSeed
  , setCurrentGenSize
  , setAutoResetAfter
  , setRandomMutations
  , setPassedQueue
  , updatePassedQueue
  , setDiscardedQueue
  , updateDiscardedQueue
  , setFragmentStore
  , updateFragmentStore
  , incNumTraceStoreResets
  , incNumPassed
  , incNumDiscarded
  , incNumFailed
  , incNumGenerated
  , incNumMutatedFromPassed
  , incNumMutatedFromDiscarded
  , incNumInteresting
  , incNumBoring
  , incNumTestsSinceLastInteresting
  , incMutantKindCounter
  , resetNumTestsSinceLastInteresting

    -- * State-related utilities
  , timedOut
  , computeSize
  , nextCounterexamplePath
  )
where

import Data.List (elemIndex)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import System.FilePath ((<.>))
import Test.Mutagen.Config
  ( Config (..)
  , DebugMode (..)
  , LazyPruningMode (..)
  )
import Test.Mutagen.Fragment.Store
  ( FragmentStore
  , FragmentTypeFilter
  , emptyFragmentStore
  , storeFragments
  )
import Test.Mutagen.Mutant (MutantKind (..))
import Test.Mutagen.Mutation (MutationOrder)
import Test.Mutagen.Property (Args (..), Prop, Property (..))
import Test.Mutagen.Test.Queue (MutationQueue, emptyMutationQueue)
import Test.Mutagen.Tracer.Metadata (loadTracerMetadata, numTracingNodes)
import Test.Mutagen.Tracer.Store
  ( STraceBackend
  , TraceStoreImpl (..)
  , withTraceBackend
  )
import Test.QuickCheck.Gen (Gen)
import Test.QuickCheck.Random (QCGen, newQCGen)

{-------------------------------------------------------------------------------
-- * Mutagen internal state
-------------------------------------------------------------------------------}

-- | Internal testing state.
data MutagenState
  = forall trace.
  (TraceStoreImpl trace) =>
  MutagenState
  { MutagenState -> Int
stMaxSuccess :: !Int
  -- ^ Mirrored from 'Config.maxSuccess'
  , MutagenState -> Int
stMaxDiscardRatio :: !Int
  -- ^ Mirrored from 'Config.maxDiscardRatio'
  , MutagenState -> Maybe Integer
stTimeout :: !(Maybe Integer)
  -- ^ Mirrored from 'Config.timeout'
  , MutagenState -> Bool
stExpect :: Bool
  -- ^ Mirrored from 'Config.expect'
  , MutagenState -> Int
stMaxGenSize :: !Int
  -- ^ Mirrored from 'Config.maxGenSize'
  , MutagenState -> Int
stRandomMutations :: !Int
  -- ^ Mirrored from 'Config.randomMutations'
  , MutagenState -> Int
stMaxMutationDepth :: !Int
  -- ^ Mirrored from 'Config.maxMutationDepth'
  , MutagenState -> Maybe Int
stAutoResetAfter :: !(Maybe Int)
  -- ^ Mirrored from 'Config.autoResetAfter'
  , MutagenState -> LazyPruningMode
stLazyPruning :: !(LazyPruningMode)
  -- ^ Mirrored from 'Config.lazyPruning'
  , MutagenState -> MutationOrder
stMutationOrder :: !MutationOrder
  -- ^ Mirrored from 'Config.mutationOrder'
  , MutagenState -> Int
stRandomFragments :: !Int
  -- ^ Mirrored from 'Config.randomFragments'
  , MutagenState -> Bool
stUseFragments :: !Bool
  -- ^ Mirrored from 'Config.useFragments'
  , MutagenState -> FragmentTypeFilter
stFilterFragments :: !FragmentTypeFilter
  -- ^ Mirrored from 'Config.filterFragments'
  , MutagenState -> Maybe Int
stMaxTraceLength :: !(Maybe Int)
  -- ^ Mirrored from 'Config.maxTraceLength'
  , MutagenState -> Bool
stKeepGoing :: !Bool
  -- ^ Mirrored from 'Config.keepGoing'
  , MutagenState -> Maybe FilePath
stSaveCounterexamples :: !(Maybe FilePath)
  -- ^ Mirrored from 'Config.saveCounterexamples'
  , MutagenState -> Bool
stChatty :: !Bool
  -- ^ Mirrored from 'Config.chatty'
  , MutagenState -> DebugMode
stDebug :: !DebugMode
  -- ^ Mirrored from 'Config.debug'
  , MutagenState -> Bool
stTui :: !Bool
  -- ^ Mirrored from 'Config.tui'
  , MutagenState -> QCGen
stNextSeed :: !QCGen
  -- ^ Next seed to be when generating random values
  , MutagenState -> Gen Args
stArgsGen :: !(Gen Args)
  -- ^ Random generator for test case inputs
  , MutagenState -> Args -> Prop
stPropRunner :: !(Args -> Prop)
  -- ^ Test case runner
  , MutagenState -> Int
stNumTracingNodes :: !Int
  -- ^ Number of trace nodes generated by the tracer plugin
  , ()
stTraceBackend :: !(STraceBackend trace)
  -- ^ Tracing type being used
  , ()
stPassedTraceStore :: !(TraceStore trace)
  -- ^ Trace store for passed test cases
  , ()
stDiscardedTraceStore :: !(TraceStore trace)
  -- ^ Trace store for discarded test cases
  , MutagenState -> MutationQueue
stPassedQueue :: !MutationQueue
  -- ^ Mutation queue derived from passed test cases
  , MutagenState -> MutationQueue
stDiscardedQueue :: !MutationQueue
  -- ^ Mutation queue derived from discarded test cases
  , MutagenState -> FragmentStore
stFragmentStore :: !FragmentStore
  -- ^ Stored fragments for fragment-based mutation
  , MutagenState -> POSIXTime
stStartTime :: !POSIXTime
  -- ^ Timestamp when testing started
  , MutagenState -> Int
stCurrentGenSize :: !Int
  -- ^ Size of the current randomly generated test case
  , MutagenState -> Int
stNumGenerated :: !Int
  -- ^ Number of generated test cases
  , MutagenState -> Int
stNumMutatedFromPassed :: !Int
  -- ^ Number of test cases mutated from passed test cases
  , MutagenState -> Int
stNumMutatedFromDiscarded :: !Int
  -- ^ Number of test cases mutated from discarded test cases
  , MutagenState -> Int
stNumPureMutants :: !Int
  -- ^ Number of pure mutants generated
  , MutagenState -> Int
stNumRandMutants :: !Int
  -- ^ Number of random mutants generated
  , MutagenState -> Int
stNumFragMutants :: !Int
  -- ^ Number of fragment mutants generated
  , MutagenState -> Int
stNumPassed :: !Int
  -- ^ Number of passed test cases
  , MutagenState -> Int
stNumDiscarded :: !Int
  -- ^ Number of discarded test cases
  , MutagenState -> Int
stNumFailed :: !Int
  -- ^ Number of failed test cases (only useful when 'keepGoing' is enabled)
  , MutagenState -> Int
stNumInteresting :: !Int
  -- ^ Number of interesting test cases
  , MutagenState -> Int
stNumBoring :: !Int
  -- ^ Number of boring test cases
  , MutagenState -> Int
stNumTestsSinceLastInteresting :: !Int
  -- ^ Number of test cases since the last interesting one
  , MutagenState -> Int
stNumTraceStoreResets :: !Int
  -- ^ Number of times the trace store have been reset
  }

-- | Initialize the internal state.
initMutagenState :: Config -> Property -> IO MutagenState
initMutagenState :: Config -> Property -> IO MutagenState
initMutagenState Config
cfg (Property Gen Args
gen Args -> Prop
runner) = do
  -- Start timestamp
  now <- IO POSIXTime
getPOSIXTime
  -- Initialize random generator
  rng <- newQCGen
  -- Load the metadata generated
  tracingNodes <- numTracingNodes <$> loadTracerMetadata
  -- If enabled, initialize the fragment store using the provided examples
  let fragmentStore
        | Config -> Bool
useFragments Config
cfg = [Args] -> FragmentStore
fragmentStoreFromExamples (Config -> [Args]
examples Config
cfg)
        | Bool
otherwise = FragmentStore
emptyFragmentStore
  -- Reify the selected trace store implementation
  withTraceBackend (traceBackend cfg) $ \(STraceBackend trace
backend :: STraceBackend trace) -> do
    -- Initialize empty trace stores for passed and discarded test cases
    passedTraceStore <- forall (trace :: TraceBackend).
TraceStoreImpl trace =>
Int -> IO (TraceStore trace)
newTraceStore @trace Int
tracingNodes
    discardedTraceStore <- newTraceStore @trace tracingNodes
    -- Put it all together
    return
      MutagenState
        { -- From config
          stMaxSuccess = maxSuccess cfg
        , stMaxDiscardRatio = maxDiscardRatio cfg
        , stTimeout = timeout cfg
        , stExpect = expect cfg
        , stMaxGenSize = maxGenSize cfg
        , stRandomMutations = randomMutations cfg
        , stRandomFragments = randomFragments cfg
        , stMaxMutationDepth = maybe (maxGenSize cfg) id (maxMutationDepth cfg)
        , stAutoResetAfter = autoResetAfter cfg
        , stLazyPruning = lazyPruning cfg
        , stMutationOrder = mutationOrder cfg
        , stUseFragments = useFragments cfg
        , stFilterFragments = filterFragments cfg
        , stMaxTraceLength = maxTraceLength cfg
        , stKeepGoing = keepGoing cfg
        , stSaveCounterexamples = saveCounterexamples cfg
        , stChatty = chatty cfg || debug cfg /= NoDebug
        , stDebug = debug cfg
        , stTui = tui cfg
        , -- Internal
          stNextSeed = rng
        , stArgsGen = gen
        , stPropRunner = runner
        , stNumTracingNodes = tracingNodes
        , stTraceBackend = backend
        , stPassedTraceStore = passedTraceStore
        , stDiscardedTraceStore = discardedTraceStore
        , stPassedQueue = emptyMutationQueue
        , stDiscardedQueue = emptyMutationQueue
        , stFragmentStore = fragmentStore
        , stStartTime = now
        , stCurrentGenSize = 0
        , stNumGenerated = 0
        , stNumMutatedFromPassed = 0
        , stNumMutatedFromDiscarded = 0
        , stNumPureMutants = 0
        , stNumRandMutants = 0
        , stNumFragMutants = 0
        , stNumPassed = 0
        , stNumFailed = 0
        , stNumDiscarded = 0
        , stNumInteresting = 0
        , stNumBoring = 0
        , stNumTestsSinceLastInteresting = 0
        , stNumTraceStoreResets = 0
        }
  where
    fragmentStoreFromExamples :: [Args] -> FragmentStore
fragmentStoreFromExamples =
      (Args -> FragmentStore -> FragmentStore)
-> FragmentStore -> [Args] -> FragmentStore
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (FragmentTypeFilter -> Args -> FragmentStore -> FragmentStore
forall a.
Fragmentable a =>
FragmentTypeFilter -> a -> FragmentStore -> FragmentStore
storeFragments (Config -> FragmentTypeFilter
filterFragments Config
cfg))
        FragmentStore
emptyFragmentStore

{-------------------------------------------------------------------------------
-- * State modifiers
-------------------------------------------------------------------------------}

-- ** Setters

setExpect :: Bool -> MutagenState -> MutagenState
setExpect :: Bool -> MutagenState -> MutagenState
setExpect Bool
val MutagenState
st =
  MutagenState
st{stExpect = val}

setNextSeed :: QCGen -> MutagenState -> MutagenState
setNextSeed :: QCGen -> MutagenState -> MutagenState
setNextSeed QCGen
val MutagenState
st =
  MutagenState
st{stNextSeed = val}

setCurrentGenSize :: Int -> MutagenState -> MutagenState
setCurrentGenSize :: Int -> MutagenState -> MutagenState
setCurrentGenSize Int
val MutagenState
st =
  MutagenState
st{stCurrentGenSize = val}

setAutoResetAfter :: Maybe Int -> MutagenState -> MutagenState
setAutoResetAfter :: Maybe Int -> MutagenState -> MutagenState
setAutoResetAfter Maybe Int
val MutagenState
st =
  MutagenState
st{stAutoResetAfter = val}

setRandomMutations :: Int -> MutagenState -> MutagenState
setRandomMutations :: Int -> MutagenState -> MutagenState
setRandomMutations Int
val MutagenState
st =
  MutagenState
st{stRandomMutations = val}

setPassedQueue :: MutationQueue -> MutagenState -> MutagenState
setPassedQueue :: MutationQueue -> MutagenState -> MutagenState
setPassedQueue MutationQueue
val MutagenState
st =
  MutagenState
st{stPassedQueue = val}

updatePassedQueue :: (MutationQueue -> MutationQueue) -> MutagenState -> MutagenState
updatePassedQueue :: (MutationQueue -> MutationQueue) -> MutagenState -> MutagenState
updatePassedQueue MutationQueue -> MutationQueue
f MutagenState
st =
  MutagenState
st{stPassedQueue = f (stPassedQueue st)}

setDiscardedQueue :: MutationQueue -> MutagenState -> MutagenState
setDiscardedQueue :: MutationQueue -> MutagenState -> MutagenState
setDiscardedQueue MutationQueue
val MutagenState
st =
  MutagenState
st{stDiscardedQueue = val}

updateDiscardedQueue :: (MutationQueue -> MutationQueue) -> MutagenState -> MutagenState
updateDiscardedQueue :: (MutationQueue -> MutationQueue) -> MutagenState -> MutagenState
updateDiscardedQueue MutationQueue -> MutationQueue
f MutagenState
st =
  MutagenState
st{stDiscardedQueue = f (stDiscardedQueue st)}

setFragmentStore :: FragmentStore -> MutagenState -> MutagenState
setFragmentStore :: FragmentStore -> MutagenState -> MutagenState
setFragmentStore FragmentStore
val MutagenState
st =
  MutagenState
st{stFragmentStore = val}

updateFragmentStore :: (FragmentStore -> FragmentStore) -> MutagenState -> MutagenState
updateFragmentStore :: (FragmentStore -> FragmentStore) -> MutagenState -> MutagenState
updateFragmentStore FragmentStore -> FragmentStore
f MutagenState
st =
  MutagenState
st{stFragmentStore = f (stFragmentStore st)}

-- ** Incrementers

incNumTraceStoreResets :: MutagenState -> MutagenState
incNumTraceStoreResets :: MutagenState -> MutagenState
incNumTraceStoreResets MutagenState
st =
  MutagenState
st{stNumTraceStoreResets = stNumTraceStoreResets st + 1}

incNumPassed :: MutagenState -> MutagenState
incNumPassed :: MutagenState -> MutagenState
incNumPassed MutagenState
st =
  MutagenState
st{stNumPassed = stNumPassed st + 1}

incNumDiscarded :: MutagenState -> MutagenState
incNumDiscarded :: MutagenState -> MutagenState
incNumDiscarded MutagenState
st =
  MutagenState
st{stNumDiscarded = stNumDiscarded st + 1}

incNumFailed :: MutagenState -> MutagenState
incNumFailed :: MutagenState -> MutagenState
incNumFailed MutagenState
st =
  MutagenState
st{stNumFailed = stNumFailed st + 1}

incNumGenerated :: MutagenState -> MutagenState
incNumGenerated :: MutagenState -> MutagenState
incNumGenerated MutagenState
st =
  MutagenState
st{stNumGenerated = stNumGenerated st + 1}

incNumMutatedFromPassed :: MutagenState -> MutagenState
incNumMutatedFromPassed :: MutagenState -> MutagenState
incNumMutatedFromPassed MutagenState
st =
  MutagenState
st{stNumMutatedFromPassed = stNumMutatedFromPassed st + 1}

incNumMutatedFromDiscarded :: MutagenState -> MutagenState
incNumMutatedFromDiscarded :: MutagenState -> MutagenState
incNumMutatedFromDiscarded MutagenState
st =
  MutagenState
st{stNumMutatedFromDiscarded = stNumMutatedFromDiscarded st + 1}

incNumInteresting :: MutagenState -> MutagenState
incNumInteresting :: MutagenState -> MutagenState
incNumInteresting MutagenState
st =
  MutagenState
st{stNumInteresting = stNumInteresting st + 1}

incNumBoring :: MutagenState -> MutagenState
incNumBoring :: MutagenState -> MutagenState
incNumBoring MutagenState
st =
  MutagenState
st{stNumBoring = stNumBoring st + 1}

incNumTestsSinceLastInteresting :: MutagenState -> MutagenState
incNumTestsSinceLastInteresting :: MutagenState -> MutagenState
incNumTestsSinceLastInteresting MutagenState
st =
  MutagenState
st{stNumTestsSinceLastInteresting = stNumTestsSinceLastInteresting st + 1}

incMutantKindCounter :: MutantKind -> MutagenState -> MutagenState
incMutantKindCounter :: MutantKind -> MutagenState -> MutagenState
incMutantKindCounter MutantKind
kind MutagenState
st =
  case MutantKind
kind of
    MutantKind
PureMutant -> MutagenState
st{stNumPureMutants = stNumPureMutants st + 1}
    MutantKind
RandMutant -> MutagenState
st{stNumRandMutants = stNumRandMutants st + 1}
    MutantKind
FragMutant -> MutagenState
st{stNumFragMutants = stNumFragMutants st + 1}

-- ** Resetters

resetNumTestsSinceLastInteresting :: MutagenState -> MutagenState
resetNumTestsSinceLastInteresting :: MutagenState -> MutagenState
resetNumTestsSinceLastInteresting MutagenState
st =
  MutagenState
st{stNumTestsSinceLastInteresting = 0}

{-------------------------------------------------------------------------------
-- * State-related utilities
-------------------------------------------------------------------------------}

-- | Check whether the timeout has passed.
timedOut :: MutagenState -> IO Bool
timedOut :: MutagenState -> IO Bool
timedOut MutagenState
st
  | Just Integer
s <- MutagenState -> Maybe Integer
stTimeout MutagenState
st = do
      now <- IO POSIXTime
getPOSIXTime
      return (now >= stStartTime st + (fromIntegral s))
  | Bool
otherwise = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Compute the size of the next randomly generated value.
--
-- NOTE: This function mimics QuickCheck's size computation strategy.
computeSize :: MutagenState -> Int
computeSize :: MutagenState -> Int
computeSize MutagenState
st
  | MutagenState -> Int
stNumPassed MutagenState
st Int -> Int -> Int
forall {a}. Integral a => a -> a -> a
`roundTo` MutagenState -> Int
stMaxGenSize MutagenState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MutagenState -> Int
stMaxGenSize MutagenState
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= MutagenState -> Int
stMaxSuccess MutagenState
st
      Bool -> Bool -> Bool
|| MutagenState -> Int
stNumPassed MutagenState
st Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= MutagenState -> Int
stMaxSuccess MutagenState
st
      Bool -> Bool -> Bool
|| MutagenState -> Int
stMaxSuccess MutagenState
st Int -> Int -> Int
forall {a}. Integral a => a -> a -> a
`mod` MutagenState -> Int
stMaxGenSize MutagenState
st Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
      ( MutagenState -> Int
stNumPassed MutagenState
st
          Int -> Int -> Int
forall {a}. Integral a => a -> a -> a
`mod` MutagenState -> Int
stMaxGenSize MutagenState
st
          Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MutagenState -> Int
stNumDiscarded MutagenState
st Int -> Int -> Int
forall {a}. Integral a => a -> a -> a
`div` Int
10
      )
        Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` MutagenState -> Int
stMaxGenSize MutagenState
st
  | Bool
otherwise =
      ( (MutagenState -> Int
stNumPassed MutagenState
st Int -> Int -> Int
forall {a}. Integral a => a -> a -> a
`mod` MutagenState -> Int
stMaxGenSize MutagenState
st)
          Int -> Int -> Int
forall a. Num a => a -> a -> a
* MutagenState -> Int
stMaxGenSize MutagenState
st
          Int -> Int -> Int
forall {a}. Integral a => a -> a -> a
`div` (MutagenState -> Int
stMaxSuccess MutagenState
st Int -> Int -> Int
forall {a}. Integral a => a -> a -> a
`mod` MutagenState -> Int
stMaxGenSize MutagenState
st)
          Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MutagenState -> Int
stNumDiscarded MutagenState
st Int -> Int -> Int
forall {a}. Integral a => a -> a -> a
`div` Int
10
      )
        Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` MutagenState -> Int
stMaxGenSize MutagenState
st
  where
    roundTo :: a -> a -> a
roundTo a
n a
m = (a
n a -> a -> a
forall {a}. Integral a => a -> a -> a
`div` a
m) a -> a -> a
forall a. Num a => a -> a -> a
* a
m

-- | Compute the path for the next counterexample to be saved.
--
-- If no counterexamples are to be saved, returns 'Nothing'. If a path template
-- is provided (containing @\@@), replaces @\@@ with the current failure
-- counter. Otherwise, appends the counter to the given path.
nextCounterexamplePath :: MutagenState -> Maybe FilePath
nextCounterexamplePath :: MutagenState -> Maybe FilePath
nextCounterexamplePath MutagenState
st
  | Just FilePath
path <- MutagenState -> Maybe FilePath
stSaveCounterexamples MutagenState
st =
      case Char -> FilePath -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Char
'@' FilePath
path of
        Just Int
n -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Int -> FilePath -> FilePath -> FilePath
forall {a}. Int -> [a] -> [a] -> [a]
replace Int
n (Int -> FilePath
forall a. Show a => a -> FilePath
show (MutagenState -> Int
stNumFailed MutagenState
st)) FilePath
path)
        Maybe Int
Nothing -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
path FilePath -> FilePath -> FilePath
<.> Int -> FilePath
forall a. Show a => a -> FilePath
show (MutagenState -> Int
stNumFailed MutagenState
st))
  | Bool
otherwise = Maybe FilePath
forall a. Maybe a
Nothing
  where
    replace :: Int -> [a] -> [a] -> [a]
replace Int
n [a]
s [a]
str =
      let ([a]
before, [a]
after) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
str in [a]
before [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
s [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 [a]
after