git.iko.soy/typeable/aeson
on acc-errors help sign in
typeable/aeson/tests/Properties.hs
558 lines 28 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-} -- For arbitrary Compose
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE ScopedTypeVariables #-}
7module Properties (module Properties) where
9import Prelude ()
10import Prelude.Compat
12import Control.Applicative (Const)
13import Data.Aeson (eitherDecode, encode)
14import Data.Aeson.Encoding (encodingToLazyByteString)
15import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse)
16import qualified Data.Aeson.Internal as I
17import Data.Aeson.Parser (value)
18import Data.Aeson.Types
19import Data.DList (DList)
20import Data.Functor.Compose (Compose (..))
21import Data.HashMap.Strict (HashMap)
22import Data.Hashable (Hashable)
23import Data.Int (Int8)
24import Data.List.NonEmpty (NonEmpty((:|)))
25import Data.Map (Map)
26import Data.Proxy (Proxy)
27import Data.Ratio (Ratio)
28import Data.Semigroup (Option(..))
29import Data.Sequence (Seq)
30import Data.Tagged (Tagged)
31import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
32import Data.Version (Version)
33import Encoders
34import Instances ()
35import Numeric.Natural (Natural)
36import Test.Framework (Test, testGroup)
37import Test.Framework.Providers.QuickCheck2 (testProperty)
38import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample)
39import Types
40import qualified Data.Attoparsec.Lazy as L
41import qualified Data.ByteString.Lazy.Char8 as L
42import qualified Data.HashMap.Strict as H
43import qualified Data.Map as Map
44import qualified Data.Text as T
45import qualified Data.Text.Lazy as LT
46import qualified Data.UUID.Types as UUID
47import qualified Data.Vector as V
49encodeDouble :: Double -> Double -> Property
50encodeDouble num denom
51 | isInfinite d || isNaN d = encode d === "null"
52 | otherwise = (read . L.unpack . encode) d === d
53 where d = num / denom
55encodeInteger :: Integer -> Property
56encodeInteger i = encode i === L.pack (show i)
58toParseJSON :: (Eq a, Show a) =>
59 (Value -> Parser a) -> (a -> Value) -> a -> Property
60toParseJSON parsejson tojson x =
61 case iparse parsejson . tojson $ x of
62 IError ((path, msg) :| _) -> failure "parse" (formatError path msg) x
63 ISuccess x' -> x === x'
65toParseJSON1
66 :: (Eq (f Int), Show (f Int))
67 => (forall a. LiftParseJSON f a)
68 -> (forall a. LiftToJSON f a)
69 -> f Int
70 -> Property
71toParseJSON1 parsejson1 tojson1 = toParseJSON parsejson tojson
72 where
73 parsejson = parsejson1 parseJSON (listParser parseJSON)
74 tojson = tojson1 toJSON (listValue toJSON)
76roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>
77 (a -> a -> Property) -> a -> a -> Property
78roundTripEnc eq _ i =
79 case fmap ifromJSON . L.parse value . encode $ i of
80 L.Done _ (ISuccess v) -> v `eq` i
81 L.Done _ (IError ((path, err) :| _)) -> failure "fromJSON" (formatError path err) i
82 L.Fail _ _ err -> failure "parse" err i
84roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>
85 (a -> a -> Property) -> a -> a -> Property
86roundTripNoEnc eq _ i =
87 case ifromJSON . toJSON $ i of
88 ISuccess v -> v `eq` i
89 IError ((path, err) :| _) -> failure "fromJSON" (formatError path err) i
91roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property
92roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y
94-- We test keys by encoding HashMap and Map with it
95roundTripKey
96 :: (Ord a, Hashable a, FromJSONKey a, ToJSONKey a, Show a)
97 => a -> HashMap a Int -> Map a Int -> Property
98roundTripKey _ h m = roundTripEq h h .&&. roundTripEq m m
100infix 4 ==~
101(==~) :: (ApproxEq a, Show a) => a -> a -> Property
102x ==~ y =
103 counterexample (show x ++ " /= " ++ show y) (x =~ y)
105toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property
106toFromJSON x = case ifromJSON (toJSON x) of
107 IError ((path, err) :| _) -> failure "fromJSON" (formatError path err) x
108 ISuccess x' -> x === x'
110modifyFailureProp :: String -> String -> Bool
111modifyFailureProp orig added =
112 result == Error (added ++ orig)
113 where
114 parser = const $ modifyFailure (added ++) $ fail orig
115 result :: Result ()
116 result = parse parser ()
118parserThrowErrorProp :: String -> Property
119parserThrowErrorProp msg =
120 result === Error msg
121 where
122 parser = const $ parserThrowError [] msg
123 result :: Result ()
124 result = parse parser ()
126-- | Tests (also) that we catch the JSONPath and it has elements in the right order.
127parserCatchErrorProp :: [String] -> String -> Property
128parserCatchErrorProp path msg =
129 result === Success ([I.Key "outer", I.Key "inner"] ++ jsonPath, msg)
130 where
131 parser = parserCatchError outer (curry pure)
133 outer = inner I.<?> I.Key "outer"
134 inner = parserThrowError jsonPath msg I.<?> I.Key "inner"
136 result :: Result (I.JSONPath, String)
137 result = parse (const parser) ()
139 jsonPath = map (I.Key . T.pack) path
141-- | Perform a structural comparison of the results of two encoding
142-- methods. Compares decoded values to account for HashMap-driven
143-- variation in JSON object key ordering.
144sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property
145sameAs toVal toEnc v =
146 counterexample (show s) $
147 eitherDecode s === Right (toVal v)
148 where
149 s = encodingToLazyByteString (toEnc v)
151sameAs1
152 :: (forall a. LiftToJSON f a)
153 -> (forall a. LiftToEncoding f a)
154 -> f Int
155 -> Property
156sameAs1 toVal1 toEnc1 v = lhs === rhs
157 where
158 rhs = Right $ toVal1 toJSON (listValue toJSON) v
159 lhs = eitherDecode . encodingToLazyByteString $
160 toEnc1 toEncoding (listEncoding toEncoding) v
162sameAs1Agree
163 :: ToJSON a
164 => (f a -> Encoding)
165 -> (forall b. LiftToEncoding f b)
166 -> f a
167 -> Property
168sameAs1Agree toEnc toEnc1 v = rhs === lhs
169 where
170 rhs = encodingToLazyByteString $ toEnc v
171 lhs = encodingToLazyByteString $ toEnc1 toEncoding (listEncoding toEncoding) v
173type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()
174type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)
176--------------------------------------------------------------------------------
177-- Value properties
178--------------------------------------------------------------------------------
180-- | Add the formatted @Value@ to the printed counterexample when the property
181-- fails.
182checkValue :: Testable a => (Value -> a) -> Value -> Property
183checkValue prop v = counterexample (L.unpack (encode v)) (prop v)
185isString :: Value -> Bool
186isString (String _) = True
187isString _ = False
189is2ElemArray :: Value -> Bool
190is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)
191is2ElemArray _ = False
193isTaggedObjectValue :: Value -> Bool
194isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&
195 "contents" `H.member` obj
196isTaggedObjectValue _ = False
198isNullaryTaggedObject :: Value -> Bool
199isNullaryTaggedObject obj = isTaggedObject' obj && isObjectWithSingleField obj
201isTaggedObject :: Value -> Property
202isTaggedObject = checkValue isTaggedObject'
204isTaggedObject' :: Value -> Bool
205isTaggedObject' (Object obj) = "tag" `H.member` obj
206isTaggedObject' _ = False
208isObjectWithSingleField :: Value -> Bool
209isObjectWithSingleField (Object obj) = H.size obj == 1
210isObjectWithSingleField _ = False
212-- | is untaggedValue of EitherTextInt
213isUntaggedValueETI :: Value -> Bool
214isUntaggedValueETI (String s)
215 | s == "nonenullary" = True
216isUntaggedValueETI (Bool _) = True
217isUntaggedValueETI (Number _) = True
218isUntaggedValueETI (Array a) = length a == 2
219isUntaggedValueETI _ = False
221isEmptyArray :: Value -> Property
222isEmptyArray = checkValue isEmptyArray'
224isEmptyArray' :: Value -> Bool
225isEmptyArray' = (Array mempty ==)
228--------------------------------------------------------------------------------
231tests :: Test
232tests = testGroup "properties" [
233 testGroup "encode" [
234 testProperty "encodeDouble" encodeDouble
235 , testProperty "encodeInteger" encodeInteger
236 ]
237 , testGroup "roundTrip" [
238 testProperty "Bool" $ roundTripEq True
239 , testProperty "Double" $ roundTripEq (1 :: Approx Double)
240 , testProperty "Int" $ roundTripEq (1 :: Int)
241 , testProperty "NonEmpty Char" $ roundTripEq (undefined :: NonEmpty Char)
242 , testProperty "Integer" $ roundTripEq (1 :: Integer)
243 , testProperty "String" $ roundTripEq ("" :: String)
244 , testProperty "Text" $ roundTripEq T.empty
245 , testProperty "Lazy Text" $ roundTripEq LT.empty
246 , testProperty "Foo" $ roundTripEq (undefined :: Foo)
247 , testProperty "Day" $ roundTripEq (undefined :: Day)
248 , testProperty "BCE Day" $ roundTripEq (undefined :: BCEDay)
249 , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)
250 , testProperty "LocalTime" $ roundTripEq (undefined :: LocalTime)
251 , testProperty "TimeOfDay" $ roundTripEq (undefined :: TimeOfDay)
252 , testProperty "UTCTime" $ roundTripEq (undefined :: UTCTime)
253 , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime)
254 , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)
255 , testProperty "DiffTime" $ roundTripEq (undefined :: DiffTime)
256 , testProperty "Version" $ roundTripEq (undefined :: Version)
257 , testProperty "Natural" $ roundTripEq (undefined :: Natural)
258 , testProperty "Proxy" $ roundTripEq (undefined :: Proxy Int)
259 , testProperty "Tagged" $ roundTripEq (undefined :: Tagged Int Char)
260 , testProperty "Const" $ roundTripEq (undefined :: Const Int Char)
261 , testProperty "DList" $ roundTripEq (undefined :: DList Int)
262 , testProperty "Seq" $ roundTripEq (undefined :: Seq Int)
263 , testProperty "Rational" $ roundTripEq (undefined :: Rational)
264 , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int)
265 , testProperty "UUID" $ roundTripEq UUID.nil
266 , testGroup "functors"
267 [ testProperty "Identity Char" $ roundTripEq (undefined :: I Int)
269 , testProperty "Identity Char" $ roundTripEq (undefined :: I Char)
270 , testProperty "Identity [Char]" $ roundTripEq (undefined :: I String)
271 , testProperty "[Identity Char]" $ roundTripEq (undefined :: [I Char])
273 , testProperty "Compose I I Int" $ roundTripEq (undefined :: LogScaled (Compose I I Int))
274 , testProperty "Compose [] I Int" $ roundTripEq (undefined :: LogScaled (Compose [] I Int))
275 , testProperty "Compose I [] Int" $ roundTripEq (undefined :: LogScaled (Compose I [] Int))
276 , testProperty "Compose [] [] Int" $ roundTripEq (undefined :: LogScaled (Compose [] [] Int))
278 , testProperty "Compose I I Char" $ roundTripEq (undefined :: LogScaled (Compose I I Char))
279 , testProperty "Compose [] I Char" $ roundTripEq (undefined :: LogScaled (Compose [] I Char))
280 , testProperty "Compose I [] Char" $ roundTripEq (undefined :: LogScaled (Compose I [] Char))
281 , testProperty "Compose [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose [] [] Char))
283 , testProperty "Compose3 I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I I Char))
284 , testProperty "Compose3 I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] I Char))
285 , testProperty "Compose3 I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I [] Char))
286 , testProperty "Compose3 I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] [] Char))
287 , testProperty "Compose3 [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I I Char))
288 , testProperty "Compose3 [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] I Char))
289 , testProperty "Compose3 [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I [] Char))
290 , testProperty "Compose3 [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] [] Char))
292 , testProperty "Compose3' I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I I Char))
293 , testProperty "Compose3' I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] I Char))
294 , testProperty "Compose3' I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I [] Char))
295 , testProperty "Compose3' I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] [] Char))
296 , testProperty "Compose3' [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I I Char))
297 , testProperty "Compose3' [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] I Char))
298 , testProperty "Compose3' [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I [] Char))
299 , testProperty "Compose3' [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] [] Char))
300 ]
301 , testGroup "ghcGenerics" [
302 testProperty "OneConstructor" $ roundTripEq OneConstructor
303 , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)
304 , testProperty "Product6" $ roundTripEq (undefined :: P6)
305 , testProperty "Sum4" $ roundTripEq (undefined :: S4)
306 ]
307 ]
308 , testGroup "roundTrip Key"
309 [ testProperty "Bool" $ roundTripKey True
310 , testProperty "Text" $ roundTripKey (undefined :: T.Text)
311 , testProperty "String" $ roundTripKey (undefined :: String)
312 , testProperty "Int" $ roundTripKey (undefined :: Int)
313 , testProperty "[Text]" $ roundTripKey (undefined :: LogScaled [T.Text])
314 , testProperty "(Int,Char)" $ roundTripKey (undefined :: (Int,Char))
315 , testProperty "Integer" $ roundTripKey (undefined :: Integer)
316 , testProperty "Natural" $ roundTripKey (undefined :: Natural)
317 , testProperty "Float" $ roundTripKey (undefined :: Float)
318 , testProperty "Double" $ roundTripKey (undefined :: Double)
319#if MIN_VERSION_base(4,7,0)
320 , testProperty "Day" $ roundTripKey (undefined :: Day)
321 , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime)
322 , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)
323 , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)
324#endif
325 , testProperty "Version" $ roundTripKey (undefined :: Version)
326 , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text)
327 , testProperty "UUID" $ roundTripKey UUID.nil
328 ]
329 , testGroup "toFromJSON" [
330 testProperty "Integer" (toFromJSON :: Integer -> Property)
331 , testProperty "Double" (toFromJSON :: Double -> Property)
332 , testProperty "Maybe Integer" (toFromJSON :: Maybe Integer -> Property)
333 , testProperty "Either Integer Double" (toFromJSON :: Either Integer Double -> Property)
334 , testProperty "Either Integer Integer" (toFromJSON :: Either Integer Integer -> Property)
335 ]
336 , testGroup "failure messages" [
337 testProperty "modify failure" modifyFailureProp
338 , testProperty "parserThrowError" parserThrowErrorProp
339 , testProperty "parserCatchError" parserCatchErrorProp
340 ]
341 , testGroup "generic" [
342 testGroup "toJSON" [
343 testGroup "Nullary" [
344 testProperty "string" (isString . gNullaryToJSONString)
345 , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
346 , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)
347 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
348 , testGroup "roundTrip" [
349 testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
350 , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
351 , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)
352 , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
353 ]
354 ]
355 , testGroup "EitherTextInt" [
356 testProperty "UntaggedValue" (isUntaggedValueETI . gEitherTextIntToJSONUntaggedValue)
357 , testProperty "roundtrip" (toParseJSON gEitherTextIntParseJSONUntaggedValue gEitherTextIntToJSONUntaggedValue)
358 ]
359 , testGroup "SomeType" [
360 testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)
361 , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)
362 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gSomeTypeToJSONObjectWithSingleField)
363 , testGroup "roundTrip" [
364 testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)
365 , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)
366 , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)
368#if __GLASGOW_HASKELL__ >= 706
369 , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)
370 , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)
371 , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)
372#endif
373 ]
374 ]
375 , testGroup "OneConstructor" [
376 testProperty "default" (isEmptyArray . gOneConstructorToJSONDefault)
377 , testProperty "Tagged" (isTaggedObject . gOneConstructorToJSONTagged)
378 , testGroup "roundTrip" [
379 testProperty "default" (toParseJSON gOneConstructorParseJSONDefault gOneConstructorToJSONDefault)
380 , testProperty "Tagged" (toParseJSON gOneConstructorParseJSONTagged gOneConstructorToJSONTagged)
381 ]
382 ]
383 , testGroup "OptionField" [
384 testProperty "like Maybe" $
385 \x -> gOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)
386 , testProperty "roundTrip" (toParseJSON gOptionFieldParseJSON gOptionFieldToJSON)
387 ]
388 ]
389 , testGroup "toEncoding" [
390 testProperty "NullaryString" $
391 gNullaryToJSONString `sameAs` gNullaryToEncodingString
392 , testProperty "Nullary2ElemArray" $
393 gNullaryToJSON2ElemArray `sameAs` gNullaryToEncoding2ElemArray
394 , testProperty "NullaryTaggedObject" $
395 gNullaryToJSONTaggedObject `sameAs` gNullaryToEncodingTaggedObject
396 , testProperty "NullaryObjectWithSingleField" $
397 gNullaryToJSONObjectWithSingleField `sameAs`
398 gNullaryToEncodingObjectWithSingleField
399 -- , testProperty "ApproxUnwrap" $
400 -- gApproxToJSONUnwrap `sameAs` gApproxToEncodingUnwrap
401 , testProperty "ApproxDefault" $
402 gApproxToJSONDefault `sameAs` gApproxToEncodingDefault
404 , testProperty "EitherTextInt UntaggedValue" $
405 gEitherTextIntToJSONUntaggedValue `sameAs` gEitherTextIntToEncodingUntaggedValue
407 , testProperty "SomeType2ElemArray" $
408 gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray
409#if __GLASGOW_HASKELL__ >= 706
410 , testProperty "SomeType2ElemArray unary" $
411 gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray
412 , testProperty "SomeType2ElemArray unary agree" $
413 gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray
414#endif
416 , testProperty "SomeTypeTaggedObject" $
417 gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject
418#if __GLASGOW_HASKELL__ >= 706
419 , testProperty "SomeTypeTaggedObject unary" $
420 gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject
421 , testProperty "SomeTypeTaggedObject unary agree" $
422 gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject
423#endif
425 , testProperty "SomeTypeObjectWithSingleField" $
426 gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField
427#if __GLASGOW_HASKELL__ >= 706
428 , testProperty "SomeTypeObjectWithSingleField unary" $
429 gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField
430 , testProperty "SomeTypeObjectWithSingleField unary agree" $
431 gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField
432#endif
434 , testProperty "SomeTypeOmitNothingFields" $
435 gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields
437 , testProperty "OneConstructorDefault" $
438 gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault
439 , testProperty "OneConstructorTagged" $
440 gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged
442 , testProperty "OptionField" $
443 gOptionFieldToJSON `sameAs` gOptionFieldToEncoding
444 ]
445 ]
446 , testGroup "template-haskell" [
447 testGroup "toJSON" [
448 testGroup "Nullary" [
449 testProperty "string" (isString . thNullaryToJSONString)
450 , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
451 , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
452 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
454 , testGroup "roundTrip" [
455 testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)
456 , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
457 , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)
458 , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
459 ]
460 ]
461 , testGroup "EitherTextInt" [
462 testProperty "UntaggedValue" (isUntaggedValueETI . thEitherTextIntToJSONUntaggedValue)
463 , testProperty "roundtrip" (toParseJSON thEitherTextIntParseJSONUntaggedValue thEitherTextIntToJSONUntaggedValue)
464 ]
465 , testGroup "SomeType" [
466 testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)
467 , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)
468 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thSomeTypeToJSONObjectWithSingleField)
469 , testGroup "roundTrip" [
470 testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)
471 , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)
472 , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)
474 , testProperty "2ElemArray unary" (toParseJSON1 thSomeTypeLiftParseJSON2ElemArray thSomeTypeLiftToJSON2ElemArray)
475 , testProperty "TaggedObject unary" (toParseJSON1 thSomeTypeLiftParseJSONTaggedObject thSomeTypeLiftToJSONTaggedObject)
476 , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)
478 ]
479 ]
480 , testGroup "Approx" [
481 testProperty "string" (isString . thApproxToJSONUnwrap)
482 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)
483 , testGroup "roundTrip" [
484 testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)
485 , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
486 ]
487 ]
488 , testGroup "GADT" [
489 testProperty "string" (isString . thGADTToJSONUnwrap)
490 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)
491 , testGroup "roundTrip" [
492 testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)
493 , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)
494 ]
495 ]
496 , testGroup "OneConstructor" [
497 testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)
498 , testProperty "Tagged" (isTaggedObject . thOneConstructorToJSONTagged)
499 , testGroup "roundTrip" [
500 testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)
501 , testProperty "Tagged" (toParseJSON thOneConstructorParseJSONTagged thOneConstructorToJSONTagged)
502 ]
503 ]
504 , testGroup "OptionField" [
505 testProperty "like Maybe" $
506 \x -> thOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)
507 , testProperty "roundTrip" (toParseJSON thOptionFieldParseJSON thOptionFieldToJSON)
508 ]
509 ]
510 , testGroup "toEncoding" [
511 testProperty "NullaryString" $
512 thNullaryToJSONString `sameAs` thNullaryToEncodingString
513 , testProperty "Nullary2ElemArray" $
514 thNullaryToJSON2ElemArray `sameAs` thNullaryToEncoding2ElemArray
515 , testProperty "NullaryTaggedObject" $
516 thNullaryToJSONTaggedObject `sameAs` thNullaryToEncodingTaggedObject
517 , testProperty "NullaryObjectWithSingleField" $
518 thNullaryToJSONObjectWithSingleField `sameAs`
519 thNullaryToEncodingObjectWithSingleField
520 , testProperty "ApproxUnwrap" $
521 thApproxToJSONUnwrap `sameAs` thApproxToEncodingUnwrap
522 , testProperty "ApproxDefault" $
523 thApproxToJSONDefault `sameAs` thApproxToEncodingDefault
525 , testProperty "EitherTextInt UntaggedValue" $
526 thEitherTextIntToJSONUntaggedValue `sameAs` thEitherTextIntToEncodingUntaggedValue
528 , testProperty "SomeType2ElemArray" $
529 thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray
530 , testProperty "SomeType2ElemArray unary" $
531 thSomeTypeLiftToJSON2ElemArray `sameAs1` thSomeTypeLiftToEncoding2ElemArray
532 , testProperty "SomeType2ElemArray unary agree" $
533 thSomeTypeToEncoding2ElemArray `sameAs1Agree` thSomeTypeLiftToEncoding2ElemArray
535 , testProperty "SomeTypeTaggedObject" $
536 thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject
537 , testProperty "SomeTypeTaggedObject unary" $
538 thSomeTypeLiftToJSONTaggedObject `sameAs1` thSomeTypeLiftToEncodingTaggedObject
539 , testProperty "SomeTypeTaggedObject unary agree" $
540 thSomeTypeToEncodingTaggedObject `sameAs1Agree` thSomeTypeLiftToEncodingTaggedObject
542 , testProperty "SomeTypeObjectWithSingleField" $
543 thSomeTypeToJSONObjectWithSingleField `sameAs` thSomeTypeToEncodingObjectWithSingleField
544 , testProperty "SomeTypeObjectWithSingleField unary" $
545 thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField
546 , testProperty "SomeTypeObjectWithSingleField unary agree" $
547 thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField
549 , testProperty "OneConstructorDefault" $
550 thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault
551 , testProperty "OneConstructorTagged" $
552 thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged
554 , testProperty "OptionField" $
555 thOptionFieldToJSON `sameAs` thOptionFieldToEncoding
556 ]
557 ]
558 ]