@@ -3,6 +3,7 @@ module Test.Main where
3
3
import Prelude
4
4
5
5
import Control.Monad.Gen.Common (genMaybe )
6
+ import Control.Monad.Reader (ReaderT , ask , local , runReaderT )
6
7
import Data.Argonaut.Core (Json , isObject , stringify , toObject )
7
8
import Data.Argonaut.Decode (class DecodeJson , decodeJson , (.:), (.:!), (.:?), (.!=))
8
9
import Data.Argonaut.Encode (encodeJson , (:=), (:=?), (~>), (~>?))
@@ -12,23 +13,54 @@ import Data.Bifunctor (rmap)
12
13
import Data.Either (Either (..))
13
14
import Data.Foldable (foldl )
14
15
import Data.List (List )
16
+ import Data.List as List
15
17
import Data.Maybe (Maybe (..), isJust , isNothing , maybe )
18
+ import Data.Monoid (power )
16
19
import Data.NonEmpty (NonEmpty )
17
20
import Data.String.Gen (genUnicodeString )
18
21
import Data.Tuple (Tuple (..))
19
22
import Effect (Effect )
23
+ import Effect.Class (liftEffect )
24
+ import Effect.Class.Console (log )
25
+ import Effect.Exception (throw )
20
26
import Foreign.Object as FO
21
- import Test.QuickCheck (Result (..), (<?>), (===))
27
+ import Test.Assert as Assert
28
+ import Test.QuickCheck (Result (..), unSeed , (<?>), (===))
29
+ import Test.QuickCheck as LCG
30
+ import Test.QuickCheck as QC
22
31
import Test.QuickCheck.Arbitrary (arbitrary )
23
32
import Test.QuickCheck.Gen (Gen , resize , suchThat )
24
- import Test.Unit (TestSuite , failure , success , suite , test )
25
- import Test.Unit.Assert as Assert
26
- import Test.Unit.Main (runTest )
27
- import Test.Unit.QuickCheck (quickCheck )
28
33
34
+ type Test = ReaderT Int Effect Unit
35
+
36
+ suite :: String -> Test -> Test
37
+ suite = test
38
+
39
+ test :: String -> Test -> Test
40
+ test name run = do
41
+ indent <- ask
42
+ log (mkIndent indent <> name)
43
+ local (_ + 2 ) run
44
+
45
+ mkIndent :: Int -> String
46
+ mkIndent = power " "
47
+
48
+ assertEqual :: forall a . Eq a => Show a => { actual :: a , expected :: a } -> Test
49
+ assertEqual = liftEffect <<< Assert .assertEqual
50
+
51
+ quickCheck :: forall prop . QC.Testable prop => prop -> Test
52
+ quickCheck prop = liftEffect do
53
+ seed <- LCG .randomSeed
54
+ let summary = QC .checkResults (QC .quickCheckPure' seed 100 prop)
55
+ case List .head summary.failures of
56
+ Nothing -> pure unit
57
+ Just err -> throw $ " Property failed (seed " <> show (unSeed err.seed) <> " ) failed: \n " <> err.message
58
+
59
+ failure :: String -> Test
60
+ failure = liftEffect <<< throw
29
61
30
62
main :: Effect Unit
31
- main = runTest do
63
+ main = flip runReaderT 0 do
32
64
suite " Either Check" eitherCheck
33
65
suite " Encode/Decode NonEmpty Check" nonEmptyCheck
34
66
suite " Encode/Decode Checks" encodeDecodeCheck
@@ -46,7 +78,7 @@ genTestRecord
46
78
))
47
79
genTestRecord = arbitrary
48
80
49
- encodeDecodeRecordCheck :: TestSuite
81
+ encodeDecodeRecordCheck :: Test
50
82
encodeDecodeRecordCheck = do
51
83
test " Testing that any record can be encoded and then decoded" do
52
84
quickCheck rec_encode_then_decode
@@ -62,7 +94,7 @@ encodeDecodeRecordCheck = do
62
94
genTestJson :: Gen Json
63
95
genTestJson = resize 5 genJson
64
96
65
- encodeDecodeCheck :: TestSuite
97
+ encodeDecodeCheck :: Test
66
98
encodeDecodeCheck = do
67
99
test " Testing that any JSON can be encoded and then decoded" do
68
100
quickCheck prop_encode_then_decode
@@ -88,7 +120,7 @@ encodeDecodeCheck = do
88
120
genObj :: Gen Json
89
121
genObj = suchThat (resize 5 genJson) isObject
90
122
91
- combinatorsCheck :: TestSuite
123
+ combinatorsCheck :: Test
92
124
combinatorsCheck = do
93
125
test " Check assoc builder `:=`" do
94
126
quickCheck prop_assoc_builder_str
@@ -150,7 +182,7 @@ combinatorsCheck = do
150
182
let keys = FO .keys object
151
183
in foldl (\ok key -> ok && isJust (FO .lookup key object)) true keys
152
184
153
- eitherCheck :: TestSuite
185
+ eitherCheck :: Test
154
186
eitherCheck = do
155
187
test " Test EncodeJson/DecodeJson Either test" do
156
188
quickCheck \(x :: Either String String ) ->
@@ -161,83 +193,83 @@ eitherCheck = do
161
193
Left err ->
162
194
false <?> err
163
195
164
- manualRecordDecode :: TestSuite
196
+ manualRecordDecode :: Test
165
197
manualRecordDecode = do
166
- test " Test that decoding custom record is successful " do
198
+ test " Test that decoding custom record is pure unitful " do
167
199
case decodeJson =<< jsonParser fooJson of
168
- Right (Foo _) -> success
200
+ Right (Foo _) -> pure unit
169
201
Left err -> failure err
170
202
suite " Test decoding empty record" testEmptyCases
171
203
suite " Test decoding missing 'bar' key" testBarCases
172
204
suite " Test decoding missing 'baz' key" testBazCases
173
205
suite " Test decoding with all fields present" testFullCases
174
206
where
175
- testEmptyCases :: TestSuite
207
+ testEmptyCases :: Test
176
208
testEmptyCases = do
177
209
test " Empty Json should decode to FooNested" do
178
210
case decodeJson =<< jsonParser fooNestedEmptyJson of
179
- Right (FooNested { bar: Nothing , baz: false }) -> success
211
+ Right (FooNested { bar: Nothing , baz: false }) -> pure unit
180
212
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedEmptyJson)
181
213
test " Json with null values should fail to decode to FooNested" do
182
214
case decodeJson =<< jsonParser fooNestedEmptyJsonNull of
183
215
Right (FooNested _) -> failure (" Should have failed to decode JSON string: " <> fooNestedEmptyJsonNull)
184
- _ -> success
216
+ _ -> pure unit
185
217
test " Empty Json should decode to FooNested'" do
186
218
case decodeJson =<< jsonParser fooNestedEmptyJson of
187
- Right (FooNested' { bar: Nothing , baz: false }) -> success
219
+ Right (FooNested' { bar: Nothing , baz: false }) -> pure unit
188
220
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedEmptyJson)
189
221
test " Json with null values should decode to FooNested'" do
190
222
case decodeJson =<< jsonParser fooNestedEmptyJsonNull of
191
- Right (FooNested' { bar: Nothing , baz: false }) -> success
223
+ Right (FooNested' { bar: Nothing , baz: false }) -> pure unit
192
224
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedEmptyJsonNull)
193
225
194
- testBarCases :: TestSuite
226
+ testBarCases :: Test
195
227
testBarCases = do
196
228
test " Missing 'bar' key should decode to FooNested" do
197
229
case decodeJson =<< jsonParser fooNestedBazJson of
198
- Right (FooNested { bar: Nothing , baz: true }) -> success
230
+ Right (FooNested { bar: Nothing , baz: true }) -> pure unit
199
231
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedBazJson)
200
232
test " Null 'bar' key should fail to decode to FooNested" do
201
233
case decodeJson =<< jsonParser fooNestedBazJsonNull of
202
234
Right (FooNested _) -> failure (" Should have failed to decode JSON string: " <> fooNestedBazJsonNull)
203
- _ -> success
235
+ _ -> pure unit
204
236
test " Missing 'bar' key should decode to FooNested'" do
205
237
case decodeJson =<< jsonParser fooNestedBazJson of
206
- Right (FooNested' { bar: Nothing , baz: true }) -> success
238
+ Right (FooNested' { bar: Nothing , baz: true }) -> pure unit
207
239
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedBazJson)
208
240
test " Null 'bar' key should decode to FooNested'" do
209
241
case decodeJson =<< jsonParser fooNestedBazJsonNull of
210
- Right (FooNested' { bar: Nothing , baz: true }) -> success
242
+ Right (FooNested' { bar: Nothing , baz: true }) -> pure unit
211
243
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedBazJsonNull)
212
244
213
- testBazCases :: TestSuite
245
+ testBazCases :: Test
214
246
testBazCases = do
215
247
test " Missing 'baz' key should decode to FooNested" do
216
248
case decodeJson =<< jsonParser fooNestedBarJson of
217
- Right (FooNested { bar: Just [1 ], baz: false }) -> success
249
+ Right (FooNested { bar: Just [1 ], baz: false }) -> pure unit
218
250
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedBarJson)
219
251
test " Null 'baz' key should fail to decode to FooNested" do
220
252
case decodeJson =<< jsonParser fooNestedBarJsonNull of
221
253
Right (FooNested _) -> failure (" Should have failed to decode JSON string: " <> fooNestedBarJsonNull)
222
- _ -> success
254
+ _ -> pure unit
223
255
test " Missing 'baz' key should decode to FooNested'" do
224
256
case decodeJson =<< jsonParser fooNestedBarJson of
225
- Right (FooNested' { bar: Just [1 ], baz: false }) -> success
257
+ Right (FooNested' { bar: Just [1 ], baz: false }) -> pure unit
226
258
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedBarJson)
227
259
test " Null 'baz' key should decode to FooNested'" do
228
260
case decodeJson =<< jsonParser fooNestedBarJsonNull of
229
- Right (FooNested' { bar: Just [1 ], baz: false }) -> success
261
+ Right (FooNested' { bar: Just [1 ], baz: false }) -> pure unit
230
262
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedBarJsonNull)
231
263
232
- testFullCases :: TestSuite
264
+ testFullCases :: Test
233
265
testFullCases = do
234
266
test " Json should decode to FooNested" do
235
267
case decodeJson =<< jsonParser fooNestedFullJson of
236
- Right (FooNested { bar: Just [1 ], baz: true }) -> success
268
+ Right (FooNested { bar: Just [1 ], baz: true }) -> pure unit
237
269
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedFullJson)
238
270
test " Json should decode to FooNested'" do
239
271
case decodeJson =<< jsonParser fooNestedFullJson of
240
- Right (FooNested { bar: Just [1 ], baz: true }) -> success
272
+ Right (FooNested { bar: Just [1 ], baz: true }) -> pure unit
241
273
_ -> failure (" Failed to properly decode JSON string: " <> fooNestedFullJson)
242
274
243
275
fooJson :: String
@@ -264,7 +296,7 @@ manualRecordDecode = do
264
296
fooNestedFullJson :: String
265
297
fooNestedFullJson = """ { "bar": [1], "baz": true }"""
266
298
267
- nonEmptyCheck :: TestSuite
299
+ nonEmptyCheck :: Test
268
300
nonEmptyCheck = do
269
301
test " Test EncodeJson/DecodeJson on NonEmpty Array" do
270
302
quickCheck \(x :: NonEmpty Array String ) ->
@@ -283,15 +315,15 @@ nonEmptyCheck = do
283
315
Left err ->
284
316
false <?> err
285
317
286
- errorMsgCheck :: TestSuite
318
+ errorMsgCheck :: Test
287
319
errorMsgCheck = do
288
320
test " Test that decoding array fails with the proper message" do
289
321
case notBar of
290
- Left err -> Assert .equal barErr err
322
+ Left err -> assertEqual { expected: barErr, actual: err }
291
323
_ -> failure " Should have failed to decode"
292
324
test " Test that decoding record fails with the proper message" do
293
325
case notBaz of
294
- Left err -> Assert .equal bazErr err
326
+ Left err -> assertEqual { expected: bazErr, actual: err }
295
327
_ -> failure " Should have failed to decode"
296
328
where
297
329
barErr :: String
0 commit comments