{-# 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 = id
instance Example (PropertyT IO ()) where
type Arg (PropertyT IO ()) = ()
evaluateExample e = evaluateExample (\() -> e)
instance Example (a -> PropertyT IO ()) where
type Arg (a -> PropertyT IO ()) = a
evaluateExample (fmap property -> aprop) params aroundAction progressCallback = do
ref <- newIORef (Result "" (Pending Nothing Nothing))
aroundAction $ \a -> do
color <- detectColor
let size = 0
prop = aprop a
propConfig = useQuickCheckArgs (propertyConfig prop)
qcArgs = paramsQuickCheckArgs params
maxTests = maxSuccess qcArgs
useQuickCheckArgs pc =
pc
{ propertyTerminationCriteria =
case propertyTerminationCriteria pc of
EarlyTermination x (TestLimit _) ->
EarlyTermination x (TestLimit maxTests)
NoEarlyTermination x (TestLimit _) ->
NoEarlyTermination x (TestLimit maxTests)
NoConfidenceTermination (TestLimit _) ->
NoConfidenceTermination (TestLimit maxTests)
, propertyDiscardLimit =
DiscardLimit $ maxDiscardRatio qcArgs
, propertyShrinkLimit =
ShrinkLimit $ maxShrinks qcArgs
}
testCount report =
case reportTests report of
TestCount n -> n
cb progress = do
case reportStatus progress of
Running ->
progressCallback (testCount progress, maxTests)
Shrinking _ ->
progressCallback (testCount progress, maxTests)
seed <- liftIO $ case replay (paramsQuickCheckArgs params) of
Nothing -> Seed.random
Just (rng, _) -> pure (uncurry Seed (unseedSMGen (coerce rng)))
hedgeResult <- checkReport propConfig size seed (propertyTest prop) cb
ppresult <- renderResult color Nothing hedgeResult
writeIORef ref $ Result "" $ case reportStatus hedgeResult of
Failed FailureReport{..} ->
let
fromSpan Span{..} =
Location
{ locationFile = spanFile
, locationLine = coerce spanStartLine
, locationColumn = coerce spanStartColumn
}
in
Hspec.Failure (fromSpan <$> failureLocation) $ Reason ppresult
GaveUp ->
Failure Nothing (Reason "GaveUp")
OK ->
Success
readIORef ref