quickcheck-silent-0.11.0.16: src/Test/QuickCheck/Silent.hs
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveDataTypeable #-}
--------------------------------------------------------------------------------
-- |
-- Copyright : (c) 2026 SPISE MISU ApS
-- License : LGPL-3.0-only
-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>
-- Stability : experimental
--
-- Testing with QuickCheck in silence
--------------------------------------------------------------------------------
module Test.QuickCheck.Silent
( -- * Declaring tests
Test (Case, Group)
, Label
-- * Property without IO
, SilentProp ()
, property
, silent
, withNumTests
-- * Running tests
, Status(..)
, Result(..)
, JSON
, quickCheckSilent
, quickCheckSilentSuite
, quickCheckSilentSuiteJSON
, isSuccess
)
where
--------------------------------------------------------------------------------
import Data.Data ( Data )
import Data.List ( isPrefixOf )
import qualified Test.QuickCheck as QC
import Test.QuickCheck
( Property
, Testable
, chatty
, stdArgs
)
import Internal.GaloisInc.Text.JSON.Generic ( encodeJSON )
--------------------------------------------------------------------------------
-- | A `Testable` silent property.
newtype SilentProp =
SilentProp
{ property :: Property
-- ^ Unwrap the the silent property.
}
--------------------------------------------------------------------------------
-- | A name or description for a case or a subtree of the @Test@s.
type Label = String
-- | The basic structure used to create an annotated tree of test cases.
data Test
-- | A set of @Test@s sharing the same level in the hierarchy.
= Group !Label ![Test]
-- | A single, independent test case composed.
| Case !Label !SilentProp
--------------------------------------------------------------------------------
-- | Status represents the outcome of a test
data Status
-- | A successful test run
= Success
-- | A failed test run
| Failure
-- | Given up
| Desisted
-- | A property that should have failed did not
| NoFailure
deriving (Data, Show)
-- | Result represents the test result
data Result =
Result
{ status :: !Status
-- ^ Outcome of the test
, numTests :: !Int
-- ^ Number of tests performed
, numDiscarded :: !Int
-- ^ Number of tests skipped
, numShrinks :: !Int
-- ^ Number of successful shrinking steps performed
, numShrinkTries :: !Int
-- ^ Number of unsuccessful shrinking steps performed
, numShrinkFinal :: !Int
-- ^ Number of unsuccessful shrinking steps performed since last successful shrink
, usedSeed :: !String
-- ^ What seed was used
, usedSize :: !Int
-- ^ What was the test size
, output :: !String
-- ^ Non-printed output
, reason :: !String
-- ^ If the property failed, why?
, theException :: !String
-- ^ The exception the property threw, if any
}
deriving (Data, Show)
data LabelResultJSON =
LabelResultJSON
{ label :: !Label
, result :: !Result
}
deriving (Data, Show)
-- | A 'JSON' payload string that represents the test 'Result' with its
-- respective 'Label'
--
-- > { "label": "…", "result": { "status": "…", …, "theException": "…" } }
type JSON = String
--------------------------------------------------------------------------------
-- | Convert a `Testable` thing, without 'System.IO.IO' effects, to a silent
-- property.
silent
:: Testable prop
=> prop
-> SilentProp
silent =
SilentProp . QC.property
-- | Configures how many times a silent property will be tested.
--
-- For example,
--
-- > quickCheckSilent [withNumTests 1000 p]
--
-- will test @p@ up to 1000 times.
withNumTests
:: Testable prop
=> Int
-> prop
-> SilentProp
withNumTests n =
SilentProp . QC.withNumTests n
--------------------------------------------------------------------------------
-- | Tests a sequence of silent properties, producing a list of results, without
-- printing them to 'System.IO.stdout'.
quickCheckSilent
:: [SilentProp]
-> IO [Result]
quickCheckSilent =
mapM (\ p -> resultAux <$> (aux . property) p)
where
aux =
QC.quickCheckWithResult $ stdArgs { chatty = False }
-- | Tests a suite of silent properties, producing a list of results with their
-- respective labels and without printing them to 'System.IO.stdout'.
--
-- For example,
--
-- > check =
-- > quickCheckSilentSuite sep pts tcs
-- > where
-- > sep = '.'
-- > pts = [ "Test.QuickCheck.Silent" ]
-- > tcs =
-- > Group "Test"
-- > [ Group "QuickCheck"
-- > [ Group "Silent"
-- > [ Case "foo" (withNumTests 100 p)
-- > , Case "bar" (withNumTests 1000 q)
-- > ]
-- > , Group "OtherModule"
-- > [ Case "baz" (withNumTests 10 r)
-- > ]
-- > ]
-- > ]
--
-- will test both @p@ and @q@, but not @r@.
--
-- The provided @patterns@, will be checked if they are a 'Data.List.isPrefixOf'
-- of each @label@:
--
-- > any (`isPrefixOf` label) [ pattern_0, pattern_1, … pattern_n ]
--
-- @NOTE@: To test all cases, just provide a singleton list with an empty string
-- element as @pattern@ as it's a prefix for all possible @labels@.
quickCheckSilentSuite
:: Char
-> [String]
-> Test
-> IO [(Label, Result)]
quickCheckSilentSuite sep pts suite =
mapM
( \ (l, sp) ->
(aux . property) sp >>= \ r ->
pure (l, resultAux r)
)
$ filter ( \(l, _) -> any (`isPrefixOf` l) pts)
$ dfs [] suite
where
dfs [ ] (Group l ts) = concatMap (dfs l) ts
dfs acc (Group l ts) = concatMap (dfs (acc ++ [sep] ++ l)) ts
dfs [ ] (Case l p) = [ ( l, p)]
dfs acc (Case l p) = [ (acc ++ [sep] ++ l, p)]
aux =
QC.quickCheckWithResult $ stdArgs { chatty = False }
-- | Same behavior as 'quickCheckSilentSuite', but, producing a list of 'JSON'
-- data payloads instead.
quickCheckSilentSuiteJSON
:: Char
-> [String]
-> Test
-> IO [JSON]
quickCheckSilentSuiteJSON sep pts suite =
map
( \ (l, r) ->
encodeJSON $ LabelResultJSON l r
)
<$> quickCheckSilentSuite sep pts suite
-- | Check if the test run result was a success
isSuccess :: Result -> Bool
isSuccess Result { status = Success } = True
isSuccess ___________________________ = False
--------------------------------------------------------------------------------
-- HELPERS
resultAux
:: QC.Result
-> Result
resultAux res =
case res of
QC.Success t d _ _ _ o ->
Result
{ status = Success
, Test.QuickCheck.Silent.numTests = t
, Test.QuickCheck.Silent.numDiscarded = d
, Test.QuickCheck.Silent.numShrinks = 0
, Test.QuickCheck.Silent.numShrinkTries = 0
, Test.QuickCheck.Silent.numShrinkFinal = 0
, Test.QuickCheck.Silent.usedSeed = []
, Test.QuickCheck.Silent.usedSize = 0
, Test.QuickCheck.Silent.output = o
, Test.QuickCheck.Silent.reason = []
, Test.QuickCheck.Silent.theException = []
}
QC.GaveUp t d _ _ _ o ->
Result
{ status = Desisted
, Test.QuickCheck.Silent.numTests = t
, Test.QuickCheck.Silent.numDiscarded = d
, Test.QuickCheck.Silent.numShrinks = 0
, Test.QuickCheck.Silent.numShrinkTries = 0
, Test.QuickCheck.Silent.numShrinkFinal = 0
, Test.QuickCheck.Silent.usedSeed = []
, Test.QuickCheck.Silent.usedSize = 0
, Test.QuickCheck.Silent.output = o
, Test.QuickCheck.Silent.reason = []
, Test.QuickCheck.Silent.theException = []
}
QC.Failure t d ss st sf se si r e o _ _ _ _ ->
Result
{ status = Failure
, Test.QuickCheck.Silent.numTests = t
, Test.QuickCheck.Silent.numDiscarded = d
, Test.QuickCheck.Silent.numShrinks = ss
, Test.QuickCheck.Silent.numShrinkTries = st
, Test.QuickCheck.Silent.numShrinkFinal = sf
, Test.QuickCheck.Silent.usedSeed = show se
, Test.QuickCheck.Silent.usedSize = si
, Test.QuickCheck.Silent.output = o
, Test.QuickCheck.Silent.reason = r
, Test.QuickCheck.Silent.theException = maybe [] show e
}
QC.NoExpectedFailure t d _ _ _ o ->
Result
{ status = NoFailure
, Test.QuickCheck.Silent.numTests = t
, Test.QuickCheck.Silent.numDiscarded = d
, Test.QuickCheck.Silent.numShrinks = 0
, Test.QuickCheck.Silent.numShrinkTries = 0
, Test.QuickCheck.Silent.numShrinkFinal = 0
, Test.QuickCheck.Silent.usedSeed = []
, Test.QuickCheck.Silent.usedSize = 0
, Test.QuickCheck.Silent.output = o
, Test.QuickCheck.Silent.reason = []
, Test.QuickCheck.Silent.theException = []
}