{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Test.Hspec.Core.QuickCheck (
modifyMaxSuccess
, modifyMaxDiscardRatio
, modifyMaxSize
, modifyMaxShrinks
, modifyArgs
) where
import Prelude ()
import Test.Hspec.Core.Compat
import Test.QuickCheck (Args(..))
import qualified Test.QuickCheck as QC
import qualified Test.QuickCheck.State as QC (numSuccessTests, maxSuccessTests)
import qualified Test.QuickCheck.Property as QCP
import Test.Hspec.Core.Util
import Test.Hspec.Core.QuickCheck.Util
import Test.Hspec.Core.Example (Example(..), Params(..), Result(..), ResultStatus(..), FailureReason(..), hunitFailureToResult)
import Test.Hspec.Core.Spec.Monad (SpecWith, modifyParams)
modifyMaxSuccess :: (Int -> Int) -> SpecWith a -> SpecWith a
modifyMaxSuccess :: forall a. (Int -> Int) -> SpecWith a -> SpecWith a
modifyMaxSuccess = (Args -> Args) -> SpecWith a -> SpecWith a
forall a. (Args -> Args) -> SpecWith a -> SpecWith a
modifyArgs ((Args -> Args) -> SpecWith a -> SpecWith a)
-> ((Int -> Int) -> Args -> Args)
-> (Int -> Int)
-> SpecWith a
-> SpecWith a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> Args -> Args
modify
where
modify :: (Int -> Int) -> Args -> Args
modify :: (Int -> Int) -> Args -> Args
modify Int -> Int
f Args
args = Args
args {maxSuccess = f (maxSuccess args)}
modifyMaxDiscardRatio :: (Int -> Int) -> SpecWith a -> SpecWith a
modifyMaxDiscardRatio :: forall a. (Int -> Int) -> SpecWith a -> SpecWith a
modifyMaxDiscardRatio = (Args -> Args) -> SpecWith a -> SpecWith a
forall a. (Args -> Args) -> SpecWith a -> SpecWith a
modifyArgs ((Args -> Args) -> SpecWith a -> SpecWith a)
-> ((Int -> Int) -> Args -> Args)
-> (Int -> Int)
-> SpecWith a
-> SpecWith a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> Args -> Args
modify
where
modify :: (Int -> Int) -> Args -> Args
modify :: (Int -> Int) -> Args -> Args
modify Int -> Int
f Args
args = Args
args {maxDiscardRatio = f (maxDiscardRatio args)}
modifyMaxSize :: (Int -> Int) -> SpecWith a -> SpecWith a
modifyMaxSize :: forall a. (Int -> Int) -> SpecWith a -> SpecWith a
modifyMaxSize = (Args -> Args) -> SpecWith a -> SpecWith a
forall a. (Args -> Args) -> SpecWith a -> SpecWith a
modifyArgs ((Args -> Args) -> SpecWith a -> SpecWith a)
-> ((Int -> Int) -> Args -> Args)
-> (Int -> Int)
-> SpecWith a
-> SpecWith a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> Args -> Args
modify
where
modify :: (Int -> Int) -> Args -> Args
modify :: (Int -> Int) -> Args -> Args
modify Int -> Int
f Args
args = Args
args {maxSize = f (maxSize args)}
modifyMaxShrinks :: (Int -> Int) -> SpecWith a -> SpecWith a
modifyMaxShrinks :: forall a. (Int -> Int) -> SpecWith a -> SpecWith a
modifyMaxShrinks = (Args -> Args) -> SpecWith a -> SpecWith a
forall a. (Args -> Args) -> SpecWith a -> SpecWith a
modifyArgs ((Args -> Args) -> SpecWith a -> SpecWith a)
-> ((Int -> Int) -> Args -> Args)
-> (Int -> Int)
-> SpecWith a
-> SpecWith a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> Args -> Args
modify
where
modify :: (Int -> Int) -> Args -> Args
modify :: (Int -> Int) -> Args -> Args
modify Int -> Int
f Args
args = Args
args {maxShrinks = f (maxShrinks args)}
modifyArgs :: (Args -> Args) -> SpecWith a -> SpecWith a
modifyArgs :: forall a. (Args -> Args) -> SpecWith a -> SpecWith a
modifyArgs = (Params -> Params) -> SpecWith a -> SpecWith a
forall a. (Params -> Params) -> SpecWith a -> SpecWith a
modifyParams ((Params -> Params) -> SpecWith a -> SpecWith a)
-> ((Args -> Args) -> Params -> Params)
-> (Args -> Args)
-> SpecWith a
-> SpecWith a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Args -> Args) -> Params -> Params
modify
where
modify :: (Args -> Args) -> Params -> Params
modify :: (Args -> Args) -> Params -> Params
modify Args -> Args
f Params
p = Params
p {paramsQuickCheckArgs = f (paramsQuickCheckArgs p)}
instance Example QC.Property where
type Arg QC.Property = ()
evaluateExample :: Property
-> Params
-> (ActionWith (Arg Property) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample Property
e = (() -> Property)
-> Params
-> (ActionWith (Arg (() -> Property)) -> IO ())
-> ProgressCallback
-> IO Result
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample (\() -> Property
e)
instance Example (a -> QC.Property) where
type Arg (a -> QC.Property) = a
evaluateExample :: (a -> Property)
-> Params
-> (ActionWith (Arg (a -> Property)) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample a -> Property
p Params
params ActionWith (Arg (a -> Property)) -> IO ()
hook ProgressCallback
progressCallback = do
let args :: Args
args = Params -> Args
paramsQuickCheckArgs Params
params
Result
r <- Args -> Property -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
QC.quickCheckWithResult Args
args {QC.chatty = False} (Callback -> Property -> Property
forall prop. Testable prop => Callback -> prop -> Property
QCP.callback Callback
qcProgressCallback (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property
forall a. ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property
aroundProperty (a -> IO ()) -> IO ()
ActionWith (Arg (a -> Property)) -> IO ()
hook a -> Property
p)
Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ Args -> Result -> Result
fromQuickCheckResult Args
args Result
r
where
qcProgressCallback :: Callback
qcProgressCallback = CallbackKind -> (State -> Result -> IO ()) -> Callback
QCP.PostTest CallbackKind
QCP.NotCounterexample ((State -> Result -> IO ()) -> Callback)
-> (State -> Result -> IO ()) -> Callback
forall a b. (a -> b) -> a -> b
$
\State
st Result
_ -> ProgressCallback
progressCallback (State -> Int
QC.numSuccessTests State
st, State -> Int
QC.maxSuccessTests State
st)
fromQuickCheckResult :: QC.Args -> QC.Result -> Result
fromQuickCheckResult :: Args -> Result -> Result
fromQuickCheckResult Args
args Result
r = case Result -> QuickCheckResult
parseQuickCheckResult Result
r of
QuickCheckResult Int
_ String
info (QuickCheckOtherFailure String
err) -> String -> ResultStatus -> Result
Result String
info (ResultStatus -> Result) -> ResultStatus -> Result
forall a b. (a -> b) -> a -> b
$ Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (String -> FailureReason
Reason String
err)
QuickCheckResult Int
_ String
info Status
QuickCheckSuccess -> String -> ResultStatus -> Result
Result (if Args -> Bool
QC.chatty Args
args then String
info else String
"") ResultStatus
Success
QuickCheckResult Int
n String
info (QuickCheckFailure QCFailure{Int
String
[String]
Maybe SomeException
quickCheckFailureNumShrinks :: Int
quickCheckFailureException :: Maybe SomeException
quickCheckFailureReason :: String
quickCheckFailureCounterexample :: [String]
quickCheckFailureNumShrinks :: QuickCheckFailure -> Int
quickCheckFailureException :: QuickCheckFailure -> Maybe SomeException
quickCheckFailureReason :: QuickCheckFailure -> String
quickCheckFailureCounterexample :: QuickCheckFailure -> [String]
..}) -> case Maybe SomeException
quickCheckFailureException of
Just SomeException
e | Just ResultStatus
result <- SomeException -> Maybe ResultStatus
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> String -> ResultStatus -> Result
Result String
info ResultStatus
result
Just SomeException
e | Just HUnitFailure
hunit <- SomeException -> Maybe HUnitFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> String -> ResultStatus -> Result
Result String
info (ResultStatus -> Result) -> ResultStatus -> Result
forall a b. (a -> b) -> a -> b
$ Maybe String -> HUnitFailure -> ResultStatus
hunitFailureToResult (String -> Maybe String
forall a. a -> Maybe a
Just String
hunitAssertion) HUnitFailure
hunit
Just SomeException
e -> String -> Result
failure (SomeException -> String
uncaughtException SomeException
e)
Maybe SomeException
Nothing -> String -> Result
failure String
falsifiable
where
failure :: String -> Result
failure = String -> ResultStatus -> Result
Result String
info (ResultStatus -> Result)
-> (String -> ResultStatus) -> String -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (FailureReason -> ResultStatus)
-> (String -> FailureReason) -> String -> ResultStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FailureReason
Reason
numbers :: String
numbers = Int -> Int -> String
formatNumbers Int
n Int
quickCheckFailureNumShrinks
hunitAssertion :: String
hunitAssertion :: String
hunitAssertion = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [
String
"Falsifiable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
numbers String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
, String -> String
indent ([String] -> String
unlines [String]
quickCheckFailureCounterexample)
]
uncaughtException :: SomeException -> String
uncaughtException SomeException
e = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [
String
"uncaught exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
formatException SomeException
e
, String
numbers
, String -> String
indent ([String] -> String
unlines [String]
quickCheckFailureCounterexample)
]
falsifiable :: String
falsifiable = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [
String
quickCheckFailureReason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
numbers String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
, String -> String
indent ([String] -> String
unlines [String]
quickCheckFailureCounterexample)
]
indent :: String -> String
indent :: String -> String
indent = 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) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines