{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
module Test.Hspec.Core.QuickCheckUtil (
  liftHook
, aroundProperty

, QuickCheckResult(..)
, Status(..)
, QuickCheckFailure(..)
, parseQuickCheckResult

, formatNumbers

, mkGen
, newSeed
#ifdef TEST
, stripSuffix
, splitBy
#endif
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

import           Data.Int
import           System.Random

import           Test.QuickCheck
import           Test.QuickCheck.Text (isOneLine)
import qualified Test.QuickCheck.Property as QCP
import           Test.QuickCheck.Property hiding (Result(..))
import           Test.QuickCheck.Gen
import           Test.QuickCheck.IO ()
import           Test.QuickCheck.Random
import qualified Test.QuickCheck.Test as QC (showTestCount)
import           Test.QuickCheck.State (State(..))

import           Test.Hspec.Core.Util

liftHook :: r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r
liftHook :: forall r a. r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r
liftHook r
def (a -> IO ()) -> IO ()
hook a -> IO r
inner = do
  IORef r
ref <- forall a. a -> IO (IORef a)
newIORef r
def
  (a -> IO ()) -> IO ()
hook forall a b. (a -> b) -> a -> b
$ a -> IO r
inner forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a. IORef a -> a -> IO ()
writeIORef IORef r
ref
  forall a. IORef a -> IO a
readIORef IORef r
ref

aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property
aroundProperty :: forall a. ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property
aroundProperty (a -> IO ()) -> IO ()
hook a -> Property
p = Gen Prop -> Property
MkProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (QCGen -> Int -> a) -> Gen a
MkGen forall a b. (a -> b) -> a -> b
$ \QCGen
r Int
n -> forall a. ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop
aroundProp (a -> IO ()) -> IO ()
hook forall a b. (a -> b) -> a -> b
$ \a
a -> (forall a. Gen a -> QCGen -> Int -> a
unGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty forall a b. (a -> b) -> a -> b
$ a -> Property
p a
a) QCGen
r Int
n

aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop
aroundProp :: forall a. ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop
aroundProp (a -> IO ()) -> IO ()
hook a -> Prop
p = Rose Result -> Prop
MkProp forall a b. (a -> b) -> a -> b
$ forall a.
((a -> IO ()) -> IO ()) -> (a -> Rose Result) -> Rose Result
aroundRose (a -> IO ()) -> IO ()
hook (\a
a -> Prop -> Rose Result
unProp forall a b. (a -> b) -> a -> b
$ a -> Prop
p a
a)

aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result
aroundRose :: forall a.
((a -> IO ()) -> IO ()) -> (a -> Rose Result) -> Rose Result
aroundRose (a -> IO ()) -> IO ()
hook a -> Rose Result
r = IO (Rose Result) -> Rose Result
ioRose forall a b. (a -> b) -> a -> b
$ do
  forall r a. r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r
liftHook (forall (m :: * -> *) a. Monad m => a -> m a
return Result
QCP.succeeded) (a -> IO ()) -> IO ()
hook forall a b. (a -> b) -> a -> b
$ \ a
a -> Rose Result -> IO (Rose Result)
reduceRose (a -> Rose Result
r a
a)

newSeed :: IO Int
newSeed :: IO Int
newSeed = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int32)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  IO QCGen
newQCGen

mkGen :: Int -> QCGen
mkGen :: Int -> QCGen
mkGen = Int -> QCGen
mkQCGen

formatNumbers :: Int -> Int -> String
formatNumbers :: Int -> Int -> String
formatNumbers Int
n Int
shrinks = String
"(after " forall a. [a] -> [a] -> [a]
++ Int -> String -> String
pluralize Int
n String
"test" forall a. [a] -> [a] -> [a]
++ String
shrinks_ forall a. [a] -> [a] -> [a]
++ String
")"
  where
    shrinks_ :: String
shrinks_
      | Int
shrinks forall a. Ord a => a -> a -> Bool
> Int
0 = String
" and " forall a. [a] -> [a] -> [a]
++ Int -> String -> String
pluralize Int
shrinks String
"shrink"
      | Bool
otherwise = String
""

data QuickCheckResult = QuickCheckResult {
  QuickCheckResult -> Int
quickCheckResultNumTests :: Int
, QuickCheckResult -> String
quickCheckResultInfo :: String
, QuickCheckResult -> Status
quickCheckResultStatus :: Status
} deriving Int -> QuickCheckResult -> String -> String
[QuickCheckResult] -> String -> String
QuickCheckResult -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [QuickCheckResult] -> String -> String
$cshowList :: [QuickCheckResult] -> String -> String
show :: QuickCheckResult -> String
$cshow :: QuickCheckResult -> String
showsPrec :: Int -> QuickCheckResult -> String -> String
$cshowsPrec :: Int -> QuickCheckResult -> String -> String
Show

data Status =
    QuickCheckSuccess
  | QuickCheckFailure QuickCheckFailure
  | QuickCheckOtherFailure String
  deriving Int -> Status -> String -> String
[Status] -> String -> String
Status -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Status] -> String -> String
$cshowList :: [Status] -> String -> String
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> String -> String
$cshowsPrec :: Int -> Status -> String -> String
Show

data QuickCheckFailure = QCFailure {
  QuickCheckFailure -> Int
quickCheckFailureNumShrinks :: Int
, QuickCheckFailure -> Maybe SomeException
quickCheckFailureException :: Maybe SomeException
, QuickCheckFailure -> String
quickCheckFailureReason :: String
, QuickCheckFailure -> [String]
quickCheckFailureCounterexample :: [String]
} deriving Int -> QuickCheckFailure -> String -> String
[QuickCheckFailure] -> String -> String
QuickCheckFailure -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [QuickCheckFailure] -> String -> String
$cshowList :: [QuickCheckFailure] -> String -> String
show :: QuickCheckFailure -> String
$cshow :: QuickCheckFailure -> String
showsPrec :: Int -> QuickCheckFailure -> String -> String
$cshowsPrec :: Int -> QuickCheckFailure -> String -> String
Show

parseQuickCheckResult :: Result -> QuickCheckResult
parseQuickCheckResult :: Result -> QuickCheckResult
parseQuickCheckResult Result
r = case Result
r of
  Success {Int
String
Map String Int
Map String (Map String Int)
Map [String] Int
numTests :: Result -> Int
numDiscarded :: Result -> Int
labels :: Result -> Map [String] Int
classes :: Result -> Map String Int
tables :: Result -> Map String (Map String Int)
output :: Result -> String
output :: String
tables :: Map String (Map String Int)
classes :: Map String Int
labels :: Map [String] Int
numDiscarded :: Int
numTests :: Int
..} -> String -> Status -> QuickCheckResult
result String
output Status
QuickCheckSuccess

  Failure {Int
String
[String]
Maybe SomeException
QCGen
Set String
numShrinks :: Result -> Int
numShrinkTries :: Result -> Int
numShrinkFinal :: Result -> Int
usedSeed :: Result -> QCGen
usedSize :: Result -> Int
reason :: Result -> String
theException :: Result -> Maybe SomeException
failingTestCase :: Result -> [String]
failingLabels :: Result -> [String]
failingClasses :: Result -> Set String
failingClasses :: Set String
failingLabels :: [String]
failingTestCase :: [String]
output :: String
theException :: Maybe SomeException
reason :: String
usedSize :: Int
usedSeed :: QCGen
numShrinkFinal :: Int
numShrinkTries :: Int
numShrinks :: Int
numDiscarded :: Int
numTests :: Int
numTests :: Result -> Int
numDiscarded :: Result -> Int
output :: Result -> String
..} ->
    case forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
outputWithoutVerbose String
output of
      Just String
xs -> String -> Status -> QuickCheckResult
result String
verboseOutput (QuickCheckFailure -> Status
QuickCheckFailure forall a b. (a -> b) -> a -> b
$ Int
-> Maybe SomeException -> String -> [String] -> QuickCheckFailure
QCFailure Int
numShrinks Maybe SomeException
theException String
reason [String]
failingTestCase)
        where
          verboseOutput :: String
verboseOutput
            | String
xs forall a. Eq a => a -> a -> Bool
== String
"*** Failed! " = String
""
            | Bool
otherwise = String -> String -> String
maybeStripSuffix String
"*** Failed!" (String -> String
strip String
xs)
      Maybe String
Nothing -> String -> QuickCheckResult
couldNotParse String
output
    where
      outputWithoutVerbose :: String
outputWithoutVerbose = String
reasonAndNumbers forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String]
failingTestCase
      reasonAndNumbers :: String
reasonAndNumbers
        | String -> Bool
isOneLine String
reason = String
reason forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
numbers forall a. [a] -> [a] -> [a]
++ String
colonNewline
        | Bool
otherwise = String
numbers forall a. [a] -> [a] -> [a]
++ String
colonNewline forall a. [a] -> [a] -> [a]
++ String -> String
ensureTrailingNewline String
reason
      numbers :: String
numbers = Int -> Int -> String
formatNumbers Int
numTests Int
numShrinks
      colonNewline :: String
colonNewline = String
":\n"

  GaveUp {Int
String
Map String Int
Map String (Map String Int)
Map [String] Int
output :: String
tables :: Map String (Map String Int)
classes :: Map String Int
labels :: Map [String] Int
numDiscarded :: Int
numTests :: Int
numTests :: Result -> Int
numDiscarded :: Result -> Int
labels :: Result -> Map [String] Int
classes :: Result -> Map String Int
tables :: Result -> Map String (Map String Int)
output :: Result -> String
..} ->
    case forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
outputWithoutVerbose String
output of
      Just String
info -> String -> String -> QuickCheckResult
otherFailure String
info (String
"Gave up after " forall a. [a] -> [a] -> [a]
++ String
numbers forall a. [a] -> [a] -> [a]
++ String
"!")
      Maybe String
Nothing -> String -> QuickCheckResult
couldNotParse String
output
    where
      numbers :: String
numbers = Int -> Int -> String
showTestCount Int
numTests Int
numDiscarded
      outputWithoutVerbose :: String
outputWithoutVerbose = String
"*** Gave up! Passed only " forall a. [a] -> [a] -> [a]
++ String
numbers forall a. [a] -> [a] -> [a]
++ String
" tests.\n"

  NoExpectedFailure {Int
String
Map String Int
Map String (Map String Int)
Map [String] Int
output :: String
tables :: Map String (Map String Int)
classes :: Map String Int
labels :: Map [String] Int
numDiscarded :: Int
numTests :: Int
numTests :: Result -> Int
numDiscarded :: Result -> Int
labels :: Result -> Map [String] Int
classes :: Result -> Map String Int
tables :: Result -> Map String (Map String Int)
output :: Result -> String
..} -> case String -> String -> Maybe (String, String)
splitBy String
"*** Failed! " String
output of
    Just (String
info, String
err) -> String -> String -> QuickCheckResult
otherFailure String
info String
err
    Maybe (String, String)
Nothing -> String -> QuickCheckResult
couldNotParse String
output

  where
    result :: String -> Status -> QuickCheckResult
result = Int -> String -> Status -> QuickCheckResult
QuickCheckResult (Result -> Int
numTests Result
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
strip
    otherFailure :: String -> String -> QuickCheckResult
otherFailure String
info String
err = String -> Status -> QuickCheckResult
result String
info (String -> Status
QuickCheckOtherFailure forall a b. (a -> b) -> a -> b
$ String -> String
strip String
err)
    couldNotParse :: String -> QuickCheckResult
couldNotParse = String -> Status -> QuickCheckResult
result String
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Status
QuickCheckOtherFailure

showTestCount :: Int -> Int -> String
showTestCount :: Int -> Int -> String
showTestCount Int
success Int
discarded = State -> String
QC.showTestCount State
state
  where
    state :: State
state = MkState {
      terminal :: Terminal
terminal                  = forall a. HasCallStack => a
undefined
    , maxSuccessTests :: Int
maxSuccessTests           = forall a. HasCallStack => a
undefined
    , maxDiscardedRatio :: Int
maxDiscardedRatio         = forall a. HasCallStack => a
undefined
    , coverageConfidence :: Maybe Confidence
coverageConfidence        = forall a. HasCallStack => a
undefined
    , computeSize :: Int -> Int -> Int
computeSize               = forall a. HasCallStack => a
undefined
    , numTotMaxShrinks :: Int
numTotMaxShrinks          = Int
0
    , numSuccessTests :: Int
numSuccessTests           = Int
success
    , numDiscardedTests :: Int
numDiscardedTests         = Int
discarded
    , numRecentlyDiscardedTests :: Int
numRecentlyDiscardedTests = Int
0
    , labels :: Map [String] Int
labels                    = forall a. Monoid a => a
mempty
    , classes :: Map String Int
classes                   = forall a. Monoid a => a
mempty
    , tables :: Map String (Map String Int)
tables                    = forall a. Monoid a => a
mempty
    , requiredCoverage :: Map (Maybe String, String) Double
requiredCoverage          = forall a. Monoid a => a
mempty
    , expected :: Bool
expected                  = Bool
True
    , randomSeed :: QCGen
randomSeed                = Int -> QCGen
mkGen Int
0
    , numSuccessShrinks :: Int
numSuccessShrinks         = Int
0
    , numTryShrinks :: Int
numTryShrinks             = Int
0
    , numTotTryShrinks :: Int
numTotTryShrinks          = Int
0
    }

ensureTrailingNewline :: String -> String
ensureTrailingNewline :: String -> String
ensureTrailingNewline = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

maybeStripPrefix :: String -> String -> String
maybeStripPrefix :: String -> String -> String
maybeStripPrefix String
prefix String
m = forall a. a -> Maybe a -> a
fromMaybe String
m (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
m)

maybeStripSuffix :: String -> String -> String
maybeStripSuffix :: String -> String -> String
maybeStripSuffix String
suffix = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
maybeStripPrefix (forall a. [a] -> [a]
reverse String
suffix) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
stripSuffix :: forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [a]
suffix = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (forall a. [a] -> [a]
reverse [a]
suffix) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

splitBy :: String -> String -> Maybe (String, String)
splitBy :: String -> String -> Maybe (String, String)
splitBy String
sep String
xs = forall a. [a] -> Maybe a
listToMaybe [
    (String
x, String
y) | (String
x, Just String
y) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [[a]]
inits String
xs) (forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe String
stripSep forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
tails String
xs)
  ]
  where
    stripSep :: String -> Maybe String
stripSep = forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
sep