{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
-- | Stability: provisional
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)

-- | Use a modified `maxSuccess` for given spec.
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)}

-- | Use a modified `maxDiscardRatio` for given spec.
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)}

-- | Use a modified `maxSize` for given spec.
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)}

-- | Use a modified `maxShrinks` for given spec.
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)}

-- | Use modified `Args` for given spec.
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