{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

-- NoFieldSelectors is implemented in GHC 9.2.2, but HLS doesn’t support it
-- {-# LANGUAGE NoFieldSelectors #-}

-- |
-- Module:       Distribution.TestSuite.QuickCheck
-- Description:  Convert QuickCheck properties into Cabal tests
-- Copyright:    ⓒ Anselm Schüler 2022
-- License:      MIT
-- Maintainer:   Anselm Schüler <mail@anselmschueler.com>
-- Stability:    stable
-- Portability:  Portable
--
-- This module allows you to easily make Cabal tests for the @detailed-0.9@ interface. ([docs](https://cabal.readthedocs.io/en/3.6/cabal-package.html#example-package-using-detailed-0-9-interface))
-- It sets sensible option declarations for the tests.
--
-- This module re-uses record names from "Distribution.TestSuite" and "Test.QuickCheck".
-- It is recommended that you enable the [@DisambiguateRecordFields@](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/disambiguate_record_fields.html) extension in GHC and/or import the module qualified.
-- For basic tests, you don’t need to import "Distribution.TestSuite".
module Distribution.TestSuite.QuickCheck
  ( -- * Create tests
    getPropertyTest,
    getPropertyTestWith,
    getPropertyTestUsing,
    getPropertyTestWithUsing,
    getPropertyTests,
    propertyTestGroup,

    -- * Argument data types
    PropertyTest (..),
    TestArgs (..),
    Verbosity (..),

    -- * Functions for using arguments
    argsToTestArgs,
    testArgsToArgs,
    stdTestArgs,
  )
where

import Data.Bool (bool)
import Data.Functor ((<&>))
import qualified Distribution.TestSuite as T
import qualified Test.QuickCheck as QC
import Text.Read (readMaybe)

-- | Datatype for setting the verbosity of tests
data Verbosity
  = -- | QuickCheck prints nothing. This sets @'QC.chatty' = 'False'@.
    Silent
  | -- | Print basic statistics. This sets @'QC.chatty' = 'True'@.
    Chatty
  | -- | Print every test case. This applies 'QC.verbose'.
    Verbose
  deriving
    ( Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq,
      -- | 'Silent' < 'Chatty' < 'Verbose'
      Eq Verbosity
Eq Verbosity
-> (Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
Ord,
      Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show,
      ReadPrec [Verbosity]
ReadPrec Verbosity
Int -> ReadS Verbosity
ReadS [Verbosity]
(Int -> ReadS Verbosity)
-> ReadS [Verbosity]
-> ReadPrec Verbosity
-> ReadPrec [Verbosity]
-> Read Verbosity
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Verbosity]
$creadListPrec :: ReadPrec [Verbosity]
readPrec :: ReadPrec Verbosity
$creadPrec :: ReadPrec Verbosity
readList :: ReadS [Verbosity]
$creadList :: ReadS [Verbosity]
readsPrec :: Int -> ReadS Verbosity
$creadsPrec :: Int -> ReadS Verbosity
Read,
      Int -> Verbosity
Verbosity -> Int
Verbosity -> [Verbosity]
Verbosity -> Verbosity
Verbosity -> Verbosity -> [Verbosity]
Verbosity -> Verbosity -> Verbosity -> [Verbosity]
(Verbosity -> Verbosity)
-> (Verbosity -> Verbosity)
-> (Int -> Verbosity)
-> (Verbosity -> Int)
-> (Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> Verbosity -> [Verbosity])
-> Enum Verbosity
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Verbosity -> Verbosity -> Verbosity -> [Verbosity]
$cenumFromThenTo :: Verbosity -> Verbosity -> Verbosity -> [Verbosity]
enumFromTo :: Verbosity -> Verbosity -> [Verbosity]
$cenumFromTo :: Verbosity -> Verbosity -> [Verbosity]
enumFromThen :: Verbosity -> Verbosity -> [Verbosity]
$cenumFromThen :: Verbosity -> Verbosity -> [Verbosity]
enumFrom :: Verbosity -> [Verbosity]
$cenumFrom :: Verbosity -> [Verbosity]
fromEnum :: Verbosity -> Int
$cfromEnum :: Verbosity -> Int
toEnum :: Int -> Verbosity
$ctoEnum :: Int -> Verbosity
pred :: Verbosity -> Verbosity
$cpred :: Verbosity -> Verbosity
succ :: Verbosity -> Verbosity
$csucc :: Verbosity -> Verbosity
Enum,
      Verbosity
Verbosity -> Verbosity -> Bounded Verbosity
forall a. a -> a -> Bounded a
maxBound :: Verbosity
$cmaxBound :: Verbosity
minBound :: Verbosity
$cminBound :: Verbosity
Bounded
    )

-- ! [PARTIAL] This function fails when passed Silent
switchVerbosity :: Verbosity -> Bool -> Verbosity -> Verbosity
switchVerbosity :: Verbosity -> Bool -> Verbosity -> Verbosity
switchVerbosity Verbosity
v' Bool
q Verbosity
v = (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Bool
-> Verbosity
-> Verbosity
-> Verbosity
forall a. a -> a -> Bool -> a
bool Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
max Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
min Bool
q Verbosity
v (Verbosity -> Verbosity) -> Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ (Verbosity -> Verbosity)
-> (Verbosity -> Verbosity) -> Bool -> Verbosity -> Verbosity
forall a. a -> a -> Bool -> a
bool Verbosity -> Verbosity
forall a. a -> a
id Verbosity -> Verbosity
forall a. Enum a => a -> a
pred Bool
q Verbosity
v'

-- | Arguments for altering property test behaviour.
--   These can be altered in the final Cabal 'T.Test' using 'T.setOption'.
data TestArgs = TestArgs
  { -- | Verbosity for tests. See 'QC.verbose' and 'QC.chatty'.
    TestArgs -> Verbosity
verbosity :: Verbosity,
    -- TODO Consider joining verboseShrinking back into verbosity

    -- | Whether QuickCheck should print shrinks. See 'QC.verboseShrinking'.
    TestArgs -> Bool
verboseShrinking :: Bool,
    -- | Maximum discarded tests per successful test. See 'QC.maxDiscardRatio'.
    TestArgs -> Int
maxDiscardRatio :: Int,
    -- | Disable shrinking. See 'QC.noShrinking'.
    TestArgs -> Bool
noShrinking :: Bool,
    -- | Maximum number of shrink attempts. See 'QC.maxShrinks'.
    TestArgs -> Int
maxShrinks :: Int,
    -- | Maximum number of successful checks before passing. See 'QC.maxSuccess'.
    TestArgs -> Int
maxSuccess :: Int,
    -- | Maximum size of test cases. See 'QC.maxSize'.
    TestArgs -> Int
maxSize :: Int,
    -- | Scale size by an integer using 'QC.mapSize'.
    TestArgs -> Int
sizeScale :: Int
  }

-- | Transform a QuickCheck 'QC.Args' value to a 'TestArgs' value, defaulting all missing properties
argsToTestArgs :: QC.Args -> TestArgs
argsToTestArgs :: Args -> TestArgs
argsToTestArgs QC.Args {Bool
Int
Maybe (QCGen, Int)
replay :: Args -> Maybe (QCGen, Int)
maxSuccess :: Args -> Int
maxDiscardRatio :: Args -> Int
maxSize :: Args -> Int
chatty :: Args -> Bool
maxShrinks :: Args -> Int
maxShrinks :: Int
chatty :: Bool
maxSize :: Int
maxDiscardRatio :: Int
maxSuccess :: Int
replay :: Maybe (QCGen, Int)
..} =
  TestArgs
    { verbosity :: Verbosity
verbosity = if Bool
chatty then Verbosity
Chatty else Verbosity
Silent,
      verboseShrinking :: Bool
verboseShrinking = Bool
False,
      Int
maxDiscardRatio :: Int
maxDiscardRatio :: Int
maxDiscardRatio,
      noShrinking :: Bool
noShrinking = Bool
False,
      Int
maxShrinks :: Int
maxShrinks :: Int
maxShrinks,
      Int
maxSuccess :: Int
maxSuccess :: Int
maxSuccess,
      Int
maxSize :: Int
maxSize :: Int
maxSize,
      sizeScale :: Int
sizeScale = Int
1
    }

-- | Default arguments for property tests
stdTestArgs :: TestArgs
stdTestArgs :: TestArgs
stdTestArgs = Args -> TestArgs
argsToTestArgs Args
QC.stdArgs

-- | Recover arguments passed to 'QC.quickCheck' from a 'TestArgs'
testArgsToArgs :: TestArgs -> QC.Args
testArgsToArgs :: TestArgs -> Args
testArgsToArgs
  TestArgs
    { Verbosity
verbosity :: Verbosity
verbosity :: TestArgs -> Verbosity
verbosity,
      Int
maxDiscardRatio :: Int
maxDiscardRatio :: TestArgs -> Int
maxDiscardRatio,
      Int
maxShrinks :: Int
maxShrinks :: TestArgs -> Int
maxShrinks,
      Int
maxSuccess :: Int
maxSuccess :: TestArgs -> Int
maxSuccess,
      Int
maxSize :: Int
maxSize :: TestArgs -> Int
maxSize
    } =
    QC.Args
      { replay :: Maybe (QCGen, Int)
replay = Maybe (QCGen, Int)
forall a. Maybe a
Nothing,
        Int
maxSuccess :: Int
maxSuccess :: Int
maxSuccess,
        Int
maxDiscardRatio :: Int
maxDiscardRatio :: Int
maxDiscardRatio,
        Int
maxSize :: Int
maxSize :: Int
maxSize,
        chatty :: Bool
chatty = Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Chatty,
        Int
maxShrinks :: Int
maxShrinks :: Int
maxShrinks
      }

useModifiers :: QC.Testable a => TestArgs -> a -> QC.Property
useModifiers :: forall a. Testable a => TestArgs -> a -> Property
useModifiers TestArgs {Verbosity
verbosity :: Verbosity
verbosity :: TestArgs -> Verbosity
verbosity, Bool
noShrinking :: Bool
noShrinking :: TestArgs -> Bool
noShrinking, Bool
verboseShrinking :: Bool
verboseShrinking :: TestArgs -> Bool
verboseShrinking, Int
sizeScale :: Int
sizeScale :: TestArgs -> Int
sizeScale} =
  ((Property -> Property) -> (a -> Property) -> a -> Property)
-> (a -> Property) -> [Property -> Property] -> a -> Property
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Property -> Property) -> (a -> Property) -> a -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) a -> Property
forall prop. Testable prop => prop -> Property
QC.property ([Property -> Property] -> a -> Property)
-> [Property -> Property] -> a -> Property
forall a b. (a -> b) -> a -> b
$
    (Bool, Property -> Property) -> Property -> Property
forall a b. (a, b) -> b
snd
      ((Bool, Property -> Property) -> Property -> Property)
-> [(Bool, Property -> Property)] -> [Property -> Property]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Bool, Property -> Property) -> Bool)
-> [(Bool, Property -> Property)] -> [(Bool, Property -> Property)]
forall a. (a -> Bool) -> [a] -> [a]
filter
        (Bool, Property -> Property) -> Bool
forall a b. (a, b) -> a
fst
        [ (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Verbose, Property -> Property
forall prop. Testable prop => prop -> Property
QC.verbose),
          (Bool
verboseShrinking, Property -> Property
forall prop. Testable prop => prop -> Property
QC.verboseShrinking),
          (Bool
noShrinking, Property -> Property
forall prop. Testable prop => prop -> Property
QC.noShrinking),
          (Int
sizeScale Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1, (Int -> Int) -> Property -> Property
forall prop. Testable prop => (Int -> Int) -> prop -> Property
QC.mapSize (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sizeScale))
        ]

qcTestArgs :: QC.Testable a => TestArgs -> a -> IO QC.Result
qcTestArgs :: forall a. Testable a => TestArgs -> a -> IO Result
qcTestArgs TestArgs
args a
property = Args -> Property -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
QC.quickCheckWithResult (TestArgs -> Args
testArgsToArgs TestArgs
args) (TestArgs -> a -> Property
forall a. Testable a => TestArgs -> a -> Property
useModifiers TestArgs
args a
property)

switchVIn :: Verbosity -> Bool -> TestArgs -> TestArgs
switchVIn :: Verbosity -> Bool -> TestArgs -> TestArgs
switchVIn Verbosity
v' Bool
q args :: TestArgs
args@TestArgs {Verbosity
verbosity :: Verbosity
verbosity :: TestArgs -> Verbosity
verbosity} = TestArgs
args {verbosity :: Verbosity
verbosity = Verbosity -> Bool -> Verbosity -> Verbosity
switchVerbosity Verbosity
v' Bool
q Verbosity
verbosity}

setArgStr :: String -> String -> Maybe (TestArgs -> TestArgs)
setArgStr :: String -> String -> Maybe (TestArgs -> TestArgs)
setArgStr String
"silent" String
str =
  String -> Maybe Bool
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Bool
-> (Bool -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Bool
val args :: TestArgs
args@TestArgs {Verbosity
verbosity :: Verbosity
verbosity :: TestArgs -> Verbosity
verbosity} ->
    if Bool
val
      then TestArgs
args {verbosity :: Verbosity
verbosity = Verbosity
Silent}
      else TestArgs
args {verbosity :: Verbosity
verbosity = Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
max Verbosity
Chatty Verbosity
verbosity}
setArgStr String
"chatty" String
str = String -> Maybe Bool
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Bool
-> (Bool -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Verbosity -> Bool -> TestArgs -> TestArgs
switchVIn Verbosity
Chatty
setArgStr String
"verbose" String
str = String -> Maybe Bool
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Bool
-> (Bool -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Verbosity -> Bool -> TestArgs -> TestArgs
switchVIn Verbosity
Verbose
setArgStr String
"verboseShrinking" String
str =
  String -> Maybe Bool
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Bool
-> (Bool -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Bool
val TestArgs
args ->
    TestArgs
args {verboseShrinking :: Bool
verboseShrinking = Bool
val}
setArgStr String
"verbosity" String
str =
  String -> Maybe Verbosity
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Verbosity
-> (Verbosity -> TestArgs -> TestArgs)
-> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Verbosity
val TestArgs
args ->
    TestArgs
args {verbosity :: Verbosity
verbosity = Verbosity
val}
setArgStr String
"maxDiscardRatio" String
str =
  String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Int
-> (Int -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
val TestArgs
args ->
    TestArgs
args {maxDiscardRatio :: Int
maxDiscardRatio = Int
val}
setArgStr String
"noShrinking" String
str =
  String -> Maybe Bool
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Bool
-> (Bool -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Bool
val TestArgs
args ->
    TestArgs
args {noShrinking :: Bool
noShrinking = Bool
val}
setArgStr String
"shrinking" String
str =
  String -> Maybe Bool
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Bool
-> (Bool -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Bool
val TestArgs
args ->
    TestArgs
args {noShrinking :: Bool
noShrinking = Bool -> Bool
not Bool
val}
setArgStr String
"maxShrinks" String
str =
  String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Int
-> (Int -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
val TestArgs
args ->
    TestArgs
args {maxShrinks :: Int
maxShrinks = Int
val}
setArgStr String
"maxSuccess" String
str =
  String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Int
-> (Int -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
val TestArgs
args ->
    TestArgs
args {maxSuccess :: Int
maxSuccess = Int
val}
setArgStr String
"maxSize" String
str =
  String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Int
-> (Int -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
val TestArgs
args ->
    TestArgs
args {maxSize :: Int
maxSize = Int
val}
setArgStr String
"sizeScale" String
str =
  String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
str Maybe Int
-> (Int -> TestArgs -> TestArgs) -> Maybe (TestArgs -> TestArgs)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
val TestArgs
args ->
    TestArgs
args {sizeScale :: Int
sizeScale = Int
val}
setArgStr String
_ String
_ = Maybe (TestArgs -> TestArgs)
forall a. Maybe a
Nothing

positiveIntType :: T.OptionType
positiveIntType :: OptionType
positiveIntType =
  T.OptionNumber
    { optionNumberIsInt :: Bool
optionNumberIsInt = Bool
True,
      optionNumberBounds :: (Maybe String, Maybe String)
optionNumberBounds = (String -> Maybe String
forall a. a -> Maybe a
Just String
"1", Maybe String
forall a. Maybe a
Nothing)
    }

getOptionDescrs :: TestArgs -> [T.OptionDescr]
getOptionDescrs :: TestArgs -> [OptionDescr]
getOptionDescrs TestArgs {Bool
Int
Verbosity
sizeScale :: Int
maxSize :: Int
maxSuccess :: Int
maxShrinks :: Int
noShrinking :: Bool
maxDiscardRatio :: Int
verboseShrinking :: Bool
verbosity :: Verbosity
sizeScale :: TestArgs -> Int
maxSize :: TestArgs -> Int
maxSuccess :: TestArgs -> Int
maxShrinks :: TestArgs -> Int
noShrinking :: TestArgs -> Bool
maxDiscardRatio :: TestArgs -> Int
verboseShrinking :: TestArgs -> Bool
verbosity :: TestArgs -> Verbosity
..} =
  [ T.OptionDescr
      { optionName :: String
optionName = String
"silent",
        optionDescription :: String
optionDescription = String
"Suppress QuickCheck output",
        optionType :: OptionType
optionType = OptionType
T.OptionBool,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (Bool -> String) -> Bool -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show (Bool -> Maybe String) -> Bool -> Maybe String
forall a b. (a -> b) -> a -> b
$ Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Silent
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"chatty",
        optionDescription :: String
optionDescription = String
"Print QuickCheck output",
        optionType :: OptionType
optionType = OptionType
T.OptionBool,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (Bool -> String) -> Bool -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show (Bool -> Maybe String) -> Bool -> Maybe String
forall a b. (a -> b) -> a -> b
$ Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
Chatty
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"verbose",
        optionDescription :: String
optionDescription = String
"Print checked values",
        optionType :: OptionType
optionType = OptionType
T.OptionBool,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (Bool -> String) -> Bool -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show (Bool -> Maybe String) -> Bool -> Maybe String
forall a b. (a -> b) -> a -> b
$ Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
Verbose
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"verboseShrinking",
        optionDescription :: String
optionDescription = String
"Print all checked and shrunk values",
        optionType :: OptionType
optionType = OptionType
T.OptionBool,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (Bool -> String) -> Bool -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show (Bool -> Maybe String) -> Bool -> Maybe String
forall a b. (a -> b) -> a -> b
$ Bool
verboseShrinking
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"verbosity",
        optionDescription :: String
optionDescription = String
"Verbosity level",
        optionType :: OptionType
optionType = [String] -> OptionType
T.OptionEnum [String
"Silent", String
"Chatty", String
"Verbose", String
"VerboseShrinking"],
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Verbosity -> String
forall a. Show a => a -> String
show Verbosity
verbosity
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"maxDiscardRatio",
        optionDescription :: String
optionDescription = String
"Maximum number of discarded tests per successful test before giving up",
        optionType :: OptionType
optionType = OptionType
positiveIntType,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
maxDiscardRatio
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"noShrinking",
        optionDescription :: String
optionDescription = String
"Disable shrinking",
        optionType :: OptionType
optionType = OptionType
T.OptionBool,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Bool -> String
forall a. Show a => a -> String
show Bool
noShrinking
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"shrinking",
        optionDescription :: String
optionDescription = String
"Enable shrinking",
        optionType :: OptionType
optionType = OptionType
T.OptionBool,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (Bool -> String) -> Bool -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show (Bool -> Maybe String) -> Bool -> Maybe String
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
noShrinking
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"maxShrinks",
        optionDescription :: String
optionDescription = String
"Maximum number of shrinks to before giving up or zero to disable shrinking",
        optionType :: OptionType
optionType = OptionType
positiveIntType,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
maxShrinks
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"maxSuccess",
        optionDescription :: String
optionDescription = String
"Maximum number of successful tests before succeeding",
        optionType :: OptionType
optionType = OptionType
positiveIntType,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
maxSuccess
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"maxSize",
        optionDescription :: String
optionDescription = String
"Size to use for the biggest test cases",
        optionType :: OptionType
optionType = OptionType
positiveIntType,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
maxSize
      },
    T.OptionDescr
      { optionName :: String
optionName = String
"sizeScale",
        optionDescription :: String
optionDescription = String
"Scale all sizes by a number",
        optionType :: OptionType
optionType = OptionType
positiveIntType,
        optionDefault :: Maybe String
optionDefault = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
sizeScale
      }
  ]

-- | Property test declaration with metadata
data PropertyTest prop = PropertyTest
  { -- | Name of the test, for Cabal. See See Cabal’s 'T.name'.
    forall prop. PropertyTest prop -> String
name :: String,
    -- | Tags of the test, for Cabal. See Cabal’s 'T.tags'.
    forall prop. PropertyTest prop -> [String]
tags :: [String],
    -- | Property to check. This should usually be or return an instance of 'QC.Testable'.
    forall prop. PropertyTest prop -> prop
property :: prop
  }

-- | Get a Cabal 'T.Test' with custom 'TestArgs' from a 'PropertyTest' that takes the test arguments and returns a 'QC.testable' value
getPropertyTestWithUsing ::
  QC.Testable prop =>
  -- | The arguments for the test
  TestArgs ->
  -- | A property test whose 'property' takes a 'TestArgs' argument
  PropertyTest (TestArgs -> prop) ->
  T.Test
getPropertyTestWithUsing :: forall prop.
Testable prop =>
TestArgs -> PropertyTest (TestArgs -> prop) -> Test
getPropertyTestWithUsing TestArgs
originalArgs PropertyTest {String
[String]
TestArgs -> prop
property :: TestArgs -> prop
tags :: [String]
name :: String
property :: forall prop. PropertyTest prop -> prop
tags :: forall prop. PropertyTest prop -> [String]
name :: forall prop. PropertyTest prop -> String
..} =
  let withArgs :: TestArgs -> TestInstance
withArgs TestArgs
args =
        T.TestInstance
          {
            run :: IO Progress
run = do
              Result
result <- TestArgs -> prop -> IO Result
forall a. Testable a => TestArgs -> a -> IO Result
qcTestArgs TestArgs
args (TestArgs -> prop
property TestArgs
args)
              let resultStr :: String
resultStr = String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Result -> String
forall a. Show a => a -> String
show Result
result
              Progress -> IO Progress
forall (m :: * -> *) a. Monad m => a -> m a
return (Progress -> IO Progress) -> Progress -> IO Progress
forall a b. (a -> b) -> a -> b
$ Result -> Progress
T.Finished case Result
result of
                QC.Success {} -> Result
T.Pass
                QC.GaveUp {} ->
                  String -> Result
T.Error (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ String
"GaveUp: QuickCheck gave up" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
resultStr
                QC.Failure {} ->
                  String -> Result
T.Fail (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ String
"Failure: A property failed" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
resultStr
                QC.NoExpectedFailure {} ->
                  String -> Result
T.Fail (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ String
"NoExpectedFailure: A property that should have failed did not" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
resultStr,
            String
name :: String
name :: String
name,
            [String]
tags :: [String]
tags :: [String]
tags,
            options :: [OptionDescr]
options = TestArgs -> [OptionDescr]
getOptionDescrs TestArgs
originalArgs,
            setOption :: String -> String -> Either String TestInstance
setOption = \String
opt String
str -> case String -> String -> Maybe (TestArgs -> TestArgs)
setArgStr String
opt String
str of
              Maybe (TestArgs -> TestArgs)
Nothing -> String -> Either String TestInstance
forall a b. a -> Either a b
Left String
"Parse error"
              Just TestArgs -> TestArgs
f -> TestInstance -> Either String TestInstance
forall a b. b -> Either a b
Right (TestInstance -> Either String TestInstance)
-> (TestArgs -> TestInstance)
-> TestArgs
-> Either String TestInstance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestArgs -> TestInstance
withArgs (TestArgs -> Either String TestInstance)
-> TestArgs -> Either String TestInstance
forall a b. (a -> b) -> a -> b
$ TestArgs -> TestArgs
f TestArgs
args
          }
   in TestInstance -> Test
T.Test (TestInstance -> Test) -> TestInstance -> Test
forall a b. (a -> b) -> a -> b
$ TestArgs -> TestInstance
withArgs TestArgs
originalArgs

discardingTestArgs :: PropertyTest prop -> PropertyTest (TestArgs -> prop)
discardingTestArgs :: forall prop. PropertyTest prop -> PropertyTest (TestArgs -> prop)
discardingTestArgs test :: PropertyTest prop
test@PropertyTest {prop
property :: prop
property :: forall prop. PropertyTest prop -> prop
property} = PropertyTest prop
test {property :: TestArgs -> prop
property = prop -> TestArgs -> prop
forall a b. a -> b -> a
const prop
property}

-- | Get a Cabal 'T.Test' from a 'PropertyTest' that takes the test arguments and returns a 'QC.Testable' value
getPropertyTestUsing ::
  QC.Testable prop =>
  -- | A property test whose 'property' takes a 'TestArgs' argument
  PropertyTest (TestArgs -> prop) ->
  T.Test
getPropertyTestUsing :: forall prop.
Testable prop =>
PropertyTest (TestArgs -> prop) -> Test
getPropertyTestUsing = TestArgs -> PropertyTest (TestArgs -> prop) -> Test
forall prop.
Testable prop =>
TestArgs -> PropertyTest (TestArgs -> prop) -> Test
getPropertyTestWithUsing TestArgs
stdTestArgs

-- | Get a Cabal 'T.Test' from a 'PropertyTest' with custom 'TestArgs'
getPropertyTestWith ::
  QC.Testable prop =>
  -- | The arguments for the test
  TestArgs ->
  PropertyTest prop ->
  T.Test
getPropertyTestWith :: forall prop. Testable prop => TestArgs -> PropertyTest prop -> Test
getPropertyTestWith TestArgs
args = TestArgs -> PropertyTest (TestArgs -> prop) -> Test
forall prop.
Testable prop =>
TestArgs -> PropertyTest (TestArgs -> prop) -> Test
getPropertyTestWithUsing TestArgs
args (PropertyTest (TestArgs -> prop) -> Test)
-> (PropertyTest prop -> PropertyTest (TestArgs -> prop))
-> PropertyTest prop
-> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyTest prop -> PropertyTest (TestArgs -> prop)
forall prop. PropertyTest prop -> PropertyTest (TestArgs -> prop)
discardingTestArgs

-- | Get a Cabal 'T.Test' from a 'PropertyTest'
getPropertyTest :: QC.Testable prop => PropertyTest prop -> T.Test
getPropertyTest :: forall prop. Testable prop => PropertyTest prop -> Test
getPropertyTest = TestArgs -> PropertyTest (TestArgs -> prop) -> Test
forall prop.
Testable prop =>
TestArgs -> PropertyTest (TestArgs -> prop) -> Test
getPropertyTestWithUsing TestArgs
stdTestArgs (PropertyTest (TestArgs -> prop) -> Test)
-> (PropertyTest prop -> PropertyTest (TestArgs -> prop))
-> PropertyTest prop
-> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyTest prop -> PropertyTest (TestArgs -> prop)
forall prop. PropertyTest prop -> PropertyTest (TestArgs -> prop)
discardingTestArgs

-- | Get a list of 'T.Test's from a list of 'PropertyTest's
getPropertyTests :: QC.Testable prop => [PropertyTest prop] -> [T.Test]
getPropertyTests :: forall prop. Testable prop => [PropertyTest prop] -> [Test]
getPropertyTests = (PropertyTest prop -> Test
forall prop. Testable prop => PropertyTest prop -> Test
getPropertyTest (PropertyTest prop -> Test) -> [PropertyTest prop] -> [Test]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

-- | Get a named test group from a list of 'PropertyTest's. These are assumed to be able to run in parallel. See 'T.testGroup' and 'T.Group'.
propertyTestGroup :: QC.Testable prop => String -> [PropertyTest prop] -> T.Test
propertyTestGroup :: forall prop. Testable prop => String -> [PropertyTest prop] -> Test
propertyTestGroup String
name = String -> [Test] -> Test
T.testGroup String
name ([Test] -> Test)
-> ([PropertyTest prop] -> [Test]) -> [PropertyTest prop] -> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PropertyTest prop] -> [Test]
forall prop. Testable prop => [PropertyTest prop] -> [Test]
getPropertyTests