Implement keepGoing and saveCounterexamples

Author: agustinmista

src/Test/Mutagen/Config.hs

@@ -92,6 +92,19 @@ data Config
   , maxTraceLength :: Maybe Int
   -- ^ The maximim trace length to consider. Useful in conjunction with the
   -- `Tree` `traceMethod` when testing lengthy properties.
+  , keepGoing :: Bool
+  -- ^ Whether to keep searching for more counterexamples after finding the
+  -- first one. If set, Mutagen will stop only when reaching the maximum number
+  -- of successful tests or the timeout, without giving up in the presence of
+  -- too many discards. Reports will always be a 'Success' or a timeout.
+  , saveCounterexamples :: Maybe FilePath
+  -- ^ If set to a 'FilePath', save found counterexamples to the given file.
+  -- Accepts templated file paths, e.g., "counterexample_@.hs", where "@" will
+  -- be replaced by a counter. This is useful in combination with 'keepGoing'
+  -- to save multiple counterexamples.
+  --
+  -- NOTE: if 'keepGoing' is enabled and the counterexample path does not
+  -- contain "@", then the counter is appended to its end.
   , chatty :: Bool
   -- ^ Print extra info.
   , debug :: DebugMode
@@ -120,6 +133,8 @@ defaultConfig =
     , examples = []
     , traceBackend = Bitmap
     , maxTraceLength = Nothing
+    , keepGoing = False
+    , saveCounterexamples = Nothing
     , chatty = False
     , debug = NoDebug
     , tui = False

src/Test/Mutagen/Report.hs

@@ -20,6 +20,8 @@ data Report
       -- ^ Number of passed tests
       , numDiscarded :: Int
       -- ^ Number of discarded tests
+      , numFailed :: Int
+      -- ^ Number of failed tests
       }
   | -- | The property failed for the given arguments
     Counterexample

src/Test/Mutagen/Test/Loop.hs

@@ -50,13 +50,15 @@ import Test.Mutagen.Test.State
   , incMutantKindCounter
   , incNumBoring
   , incNumDiscarded
+  , incNumFailed
   , incNumGenerated
   , incNumInteresting
   , incNumMutatedFromDiscarded
   , incNumMutatedFromPassed
   , incNumPassed
   , incNumTestsSinceLastInteresting
-  , incNumTraceLogResets
+  , incNumTraceStoreResets
+  , nextCounterexamplePath
   , resetNumTestsSinceLastInteresting
   , setAutoResetAfter
   , setCurrentGenSize
@@ -102,7 +104,8 @@ loop st
   -- We discarded too many tests
   -- ==> give up
   | stNumDiscarded st
-      >= stMaxDiscardRatio st * max (stNumPassed st) (stMaxSuccess st) =
+      >= stMaxDiscardRatio st * max (stNumPassed st) (stMaxSuccess st)
+      && not (stKeepGoing st) =
       giveUp st "too many discarded tests"
   -- The time bugdet is over, we check this every so often
   -- ==> give up
@@ -127,7 +130,7 @@ loop st
             st
               & setAutoResetAfter ((* 2) <$> (stAutoResetAfter st))
               & setRandomMutations (stRandomMutations st * 2)
-              & incNumTraceLogResets
+              & incNumTraceStoreResets
               & resetNumTestsSinceLastInteresting
       newTest st'
   -- Nothing new under the sun
@@ -148,11 +151,9 @@ newTest st = do
   stopOnDebugMode (stDebug st'') result
   -- check the test result and report a counterexample or continue
   case result of
-    -- Test failed and it was not supposed to, report counterexample
-    Failed | stExpect st'' -> counterexample st'' args result
-    -- Test failed but it was expected to, stop testing
-    Failed -> success st''
-    -- Test passed or discarded, continue the loop
+    -- Test failed, report counterexample
+    Failed -> counterexample st'' args result
+    -- Test passed or discarded, continue the loop directly
     _ -> loop st''
   where
     -- Stop execution if in debug mode
@@ -165,6 +166,47 @@ newTest st = do
       message "Press enter to continue ..."
       void (liftIO getLine)
 
+-- | Found a bug!
+--
+-- NOTE: if 'keepGoing' is disabled, this is also a terminal state.
+counterexample :: (MonadMutagen m) => MutagenState -> Args -> Result -> m Report
+counterexample st args result = do
+  message "Found counterexample!"
+  pretty args
+  message "Reason of failure:"
+  case resultReason result of
+    Just failureReason -> message failureReason
+    Nothing -> message "assertion failed"
+  case resultException result of
+    Just exc -> do
+      message "The exception was:"
+      message (show exc)
+    Nothing -> return ()
+  case nextCounterexamplePath st of
+    Just path -> do
+      message $ "Saving counterexample to: " <> path
+      liftIO $ writeFile path (show args)
+    Nothing -> return ()
+  let st' = st & incNumFailed
+  next st'
+  where
+    next st'
+      -- Check if we should keep going
+      | stKeepGoing st = do
+          message $ "Failed " <> show (stNumFailed st) <> " times, continuing..."
+          loop st'
+      -- Check if this was an expected failure and mask the report as success
+      | not (stExpect st) =
+          success st'
+      -- Otherwise, report the counterexample
+      | otherwise =
+          return
+            Counterexample
+              { numPassed = stNumPassed st
+              , numDiscarded = stNumDiscarded st
+              , failingArgs = args
+              }
+
 -- * Terminal states
 
 -- | All tests passed successfully
@@ -175,6 +217,7 @@ success st = do
     Success
       { numPassed = stNumPassed st
       , numDiscarded = stNumDiscarded st
+      , numFailed = stNumFailed st
       }
 
 -- | Too many discarded tests
@@ -188,27 +231,6 @@ giveUp st gaveUpReason = do
       , numDiscarded = stNumDiscarded st
       }
 
--- | Found a bug!
-counterexample :: (MonadMutagen m) => MutagenState -> Args -> Result -> m Report
-counterexample st args result = do
-  message "Found counterexample!"
-  pretty args
-  message "*** Reason of failure:"
-  case resultReason result of
-    Just failureReason -> message failureReason
-    Nothing -> message "assertion failed"
-  case resultException result of
-    Just exc -> do
-      message "*** The exception was:"
-      message (show exc)
-    Nothing -> return ()
-  return
-    Counterexample
-      { numPassed = stNumPassed st
-      , numDiscarded = stNumDiscarded st
-      , failingArgs = args
-      }
-
 -- | Expected failure did not occur
 noExpectedFailure :: (MonadMutagen m) => MutagenState -> m Report
 noExpectedFailure st = do

src/Test/Mutagen/Test/State.hs

@@ -21,9 +21,10 @@ module Test.Mutagen.Test.State
   , updateDiscardedQueue
   , setFragmentStore
   , updateFragmentStore
-  , incNumTraceLogResets
+  , incNumTraceStoreResets
   , incNumPassed
   , incNumDiscarded
+  , incNumFailed
   , incNumGenerated
   , incNumMutatedFromPassed
   , incNumMutatedFromDiscarded
@@ -36,10 +37,13 @@ module Test.Mutagen.Test.State
     -- * 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 (..))
 import Test.Mutagen.Fragment
   ( FragmentStore
@@ -97,6 +101,10 @@ data MutagenState
   -- ^ Mirrored from 'Config.filterFragments'
   , stMaxTraceLength :: !(Maybe Int)
   -- ^ Mirrored from 'Config.maxTraceLength'
+  , stKeepGoing :: !Bool
+  -- ^ Mirrored from 'Config.keepGoing'
+  , stSaveCounterexamples :: !(Maybe FilePath)
+  -- ^ Mirrored from 'Config.saveCounterexamples'
   , stChatty :: !Bool
   -- ^ Mirrored from 'Config.chatty'
   , stDebug :: !DebugMode
@@ -143,14 +151,16 @@ data MutagenState
   -- ^ Number of passed test cases
   , stNumDiscarded :: !Int
   -- ^ Number of discarded test cases
+  , stNumFailed :: !Int
+  -- ^ Number of failed test cases (only useful when 'keepGoing' is enabled)
   , stNumInteresting :: !Int
   -- ^ Number of interesting test cases
   , stNumBoring :: !Int
   -- ^ Number of boring test cases
   , stNumTestsSinceLastInteresting :: !Int
   -- ^ Number of test cases since the last interesting one
-  , stNumTraceLogResets :: !Int
-  -- ^ Number of times the trace logs have been reset
+  , stNumTraceStoreResets :: !Int
+  -- ^ Number of times the trace store have been reset
   }
 
 -- | Initialize the internal state
@@ -189,6 +199,8 @@ initMutagenState cfg (Property gen runner) = do
         , 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
@@ -212,11 +224,12 @@ initMutagenState cfg (Property gen runner) = do
         , stNumRandMutants = 0
         , stNumFragMutants = 0
         , stNumPassed = 0
+        , stNumFailed = 0
         , stNumDiscarded = 0
         , stNumInteresting = 0
         , stNumBoring = 0
         , stNumTestsSinceLastInteresting = 0
-        , stNumTraceLogResets = 0
+        , stNumTraceStoreResets = 0
         }
   where
     fragmentStoreFromExamples =
@@ -276,9 +289,9 @@ updateFragmentStore f st =
 
 -- ** Incrementers
 
-incNumTraceLogResets :: MutagenState -> MutagenState
-incNumTraceLogResets st =
-  st{stNumTraceLogResets = stNumTraceLogResets st + 1}
+incNumTraceStoreResets :: MutagenState -> MutagenState
+incNumTraceStoreResets st =
+  st{stNumTraceStoreResets = stNumTraceStoreResets st + 1}
 
 incNumPassed :: MutagenState -> MutagenState
 incNumPassed st =
@@ -288,6 +301,10 @@ incNumDiscarded :: MutagenState -> MutagenState
 incNumDiscarded st =
   st{stNumDiscarded = stNumDiscarded st + 1}
 
+incNumFailed :: MutagenState -> MutagenState
+incNumFailed st =
+  st{stNumFailed = stNumFailed st + 1}
+
 incNumGenerated :: MutagenState -> MutagenState
 incNumGenerated st =
   st{stNumGenerated = stNumGenerated st + 1}
@@ -359,3 +376,19 @@ computeSize st
         `min` stMaxGenSize st
   where
     roundTo n m = (n `div` m) * 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 st
+  | Just path <- stSaveCounterexamples st =
+      case elemIndex '@' path of
+        Just n -> Just (replace n (show (stNumFailed st + 1)) path)
+        Nothing -> Just (path <.> show (stNumFailed st + 1))
+  | otherwise = Nothing
+  where
+    replace n s str =
+      let (before, after) = splitAt n str in before <> s <> drop 1 after

src/Test/Mutagen/Test/Terminal.hs

@@ -219,7 +219,9 @@ printGlobalStats st = do
       <> show (stNumPassed st)
       <> " tests ("
       <> show (stNumDiscarded st)
-      <> " discarded)"
+      <> " discarded, "
+      <> show (stNumFailed st)
+      <> " failed)"
   message
     $ "* Tests origin: "
       <> show (stNumGenerated st)
@@ -248,8 +250,8 @@ printGlobalStats st = do
       <> ", using "
       <> show (stRandomMutations st)
       <> " random mutations (after "
-      <> show (stNumTraceLogResets st)
-      <> " trace log resets)"
+      <> show (stNumTraceStoreResets st)
+      <> " trace store resets)"
   message
     $ "* Current generation size: "
       <> show (stCurrentGenSize st)
@@ -268,10 +270,10 @@ printGlobalStats st = do
 -- | Print short statistics about the testing session
 printShortStats :: (MonadTerminal m) => MutagenState -> m ()
 printShortStats st = do
-  let total = stNumPassed st + stNumDiscarded st
+  let total = stNumPassed st + stNumDiscarded st + stNumFailed st
   let mutated = stNumMutatedFromPassed st + stNumMutatedFromDiscarded st
   message
-    $ "Ran "
+    $ "Executed "
       <> show total
       <> " tests ("
       <> show (percentage (stNumPassed st) total)

test/re/Main.hs

@@ -43,7 +43,10 @@ main = do
 config :: Config
 config =
   defaultConfig
-    { maxGenSize =
+    { maxSuccess =
+        -- Number of successful tests to find before stopping
+        10000
+    , maxGenSize =
         -- Max generation size
         5
     , useLazyPrunning =
@@ -61,7 +64,13 @@ config =
         -- Only store fragments of the following types
         allow @ASCII
           <> allow @(RE ASCII)
-    , chatty =
+    , -- , keepGoing =
+      --     -- Keep going after finding the first counterexample
+      --     True
+      -- , saveCounterexamples =
+      --     -- Save found counterexamples to a file
+      --     Just "tmp/prop_optimize_@.txt"
+      chatty =
         -- Print extra info
         False
     , debug =