-
Notifications
You must be signed in to change notification settings - Fork 108
/
QuickCheck.hs
292 lines (259 loc) · 9.99 KB
/
QuickCheck.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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
-- | This module allows to use QuickCheck properties in tasty.
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, NamedFieldPuns #-}
module Test.Tasty.QuickCheck
( testProperty
, testProperties
, QuickCheckTests(..)
, QuickCheckReplay(..)
, QuickCheckShowReplay(..)
, QuickCheckMaxSize(..)
, QuickCheckMaxRatio(..)
, QuickCheckVerbose(..)
, QuickCheckMaxShrinks(..)
-- * Re-export of Test.QuickCheck
, module Test.QuickCheck
-- * Internal
-- | If you are building a test suite, you don't need these functions.
--
-- They may be used by other tasty add-on packages (such as tasty-hspec).
, QC(..)
, optionSetToArgs
) where
import Test.Tasty ( testGroup )
import Test.Tasty.Providers
import Test.Tasty.Options
import qualified Test.QuickCheck as QC
import qualified Test.QuickCheck.Test as QC
import qualified Test.QuickCheck.State as QC
import qualified Test.QuickCheck.Text as QC
import Test.Tasty.Runners (formatMessage, emptyProgress)
import Test.QuickCheck hiding -- for re-export
( quickCheck
, Args(..)
, Result
, stdArgs
, quickCheckWith
, quickCheckWithResult
, quickCheckResult
, verboseCheck
, verboseCheckWith
, verboseCheckWithResult
, verboseCheckResult
, verbose
-- Template Haskell functions
#if MIN_VERSION_QuickCheck(2,11,0)
, allProperties
#endif
, forAllProperties
, quickCheckAll
, verboseCheckAll
)
import Control.Applicative
import qualified Data.Char as Char
import Data.Typeable
import Data.List
import Text.Printf
import Text.Read (readMaybe)
import Test.QuickCheck.Random (QCGen, mkQCGen)
import Options.Applicative (metavar)
import System.Random (getStdRandom, randomR)
#if !MIN_VERSION_base(4,9,0)
import Data.Monoid
#endif
newtype QC = QC QC.Property
deriving Typeable
-- | Create a 'TestTree' for a QuickCheck 'QC.Testable' property
testProperty :: QC.Testable a => TestName -> a -> TestTree
testProperty name prop = singleTest name $ QC $ QC.property prop
-- | Create a test from a list of QuickCheck properties. To be used
-- with 'Test.QuickCheck.allProperties'. E.g.
--
-- >tests :: TestTree
-- >tests = testProperties "Foo" $allProperties
testProperties :: TestName -> [(String, Property)] -> TestTree
testProperties name = testGroup name . map (uncurry testProperty)
-- | Number of test cases for QuickCheck to generate
newtype QuickCheckTests = QuickCheckTests Int
deriving (Num, Ord, Eq, Real, Enum, Integral, Typeable)
-- | Replay seed
data QuickCheckReplay
= -- | No seed
--
-- @since 0.11
QuickCheckReplayNone
| -- | Legacy integer seed
--
-- @since 0.11
QuickCheckReplayLegacy Int
| -- | @(qcgen, intSize)@ holds both the seed and the size
-- to run QuickCheck tests
--
-- @since 0.11
QuickCheckReplay (QCGen, Int)
deriving (Typeable)
-- | If a test case fails unexpectedly, show the replay token
newtype QuickCheckShowReplay = QuickCheckShowReplay Bool
deriving (Typeable)
-- | Size of the biggest test cases
newtype QuickCheckMaxSize = QuickCheckMaxSize Int
deriving (Num, Ord, Eq, Real, Enum, Integral, Typeable)
-- | Maximum number of of discarded tests per successful test before giving up.
newtype QuickCheckMaxRatio = QuickCheckMaxRatio Int
deriving (Num, Ord, Eq, Real, Enum, Integral, Typeable)
-- | Show the test cases that QuickCheck generates
newtype QuickCheckVerbose = QuickCheckVerbose Bool
deriving (Typeable)
-- | Number of shrinks allowed before QuickCheck will fail a test.
--
-- @since 0.10.2
newtype QuickCheckMaxShrinks = QuickCheckMaxShrinks Int
deriving (Num, Ord, Eq, Real, Enum, Integral, Typeable)
instance IsOption QuickCheckTests where
defaultValue = 100
parseValue =
-- We allow numeric underscores for readability; see
-- https://github.com/UnkindPartition/tasty/issues/263
fmap QuickCheckTests . safeRead . filter (/= '_')
optionName = return "quickcheck-tests"
optionHelp = return "Number of test cases for QuickCheck to generate. Underscores accepted: e.g. 10_000_000"
optionCLParser = mkOptionCLParser $ metavar "NUMBER"
instance IsOption QuickCheckReplay where
defaultValue = QuickCheckReplayNone
-- Reads either a replay Int seed or a (QCGen, Int) seed
parseValue v =
(QuickCheckReplayLegacy <$> safeRead v) <|> (QuickCheckReplay <$> safeRead v)
optionName = return "quickcheck-replay"
optionHelp = return "Random seed to use for replaying a previous test run"
optionCLParser = mkOptionCLParser $ metavar "SEED"
instance IsOption QuickCheckShowReplay where
defaultValue = QuickCheckShowReplay False
parseValue = fmap QuickCheckShowReplay . safeReadBool
optionName = return "quickcheck-show-replay"
optionHelp = return "Show a replay token for replaying tests"
optionCLParser = flagCLParser Nothing (QuickCheckShowReplay True)
defaultMaxSize :: Int
defaultMaxSize = QC.maxSize QC.stdArgs
instance IsOption QuickCheckMaxSize where
defaultValue = fromIntegral defaultMaxSize
parseValue = fmap QuickCheckMaxSize . safeRead
optionName = return "quickcheck-max-size"
optionHelp = return "Size of the biggest test cases quickcheck generates"
optionCLParser = mkOptionCLParser $ metavar "NUMBER"
instance IsOption QuickCheckMaxRatio where
defaultValue = fromIntegral $ QC.maxDiscardRatio QC.stdArgs
parseValue = fmap QuickCheckMaxRatio . safeRead
optionName = return "quickcheck-max-ratio"
optionHelp = return "Maximum number of discared tests per successful test before giving up"
optionCLParser = mkOptionCLParser $ metavar "NUMBER"
instance IsOption QuickCheckVerbose where
defaultValue = QuickCheckVerbose False
parseValue = fmap QuickCheckVerbose . safeReadBool
optionName = return "quickcheck-verbose"
optionHelp = return "Show the generated test cases"
optionCLParser = mkFlagCLParser mempty (QuickCheckVerbose True)
instance IsOption QuickCheckMaxShrinks where
defaultValue = QuickCheckMaxShrinks (QC.maxShrinks QC.stdArgs)
parseValue = fmap QuickCheckMaxShrinks . safeRead
optionName = return "quickcheck-shrinks"
optionHelp = return "Number of shrinks allowed before QuickCheck will fail a test"
optionCLParser = mkOptionCLParser $ metavar "NUMBER"
-- | Convert tasty options into QuickCheck options.
--
-- This is a low-level function that was originally added for tasty-hspec
-- but may be used by others.
--
-- The returned Int is kept only for backward compatibility purposes. It
-- has no use in @tasty-quickcheck@.
--
-- @since 0.9.1
optionSetToArgs :: OptionSet -> IO (Int, QC.Args)
optionSetToArgs opts = do
(intSeed, replaySeed) <- case quickCheckReplay of
QuickCheckReplayNone -> do
intSeed <- getStdRandom (randomR (1,999999))
return (intSeed, (mkQCGen intSeed, 0))
QuickCheckReplayLegacy intSeed -> return (intSeed, (mkQCGen intSeed, 0))
-- The intSeed is not used when the new form of replay seed is used.
QuickCheckReplay replaySeed -> return (0, replaySeed)
let args = QC.stdArgs
{ QC.chatty = False
, QC.maxSuccess = nTests
, QC.maxSize = maxSize
, QC.replay = Just replaySeed
, QC.maxDiscardRatio = maxRatio
, QC.maxShrinks = maxShrinks
}
return (intSeed, args)
where
QuickCheckTests nTests = lookupOption opts
quickCheckReplay = lookupOption opts
QuickCheckMaxSize maxSize = lookupOption opts
QuickCheckMaxRatio maxRatio = lookupOption opts
QuickCheckMaxShrinks maxShrinks = lookupOption opts
instance IsTest QC where
testOptions = return
[ Option (Proxy :: Proxy QuickCheckTests)
, Option (Proxy :: Proxy QuickCheckReplay)
, Option (Proxy :: Proxy QuickCheckShowReplay)
, Option (Proxy :: Proxy QuickCheckMaxSize)
, Option (Proxy :: Proxy QuickCheckMaxRatio)
, Option (Proxy :: Proxy QuickCheckVerbose)
, Option (Proxy :: Proxy QuickCheckMaxShrinks)
]
run opts (QC prop) yieldProgress = do
(_, args) <- optionSetToArgs opts
let
QuickCheckShowReplay showReplay = lookupOption opts
QuickCheckVerbose verbose = lookupOption opts
-- Quickcheck already catches exceptions, no need to do it here.
r <- quickCheck yieldProgress
args
(if verbose then QC.verbose prop else prop)
qcOutput <- formatMessage $ QC.output r
let qcOutputNl =
if "\n" `isSuffixOf` qcOutput
then qcOutput
else qcOutput ++ "\n"
testSuccessful = successful r
putReplayInDesc = (not testSuccessful) || showReplay
Just seedSz <- return $ replayFromResult r <|> QC.replay args
let replayMsg = makeReplayMsg seedSz
return $
(if testSuccessful then testPassed else testFailed)
(qcOutputNl ++
(if putReplayInDesc then replayMsg else ""))
-- | Like the original 'QC.quickCheck' but is reporting progress using tasty
-- callback.
--
quickCheck :: (Progress -> IO ())
-> QC.Args
-> QC.Property
-> IO QC.Result
quickCheck yieldProgress args prop = do
-- Here we rely on the fact that QuickCheck currently prints its progress to
-- stderr and the overall status (which we don't need) to stdout
tm <- QC.newTerminal
(const $ pure ())
(\progressText -> yieldProgress emptyProgress { progressPercent = parseProgress progressText })
QC.withState args $ \ s ->
QC.test s { QC.terminal = tm } prop
where
-- QuickCheck outputs something like "(15461 tests)\b\b\b\b\b\b\b\b\b\b\b\b\b"
parseProgress :: String -> Float
parseProgress = maybe 0 (\n -> fromIntegral (n :: Int) / fromIntegral (QC.maxSuccess args))
. readMaybe
. takeWhile Char.isDigit
. drop 1
successful :: QC.Result -> Bool
successful r =
case r of
QC.Success {} -> True
_ -> False
makeReplayMsg :: (QCGen, Int) -> String
makeReplayMsg seedSz =
printf "Use --quickcheck-replay=\"%s\" to reproduce." (show seedSz)
replayFromResult :: QC.Result -> Maybe (QCGen, Int)
replayFromResult r =
case r of
Failure{} -> Just (QC.usedSeed r, QC.usedSize r)
_ -> Nothing