-
Notifications
You must be signed in to change notification settings - Fork 108
/
QuickCheck.hs
240 lines (209 loc) · 8.11 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
-- | This module allows to use QuickCheck properties in tasty.
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
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 Test.Tasty.Runners (formatMessage)
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 Data.Typeable
import Data.List
import Text.Printf
import Test.QuickCheck.Random (mkQCGen)
import Options.Applicative (metavar)
import System.Random (getStdRandom, randomR)
#if !MIN_VERSION_base(4,9,0)
import Control.Applicative
import Data.Monoid
#endif
newtype QC = QC QC.Property
deriving Typeable
-- | Create a 'Test' 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)
newtype QuickCheckReplay = QuickCheckReplay (Maybe 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 = QuickCheckReplay Nothing
-- Reads a replay int seed
parseValue v = QuickCheckReplay . Just <$> safeRead v
optionName = return "quickcheck-replay"
optionHelp = return "Random seed to use for replaying a previous test run (use same --quickcheck-max-size)"
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.
--
-- @since 0.9.1
optionSetToArgs :: OptionSet -> IO (Int, QC.Args)
optionSetToArgs opts = do
replaySeed <- case mReplay of
Nothing -> getStdRandom (randomR (1,999999))
Just seed -> return seed
let args = QC.stdArgs
{ QC.chatty = False
, QC.maxSuccess = nTests
, QC.maxSize = maxSize
, QC.replay = Just (mkQCGen replaySeed, 0)
, QC.maxDiscardRatio = maxRatio
, QC.maxShrinks = maxShrinks
}
return (replaySeed, args)
where
QuickCheckTests nTests = lookupOption opts
QuickCheckReplay mReplay = 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
(replaySeed, args) <- optionSetToArgs opts
let
QuickCheckShowReplay showReplay = lookupOption opts
QuickCheckVerbose verbose = lookupOption opts
maxSize = QC.maxSize args
testRunner = if verbose
then QC.verboseCheckWithResult
else QC.quickCheckWithResult
replayMsg = makeReplayMsg replaySeed maxSize
-- Quickcheck already catches exceptions, no need to do it here.
r <- testRunner args prop
qcOutput <- formatMessage $ QC.output r
let qcOutputNl =
if "\n" `isSuffixOf` qcOutput
then qcOutput
else qcOutput ++ "\n"
testSuccessful = successful r
putReplayInDesc = (not testSuccessful) || showReplay
return $
(if testSuccessful then testPassed else testFailed)
(qcOutputNl ++
(if putReplayInDesc then replayMsg else ""))
successful :: QC.Result -> Bool
successful r =
case r of
QC.Success {} -> True
_ -> False
makeReplayMsg :: Int -> Int -> String
makeReplayMsg seed size = let
sizeStr = if (size /= defaultMaxSize)
then printf " --quickcheck-max-size=%d" size
else ""
in printf "Use --quickcheck-replay=%d%s to reproduce." seed sizeStr