{-# LANGUAGE RankNTypes #-}

-- | Queues keeping a prioritized collection of test cases to mutate next.
module Test.Mutagen.Test.Queue
  ( -- * Mutation queues
    MutationQueue (..)
  , emptyMutationQueue
  , mutationQueueSize
  , enqueueMutationCandidate
  , dequeueNextMutationCandidate

    -- * Mutation candidates
  , MutationCandidate (..)

    -- * Mutation batches
  , MutationBatch (..)
  , newMutationBatch
  , newMutationBatchFromParent
  , createOrInheritMutationBatch
  , nextMutation
  )
where

import Control.Monad.Extra (concatMapM)
import Data.Maybe (fromMaybe)
import Data.PQueue.Prio.Min (MinPQueue)
import qualified Data.PQueue.Prio.Min as PQueue
import Test.Mutagen.Fragment.Store (FragmentStore)
import Test.Mutagen.Mutant (Concretized (..), MutantKind, concretize)
import Test.Mutagen.Mutation (Mutable (..), MutationOrder, Pos)
import Test.Mutagen.Property (Args)
import Test.Mutagen.Tracer.Trace (Trace)

{-------------------------------------------------------------------------------
-- * Mutation queues
-------------------------------------------------------------------------------}

-- | Mutation queue priority.
type Priority = Int

-- | Mutation queues storing prioritized mutation candidates.
newtype MutationQueue
  = MutationQueue (MinPQueue Priority (MutationCandidate Args))

-- | Empty mutation queue.
emptyMutationQueue :: MutationQueue
emptyMutationQueue :: MutationQueue
emptyMutationQueue = MinPQueue Priority (MutationCandidate Args) -> MutationQueue
MutationQueue MinPQueue Priority (MutationCandidate Args)
forall a. Monoid a => a
mempty

-- | Size of a mutation queue.
mutationQueueSize :: MutationQueue -> Int
mutationQueueSize :: MutationQueue -> Priority
mutationQueueSize (MutationQueue MinPQueue Priority (MutationCandidate Args)
q) = MinPQueue Priority (MutationCandidate Args) -> Priority
forall k a. MinPQueue k a -> Priority
PQueue.size MinPQueue Priority (MutationCandidate Args)
q

-- | Enqueue a test case into a mutation queue with a given priority.
enqueueMutationCandidate
  :: Priority
  -> MutationCandidate Args
  -> MutationQueue
  -> MutationQueue
enqueueMutationCandidate :: Priority
-> MutationCandidate Args -> MutationQueue -> MutationQueue
enqueueMutationCandidate Priority
prio MutationCandidate Args
candidate (MutationQueue MinPQueue Priority (MutationCandidate Args)
queue) =
  MinPQueue Priority (MutationCandidate Args) -> MutationQueue
MutationQueue (Priority
-> MutationCandidate Args
-> MinPQueue Priority (MutationCandidate Args)
-> MinPQueue Priority (MutationCandidate Args)
forall k a. Ord k => k -> a -> MinPQueue k a -> MinPQueue k a
PQueue.insert Priority
prio MutationCandidate Args
candidate MinPQueue Priority (MutationCandidate Args)
queue)

-- | Dequeue the next test case from a mutation queue according to its priority.
dequeueNextMutationCandidate
  :: MutationQueue
  -> (Priority, MutationCandidate Args, MutationQueue)
dequeueNextMutationCandidate :: MutationQueue -> (Priority, MutationCandidate Args, MutationQueue)
dequeueNextMutationCandidate (MutationQueue MinPQueue Priority (MutationCandidate Args)
queue) =
  let ((Priority
prio, MutationCandidate Args
candidate), MinPQueue Priority (MutationCandidate Args)
queue') = MinPQueue Priority (MutationCandidate Args)
-> ((Priority, MutationCandidate Args),
    MinPQueue Priority (MutationCandidate Args))
forall k a. Ord k => MinPQueue k a -> ((k, a), MinPQueue k a)
PQueue.deleteFindMin MinPQueue Priority (MutationCandidate Args)
queue
   in (Priority
prio, MutationCandidate Args
candidate, MinPQueue Priority (MutationCandidate Args) -> MutationQueue
MutationQueue MinPQueue Priority (MutationCandidate Args)
queue')

{-------------------------------------------------------------------------------
-- * Mutation candidates
-------------------------------------------------------------------------------}

-- | Mutation candidates.
--
-- A mutation candidate is a previously executed test case that was found
-- to be interesting according to its execution trace. Such test cases are
-- stored in a mutation queue to be later used as seeds for generating
-- new test cases via mutation.
data MutationCandidate args
  = MutationCandidate
  { forall args. MutationCandidate args -> args
mcArgs :: args
  -- ^ Test case arguments
  , forall args. MutationCandidate args -> Trace
mcTrace :: Trace
  -- ^ Execution trace of the test case
  , forall args. MutationCandidate args -> MutationBatch args
mcBatch :: MutationBatch args
  -- ^ Mutation batch associated to the test case
  }

{-------------------------------------------------------------------------------
-- * Mutation batches
-------------------------------------------------------------------------------}

-- | Mutation batches.
--
-- In contrast to mutation queues, which simultaneously store multiple test
-- cases to be mutated, mutation batches store the state of mutating a single
-- test case.
data MutationBatch args
  = MutationBatch
  { forall args. MutationBatch args -> args
mbArgs :: args
  -- ^ Original test case arguments
  , forall args. MutationBatch args -> [Pos]
mbPastPositions :: [Pos]
  -- ^ Positions already mutated
  , forall args. MutationBatch args -> [Concretized args]
mbCurrBatch :: [Concretized args]
  -- ^ Current queue of mutants for the current position
  , forall args. MutationBatch args -> [Pos]
mbNextPositions :: [Pos]
  -- ^ Positions yet to be mutated
  , forall args. MutationBatch args -> MutationOrder
mbMutationOrder :: MutationOrder
  -- ^ Mutation order to use
  , forall args. MutationBatch args -> Bool
mbTestPassed :: Bool
  -- ^ Whether the original test case passed the property or was discarded
  , forall args. MutationBatch args -> Priority
mbRandomMutationSize :: Int
  -- ^ Maximum generation size for random mutations
  , forall args. MutationBatch args -> Priority
mbNumRandomMutations :: Int
  -- ^ Number of test cases to randomly sample per random mutant
  , forall args. MutationBatch args -> Priority
mbNumFragMutations :: Int
  -- ^ Number of test cases to sample from the store per fragment mutant
  , forall args. MutationBatch args -> Priority
mbMaxMutationDepth :: Int
  -- ^ Maximum mutation depth remaining
  }

-- | Create a new mutation batch from scratch.
newMutationBatch
  :: (Mutable a)
  => MutationOrder
  -> Int
  -> Int
  -> Int
  -> Int
  -> Maybe [Pos]
  -> Bool
  -> a
  -> MutationBatch a
newMutationBatch :: forall a.
Mutable a =>
MutationOrder
-> Priority
-> Priority
-> Priority
-> Priority
-> Maybe [Pos]
-> Bool
-> a
-> MutationBatch a
newMutationBatch
  MutationOrder
mutationOrder
  Priority
numRandomMutations
  Priority
randomMutationSize
  Priority
numFragMutations
  Priority
maxMutationDepth
  Maybe [Pos]
evaluatedPositions
  Bool
testPassed
  a
args =
    MutationBatch
      { mbArgs :: a
mbArgs = a
args
      , mbPastPositions :: [Pos]
mbPastPositions = [Pos]
forall a. Monoid a => a
mempty
      , mbNextPositions :: [Pos]
mbNextPositions = [Pos]
nextPositions
      , mbCurrBatch :: [Concretized a]
mbCurrBatch = [Concretized a]
forall a. Monoid a => a
mempty
      , mbMutationOrder :: MutationOrder
mbMutationOrder = Tree a -> [a]
MutationOrder
mutationOrder
      , mbTestPassed :: Bool
mbTestPassed = Bool
testPassed
      , mbRandomMutationSize :: Priority
mbRandomMutationSize = Priority
randomMutationSize
      , mbNumRandomMutations :: Priority
mbNumRandomMutations = Priority
numRandomMutations
      , mbMaxMutationDepth :: Priority
mbMaxMutationDepth = Priority
maxMutationDepth
      , mbNumFragMutations :: Priority
mbNumFragMutations = Priority
numFragMutations
      }
    where
      -- Determine next positions to mutate based on whether we receive the
      -- concrete execution trace of the original
      nextPositions :: [Pos]
nextPositions =
        [Pos] -> Maybe [Pos] -> [Pos]
forall a. a -> Maybe a -> a
fromMaybe (Tree Pos -> [Pos]
MutationOrder
mutationOrder (a -> Tree Pos
forall a. Mutable a => a -> Tree Pos
positions a
args)) Maybe [Pos]
evaluatedPositions

-- | Create a new mutation batch by inheriting from a parent one.
--
-- NOTE: this decreases the maximum mutation depth of the parent batch by one.
newMutationBatchFromParent
  :: (Mutable a)
  => MutationBatch a
  -> Maybe [Pos]
  -> Bool
  -> a
  -> MutationBatch a
newMutationBatchFromParent :: forall a.
Mutable a =>
MutationBatch a -> Maybe [Pos] -> Bool -> a -> MutationBatch a
newMutationBatchFromParent
  MutationBatch a
batch
  Maybe [Pos]
evaluatedPos
  Bool
testPassed
  a
args =
    MutationBatch a
batch
      { mbArgs = args
      , mbNextPositions = nextPositions
      , mbPastPositions = mempty
      , mbTestPassed = testPassed
      , mbCurrBatch = mempty
      , mbMaxMutationDepth = mbMaxMutationDepth batch - 1
      }
    where
      -- Determine next positions to mutate based on whether we receive the
      -- concrete execution trace of the original
      nextPositions :: [Pos]
nextPositions =
        [Pos] -> Maybe [Pos] -> [Pos]
forall a. a -> Maybe a -> a
fromMaybe (MutationBatch a -> MutationOrder
forall args. MutationBatch args -> MutationOrder
mbMutationOrder MutationBatch a
batch (a -> Tree Pos
forall a. Mutable a => a -> Tree Pos
positions a
args)) Maybe [Pos]
evaluatedPos

-- | Create or inherit mutation batch for a test case.
--
-- If the test case was generated by mutating an existing one, we can inherit
-- its parent mutation batch and just update it with the new test case.
-- Otherwise, we need to create a new mutation batch from scratch.
createOrInheritMutationBatch
  :: MutationOrder
  -- ^ Mutation order to use
  -> Int
  -- ^ Maximum number of random mutations to sample per mutant
  -> Int
  -- ^ Maximum generation size for random mutations
  -> Int
  -- ^ Number of random fragments to sample from the fragment store
  -> Int
  -- ^ Maximum mutation limit for the test case
  -> Args
  -- ^ Test case arguments
  -> Maybe (MutationBatch Args)
  -- ^ Parent test case mutation batch to derive a new one from, if any
  -> Maybe [Pos]
  -- ^ Mutation positions available in the test case
  -> Bool
  -- ^ Whether the test case passed the property or was discarded
  -> MutationBatch Args
createOrInheritMutationBatch :: MutationOrder
-> Priority
-> Priority
-> Priority
-> Priority
-> Args
-> Maybe (MutationBatch Args)
-> Maybe [Pos]
-> Bool
-> MutationBatch Args
createOrInheritMutationBatch
  MutationOrder
mutationOrder
  Priority
randomMutations
  Priority
maxGenSize
  Priority
randomFragments
  Priority
maxMutationDepth
  Args
args
  Maybe (MutationBatch Args)
parentBatch
  Maybe [Pos]
evaluatedPos
  Bool
isPassed =
    case Maybe (MutationBatch Args)
parentBatch of
      -- The test case was mutated from an existing one
      Just MutationBatch Args
mb ->
        MutationBatch Args
-> Maybe [Pos] -> Bool -> Args -> MutationBatch Args
forall a.
Mutable a =>
MutationBatch a -> Maybe [Pos] -> Bool -> a -> MutationBatch a
newMutationBatchFromParent
          MutationBatch Args
mb
          Maybe [Pos]
evaluatedPos
          Bool
isPassed
          Args
args
      -- The test case was freshly generated
      Maybe (MutationBatch Args)
Nothing ->
        MutationOrder
-> Priority
-> Priority
-> Priority
-> Priority
-> Maybe [Pos]
-> Bool
-> Args
-> MutationBatch Args
forall a.
Mutable a =>
MutationOrder
-> Priority
-> Priority
-> Priority
-> Priority
-> Maybe [Pos]
-> Bool
-> a
-> MutationBatch a
newMutationBatch
          Tree a -> [a]
MutationOrder
mutationOrder
          Priority
randomMutations
          Priority
maxGenSize
          Priority
randomFragments
          Priority
maxMutationDepth
          Maybe [Pos]
evaluatedPos
          Bool
isPassed
          Args
args

-- | Compute the next mutation from a mutation batch.
nextMutation
  :: (Mutable a)
  => FragmentStore
  -> MutationBatch a
  -> IO (Maybe (a, MutantKind, MutationBatch a))
nextMutation :: forall a.
Mutable a =>
FragmentStore
-> MutationBatch a -> IO (Maybe (a, MutantKind, MutationBatch a))
nextMutation FragmentStore
_ MutationBatch a
batch
  | MutationBatch a -> Priority
forall args. MutationBatch args -> Priority
mbMaxMutationDepth MutationBatch a
batch Priority -> Priority -> Bool
forall a. Eq a => a -> a -> Bool
== Priority
0 = Maybe (a, MutantKind, MutationBatch a)
-> IO (Maybe (a, MutantKind, MutationBatch a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, MutantKind, MutationBatch a)
forall a. Maybe a
Nothing -- too many mutations
nextMutation FragmentStore
fs MutationBatch a
batch = do
  case MutationBatch a -> [Concretized a]
forall args. MutationBatch args -> [Concretized args]
mbCurrBatch MutationBatch a
batch of
    -- Queue is empty, advance to next position
    [] -> do
      case MutationBatch a -> [Pos]
forall args. MutationBatch args -> [Pos]
mbNextPositions MutationBatch a
batch of
        -- No more positions to mutate
        [] -> Maybe (a, MutantKind, MutationBatch a)
-> IO (Maybe (a, MutantKind, MutationBatch a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, MutantKind, MutationBatch a)
forall a. Maybe a
Nothing
        -- Next position available
        Pos
pos : [Pos]
ps -> do
          let mutants :: [Mutant a]
mutants = Pos -> (forall x. Mutable x => Mutation x) -> Mutation a
forall a.
Mutable a =>
Pos -> (forall x. Mutable x => Mutation x) -> Mutation a
inside Pos
pos Mutation x
forall x. Mutable x => Mutation x
mutate (MutationBatch a -> a
forall args. MutationBatch args -> args
mbArgs MutationBatch a
batch)
          queue <-
            (Mutant a -> IO [Concretized a])
-> [Mutant a] -> IO [Concretized a]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM
              ( (Priority, Priority)
-> (Priority, FragmentStore) -> Mutant a -> IO [Concretized a]
forall a.
Typeable a =>
(Priority, Priority)
-> (Priority, FragmentStore) -> Mutant a -> IO [Concretized a]
concretize
                  (MutationBatch a -> Priority
forall args. MutationBatch args -> Priority
mbNumRandomMutations MutationBatch a
batch, MutationBatch a -> Priority
forall args. MutationBatch args -> Priority
mbRandomMutationSize MutationBatch a
batch)
                  (MutationBatch a -> Priority
forall args. MutationBatch args -> Priority
mbNumRandomMutations MutationBatch a
batch, FragmentStore
fs)
              )
              [Mutant a]
mutants
          case queue of
            -- Current position admits no mutations: advance to next position
            [] -> do
              let mb' :: MutationBatch a
mb' =
                    MutationBatch a
batch
                      { mbNextPositions = ps
                      , mbPastPositions = pos : mbPastPositions batch
                      }
              FragmentStore
-> MutationBatch a -> IO (Maybe (a, MutantKind, MutationBatch a))
forall a.
Mutable a =>
FragmentStore
-> MutationBatch a -> IO (Maybe (a, MutantKind, MutationBatch a))
nextMutation FragmentStore
fs MutationBatch a
mb'
            -- Current position admits some mutations: update the batch queue
            -- and lock the current position
            Concretized MutantKind
kind a
a : [Concretized a]
as -> do
              let mb' :: MutationBatch a
mb' =
                    MutationBatch a
batch
                      { mbNextPositions = ps
                      , mbPastPositions = pos : mbPastPositions batch
                      , mbCurrBatch = as
                      }
              Maybe (a, MutantKind, MutationBatch a)
-> IO (Maybe (a, MutantKind, MutationBatch a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, MutantKind, MutationBatch a)
-> Maybe (a, MutantKind, MutationBatch a)
forall a. a -> Maybe a
Just (a
a, MutantKind
kind, MutationBatch a
mb'))
    -- There are some mutants still in the queue for the current position
    Concretized MutantKind
kind a
a : [Concretized a]
as -> do
      Maybe (a, MutantKind, MutationBatch a)
-> IO (Maybe (a, MutantKind, MutationBatch a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, MutantKind, MutationBatch a)
-> Maybe (a, MutantKind, MutationBatch a)
forall a. a -> Maybe a
Just (a
a, MutantKind
kind, MutationBatch a
batch{mbCurrBatch = as}))