{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
module Test.Hspec.Core.QuickCheck.Util (
  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 <- r -> IO (IORef r)
forall a. a -> IO (IORef a)
newIORef r
def
  (a -> IO ()) -> IO ()
hook ((a -> IO ()) -> IO ()) -> (a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> IO r
inner (a -> IO r) -> (r -> IO ()) -> a -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IORef r -> r -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef r
ref
  IORef r -> IO r
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 (Gen Prop -> Property)
-> ((QCGen -> Int -> Prop) -> Gen Prop)
-> (QCGen -> Int -> Prop)
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QCGen -> Int -> Prop) -> Gen Prop
forall a. (QCGen -> Int -> a) -> Gen a
MkGen ((QCGen -> Int -> Prop) -> Property)
-> (QCGen -> Int -> Prop) -> Property
forall a b. (a -> b) -> a -> b
$ \QCGen
r Int
n -> ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop
forall a. ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop
aroundProp (a -> IO ()) -> IO ()
hook ((a -> Prop) -> Prop) -> (a -> Prop) -> Prop
forall a b. (a -> b) -> a -> b
$ \a
a -> (Gen Prop -> QCGen -> Int -> Prop
forall a. Gen a -> QCGen -> Int -> a
unGen (Gen Prop -> QCGen -> Int -> Prop)
-> (Property -> Gen Prop) -> Property -> QCGen -> Int -> Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> Gen Prop
unProperty (Property -> QCGen -> Int -> Prop)
-> Property -> QCGen -> Int -> Prop
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 (Rose Result -> Prop) -> Rose Result -> Prop
forall a b. (a -> b) -> a -> b
$ ((a -> IO ()) -> IO ()) -> (a -> Rose Result) -> Rose Result
forall a.
((a -> IO ()) -> IO ()) -> (a -> Rose Result) -> Rose Result
aroundRose (a -> IO ()) -> IO ()
hook (\a
a -> Prop -> Rose Result
unProp (Prop -> Rose Result) -> Prop -> Rose Result
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 (IO (Rose Result) -> Rose Result)
-> IO (Rose Result) -> Rose Result
forall a b. (a -> b) -> a -> b
$ do
  Rose Result
-> ((a -> IO ()) -> IO ())
-> (a -> IO (Rose Result))
-> IO (Rose Result)
forall r a. r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r
liftHook (Result -> Rose Result
forall a. a -> Rose a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
QCP.succeeded) (a -> IO ()) -> IO ()
hook ((a -> IO (Rose Result)) -> IO (Rose Result))
-> (a -> IO (Rose Result)) -> IO (Rose Result)
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 = (Int, QCGen) -> Int
forall a b. (a, b) -> a
fst ((Int, QCGen) -> Int) -> (QCGen -> (Int, QCGen)) -> QCGen -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> QCGen -> (Int, QCGen)
forall g. RandomGen g => (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
maxBound :: Int32)) (QCGen -> Int) -> IO QCGen -> IO Int
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
pluralize Int
n String
"test" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
shrinks_ String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  where
    shrinks_ :: String
shrinks_
      | Int
shrinks Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = String
" and " String -> String -> String
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
(Int -> QuickCheckResult -> String -> String)
-> (QuickCheckResult -> String)
-> ([QuickCheckResult] -> String -> String)
-> Show QuickCheckResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> QuickCheckResult -> String -> String
showsPrec :: Int -> QuickCheckResult -> String -> String
$cshow :: QuickCheckResult -> String
show :: QuickCheckResult -> String
$cshowList :: [QuickCheckResult] -> String -> String
showList :: [QuickCheckResult] -> String -> String
Show

data Status =
    QuickCheckSuccess
  | QuickCheckFailure QuickCheckFailure
  | QuickCheckOtherFailure String
  deriving Int -> Status -> String -> String
[Status] -> String -> String
Status -> String
(Int -> Status -> String -> String)
-> (Status -> String)
-> ([Status] -> String -> String)
-> Show Status
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Status -> String -> String
showsPrec :: Int -> Status -> String -> String
$cshow :: Status -> String
show :: Status -> String
$cshowList :: [Status] -> String -> String
showList :: [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
(Int -> QuickCheckFailure -> String -> String)
-> (QuickCheckFailure -> String)
-> ([QuickCheckFailure] -> String -> String)
-> Show QuickCheckFailure
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> QuickCheckFailure -> String -> String
showsPrec :: Int -> QuickCheckFailure -> String -> String
$cshow :: QuickCheckFailure -> String
show :: QuickCheckFailure -> String
$cshowList :: [QuickCheckFailure] -> String -> String
showList :: [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 :: Int
numDiscarded :: Int
labels :: Map [String] Int
classes :: Map String Int
tables :: Map String (Map String Int)
output :: String
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
..} -> String -> Status -> QuickCheckResult
result String
output Status
QuickCheckSuccess

  Failure {Int
String
[String]
[Witness]
Maybe SomeException
QCGen
Set String
numTests :: Result -> Int
numDiscarded :: Result -> Int
output :: Result -> String
numTests :: Int
numDiscarded :: Int
numShrinks :: Int
numShrinkTries :: Int
numShrinkFinal :: Int
usedSeed :: QCGen
usedSize :: Int
reason :: String
theException :: Maybe SomeException
output :: String
failingTestCase :: [String]
failingLabels :: [String]
failingClasses :: Set String
witnesses :: [Witness]
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
witnesses :: Result -> [Witness]
..} ->
    case String -> String -> Maybe String
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 (QuickCheckFailure -> Status) -> QuickCheckFailure -> Status
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 String -> String -> Bool
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String]
failingTestCase
      reasonAndNumbers :: String
reasonAndNumbers
        | String -> Bool
isOneLine String
reason = String
reason 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
colonNewline
        | Bool
otherwise = String
numbers String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
colonNewline String -> String -> String
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
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
numTests :: Int
numDiscarded :: Int
labels :: Map [String] Int
classes :: Map String Int
tables :: Map String (Map String Int)
output :: String
..} ->
    case String -> String -> Maybe String
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
numbers String -> String -> String
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
numbers String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tests.\n"

  NoExpectedFailure {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
numTests :: Int
numDiscarded :: Int
labels :: Map [String] Int
classes :: Map String Int
tables :: Map String (Map String Int)
output :: 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) (String -> Status -> QuickCheckResult)
-> (String -> String) -> String -> Status -> QuickCheckResult
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 (String -> Status) -> String -> Status
forall a b. (a -> b) -> a -> b
$ String -> String
strip String
err)
    couldNotParse :: String -> QuickCheckResult
couldNotParse = String -> Status -> QuickCheckResult
result String
"" (Status -> QuickCheckResult)
-> (String -> Status) -> String -> QuickCheckResult
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                  = Terminal
forall a. HasCallStack => a
undefined
    , maxSuccessTests :: Int
maxSuccessTests           = Int
forall a. HasCallStack => a
undefined
    , maxDiscardedRatio :: Int
maxDiscardedRatio         = Int
forall a. HasCallStack => a
undefined
    , coverageConfidence :: Maybe Confidence
coverageConfidence        = Maybe Confidence
forall a. HasCallStack => a
undefined
#if MIN_VERSION_QuickCheck(2,15,0)
    , maxTestSize :: Int
maxTestSize               = Int
0
    , replayStartSize :: Maybe Int
replayStartSize           = Maybe Int
forall a. HasCallStack => a
undefined
#else
    , computeSize               = undefined
#endif
    , 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                    = Map [String] Int
forall a. Monoid a => a
mempty
    , classes :: Map String Int
classes                   = Map String Int
forall a. Monoid a => a
mempty
    , tables :: Map String (Map String Int)
tables                    = Map String (Map String Int)
forall a. Monoid a => a
mempty
    , requiredCoverage :: Map (Maybe String, String) Double
requiredCoverage          = Map (Maybe String, String) Double
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 ([String] -> String) -> (String -> [String]) -> String -> String
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 = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
m (String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
m)

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

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

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