{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Hspec.Hedgehog
(
hedgehog
, modifyArgs
, modifyMaxSuccess
, modifyMaxDiscardRatio
, modifyMaxSize
, modifyMaxShrinks
, module Hedgehog
) where
import Control.Monad.IO.Class (liftIO)
import Data.Coerce (coerce)
import Data.IORef (newIORef, readIORef, writeIORef)
import Hedgehog
import Hedgehog.Internal.Config (detectColor)
import Hedgehog.Internal.Property (DiscardLimit (..), Property (..),
PropertyConfig (..),
ShrinkLimit (..),
TerminationCriteria (..),
TestCount (..), TestLimit (..))
import Hedgehog.Internal.Report as Hedge
import Hedgehog.Internal.Runner (checkReport)
import qualified Hedgehog.Internal.Seed as Seed
import Hedgehog.Internal.Source (ColumnNo (..), LineNo (..),
Span (..))
import System.Random.SplitMix (unseedSMGen)
import Test.Hspec
import Test.Hspec.Core.Spec as Hspec
import Test.Hspec.QuickCheck (modifyArgs, modifyMaxDiscardRatio,
modifyMaxShrinks, modifyMaxSize,
modifyMaxSuccess)
import Test.HUnit.Base (assertFailure)
import Test.QuickCheck.Random (QCGen (..))
import Test.QuickCheck.Test (Args (..))
hedgehog :: HasCallStack => PropertyT IO () -> PropertyT IO ()
hedgehog :: HasCallStack => PropertyT IO () -> PropertyT IO ()
hedgehog = PropertyT IO () -> PropertyT IO ()
forall a. a -> a
id
instance Example (PropertyT IO ()) where
type Arg (PropertyT IO ()) = ()
evaluateExample :: PropertyT IO ()
-> Params
-> (ActionWith (Arg (PropertyT IO ())) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample PropertyT IO ()
e = (() -> PropertyT IO ())
-> Params
-> (ActionWith (Arg (() -> PropertyT IO ())) -> IO ())
-> ProgressCallback
-> IO Result
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample (\() -> PropertyT IO ()
e)
instance Example (a -> PropertyT IO ()) where
type Arg (a -> PropertyT IO ()) = a
evaluateExample :: (a -> PropertyT IO ())
-> Params
-> (ActionWith (Arg (a -> PropertyT IO ())) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample ((PropertyT IO () -> Property)
-> (a -> PropertyT IO ()) -> a -> Property
forall a b. (a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property -> a -> Property
aprop) Params
params ActionWith (Arg (a -> PropertyT IO ())) -> IO ()
aroundAction ProgressCallback
progressCallback = do
IORef Result
ref <- Result -> IO (IORef Result)
forall a. a -> IO (IORef a)
newIORef (String -> ResultStatus -> Result
Result String
"" (Maybe Location -> Maybe String -> ResultStatus
Pending Maybe Location
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing))
ActionWith (Arg (a -> PropertyT IO ())) -> IO ()
aroundAction (ActionWith (Arg (a -> PropertyT IO ())) -> IO ())
-> ActionWith (Arg (a -> PropertyT IO ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Arg (a -> PropertyT IO ())
a -> do
UseColor
color <- IO UseColor
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
let size :: Size
size = Size
0
prop :: Property
prop = a -> Property
aprop a
Arg (a -> PropertyT IO ())
a
propConfig :: PropertyConfig
propConfig = PropertyConfig -> PropertyConfig
useQuickCheckArgs (Property -> PropertyConfig
propertyConfig Property
prop)
qcArgs :: Args
qcArgs = Params -> Args
paramsQuickCheckArgs Params
params
maxTests :: Int
maxTests = Args -> Int
maxSuccess Args
qcArgs
useQuickCheckArgs :: PropertyConfig -> PropertyConfig
useQuickCheckArgs PropertyConfig
pc =
PropertyConfig
pc
{ propertyTerminationCriteria :: TerminationCriteria
propertyTerminationCriteria =
case PropertyConfig -> TerminationCriteria
propertyTerminationCriteria PropertyConfig
pc of
EarlyTermination Confidence
x (TestLimit Int
_) ->
Confidence -> TestLimit -> TerminationCriteria
EarlyTermination Confidence
x (Int -> TestLimit
TestLimit Int
maxTests)
NoEarlyTermination Confidence
x (TestLimit Int
_) ->
Confidence -> TestLimit -> TerminationCriteria
NoEarlyTermination Confidence
x (Int -> TestLimit
TestLimit Int
maxTests)
NoConfidenceTermination (TestLimit Int
_) ->
TestLimit -> TerminationCriteria
NoConfidenceTermination (Int -> TestLimit
TestLimit Int
maxTests)
, propertyDiscardLimit :: DiscardLimit
propertyDiscardLimit =
Int -> DiscardLimit
DiscardLimit (Int -> DiscardLimit) -> Int -> DiscardLimit
forall a b. (a -> b) -> a -> b
$ Args -> Int
maxDiscardRatio Args
qcArgs
, propertyShrinkLimit :: ShrinkLimit
propertyShrinkLimit =
Int -> ShrinkLimit
ShrinkLimit (Int -> ShrinkLimit) -> Int -> ShrinkLimit
forall a b. (a -> b) -> a -> b
$ Args -> Int
maxShrinks Args
qcArgs
}
testCount :: Report a -> Int
testCount Report a
report =
case Report a -> TestCount
forall a. Report a -> TestCount
reportTests Report a
report of
TestCount Int
n -> Int
n
cb :: Report Progress -> IO ()
cb Report Progress
progress = do
case Report Progress -> Progress
forall a. Report a -> a
reportStatus Report Progress
progress of
Progress
Running ->
ProgressCallback
progressCallback (Report Progress -> Int
forall {a}. Report a -> Int
testCount Report Progress
progress, Int
maxTests)
Shrinking FailureReport
_ ->
ProgressCallback
progressCallback (Report Progress -> Int
forall {a}. Report a -> Int
testCount Report Progress
progress, Int
maxTests)
Seed
seed <- IO Seed -> IO Seed
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Seed -> IO Seed) -> IO Seed -> IO Seed
forall a b. (a -> b) -> a -> b
$ case Args -> Maybe (QCGen, Int)
replay (Params -> Args
paramsQuickCheckArgs Params
params) of
Maybe (QCGen, Int)
Nothing -> IO Seed
forall (m :: * -> *). MonadIO m => m Seed
Seed.random
Just (QCGen
rng, Int
_) -> Seed -> IO Seed
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Word64 -> Word64 -> Seed) -> (Word64, Word64) -> Seed
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word64 -> Word64 -> Seed
Seed (SMGen -> (Word64, Word64)
unseedSMGen (QCGen -> SMGen
forall a b. Coercible a b => a -> b
coerce QCGen
rng)))
Report Result
hedgeResult <- PropertyConfig
-> Size
-> Seed
-> PropertyT IO ()
-> (Report Progress -> IO ())
-> IO (Report Result)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PropertyConfig
-> Size
-> Seed
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
checkReport PropertyConfig
propConfig Size
size Seed
seed (Property -> PropertyT IO ()
propertyTest Property
prop) Report Progress -> IO ()
cb
String
ppresult <- UseColor -> Maybe PropertyName -> Report Result -> IO String
forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m String
renderResult UseColor
color Maybe PropertyName
forall a. Maybe a
Nothing Report Result
hedgeResult
IORef Result -> Result -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Result
ref (Result -> IO ()) -> Result -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ResultStatus -> Result
Result String
"" (ResultStatus -> Result) -> ResultStatus -> Result
forall a b. (a -> b) -> a -> b
$ case Report Result -> Result
forall a. Report a -> a
reportStatus Report Result
hedgeResult of
Failed FailureReport{String
[String]
[FailedAnnotation]
Maybe Span
Maybe (Coverage CoverCount)
Maybe Diff
ShrinkPath
ShrinkCount
failureShrinks :: ShrinkCount
failureShrinkPath :: ShrinkPath
failureCoverage :: Maybe (Coverage CoverCount)
failureAnnotations :: [FailedAnnotation]
failureLocation :: Maybe Span
failureMessage :: String
failureDiff :: Maybe Diff
failureFootnotes :: [String]
failureShrinks :: FailureReport -> ShrinkCount
failureShrinkPath :: FailureReport -> ShrinkPath
failureCoverage :: FailureReport -> Maybe (Coverage CoverCount)
failureAnnotations :: FailureReport -> [FailedAnnotation]
failureLocation :: FailureReport -> Maybe Span
failureMessage :: FailureReport -> String
failureDiff :: FailureReport -> Maybe Diff
failureFootnotes :: FailureReport -> [String]
..} ->
let
fromSpan :: Span -> Location
fromSpan Span{String
ColumnNo
LineNo
spanFile :: String
spanStartLine :: LineNo
spanStartColumn :: ColumnNo
spanEndLine :: LineNo
spanEndColumn :: ColumnNo
spanFile :: Span -> String
spanStartLine :: Span -> LineNo
spanStartColumn :: Span -> ColumnNo
spanEndLine :: Span -> LineNo
spanEndColumn :: Span -> ColumnNo
..} =
Location
{ locationFile :: String
locationFile = String
spanFile
, locationLine :: Int
locationLine = LineNo -> Int
forall a b. Coercible a b => a -> b
coerce LineNo
spanStartLine
, locationColumn :: Int
locationColumn = ColumnNo -> Int
forall a b. Coercible a b => a -> b
coerce ColumnNo
spanStartColumn
}
in
Maybe Location -> FailureReason -> ResultStatus
Hspec.Failure (Span -> Location
fromSpan (Span -> Location) -> Maybe Span -> Maybe Location
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Span
failureLocation) (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
ppresult
Result
GaveUp ->
Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (String -> FailureReason
Reason String
"GaveUp")
Result
OK ->
ResultStatus
Success
IORef Result -> IO Result
forall a. IORef a -> IO a
readIORef IORef Result
ref