git.iko.soy/typeable/aeson
on master help sign in
Add tests for unary type class th and generics derivation
commit4d6730320405f5ed02dc64f427bf56790de4b092 authorOleg Grenrus <oleg.grenrus@iki.fi> dateMon 4 Jul 2016, 01:23 (10 years ago) parent334e5a2
3 files changed+163−14
compare with master
unifiedsplit
tests/Encoders.hs+72−6 tests/Properties.hs+87−8 tests/Types.hs+4
tests/Encoders.hs+72−6
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE GADTs #-}
23{-# LANGUAGE TemplateHaskell #-}
34
@@ -97,15 +98,32 @@ gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleFi
9798-- SomeType encoders/decoders
9899--------------------------------------------------------------------------------
99100
101+-- Unary types
102+type LiftToJSON f a =
103+ (a -> Value) -> ([a] -> Value) -> f a -> Value
104+type LiftToEncoding f a =
105+ (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
106+type LiftParseJSON f a =
107+ (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)
108+
100109thSomeTypeToJSON2ElemArray :: SomeType Int -> Value
101110thSomeTypeToJSON2ElemArray = $(mkToJSON opts2ElemArray ''SomeType)
102111
103112thSomeTypeToEncoding2ElemArray :: SomeType Int -> Encoding
104113thSomeTypeToEncoding2ElemArray = $(mkToEncoding opts2ElemArray ''SomeType)
105114
115+thSomeTypeLiftToJSON2ElemArray :: LiftToJSON SomeType a
116+thSomeTypeLiftToJSON2ElemArray = $(mkLiftToJSON opts2ElemArray ''SomeType)
117+
118+thSomeTypeLiftToEncoding2ElemArray :: LiftToEncoding SomeType a
119+thSomeTypeLiftToEncoding2ElemArray = $(mkLiftToEncoding opts2ElemArray ''SomeType)
120+
106121thSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType Int)
107122thSomeTypeParseJSON2ElemArray = $(mkParseJSON opts2ElemArray ''SomeType)
108123
124+thSomeTypeLiftParseJSON2ElemArray :: LiftParseJSON SomeType a
125+thSomeTypeLiftParseJSON2ElemArray = $(mkLiftParseJSON opts2ElemArray ''SomeType)
126+
109127
110128thSomeTypeToJSONTaggedObject :: SomeType Int -> Value
111129thSomeTypeToJSONTaggedObject = $(mkToJSON optsTaggedObject ''SomeType)
@@ -113,21 +131,36 @@ thSomeTypeToJSONTaggedObject = $(mkToJSON optsTaggedObject ''SomeType)
113131thSomeTypeToEncodingTaggedObject :: SomeType Int -> Encoding
114132thSomeTypeToEncodingTaggedObject = $(mkToEncoding optsTaggedObject ''SomeType)
115133
134+thSomeTypeLiftToJSONTaggedObject :: LiftToJSON SomeType a
135+thSomeTypeLiftToJSONTaggedObject = $(mkLiftToJSON optsTaggedObject ''SomeType)
136+
137+thSomeTypeLiftToEncodingTaggedObject :: LiftToEncoding SomeType a
138+thSomeTypeLiftToEncodingTaggedObject = $(mkLiftToEncoding optsTaggedObject ''SomeType)
139+
116140thSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int)
117141thSomeTypeParseJSONTaggedObject = $(mkParseJSON optsTaggedObject ''SomeType)
118142
143+thSomeTypeLiftParseJSONTaggedObject :: LiftParseJSON SomeType a
144+thSomeTypeLiftParseJSONTaggedObject = $(mkLiftParseJSON optsTaggedObject ''SomeType)
145+
119146
120147thSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value
121−thSomeTypeToJSONObjectWithSingleField =
122− $(mkToJSON optsObjectWithSingleField ''SomeType)
148+thSomeTypeToJSONObjectWithSingleField = $(mkToJSON optsObjectWithSingleField ''SomeType)
123149
124150thSomeTypeToEncodingObjectWithSingleField :: SomeType Int -> Encoding
125−thSomeTypeToEncodingObjectWithSingleField =
126− $(mkToEncoding optsObjectWithSingleField ''SomeType)
151+thSomeTypeToEncodingObjectWithSingleField = $(mkToEncoding optsObjectWithSingleField ''SomeType)
152+
153+thSomeTypeLiftToJSONObjectWithSingleField :: LiftToJSON SomeType a
154+thSomeTypeLiftToJSONObjectWithSingleField = $(mkLiftToJSON optsObjectWithSingleField ''SomeType)
155+
156+thSomeTypeLiftToEncodingObjectWithSingleField :: LiftToEncoding SomeType a
157+thSomeTypeLiftToEncodingObjectWithSingleField = $(mkLiftToEncoding optsObjectWithSingleField ''SomeType)
127158
128159thSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int)
129−thSomeTypeParseJSONObjectWithSingleField =
130− $(mkParseJSON optsObjectWithSingleField ''SomeType)
160+thSomeTypeParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''SomeType)
161+
162+thSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a
163+thSomeTypeLiftParseJSONObjectWithSingleField = $(mkLiftParseJSON optsObjectWithSingleField ''SomeType)
131164
132165
133166gSomeTypeToJSON2ElemArray :: SomeType Int -> Value
@@ -139,6 +172,17 @@ gSomeTypeToEncoding2ElemArray = genericToEncoding opts2ElemArray
139172gSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType Int)
140173gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray
141174
175+#if __GLASGOW_HASKELL__ >= 706
176+gSomeTypeLiftToEncoding2ElemArray :: LiftToEncoding SomeType a
177+gSomeTypeLiftToEncoding2ElemArray = genericLiftToEncoding opts2ElemArray
178+
179+gSomeTypeLiftToJSON2ElemArray :: LiftToJSON SomeType a
180+gSomeTypeLiftToJSON2ElemArray = genericLiftToJSON opts2ElemArray
181+
182+gSomeTypeLiftParseJSON2ElemArray :: LiftParseJSON SomeType a
183+gSomeTypeLiftParseJSON2ElemArray = genericLiftParseJSON opts2ElemArray
184+#endif
185+
142186
143187gSomeTypeToJSONTaggedObject :: SomeType Int -> Value
144188gSomeTypeToJSONTaggedObject = genericToJSON optsTaggedObject
@@ -149,6 +193,17 @@ gSomeTypeToEncodingTaggedObject = genericToEncoding optsTaggedObject
149193gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int)
150194gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject
151195
196+#if __GLASGOW_HASKELL__ >= 706
197+gSomeTypeLiftToEncodingTaggedObject :: LiftToEncoding SomeType a
198+gSomeTypeLiftToEncodingTaggedObject = genericLiftToEncoding optsTaggedObject
199+
200+gSomeTypeLiftToJSONTaggedObject :: LiftToJSON SomeType a
201+gSomeTypeLiftToJSONTaggedObject = genericLiftToJSON optsTaggedObject
202+
203+gSomeTypeLiftParseJSONTaggedObject :: LiftParseJSON SomeType a
204+gSomeTypeLiftParseJSONTaggedObject = genericLiftParseJSON optsTaggedObject
205+#endif
206+
152207
153208gSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value
154209gSomeTypeToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField
@@ -159,6 +214,17 @@ gSomeTypeToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingl
159214gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int)
160215gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
161216
217+#if __GLASGOW_HASKELL__ >= 706
218+gSomeTypeLiftToEncodingObjectWithSingleField :: LiftToEncoding SomeType a
219+gSomeTypeLiftToEncodingObjectWithSingleField = genericLiftToEncoding optsObjectWithSingleField
220+
221+gSomeTypeLiftToJSONObjectWithSingleField :: LiftToJSON SomeType a
222+gSomeTypeLiftToJSONObjectWithSingleField = genericLiftToJSON optsObjectWithSingleField
223+
224+gSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a
225+gSomeTypeLiftParseJSONObjectWithSingleField = genericLiftParseJSON optsObjectWithSingleField
226+#endif
227+
162228
163229gSomeTypeToJSONOmitNothingFields :: SomeType Int -> Value
164230gSomeTypeToJSONOmitNothingFields = genericToJSON optsOmitNothingFields
tests/Properties.hs+87−8
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}
1+{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables, RankNTypes #-}
22
33-- For Arbitrary Compose
44{-# LANGUAGE FlexibleContexts #-}
@@ -12,8 +12,8 @@ import Control.Applicative (Const)
1212import Data.Aeson (eitherDecode, encode)
1313import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse)
1414import Data.Aeson.Parser (value)
15+import Data.Aeson.Encoding (encodingToLazyByteString)
1516import Data.Aeson.Types
16−import Data.ByteString.Builder (toLazyByteString)
1717import Data.Int (Int8)
1818import Data.Sequence (Seq)
1919import Data.DList (DList)
@@ -52,13 +52,24 @@ encodeDouble num denom
5252encodeInteger :: Integer -> Property
5353encodeInteger i = encode i === L.pack (show i)
5454
55−toParseJSON :: (Arbitrary a, Eq a, Show a) =>
55+toParseJSON :: (Eq a, Show a) =>
5656 (Value -> Parser a) -> (a -> Value) -> a -> Property
5757toParseJSON parsejson tojson x =
5858 case iparse parsejson . tojson $ x of
5959 IError path msg -> failure "parse" (formatError path msg) x
6060 ISuccess x' -> x === x'
6161
62+toParseJSON1
63+ :: (Eq (f Int), Show (f Int))
64+ => (forall a. LiftParseJSON f a)
65+ -> (forall a. LiftToJSON f a)
66+ -> f Int
67+ -> Property
68+toParseJSON1 parsejson1 tojson1 = toParseJSON parsejson tojson
69+ where
70+ parsejson = parsejson1 parseJSON (listParser parseJSON)
71+ tojson = tojson1 toJSON (listValue toJSON)
72+
6273roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>
6374 (a -> a -> Property) -> a -> a -> Property
6475roundTripEnc eq _ i =
@@ -106,7 +117,29 @@ modifyFailureProp orig added =
106117-- variation in JSON object key ordering.
107118sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property
108119sameAs toVal toEnc v =
109− eitherDecode (toLazyByteString (fromEncoding (toEnc v))) === Right (toVal v)
120+ eitherDecode (encodingToLazyByteString (toEnc v)) === Right (toVal v)
121+
122+sameAs1
123+ :: (forall a. LiftToJSON f a)
124+ -> (forall a. LiftToEncoding f a)
125+ -> f Int
126+ -> Property
127+sameAs1 toVal1 toEnc1 v = lhs === rhs
128+ where
129+ rhs = Right $ toVal1 toJSON (listValue toJSON) v
130+ lhs = eitherDecode . encodingToLazyByteString $
131+ toEnc1 toEncoding (listEncoding toEncoding) v
132+
133+sameAs1Agree
134+ :: ToJSON a
135+ => (f a -> Encoding)
136+ -> (forall b. LiftToEncoding f b)
137+ -> f a
138+ -> Property
139+sameAs1Agree toEnc toEnc1 v = rhs === lhs
140+ where
141+ rhs = encodingToLazyByteString $ toEnc v
142+ lhs = encodingToLazyByteString $ toEnc1 toEncoding (listEncoding toEncoding) v
110143
111144type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()
112145type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)
@@ -268,6 +301,12 @@ tests = testGroup "properties" [
268301 testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)
269302 , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)
270303 , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)
304+
305+#if __GLASGOW_HASKELL__ >= 706
306+ , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)
307+ , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)
308+ , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)
309+#endif
271310 ]
272311 ]
273312 ]
@@ -285,13 +324,34 @@ tests = testGroup "properties" [
285324 -- gApproxToJSONUnwrap `sameAs` gApproxToEncodingUnwrap
286325 , testProperty "ApproxDefault" $
287326 gApproxToJSONDefault `sameAs` gApproxToEncodingDefault
327+
288328 , testProperty "SomeType2ElemArray" $
289329 gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray
330+#if __GLASGOW_HASKELL__ >= 706
331+ , testProperty "SomeType2ElemArray unary" $
332+ gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray
333+ , testProperty "SomeType2ElemArray unary agree" $
334+ gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray
335+#endif
336+
290337 , testProperty "SomeTypeTaggedObject" $
291338 gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject
339+#if __GLASGOW_HASKELL__ >= 706
340+ , testProperty "SomeTypeTaggedObject unary" $
341+ gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject
342+ , testProperty "SomeTypeTaggedObject unary agree" $
343+ gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject
344+#endif
345+
292346 , testProperty "SomeTypeObjectWithSingleField" $
293− gSomeTypeToJSONObjectWithSingleField `sameAs`
294− gSomeTypeToEncodingObjectWithSingleField
347+ gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField
348+#if __GLASGOW_HASKELL__ >= 706
349+ , testProperty "SomeTypeObjectWithSingleField unary" $
350+ gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField
351+ , testProperty "SomeTypeObjectWithSingleField unary agree" $
352+ gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField
353+#endif
354+
295355 , testProperty "SomeTypeOmitNothingFields" $
296356 gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields
297357 ]
@@ -319,6 +379,11 @@ tests = testGroup "properties" [
319379 testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)
320380 , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)
321381 , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)
382+
383+ , testProperty "2ElemArray unary" (toParseJSON1 thSomeTypeLiftParseJSON2ElemArray thSomeTypeLiftToJSON2ElemArray)
384+ , testProperty "TaggedObject unary" (toParseJSON1 thSomeTypeLiftParseJSONTaggedObject thSomeTypeLiftToJSONTaggedObject)
385+ , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)
386+
322387 ]
323388 , testGroup "Approx" [
324389 testProperty "string" (isString . thApproxToJSONUnwrap)
@@ -352,13 +417,27 @@ tests = testGroup "properties" [
352417 thApproxToJSONUnwrap `sameAs` thApproxToEncodingUnwrap
353418 , testProperty "ApproxDefault" $
354419 thApproxToJSONDefault `sameAs` thApproxToEncodingDefault
420+
355421 , testProperty "SomeType2ElemArray" $
356422 thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray
423+ , testProperty "SomeType2ElemArray unary" $
424+ thSomeTypeLiftToJSON2ElemArray `sameAs1` thSomeTypeLiftToEncoding2ElemArray
425+ , testProperty "SomeType2ElemArray unary agree" $
426+ thSomeTypeToEncoding2ElemArray `sameAs1Agree` thSomeTypeLiftToEncoding2ElemArray
427+
357428 , testProperty "SomeTypeTaggedObject" $
358429 thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject
430+ , testProperty "SomeTypeTaggedObject unary" $
431+ thSomeTypeLiftToJSONTaggedObject `sameAs1` thSomeTypeLiftToEncodingTaggedObject
432+ , testProperty "SomeTypeTaggedObject unary agree" $
433+ thSomeTypeToEncodingTaggedObject `sameAs1Agree` thSomeTypeLiftToEncodingTaggedObject
434+
359435 , testProperty "SomeTypeObjectWithSingleField" $
360− thSomeTypeToJSONObjectWithSingleField `sameAs`
361− thSomeTypeToEncodingObjectWithSingleField
436+ thSomeTypeToJSONObjectWithSingleField `sameAs` thSomeTypeToEncodingObjectWithSingleField
437+ , testProperty "SomeTypeObjectWithSingleField unary" $
438+ thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField
439+ , testProperty "SomeTypeObjectWithSingleField unary agree" $
440+ thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField
362441 ]
363442 ]
364443 ]
tests/Types.hs+4
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DeriveDataTypeable #-}
23{-# LANGUAGE DeriveGeneric #-}
34{-# LANGUAGE FlexibleInstances #-}
@@ -81,6 +82,9 @@ deriving instance Generic (Sum4 a b c d)
8182deriving instance Generic (Approx a)
8283deriving instance Generic Nullary
8384deriving instance Generic (SomeType a)
85+#if __GLASGOW_HASKELL__ >= 706
86+deriving instance Generic1 SomeType
87+#endif
8488
8589failure :: Show a => String -> String -> a -> Property
8690failure func msg v = counterexample