{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Syd.Hedgehog (fromHedgehogGroup) where
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import qualified Data.Map as M
import qualified Hedgehog
import qualified Hedgehog.Internal.Config as Hedgehog
import qualified Hedgehog.Internal.Property as Hedgehog
import qualified Hedgehog.Internal.Report as Hedgehog
import qualified Hedgehog.Internal.Runner as Hedgehog
import qualified Hedgehog.Internal.Seed as Seed
import Test.Syd as Syd
fromHedgehogGroup :: Hedgehog.Group -> Syd.Spec
fromHedgehogGroup :: Group -> Spec
fromHedgehogGroup Group
hedgehogGroup = forall (outers :: [*]) inner.
String -> TestDefM outers inner () -> TestDefM outers inner ()
Syd.describe (GroupName -> String
Hedgehog.unGroupName forall a b. (a -> b) -> a -> b
$ Group -> GroupName
Hedgehog.groupName Group
hedgehogGroup) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Group -> [(PropertyName, Property)]
Hedgehog.groupProperties Group
hedgehogGroup) forall a b. (a -> b) -> a -> b
$ \(PropertyName
propertyName, Property
property) -> do
forall (outers :: [*]) inner test.
(HasCallStack, IsTest test, Arg1 test ~ (), Arg2 test ~ inner) =>
String -> test -> TestDefM outers inner ()
it (PropertyName -> String
Hedgehog.unPropertyName PropertyName
propertyName) Property
property
instance IsTest Hedgehog.Property where
type Arg1 Hedgehog.Property = ()
type Arg2 Hedgehog.Property = ()
runTest :: Property
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 Property -> Arg2 Property -> IO ()) -> IO ())
-> IO TestRunResult
runTest Property
func = forall outerArgs innerArg.
(outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runHedgehogPropertyWithArg (\() () -> Property
func)
instance IsTest (arg -> Hedgehog.Property) where
type Arg1 (arg -> Hedgehog.Property) = ()
type Arg2 (arg -> Hedgehog.Property) = arg
runTest :: (arg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (arg -> Property) -> Arg2 (arg -> Property) -> IO ())
-> IO ())
-> IO TestRunResult
runTest arg -> Property
func = forall outerArgs innerArg.
(outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runHedgehogPropertyWithArg (\() arg
a -> arg -> Property
func arg
a)
instance IsTest (outerArgs -> innerArg -> Hedgehog.Property) where
type Arg1 (outerArgs -> innerArg -> Hedgehog.Property) = outerArgs
type Arg2 (outerArgs -> innerArg -> Hedgehog.Property) = innerArg
runTest :: (outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (outerArgs -> innerArg -> Property)
-> Arg2 (outerArgs -> innerArg -> Property) -> IO ())
-> IO ())
-> IO TestRunResult
runTest = forall outerArgs innerArg.
(outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runHedgehogPropertyWithArg
runHedgehogPropertyWithArg ::
forall outerArgs innerArg.
(outerArgs -> innerArg -> Hedgehog.Property) ->
TestRunSettings ->
ProgressReporter ->
((outerArgs -> innerArg -> IO ()) -> IO ()) ->
IO TestRunResult
runHedgehogPropertyWithArg :: forall outerArgs innerArg.
(outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runHedgehogPropertyWithArg
outerArgs -> innerArg -> Property
hedgehogProp
TestRunSettings {Bool
Int
SeedSetting
testRunSettingSeed :: TestRunSettings -> SeedSetting
testRunSettingMaxSuccess :: TestRunSettings -> Int
testRunSettingMaxSize :: TestRunSettings -> Int
testRunSettingMaxDiscardRatio :: TestRunSettings -> Int
testRunSettingMaxShrinks :: TestRunSettings -> Int
testRunSettingGoldenStart :: TestRunSettings -> Bool
testRunSettingGoldenReset :: TestRunSettings -> Bool
testRunSettingGoldenReset :: Bool
testRunSettingGoldenStart :: Bool
testRunSettingMaxShrinks :: Int
testRunSettingMaxDiscardRatio :: Int
testRunSettingMaxSize :: Int
testRunSettingMaxSuccess :: Int
testRunSettingSeed :: SeedSetting
..}
ProgressReporter
progressReporter
(outerArgs -> innerArg -> IO ()) -> IO ()
wrapper = do
let report :: ProgressReporter
report = ProgressReporter -> ProgressReporter
reportProgress ProgressReporter
progressReporter
let size :: Size
size = Int -> Size
Hedgehog.Size Int
testRunSettingMaxSize
Seed
seed <- case SeedSetting
testRunSettingSeed of
SeedSetting
RandomSeed -> forall (m :: * -> *). MonadIO m => m Seed
Seed.random
FixedSeed Int
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word64 -> Seed
Seed.from (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
TVar Word
exampleCounter <- forall a. a -> IO (TVar a)
newTVarIO Word
1
let totalExamples :: Word
totalExamples = (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word) Int
testRunSettingMaxSuccess
ProgressReporter
report Progress
ProgressTestStarting
Either SomeException (Report Result)
errOrReport <- forall r outerArgs innerArg.
((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO r) -> IO (Either SomeException r)
applyWrapper2 (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper forall a b. (a -> b) -> a -> b
$ \outerArgs
outer innerArg
inner -> do
let config :: PropertyConfig
config =
(Property -> PropertyConfig
Hedgehog.propertyConfig (outerArgs -> innerArg -> Property
hedgehogProp outerArgs
outer innerArg
inner))
{ propertyDiscardLimit :: DiscardLimit
Hedgehog.propertyDiscardLimit = Int -> DiscardLimit
Hedgehog.DiscardLimit Int
testRunSettingMaxDiscardRatio,
propertyShrinkLimit :: ShrinkLimit
Hedgehog.propertyShrinkLimit = Int -> ShrinkLimit
Hedgehog.ShrinkLimit Int
testRunSettingMaxShrinks,
propertyTerminationCriteria :: TerminationCriteria
Hedgehog.propertyTerminationCriteria = TestLimit -> TerminationCriteria
Hedgehog.NoConfidenceTermination forall a b. (a -> b) -> a -> b
$ Int -> TestLimit
Hedgehog.TestLimit Int
testRunSettingMaxSuccess
}
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PropertyConfig
-> Size
-> Seed
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
Hedgehog.checkReport
PropertyConfig
config
Size
size
Seed
seed
( do
Word
exampleNr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar Word
exampleCounter
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProgressReporter
report forall a b. (a -> b) -> a -> b
$ Word -> Word -> Progress
ProgressExampleStarting Word
totalExamples Word
exampleNr
(()
result, Word64
duration) <- forall (m :: * -> *) a. MonadIO m => m a -> m (a, Word64)
timeItDuration forall a b. (a -> b) -> a -> b
$ Property -> PropertyT IO ()
Hedgehog.propertyTest (outerArgs -> innerArg -> Property
hedgehogProp outerArgs
outer innerArg
inner)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProgressReporter
report forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word64 -> Progress
ProgressExampleDone Word
totalExamples Word
exampleNr Word64
duration
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Word
exampleCounter forall a. Enum a => a -> a
succ
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
result
)
(\Report Progress
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
ProgressReporter
report Progress
ProgressTestDone
( TestStatus
testRunResultStatus,
Maybe SomeException
testRunResultException,
Maybe Word
testRunResultNumTests,
Maybe (Map [String] Int)
testRunResultLabels,
Maybe Word
testRunResultNumShrinks,
[String]
testRunResultFailingInputs
) <- case Either SomeException (Report Result)
errOrReport of
Left SomeException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestFailed, forall a. a -> Maybe a
Just SomeException
e, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing, [])
Right Report Result
hedgehogReport -> do
let Hedgehog.TestCount Int
testCountInt = forall a. Report a -> TestCount
Hedgehog.reportTests Report Result
hedgehogReport
numTests :: Maybe Word
numTests = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
testCountInt
labelList :: [(LabelName, Label CoverCount)]
labelList =
forall k a. Map k a -> [(k, a)]
M.toList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Coverage a -> Map LabelName (Label a)
Hedgehog.coverageLabels
forall a b. (a -> b) -> a -> b
$ forall a. Report a -> Coverage CoverCount
Hedgehog.reportCoverage Report Result
hedgehogReport
labels :: Maybe (Map [String] Int)
labels =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, Label CoverCount)]
labelList
then forall a. Maybe a
Nothing
else
forall a. a -> Maybe a
Just
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map
( \(LabelName
labelName, Label CoverCount
label) ->
([LabelName -> String
Hedgehog.unLabelName LabelName
labelName], CoverCount -> Int
Hedgehog.unCoverCount forall a b. (a -> b) -> a -> b
$ forall a. Label a -> a
Hedgehog.labelAnnotation Label CoverCount
label)
)
forall a b. (a -> b) -> a -> b
$ [(LabelName, Label CoverCount)]
labelList
case forall a. Report a -> a
Hedgehog.reportStatus Report Result
hedgehogReport of
Result
Hedgehog.OK -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestPassed, forall a. Maybe a
Nothing, Maybe Word
numTests, Maybe (Map [String] Int)
labels, forall a. Maybe a
Nothing, [])
Result
Hedgehog.GaveUp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestFailed, forall a. Maybe a
Nothing, Maybe Word
numTests, Maybe (Map [String] Int)
labels, forall a. Maybe a
Nothing, [])
Hedgehog.Failed FailureReport
failureReport -> do
String
s <-
forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m String
Hedgehog.renderResult
UseColor
Hedgehog.EnableColor
forall a. Maybe a
Nothing
Report Result
hedgehogReport
let Hedgehog.ShrinkCount Int
shrinkCountInt = FailureReport -> ShrinkCount
Hedgehog.failureShrinks FailureReport
failureReport
numShrinks :: Maybe Word
numShrinks = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
shrinkCountInt
exception :: Maybe SomeException
exception = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ String -> Assertion
ExpectationFailed String
s
inputs :: [String]
inputs = forall a b. (a -> b) -> [a] -> [b]
map FailedAnnotation -> String
Hedgehog.failedValue forall a b. (a -> b) -> a -> b
$ FailureReport -> [FailedAnnotation]
Hedgehog.failureAnnotations FailureReport
failureReport
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestFailed, Maybe SomeException
exception, Maybe Word
numTests, Maybe (Map [String] Int)
labels, Maybe Word
numShrinks, [String]
inputs)
let testRunResultGoldenCase :: Maybe a
testRunResultGoldenCase = forall a. Maybe a
Nothing
let testRunResultExtraInfo :: Maybe a
testRunResultExtraInfo = forall a. Maybe a
Nothing
let testRunResultClasses :: Maybe a
testRunResultClasses = forall a. Maybe a
Nothing
let testRunResultTables :: Maybe a
testRunResultTables = forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult {[String]
Maybe Word
Maybe (Map [String] Int)
Maybe SomeException
TestStatus
forall a. Maybe a
testRunResultStatus :: TestStatus
testRunResultException :: Maybe SomeException
testRunResultNumTests :: Maybe Word
testRunResultNumShrinks :: Maybe Word
testRunResultFailingInputs :: [String]
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultClasses :: Maybe (Map String Int)
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultExtraInfo :: Maybe String
testRunResultTables :: forall a. Maybe a
testRunResultClasses :: forall a. Maybe a
testRunResultExtraInfo :: forall a. Maybe a
testRunResultGoldenCase :: forall a. Maybe a
testRunResultFailingInputs :: [String]
testRunResultNumShrinks :: Maybe Word
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultNumTests :: Maybe Word
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
..}