-
-
Notifications
You must be signed in to change notification settings - Fork 25
/
Hedgehog.hs
131 lines (123 loc) · 5.37 KB
/
Hedgehog.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
{-# LANGUAGE DataKinds #-}
{-# 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
-- | Import an Hedgehog 'Hedgehog.Group' as a Sydtest 'Test.Syd.Spec'.
--
-- The reasoning behind this function is that, eventhough migration from hedgehog
-- to sydtest is usually very simple, you might depend on certain libraries
-- beyond your control that still use hedgehog. In that case you want to be able
-- to still use those libraries but also use sydtest already.
fromHedgehogGroup :: Hedgehog.Group -> Syd.Spec
fromHedgehogGroup hedgehogGroup = Syd.describe (Hedgehog.unGroupName $ Hedgehog.groupName hedgehogGroup) $
forM_ (Hedgehog.groupProperties hedgehogGroup) $ \(propertyName, property) -> do
it (Hedgehog.unPropertyName propertyName) property
instance IsTest Hedgehog.Property where
type Arg1 Hedgehog.Property = ()
type Arg2 Hedgehog.Property = ()
runTest = runHedgehogProperty
runHedgehogProperty ::
Hedgehog.Property ->
Syd.TestRunSettings ->
Syd.ProgressReporter ->
((() -> () -> IO ()) -> IO ()) ->
IO TestRunResult
runHedgehogProperty
hedgehogProp
TestRunSettings {..}
progressReporter
wrapper = do
let report = reportProgress progressReporter
let config =
(Hedgehog.propertyConfig hedgehogProp)
{ Hedgehog.propertyDiscardLimit = Hedgehog.DiscardLimit testRunSettingMaxDiscardRatio,
Hedgehog.propertyShrinkLimit = Hedgehog.ShrinkLimit testRunSettingMaxShrinks,
Hedgehog.propertyTerminationCriteria = Hedgehog.NoConfidenceTermination $ Hedgehog.TestLimit testRunSettingMaxSuccess
}
let size = Hedgehog.Size testRunSettingMaxSize
seed <- case testRunSettingSeed of
RandomSeed -> Seed.random
FixedSeed i -> pure $ Seed.from (fromIntegral i)
exampleCounter <- newTVarIO 1
let totalExamples = (fromIntegral :: Int -> Word) testRunSettingMaxSuccess
report ProgressTestStarting
-- We make the same tradeoff here as in sydtest-hspec.
-- We show ProgressExampleStarting for non-property tests as well so that
-- we can attach timing information.
-- In the case of hedgehog, non-property tests should be rarer so that
-- should matter even less.
errOrReport <- applyWrapper2 wrapper $ \() () ->
Hedgehog.checkReport
config
size
seed
( do
exampleNr <- liftIO $ readTVarIO exampleCounter
liftIO $ report $ ProgressExampleStarting totalExamples exampleNr
timedResult <- timeItT $ Hedgehog.propertyTest hedgehogProp
liftIO $ report $ ProgressExampleDone totalExamples exampleNr $ timedTime timedResult
liftIO $ atomically $ modifyTVar' exampleCounter succ
pure $ timedValue timedResult
)
(\_ -> pure ()) -- Don't report progress
report ProgressTestDone
( testRunResultStatus,
testRunResultException,
testRunResultNumTests,
testRunResultLabels,
testRunResultNumShrinks,
testRunResultFailingInputs
) <- case errOrReport of
Left e -> pure (TestFailed, Just e, Nothing, Nothing, Nothing, [])
Right hedgehogReport -> do
let Hedgehog.TestCount testCountInt = Hedgehog.reportTests hedgehogReport
numTests = Just $ fromIntegral testCountInt
labelList =
M.toList
. Hedgehog.coverageLabels
$ Hedgehog.reportCoverage hedgehogReport
labels =
if null labelList
then Nothing
else
Just
. M.fromList
. map
( \(labelName, label) ->
([Hedgehog.unLabelName labelName], Hedgehog.unCoverCount $ Hedgehog.labelAnnotation label)
)
$ labelList
case Hedgehog.reportStatus hedgehogReport of
Hedgehog.OK -> pure (TestPassed, Nothing, numTests, labels, Nothing, [])
Hedgehog.GaveUp -> pure (TestFailed, Nothing, numTests, labels, Nothing, [])
Hedgehog.Failed failureReport -> do
s <-
Hedgehog.renderResult
Hedgehog.EnableColor
Nothing
hedgehogReport
let Hedgehog.ShrinkCount shrinkCountInt = Hedgehog.failureShrinks failureReport
numShrinks = Just $ fromIntegral shrinkCountInt
exception = Just $ SomeException $ ExpectationFailed s
inputs = map Hedgehog.failedValue $ Hedgehog.failureAnnotations failureReport
pure (TestFailed, exception, numTests, labels, numShrinks, inputs) -- TODO
let testRunResultRetries = Nothing
let testRunResultGoldenCase = Nothing
let testRunResultExtraInfo = Nothing
let testRunResultClasses = Nothing
let testRunResultTables = Nothing
let testRunResultFlakinessMessage = Nothing
pure TestRunResult {..}