-- | Test driver
--
-- Intended for qualified import.
--
-- > import Test.Falsify.Internal.Driver (Success, Failure, falsify)
-- > import qualified Test.Falsify.Internal.Driver as Driver
module Test.Falsify.Internal.Driver (
    -- * Options
    Options(..)
    -- * Results
  , Success(..)
  , Failure(..)
  , TestOutcome'(..)
  , TestOutcome
    -- * Test driver
  , falsify
    -- * Process results
  , Verbose(..)
  , ExpectFailure(..)
  , RenderedTestOutcome(..)
  , renderTestOutcome
  ) where

import Prelude hiding (log)

import Data.Bifunctor
import Data.Default
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Data.Set (Set)
import GHC.Exception
import System.Random.SplitMix
import Text.Printf

import qualified Data.List.NonEmpty as NE
import qualified Data.Map           as Map
import qualified Data.Set           as Set

import Test.Falsify.Context (Context(Context))
import Test.Falsify.Internal.Driver.ReplaySeed
import Test.Falsify.Internal.Generator
import Test.Falsify.Internal.Property
import Test.Falsify.Internal.Shrinking
import Test.Falsify.SampleTree (SampleTree)

import qualified Test.Falsify.Context    as Context
import qualified Test.Falsify.SampleTree as SampleTree

{-------------------------------------------------------------------------------
  Options
-------------------------------------------------------------------------------}

-- | Options for running a test
data Options = Options {
      -- | Number of test cases to generate
      Options -> Word
tests :: Word

      -- | Number of shrinks allowed before failing a test
    , Options -> Maybe Word
maxShrinks :: Maybe Word

      -- | Random seed to use for replaying a previous test run
    , Options -> Maybe ReplaySeed
replay :: Maybe ReplaySeed

      -- | Maximum number of discarded test per successful test
    , Options -> Word
maxRatio :: Word
    }

instance Default Options where
  def :: Options
def = Options {
        tests :: Word
tests      = Word
100
      , maxShrinks :: Maybe Word
maxShrinks = Maybe Word
forall a. Maybe a
Nothing
      , replay :: Maybe ReplaySeed
replay     = Maybe ReplaySeed
forall a. Maybe a
Nothing
      , maxRatio :: Word
maxRatio   = Word
100
      }

{-------------------------------------------------------------------------------
  Driver
-------------------------------------------------------------------------------}

data Success a = Success {
      forall a. Success a -> Iteration
successIteration :: Context.Iteration
    , forall a. Success a -> a
successResult    :: a
    , forall a. Success a -> ReplaySeed
successSeed      :: ReplaySeed
    , forall a. Success a -> TestRun
successRun       :: TestRun
    }
  deriving (Int -> Success a -> ShowS
[Success a] -> ShowS
Success a -> String
(Int -> Success a -> ShowS)
-> (Success a -> String)
-> ([Success a] -> ShowS)
-> Show (Success a)
forall a. Show a => Int -> Success a -> ShowS
forall a. Show a => [Success a] -> ShowS
forall a. Show a => Success a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Success a -> ShowS
showsPrec :: Int -> Success a -> ShowS
$cshow :: forall a. Show a => Success a -> String
show :: Success a -> String
$cshowList :: forall a. Show a => [Success a] -> ShowS
showList :: [Success a] -> ShowS
Show)

data Failure e = Failure {
      forall e. Failure e -> ReplaySeed
failureSeed :: ReplaySeed
    , forall e. Failure e -> ShrinkExplanation (Counterexample e) TestRun
failureRun  :: ShrinkExplanation (Counterexample e) TestRun
    }
  deriving (Int -> Failure e -> ShowS
[Failure e] -> ShowS
Failure e -> String
(Int -> Failure e -> ShowS)
-> (Failure e -> String)
-> ([Failure e] -> ShowS)
-> Show (Failure e)
forall e. Show e => Int -> Failure e -> ShowS
forall e. Show e => [Failure e] -> ShowS
forall e. Show e => Failure e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> Failure e -> ShowS
showsPrec :: Int -> Failure e -> ShowS
$cshow :: forall e. Show e => Failure e -> String
show :: Failure e -> String
$cshowList :: forall e. Show e => [Failure e] -> ShowS
showList :: [Failure e] -> ShowS
Show)

-- | Result of running @falsify@
--
-- This is an opaque type; see 'renderTestOutcome' and the additional accessors
-- provided in "Test.Falsify.Driver".
data TestOutcome' e a = TestOutcome{
      -- | Initial replay seed (each test also records its own seed)
      forall e a. TestOutcome' e a -> ReplaySeed
testReplaySeed :: ReplaySeed

      -- | Successful tests
    , forall e a. TestOutcome' e a -> [Success a]
testSuccesses :: [Success a]

      -- | Number of discarded tests
    , forall e a. TestOutcome' e a -> Word
testDiscarded :: Word

      -- | Failed test (if any)
    , forall e a. TestOutcome' e a -> Maybe (Failure e)
testFailure :: Maybe (Failure e)
    }

-- | t'TestOutcome' specialized to 'String' for errors
--
-- This mimicks the 'Property'' vs 'Property' distinction.
type TestOutcome = TestOutcome' String

-- | Run a test: attempt to falsify the given property
falsify :: forall e a. Options -> Property' e a -> IO (TestOutcome' e a)
falsify :: forall e a. Options -> Property' e a -> IO (TestOutcome' e a)
falsify Options
opts Property' e a
prop = do
    DriverState a
acc <- Options -> IO (DriverState a)
forall a. Options -> IO (DriverState a)
initDriverState Options
opts
    ([Success a]
successes, Word
discarded, Maybe (Failure e)
mFailure) <- DriverState a -> IO ([Success a], Word, Maybe (Failure e))
go DriverState a
acc
    TestOutcome' e a -> IO (TestOutcome' e a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TestOutcome{
        testReplaySeed :: ReplaySeed
testReplaySeed = SMGen -> ReplaySeed
splitmixReplaySeed (DriverState a -> SMGen
forall a. DriverState a -> SMGen
prng DriverState a
acc)
      , testSuccesses :: [Success a]
testSuccesses  = [Success a]
successes
      , testDiscarded :: Word
testDiscarded  = Word
discarded
      , testFailure :: Maybe (Failure e)
testFailure    = Maybe (Failure e)
mFailure
      }
  where
    static :: Context.Static
    static :: Static
static = Context.Static{
          tests :: Word
tests      = Options -> Word
tests      Options
opts
        , maxShrinks :: Maybe Word
maxShrinks = Options -> Maybe Word
maxShrinks Options
opts
        , maxRatio :: Word
maxRatio   = Options -> Word
maxRatio   Options
opts
        }

    go :: DriverState a -> IO ([Success a], Word, Maybe (Failure e))
    go :: DriverState a -> IO ([Success a], Word, Maybe (Failure e))
go DriverState a
acc | DriverState a -> Word
forall a. DriverState a -> Word
thisTest DriverState a
acc Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Options -> Word
tests Options
opts = ([Success a], Word, Maybe (Failure e))
-> IO ([Success a], Word, Maybe (Failure e))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (
          [Success a] -> [Success a]
forall a. [a] -> [a]
reverse ([Success a] -> [Success a]) -> [Success a] -> [Success a]
forall a b. (a -> b) -> a -> b
$ DriverState a -> [Success a]
forall a. DriverState a -> [Success a]
successes DriverState a
acc
        , DriverState a -> Word
forall a. DriverState a -> Word
discardedTotal DriverState a
acc
        , Maybe (Failure e)
forall a. Maybe a
Nothing
        )
    go DriverState a
acc = do
        let iteration :: Context.Iteration
            iteration :: Iteration
iteration = Context.Iteration{
                  thisTest :: Word
thisTest = DriverState a -> Word
forall a. DriverState a -> Word
thisTest DriverState a
acc
                }

            initContext :: Context
            initContext :: Context
initContext = Static -> Iteration -> Execution -> Context
Context Static
static Iteration
iteration Execution
Context.Initial

            now, later :: SMGen
            (SMGen
now, SMGen
later) = SMGen -> (SMGen, SMGen)
splitSMGen (DriverState a -> SMGen
forall a. DriverState a -> SMGen
prng DriverState a
acc)

            st :: SampleTree
            st :: SampleTree
st = SMGen -> SampleTree
SampleTree.fromPRNG SMGen
now

            result :: TestResult e a
            run    :: TestRun
            shrunk :: [SampleTree]
            ((TestResult e a
result, TestRun
run), [SampleTree]
shrunk) = Gen (TestResult e a, TestRun)
-> SampleTree -> ((TestResult e a, TestRun), [SampleTree])
forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen (Property' e a -> Context -> Gen (TestResult e a, TestRun)
forall e a.
Property' e a -> Context -> Gen (TestResult e a, TestRun)
runProperty Property' e a
prop Context
initContext) SampleTree
st

        case TestResult e a
result of
          -- Test passed
          TestPassed a
x -> do
            let success :: Success a
                success :: Success a
success = Success {
                    successIteration :: Iteration
successIteration = Iteration
iteration
                  , successResult :: a
successResult    = a
x
                  , successSeed :: ReplaySeed
successSeed      = SMGen -> ReplaySeed
splitmixReplaySeed SMGen
now
                  , successRun :: TestRun
successRun       = TestRun
run
                  }
            if TestRun -> Bool
runDeterministic TestRun
run then
              case (DriverState a -> [Success a]
forall a. DriverState a -> [Success a]
successes DriverState a
acc, DriverState a -> Word
forall a. DriverState a -> Word
discardedTotal DriverState a
acc) of
                ([], Word
0)    -> ([Success a], Word, Maybe (Failure e))
-> IO ([Success a], Word, Maybe (Failure e))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Success a
success], Word
0, Maybe (Failure e)
forall a. Maybe a
Nothing)
                ([Success a], Word)
_otherwise -> String -> IO ([Success a], Word, Maybe (Failure e))
forall a. HasCallStack => String -> a
error String
"falsify.go: impossible"
            else
              DriverState a -> IO ([Success a], Word, Maybe (Failure e))
go (DriverState a -> IO ([Success a], Word, Maybe (Failure e)))
-> DriverState a -> IO ([Success a], Word, Maybe (Failure e))
forall a b. (a -> b) -> a -> b
$ SMGen -> Success a -> DriverState a -> DriverState a
forall a. SMGen -> Success a -> DriverState a -> DriverState a
withSuccess SMGen
later Success a
success DriverState a
acc

          -- Test failed
          --
          -- We ignore the failure message here, because this is the failure
          -- message before shrinking, which we are typically not interested in.
          TestFailed e
e -> do
            let explanation :: ShrinkExplanation (Counterexample e) TestRun
                explanation :: ShrinkExplanation (Counterexample e) TestRun
explanation =
                    ((Maybe a, TestRun) -> TestRun)
-> ShrinkExplanation (Counterexample e) (Maybe a, TestRun)
-> ShrinkExplanation (Counterexample e) TestRun
forall b c a.
(b -> c) -> ShrinkExplanation a b -> ShrinkExplanation a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Maybe a, TestRun) -> TestRun
forall a b. (a, b) -> b
snd (ShrinkExplanation (Counterexample e) (Maybe a, TestRun)
 -> ShrinkExplanation (Counterexample e) TestRun)
-> ShrinkExplanation (Counterexample e) (Maybe a, TestRun)
-> ShrinkExplanation (Counterexample e) TestRun
forall a b. (a -> b) -> a -> b
$
                      Static
-> Iteration
-> (Context
    -> Gen (IsValidShrink (Counterexample e) (Maybe a, TestRun)))
-> SampleTree
-> (Counterexample e, [SampleTree])
-> ShrinkExplanation (Counterexample e) (Maybe a, TestRun)
forall p n.
Static
-> Iteration
-> (Context -> Gen (IsValidShrink p n))
-> SampleTree
-> (p, [SampleTree])
-> ShrinkExplanation p n
shrinkFrom
                        Static
static
                        Iteration
iteration
                        ( \Context
ctx ->
                             Execution
-> (TestResult e a, TestRun)
-> IsValidShrink (Counterexample e) (Maybe a, TestRun)
forall e a.
Execution
-> (TestResult e a, TestRun)
-> IsValidShrink (Counterexample e) (Maybe a, TestRun)
resultIsValidShrink (Context -> Execution
Context.execution Context
ctx) ((TestResult e a, TestRun)
 -> IsValidShrink (Counterexample e) (Maybe a, TestRun))
-> Gen (TestResult e a, TestRun)
-> Gen (IsValidShrink (Counterexample e) (Maybe a, TestRun))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                               Property' e a -> Context -> Gen (TestResult e a, TestRun)
forall e a.
Property' e a -> Context -> Gen (TestResult e a, TestRun)
runProperty Property' e a
prop Context
ctx
                        )
                        SampleTree
st
                        (Execution -> e -> TestRun -> Counterexample e
forall e. Execution -> e -> TestRun -> Counterexample e
Counterexample Execution
Context.Initial e
e TestRun
run, [SampleTree]
shrunk)

                -- We have to be careful here: if the user specifies a seed, we
                -- will first /split/ it to run the test (call to splitSMGen,
                -- above). This means that the seed we should provide for the
                -- test is the seed /before/ splitting.
                failure :: Failure e
                failure :: Failure e
failure = Failure {
                      failureSeed :: ReplaySeed
failureSeed = SMGen -> ReplaySeed
splitmixReplaySeed (DriverState a -> SMGen
forall a. DriverState a -> SMGen
prng DriverState a
acc)
                    , failureRun :: ShrinkExplanation (Counterexample e) TestRun
failureRun  = ShrinkExplanation (Counterexample e) TestRun
explanation
                    }

            ([Success a], Word, Maybe (Failure e))
-> IO ([Success a], Word, Maybe (Failure e))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DriverState a -> [Success a]
forall a. DriverState a -> [Success a]
successes DriverState a
acc, DriverState a -> Word
forall a. DriverState a -> Word
discardedTotal DriverState a
acc, Failure e -> Maybe (Failure e)
forall a. a -> Maybe a
Just Failure e
failure)

          -- Test discarded, but reached maximum already
          TestResult e a
TestDiscarded | DriverState a -> Word
forall a. DriverState a -> Word
discardedForTest DriverState a
acc Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Options -> Word
maxRatio Options
opts ->
            ([Success a], Word, Maybe (Failure e))
-> IO ([Success a], Word, Maybe (Failure e))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DriverState a -> [Success a]
forall a. DriverState a -> [Success a]
successes DriverState a
acc, DriverState a -> Word
forall a. DriverState a -> Word
discardedTotal DriverState a
acc, Maybe (Failure e)
forall a. Maybe a
Nothing)

          -- Test discarded; continue.
          TestResult e a
TestDiscarded ->
            DriverState a -> IO ([Success a], Word, Maybe (Failure e))
go (DriverState a -> IO ([Success a], Word, Maybe (Failure e)))
-> DriverState a -> IO ([Success a], Word, Maybe (Failure e))
forall a b. (a -> b) -> a -> b
$ SMGen -> DriverState a -> DriverState a
forall a. SMGen -> DriverState a -> DriverState a
withDiscard SMGen
later DriverState a
acc

{-------------------------------------------------------------------------------
  Internal: driver state
-------------------------------------------------------------------------------}

data DriverState a = DriverState {
      -- | State of the PRNG after the previously executed test
      forall a. DriverState a -> SMGen
prng :: SMGen

      -- | Accumulated successful tests
    , forall a. DriverState a -> [Success a]
successes :: [Success a]

      -- | Number of tests we discarded so far (for this test)
    , forall a. DriverState a -> Word
discardedForTest :: Word

      -- | Number of tests we discarded (in total)
    , forall a. DriverState a -> Word
discardedTotal :: Word

      -- | Current test number
    , forall a. DriverState a -> Word
thisTest :: Word
    }
  deriving (Int -> DriverState a -> ShowS
[DriverState a] -> ShowS
DriverState a -> String
(Int -> DriverState a -> ShowS)
-> (DriverState a -> String)
-> ([DriverState a] -> ShowS)
-> Show (DriverState a)
forall a. Show a => Int -> DriverState a -> ShowS
forall a. Show a => [DriverState a] -> ShowS
forall a. Show a => DriverState a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> DriverState a -> ShowS
showsPrec :: Int -> DriverState a -> ShowS
$cshow :: forall a. Show a => DriverState a -> String
show :: DriverState a -> String
$cshowList :: forall a. Show a => [DriverState a] -> ShowS
showList :: [DriverState a] -> ShowS
Show)

initDriverState :: Options -> IO (DriverState a)
initDriverState :: forall a. Options -> IO (DriverState a)
initDriverState Options
opts = do
    SMGen
prng <- case Options -> Maybe ReplaySeed
replay Options
opts of
              Just ReplaySeed{Word64
replaySeed :: Word64
replaySeed :: ReplaySeed -> Word64
replaySeed, Word64
replayGamma :: Word64
replayGamma :: ReplaySeed -> Word64
replayGamma} ->
                SMGen -> IO SMGen
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SMGen -> IO SMGen) -> SMGen -> IO SMGen
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> SMGen
seedSMGen Word64
replaySeed Word64
replayGamma
              Maybe ReplaySeed
Nothing ->
                IO SMGen
initSMGen
    DriverState a -> IO (DriverState a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DriverState a -> IO (DriverState a))
-> DriverState a -> IO (DriverState a)
forall a b. (a -> b) -> a -> b
$ DriverState {
        SMGen
prng :: SMGen
prng :: SMGen
prng
      , successes :: [Success a]
successes        = []
      , discardedForTest :: Word
discardedForTest = Word
0
      , discardedTotal :: Word
discardedTotal   = Word
0
      , thisTest :: Word
thisTest         = Word
1
      }

withSuccess :: SMGen -> Success a -> DriverState a -> DriverState a
withSuccess :: forall a. SMGen -> Success a -> DriverState a -> DriverState a
withSuccess SMGen
next Success a
success DriverState a
acc = DriverState {
      prng :: SMGen
prng             = SMGen
next
    , successes :: [Success a]
successes        = Success a
success Success a -> [Success a] -> [Success a]
forall a. a -> [a] -> [a]
: DriverState a -> [Success a]
forall a. DriverState a -> [Success a]
successes DriverState a
acc
    , discardedForTest :: Word
discardedForTest = Word
0 -- reset for the next test
    , discardedTotal :: Word
discardedTotal   = DriverState a -> Word
forall a. DriverState a -> Word
discardedTotal DriverState a
acc
    , thisTest :: Word
thisTest         = Word -> Word
forall a. Enum a => a -> a
succ (DriverState a -> Word
forall a. DriverState a -> Word
thisTest DriverState a
acc)
    }

withDiscard :: SMGen -> DriverState a -> DriverState a
withDiscard :: forall a. SMGen -> DriverState a -> DriverState a
withDiscard SMGen
next DriverState a
acc = DriverState {
      prng :: SMGen
prng             = SMGen
next
    , successes :: [Success a]
successes        = DriverState a -> [Success a]
forall a. DriverState a -> [Success a]
successes DriverState a
acc
    , discardedForTest :: Word
discardedForTest = Word -> Word
forall a. Enum a => a -> a
succ (Word -> Word) -> Word -> Word
forall a b. (a -> b) -> a -> b
$ DriverState a -> Word
forall a. DriverState a -> Word
discardedForTest DriverState a
acc
    , discardedTotal :: Word
discardedTotal   = Word -> Word
forall a. Enum a => a -> a
succ (Word -> Word) -> Word -> Word
forall a b. (a -> b) -> a -> b
$ DriverState a -> Word
forall a. DriverState a -> Word
discardedTotal DriverState a
acc
    , thisTest :: Word
thisTest         = DriverState a -> Word
forall a. DriverState a -> Word
thisTest DriverState a
acc
    }

{-------------------------------------------------------------------------------
  Process results
-------------------------------------------------------------------------------}

-- | Verbose output
--
-- Note that if a test fails (and we were not expecting failure) we show the
-- logs independent of verbosity.
data Verbose = Verbose | NotVerbose

-- | Do we expect the property to fail?
--
-- If v'ExpectFailure', the test will fail if the property does /not/ fail.
-- Note that if we expect failure for a property, then we can stop at the first
-- failed test; the number of tests to run for the property becomes a maximum
-- rather than a goal.
data ExpectFailure = ExpectFailure | DontExpectFailure

-- | Test outcome as it should be shown to the user
--
-- The rendered test outcome can usually be used directly in test framework
-- integration. For example, the @tasty@ integration uses
--
-- > toTastyResult :: RenderedTestOutcome -> Tasty.Result
-- > toTastyResult RenderedTestOutcome{testPassed, testOutput}
-- >   | testPassed = Tasty.testPassed testOutput
-- >   | otherwise  = Tasty.testFailed testOutput
data RenderedTestOutcome = RenderedTestOutcome {
      RenderedTestOutcome -> Bool
testPassed :: Bool
    , RenderedTestOutcome -> String
testOutput :: String
    }

-- | Render test outcome
--
-- See t'RenderedTestOutcome' for discussion.
renderTestOutcome ::
     Verbose
  -> ExpectFailure
  -> TestOutcome ()
  -> RenderedTestOutcome
renderTestOutcome :: Verbose -> ExpectFailure -> TestOutcome () -> RenderedTestOutcome
renderTestOutcome
      Verbose
verbose
      ExpectFailure
expectFailure
      (TestOutcome ReplaySeed
initSeed [Success ()]
successes Word
discarded Maybe (Failure String)
mFailure) =
    case (Verbose
verbose, ExpectFailure
expectFailure, Maybe (Failure String)
mFailure) of

      --
      -- All tests discarded
      --
      -- TODO: Verbose mode here does nothing currently (we get no logs for
      -- discarded tests).
      --

      (Verbose
_, ExpectFailure
DontExpectFailure, Maybe (Failure String)
Nothing) | [Success ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Success ()]
successes -> RenderedTestOutcome {
            testPassed :: Bool
testPassed = Bool
False
          , testOutput :: String
testOutput = [String] -> String
unlines [
                [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                    String
"All tests discarded"
                  , String
countDiscarded
                  ]
              ]
          }

      --
      -- Test succeeded
      --
      -- This may still be a failure, if we were expecting the test not to
      -- succeed.
      --

      (Verbose
NotVerbose, ExpectFailure
DontExpectFailure, Maybe (Failure String)
Nothing) -> RenderedTestOutcome {
             testPassed :: Bool
testPassed = Bool
True
           , testOutput :: String
testOutput = [String] -> String
unlines [
                 [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                     String
countSuccess
                   , String
countDiscarded
                   ]
               , String
showLabels
               ]
           }

      (Verbose
Verbose, ExpectFailure
DontExpectFailure, Maybe (Failure String)
Nothing) -> RenderedTestOutcome {
             testPassed :: Bool
testPassed = Bool
True
           , testOutput :: String
testOutput = [String] -> String
unlines [
                 [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                     String
countSuccess
                   , String
countDiscarded
                   ]
               , String
""
               , String
"Logs for each test run below."
               , String
""
               , [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Success () -> String) -> [Success ()] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Success () -> String
renderSuccess [Success ()]
successes
               ]
           }

      (Verbose
NotVerbose, ExpectFailure
ExpectFailure, Maybe (Failure String)
Nothing) -> RenderedTestOutcome {
             testPassed :: Bool
testPassed = Bool
False
           , testOutput :: String
testOutput = [String] -> String
unlines [
                 String
"Expected failure, but " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
countAll String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" passed"
               , ReplaySeed -> String
showSeed ReplaySeed
initSeed
               ]
           }

      (Verbose
Verbose, ExpectFailure
ExpectFailure, Maybe (Failure String)
Nothing) -> RenderedTestOutcome {
             testPassed :: Bool
testPassed = Bool
False
           , testOutput :: String
testOutput = [String] -> String
unlines [
                 String
"Expected failure, but " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
countAll String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" passed"
               , String
""
               , String
"Logs for each test run below."
               , String
""
               , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Success () -> String) -> [Success ()] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Success () -> String
renderSuccess [Success ()]
successes
               , ReplaySeed -> String
showSeed ReplaySeed
initSeed
               ]
           }

      --
      -- Test failed
      --
      -- This might still mean the test passed, if we /expected/ failure.
      --
      -- If the test failed and we were not expecting failure, we show the
      -- logs independent of verbosity.
      --

      (Verbose
NotVerbose, ExpectFailure
ExpectFailure, Just Failure String
e) -> RenderedTestOutcome {
             testPassed :: Bool
testPassed = Bool
True
           , testOutput :: String
testOutput = [String] -> String
unlines [
                 [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                     String
"expected failure after "
                   , NonEmpty (Counterexample String) -> String
countHistory NonEmpty (Counterexample String)
history
                   , String
countDiscarded
                   ]
               , Counterexample String -> String
forall e. Counterexample e -> e
counterexampleError (Counterexample String -> String)
-> Counterexample String -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty (Counterexample String) -> Counterexample String
forall a. NonEmpty a -> a
NE.last NonEmpty (Counterexample String)
history
               ]
           }
         where
           history :: NonEmpty (Counterexample String)
history = ShrinkExplanation (Counterexample String) TestRun
-> NonEmpty (Counterexample String)
forall p n. ShrinkExplanation p n -> NonEmpty p
shrinkHistory (Failure String -> ShrinkExplanation (Counterexample String) TestRun
forall e. Failure e -> ShrinkExplanation (Counterexample e) TestRun
failureRun Failure String
e)

      (Verbose
Verbose, ExpectFailure
ExpectFailure, Just Failure String
e) -> RenderedTestOutcome {
             testPassed :: Bool
testPassed = Bool
True
           , testOutput :: String
testOutput = [String] -> String
unlines [
                 [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                     String
"expected failure after "
                   , NonEmpty (Counterexample String) -> String
countHistory NonEmpty (Counterexample String)
history
                   , String
countDiscarded
                   ]
               , Counterexample String -> String
forall e. Counterexample e -> e
counterexampleError (Counterexample String -> String)
-> Counterexample String -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty (Counterexample String) -> Counterexample String
forall a. NonEmpty a -> a
NE.last NonEmpty (Counterexample String)
history
               , String
"Logs for failed test run:"
               , Log -> String
renderLog (Log -> String)
-> (Counterexample String -> Log)
-> Counterexample String
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestRun -> Log
runLog (TestRun -> Log)
-> (Counterexample String -> TestRun)
-> Counterexample String
-> Log
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Counterexample String -> TestRun
forall e. Counterexample e -> TestRun
counterexampleRun (Counterexample String -> String)
-> Counterexample String -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty (Counterexample String) -> Counterexample String
forall a. NonEmpty a -> a
NE.last NonEmpty (Counterexample String)
history
               ]
           }
         where
           history :: NonEmpty (Counterexample String)
history = ShrinkExplanation (Counterexample String) TestRun
-> NonEmpty (Counterexample String)
forall p n. ShrinkExplanation p n -> NonEmpty p
shrinkHistory (Failure String -> ShrinkExplanation (Counterexample String) TestRun
forall e. Failure e -> ShrinkExplanation (Counterexample e) TestRun
failureRun Failure String
e)

      (Verbose
NotVerbose, ExpectFailure
DontExpectFailure, Just Failure String
e) -> RenderedTestOutcome {
             testPassed :: Bool
testPassed = Bool
False
           , testOutput :: String
testOutput = [String] -> String
unlines [
                 String
"failed after " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NonEmpty (Counterexample String) -> String
countHistory NonEmpty (Counterexample String)
history
               , Counterexample String -> String
forall e. Counterexample e -> e
counterexampleError (Counterexample String -> String)
-> Counterexample String -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty (Counterexample String) -> Counterexample String
forall a. NonEmpty a -> a
NE.last NonEmpty (Counterexample String)
history
               , String
"Logs for failed test run:"
               , Log -> String
renderLog (Log -> String)
-> (Counterexample String -> Log)
-> Counterexample String
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestRun -> Log
runLog (TestRun -> Log)
-> (Counterexample String -> TestRun)
-> Counterexample String
-> Log
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Counterexample String -> TestRun
forall e. Counterexample e -> TestRun
counterexampleRun (Counterexample String -> String)
-> Counterexample String -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty (Counterexample String) -> Counterexample String
forall a. NonEmpty a -> a
NE.last NonEmpty (Counterexample String)
history
               , ReplaySeed -> String
showSeed (ReplaySeed -> String) -> ReplaySeed -> String
forall a b. (a -> b) -> a -> b
$ Failure String -> ReplaySeed
forall e. Failure e -> ReplaySeed
failureSeed Failure String
e
               ]
           }
         where
           history :: NonEmpty (Counterexample String)
history = ShrinkExplanation (Counterexample String) TestRun
-> NonEmpty (Counterexample String)
forall p n. ShrinkExplanation p n -> NonEmpty p
shrinkHistory (Failure String -> ShrinkExplanation (Counterexample String) TestRun
forall e. Failure e -> ShrinkExplanation (Counterexample e) TestRun
failureRun Failure String
e)

      (Verbose
Verbose, ExpectFailure
DontExpectFailure, Just Failure String
e) -> RenderedTestOutcome {
             testPassed :: Bool
testPassed = Bool
False
           , testOutput :: String
testOutput = [String] -> String
unlines [
                 String
"failed after " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NonEmpty (Counterexample String) -> String
countHistory NonEmpty (Counterexample String)
history
               , Counterexample String -> String
forall e. Counterexample e -> e
counterexampleError (Counterexample String -> String)
-> Counterexample String -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty (Counterexample String) -> Counterexample String
forall a. NonEmpty a -> a
NE.last NonEmpty (Counterexample String)
history
               , String
""
               , String
"Logs for complete shrink history:"
               , String
""
               , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
                     String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [
                         Execution -> String
showStep (Counterexample String -> Execution
forall e. Counterexample e -> Execution
counterexampleContext Counterexample String
example)
                       , Log -> String
renderLog (TestRun -> Log
runLog (TestRun -> Log) -> TestRun -> Log
forall a b. (a -> b) -> a -> b
$ Counterexample String -> TestRun
forall e. Counterexample e -> TestRun
counterexampleRun Counterexample String
example)
                       ]
                   | Counterexample String
example <- NonEmpty (Counterexample String) -> [Counterexample String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Counterexample String)
history
                   ]
               , ReplaySeed -> String
showSeed (ReplaySeed -> String) -> ReplaySeed -> String
forall a b. (a -> b) -> a -> b
$ Failure String -> ReplaySeed
forall e. Failure e -> ReplaySeed
failureSeed Failure String
e
               ]
           }
         where
           history :: NonEmpty (Counterexample String)
history = ShrinkExplanation (Counterexample String) TestRun
-> NonEmpty (Counterexample String)
forall p n. ShrinkExplanation p n -> NonEmpty p
shrinkHistory (Failure String -> ShrinkExplanation (Counterexample String) TestRun
forall e. Failure e -> ShrinkExplanation (Counterexample e) TestRun
failureRun Failure String
e)
  where
    countSuccess, countDiscarded, countAll :: String
    countSuccess :: String
countSuccess
      | [Success ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Success ()]
successes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = String
"1 successful test"
      | Bool
otherwise             = Int -> String
forall a. Show a => a -> String
show ([Success ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Success ()]
successes) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" successful tests"
    countDiscarded :: String
countDiscarded
      | Word
discarded Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0        = String
""
      | Bool
otherwise             = String
" (discarded " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
discarded String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    countAll :: String
countAll
      | [Success ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Success ()]
successes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = String
"the test"
      | Bool
otherwise             = String
"all " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Success ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Success ()]
successes) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" tests"

    -- The history includes the original value, so the number of shrink steps
    -- is the length of the history minus 1.
    countHistory :: NonEmpty (Counterexample String) -> [Char]
    countHistory :: NonEmpty (Counterexample String) -> String
countHistory NonEmpty (Counterexample String)
history = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
          if | [Success ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Success ()]
successes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> String
""
             | Bool
otherwise             -> String
countSuccess String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and "
        , if | Word
numShrinks Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
1 -> String
"1 shrink"
             | Bool
otherwise       -> Word -> String
forall a. Show a => a -> String
show Word
numShrinks String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" shrinks"
        ]
      where
        numShrinks :: Word
        numShrinks :: Word
numShrinks =
            case Counterexample String -> Execution
forall e. Counterexample e -> Execution
counterexampleContext (Counterexample String -> Execution)
-> Counterexample String -> Execution
forall a b. (a -> b) -> a -> b
$ NonEmpty (Counterexample String) -> Counterexample String
forall a. NonEmpty a -> a
NE.last NonEmpty (Counterexample String)
history of
              Context.Final Word
i ->
                -- Under normal circumstances this is the only expected case
                Word
i
              Execution
Context.Initial ->
                -- No shrinking steps at all
                Word
0
              Context.Shrinking Word
i ->
                -- @i@ here is the index of the step, not the number of steps
                Word
i Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1


    showSeed :: ReplaySeed -> String
    showSeed :: ReplaySeed -> String
showSeed ReplaySeed
seed = String
"Use --falsify-replay=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ReplaySeed -> String
forall a. Show a => a -> String
show ReplaySeed
seed String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to replay."

    showLabels :: String
    showLabels :: String
showLabels = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [
          String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String
"\nLabel " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [
              Int -> String
asPct Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
v
            | String
v <- Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> String -> Map String (Set String) -> Set String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set String
forall a. Set a
Set.empty String
l Map String (Set String)
allValues)
            , let n :: Int
n = Int -> String -> Map String Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0         String
v
                    (Map String Int -> Int) -> Map String Int -> Int
forall a b. (a -> b) -> a -> b
$ Map String Int
-> String -> Map String (Map String Int) -> Map String Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map String Int
forall k a. Map k a
Map.empty String
l
                    (Map String (Map String Int) -> Map String Int)
-> Map String (Map String Int) -> Map String Int
forall a b. (a -> b) -> a -> b
$ Map String (Map String Int)
perTest
            ]
        | String
l <- Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
allLabels
        ]
      where
        -- Absolute number of tests as a percentage of total successes
        asPct :: Int -> String
        asPct :: Int -> String
asPct Int
n =
           String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"  %8.4f%%" Double
pct
          where
            pct :: Double
            pct :: Double
pct = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Success ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Success ()]
successes) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
100

        -- All labels across all tests
        allLabels :: Set String
        allLabels :: Set String
allLabels = Map String (Set String) -> Set String
forall k a. Map k a -> Set k
Map.keysSet Map String (Set String)
allValues

        -- For each label, all values reported across all tests
        allValues :: Map String (Set String)
        allValues :: Map String (Set String)
allValues =
            (Set String -> Set String -> Set String)
-> [Map String (Set String)] -> Map String (Set String)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Map String (Set String)] -> Map String (Set String))
-> [Map String (Set String)] -> Map String (Set String)
forall a b. (a -> b) -> a -> b
$
              (Success () -> Map String (Set String))
-> [Success ()] -> [Map String (Set String)]
forall a b. (a -> b) -> [a] -> [b]
map (TestRun -> Map String (Set String)
runLabels (TestRun -> Map String (Set String))
-> (Success () -> TestRun) -> Success () -> Map String (Set String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Success () -> TestRun
forall a. Success a -> TestRun
successRun) [Success ()]
successes

        -- For each label and each value, the corresponding number of tests
        perTest :: Map String (Map String Int)
        perTest :: Map String (Map String Int)
perTest =
            [(String, Map String Int)] -> Map String (Map String Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
                (String
l, [(String, Int)] -> Map String Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
                    (String
v, [Success ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Success ()] -> Int) -> [Success ()] -> Int
forall a b. (a -> b) -> a -> b
$ (Success () -> Bool) -> [Success ()] -> [Success ()]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Success () -> Bool
labelHasValue String
l String
v) [Success ()]
successes)
                  | String
v <- Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$
                             Set String -> String -> Map String (Set String) -> Set String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set String
forall a. Set a
Set.empty String
l Map String (Set String)
allValues
                  ])
              | String
l <- Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
allLabels
              ]

        -- Check if in particular test run label @l@ has value @v@
        labelHasValue :: String -> String -> Success () -> Bool
        labelHasValue :: String -> String -> Success () -> Bool
labelHasValue String
l String
v =
              String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
v
            (Set String -> Bool)
-> (Success () -> Set String) -> Success () -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set String -> String -> Map String (Set String) -> Set String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set String
forall a. Set a
Set.empty String
l
            (Map String (Set String) -> Set String)
-> (Success () -> Map String (Set String))
-> Success ()
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestRun -> Map String (Set String)
runLabels
            (TestRun -> Map String (Set String))
-> (Success () -> TestRun) -> Success () -> Map String (Set String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Success () -> TestRun
forall a. Success a -> TestRun
successRun

    showStep :: Context.Execution -> [Char]
    showStep :: Execution -> String
showStep = \case
        Execution
Context.Initial ->
          String
"Initial counter-example"
        Context.Shrinking Word
i ->
          String
"Shrinking step " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
i
        Context.Final Word
i ->
          String
"Final counter-example after " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" shrink steps"

renderSuccess :: Success () -> String
renderSuccess :: Success () -> String
renderSuccess Success{Iteration
successIteration :: forall a. Success a -> Iteration
successIteration :: Iteration
successIteration, TestRun
successRun :: forall a. Success a -> TestRun
successRun :: TestRun
successRun} =
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String)
-> ([[String]] -> [String]) -> [[String]] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> String) -> [[String]] -> String
forall a b. (a -> b) -> a -> b
$ [
        [String
"Test " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show (Iteration -> Word
Context.thisTest Iteration
successIteration)]
      , [Log -> String
renderLog (Log -> String) -> Log -> String
forall a b. (a -> b) -> a -> b
$ TestRun -> Log
runLog TestRun
successRun]
      ]

renderLog :: Log -> String
renderLog :: Log -> String
renderLog (Log [LogEntry]
log) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (LogEntry -> String) -> [LogEntry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LogEntry -> String
renderLogEntry ([LogEntry] -> [LogEntry]
forall a. [a] -> [a]
reverse [LogEntry]
log)

renderLogEntry :: LogEntry -> String
renderLogEntry :: LogEntry -> String
renderLogEntry = \case
    Generated CallStack
stack String
x -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
        String
"generated "
      , String
x
      , String
" at "
      , CallStack -> String
prettyCallStack CallStack
stack
      ]
    Info String
x -> String
x