@@ -3,6 +3,7 @@ module Test.Main where
33import Prelude
44
55import Control.Monad.Gen.Common (genMaybe )
6+ import Control.Monad.Reader (ReaderT , ask , local , runReaderT )
67import Data.Argonaut.Core (Json , isObject , stringify , toObject )
78import Data.Argonaut.Decode (class DecodeJson , decodeJson , (.:), (.:!), (.:?), (.!=))
89import Data.Argonaut.Encode (encodeJson , (:=), (:=?), (~>), (~>?))
@@ -12,23 +13,54 @@ import Data.Bifunctor (rmap)
1213import Data.Either (Either (..))
1314import Data.Foldable (foldl )
1415import Data.List (List )
16+ import Data.List as List
1517import Data.Maybe (Maybe (..), isJust , isNothing , maybe )
18+ import Data.Monoid (power )
1619import Data.NonEmpty (NonEmpty )
1720import Data.String.Gen (genUnicodeString )
1821import Data.Tuple (Tuple (..))
1922import Effect (Effect )
23+ import Effect.Class (liftEffect )
24+ import Effect.Class.Console (log )
25+ import Effect.Exception (throw )
2026import 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
2231import Test.QuickCheck.Arbitrary (arbitrary )
2332import 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 )
2833
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
2961
3062main :: Effect Unit
31- main = runTest do
63+ main = flip runReaderT 0 do
3264 suite " Either Check" eitherCheck
3365 suite " Encode/Decode NonEmpty Check" nonEmptyCheck
3466 suite " Encode/Decode Checks" encodeDecodeCheck
@@ -46,7 +78,7 @@ genTestRecord
4678 ))
4779genTestRecord = arbitrary
4880
49- encodeDecodeRecordCheck :: TestSuite
81+ encodeDecodeRecordCheck :: Test
5082encodeDecodeRecordCheck = do
5183 test " Testing that any record can be encoded and then decoded" do
5284 quickCheck rec_encode_then_decode
@@ -62,7 +94,7 @@ encodeDecodeRecordCheck = do
6294genTestJson :: Gen Json
6395genTestJson = resize 5 genJson
6496
65- encodeDecodeCheck :: TestSuite
97+ encodeDecodeCheck :: Test
6698encodeDecodeCheck = do
6799 test " Testing that any JSON can be encoded and then decoded" do
68100 quickCheck prop_encode_then_decode
@@ -88,7 +120,7 @@ encodeDecodeCheck = do
88120genObj :: Gen Json
89121genObj = suchThat (resize 5 genJson) isObject
90122
91- combinatorsCheck :: TestSuite
123+ combinatorsCheck :: Test
92124combinatorsCheck = do
93125 test " Check assoc builder `:=`" do
94126 quickCheck prop_assoc_builder_str
@@ -150,7 +182,7 @@ combinatorsCheck = do
150182 let keys = FO .keys object
151183 in foldl (\ok key -> ok && isJust (FO .lookup key object)) true keys
152184
153- eitherCheck :: TestSuite
185+ eitherCheck :: Test
154186eitherCheck = do
155187 test " Test EncodeJson/DecodeJson Either test" do
156188 quickCheck \(x :: Either String String ) ->
@@ -161,83 +193,83 @@ eitherCheck = do
161193 Left err ->
162194 false <?> err
163195
164- manualRecordDecode :: TestSuite
196+ manualRecordDecode :: Test
165197manualRecordDecode = do
166- test " Test that decoding custom record is successful " do
198+ test " Test that decoding custom record is pure unitful " do
167199 case decodeJson =<< jsonParser fooJson of
168- Right (Foo _) -> success
200+ Right (Foo _) -> pure unit
169201 Left err -> failure err
170202 suite " Test decoding empty record" testEmptyCases
171203 suite " Test decoding missing 'bar' key" testBarCases
172204 suite " Test decoding missing 'baz' key" testBazCases
173205 suite " Test decoding with all fields present" testFullCases
174206 where
175- testEmptyCases :: TestSuite
207+ testEmptyCases :: Test
176208 testEmptyCases = do
177209 test " Empty Json should decode to FooNested" do
178210 case decodeJson =<< jsonParser fooNestedEmptyJson of
179- Right (FooNested { bar: Nothing , baz: false }) -> success
211+ Right (FooNested { bar: Nothing , baz: false }) -> pure unit
180212 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedEmptyJson)
181213 test " Json with null values should fail to decode to FooNested" do
182214 case decodeJson =<< jsonParser fooNestedEmptyJsonNull of
183215 Right (FooNested _) -> failure (" Should have failed to decode JSON string: " <> fooNestedEmptyJsonNull)
184- _ -> success
216+ _ -> pure unit
185217 test " Empty Json should decode to FooNested'" do
186218 case decodeJson =<< jsonParser fooNestedEmptyJson of
187- Right (FooNested' { bar: Nothing , baz: false }) -> success
219+ Right (FooNested' { bar: Nothing , baz: false }) -> pure unit
188220 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedEmptyJson)
189221 test " Json with null values should decode to FooNested'" do
190222 case decodeJson =<< jsonParser fooNestedEmptyJsonNull of
191- Right (FooNested' { bar: Nothing , baz: false }) -> success
223+ Right (FooNested' { bar: Nothing , baz: false }) -> pure unit
192224 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedEmptyJsonNull)
193225
194- testBarCases :: TestSuite
226+ testBarCases :: Test
195227 testBarCases = do
196228 test " Missing 'bar' key should decode to FooNested" do
197229 case decodeJson =<< jsonParser fooNestedBazJson of
198- Right (FooNested { bar: Nothing , baz: true }) -> success
230+ Right (FooNested { bar: Nothing , baz: true }) -> pure unit
199231 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedBazJson)
200232 test " Null 'bar' key should fail to decode to FooNested" do
201233 case decodeJson =<< jsonParser fooNestedBazJsonNull of
202234 Right (FooNested _) -> failure (" Should have failed to decode JSON string: " <> fooNestedBazJsonNull)
203- _ -> success
235+ _ -> pure unit
204236 test " Missing 'bar' key should decode to FooNested'" do
205237 case decodeJson =<< jsonParser fooNestedBazJson of
206- Right (FooNested' { bar: Nothing , baz: true }) -> success
238+ Right (FooNested' { bar: Nothing , baz: true }) -> pure unit
207239 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedBazJson)
208240 test " Null 'bar' key should decode to FooNested'" do
209241 case decodeJson =<< jsonParser fooNestedBazJsonNull of
210- Right (FooNested' { bar: Nothing , baz: true }) -> success
242+ Right (FooNested' { bar: Nothing , baz: true }) -> pure unit
211243 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedBazJsonNull)
212244
213- testBazCases :: TestSuite
245+ testBazCases :: Test
214246 testBazCases = do
215247 test " Missing 'baz' key should decode to FooNested" do
216248 case decodeJson =<< jsonParser fooNestedBarJson of
217- Right (FooNested { bar: Just [1 ], baz: false }) -> success
249+ Right (FooNested { bar: Just [1 ], baz: false }) -> pure unit
218250 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedBarJson)
219251 test " Null 'baz' key should fail to decode to FooNested" do
220252 case decodeJson =<< jsonParser fooNestedBarJsonNull of
221253 Right (FooNested _) -> failure (" Should have failed to decode JSON string: " <> fooNestedBarJsonNull)
222- _ -> success
254+ _ -> pure unit
223255 test " Missing 'baz' key should decode to FooNested'" do
224256 case decodeJson =<< jsonParser fooNestedBarJson of
225- Right (FooNested' { bar: Just [1 ], baz: false }) -> success
257+ Right (FooNested' { bar: Just [1 ], baz: false }) -> pure unit
226258 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedBarJson)
227259 test " Null 'baz' key should decode to FooNested'" do
228260 case decodeJson =<< jsonParser fooNestedBarJsonNull of
229- Right (FooNested' { bar: Just [1 ], baz: false }) -> success
261+ Right (FooNested' { bar: Just [1 ], baz: false }) -> pure unit
230262 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedBarJsonNull)
231263
232- testFullCases :: TestSuite
264+ testFullCases :: Test
233265 testFullCases = do
234266 test " Json should decode to FooNested" do
235267 case decodeJson =<< jsonParser fooNestedFullJson of
236- Right (FooNested { bar: Just [1 ], baz: true }) -> success
268+ Right (FooNested { bar: Just [1 ], baz: true }) -> pure unit
237269 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedFullJson)
238270 test " Json should decode to FooNested'" do
239271 case decodeJson =<< jsonParser fooNestedFullJson of
240- Right (FooNested { bar: Just [1 ], baz: true }) -> success
272+ Right (FooNested { bar: Just [1 ], baz: true }) -> pure unit
241273 _ -> failure (" Failed to properly decode JSON string: " <> fooNestedFullJson)
242274
243275 fooJson :: String
@@ -264,7 +296,7 @@ manualRecordDecode = do
264296 fooNestedFullJson :: String
265297 fooNestedFullJson = """ { "bar": [1], "baz": true }"""
266298
267- nonEmptyCheck :: TestSuite
299+ nonEmptyCheck :: Test
268300nonEmptyCheck = do
269301 test " Test EncodeJson/DecodeJson on NonEmpty Array" do
270302 quickCheck \(x :: NonEmpty Array String ) ->
@@ -283,15 +315,15 @@ nonEmptyCheck = do
283315 Left err ->
284316 false <?> err
285317
286- errorMsgCheck :: TestSuite
318+ errorMsgCheck :: Test
287319errorMsgCheck = do
288320 test " Test that decoding array fails with the proper message" do
289321 case notBar of
290- Left err -> Assert .equal barErr err
322+ Left err -> assertEqual { expected: barErr, actual: err }
291323 _ -> failure " Should have failed to decode"
292324 test " Test that decoding record fails with the proper message" do
293325 case notBaz of
294- Left err -> Assert .equal bazErr err
326+ Left err -> assertEqual { expected: bazErr, actual: err }
295327 _ -> failure " Should have failed to decode"
296328 where
297329 barErr :: String
0 commit comments