@@ -1,25 +1,38 @@
1−{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards,
2− ScopedTypeVariables, StandaloneDeriving #-}
1+{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings, RecordWildCards,
2+ ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}
33{-# OPTIONS_GHC -fno-warn-orphans #-}
44
5+#ifdef GENERICS
6+{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}
7+#endif
8+
59import Control.Monad
610import Control.Applicative
711import Data.Aeson.Encode
812import Data.Aeson.Parser (value)
913import Data.Aeson.Types
14+import Data.Aeson.TH
1015import Data.Attoparsec.Number
1116import Data.Data (Typeable, Data)
1217import Data.Text (Text)
1318import Test.Framework (Test, defaultMain, testGroup)
1419import Test.Framework.Providers.QuickCheck2 (testProperty)
15−import Test.QuickCheck (Arbitrary(..), choose, Gen)
20+import Test.QuickCheck (Arbitrary(..), choose, oneof, elements, Gen)
21+import qualified Data.Vector as V
1622import qualified Data.Aeson.Generic as G
1723import qualified Data.Attoparsec.Lazy as L
1824import qualified Data.ByteString.Lazy.Char8 as L
1925import qualified Data.Text as T
2026import qualified Data.Map as Map
27+import qualified Data.HashMap.Strict as H
2128import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..), hoursToTimeZone, Day(..), TimeOfDay(..))
2229
30+import Options
31+
32+#ifdef GENERICS
33+import GHC.Generics
34+#endif
35+
2336encodeDouble :: Double -> Double -> Bool
2437encodeDouble num denom
2538 | isInfinite d || isNaN d = encode (Number (D d)) == "null"
@@ -62,6 +75,11 @@ genericToFromJSON x = case G.fromJSON . G.toJSON $ x of
6275 Error _ -> False
6376 Success x' -> x == x'
6477
78+toParseJSON :: (Arbitrary a, Eq a) => (Value -> Parser a) -> (a -> Value) -> a -> Bool
79+toParseJSON parsejson tojson x = case parse parsejson . tojson $ x of
80+ Error _ -> False
81+ Success x' -> x == x'
82+
6583regress_gh72 :: [(String, Maybe String)] -> Bool
6684regress_gh72 ys = G.decode (G.encode m) == Just m
6785 where m = Map.fromList ys
@@ -83,6 +101,165 @@ data Foo = Foo {
83101 , fooMap :: Map.Map String (Text,Int)
84102 } deriving (Show, Typeable, Data)
85103
104+--------------------------------------------------------------------------------
105+-- Nullary
106+--------------------------------------------------------------------------------
107+
108+data Nullary = C1 | C2 | C3 deriving (Eq, Show)
109+
110+instance Arbitrary Nullary where
111+ arbitrary = elements [C1, C2, C3]
112+
113+thNullaryToJSONString :: Nullary -> Value
114+thNullaryToJSONString = $(mkToJSON defaultOptions ''Nullary)
115+
116+thNullaryParseJSONString :: Value -> Parser Nullary
117+thNullaryParseJSONString = $(mkParseJSON defaultOptions ''Nullary)
118+
119+
120+thNullaryToJSON2ElemArray :: Nullary -> Value
121+thNullaryToJSON2ElemArray = $(mkToJSON opts2ElemArray ''Nullary)
122+
123+thNullaryParseJSON2ElemArray :: Value -> Parser Nullary
124+thNullaryParseJSON2ElemArray = $(mkParseJSON opts2ElemArray ''Nullary)
125+
126+
127+thNullaryToJSONObjectWithType :: Nullary -> Value
128+thNullaryToJSONObjectWithType = $(mkToJSON optsObjectWithType ''Nullary)
129+
130+thNullaryParseJSONObjectWithType :: Value -> Parser Nullary
131+thNullaryParseJSONObjectWithType = $(mkParseJSON optsObjectWithType ''Nullary)
132+
133+
134+thNullaryToJSONObjectWithSingleField :: Nullary -> Value
135+thNullaryToJSONObjectWithSingleField = $(mkToJSON optsObjectWithSingleField ''Nullary)
136+
137+thNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
138+thNullaryParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''Nullary)
139+
140+#ifdef GENERICS
141+deriving instance Generic Nullary
142+
143+gNullaryToJSONString :: Nullary -> Value
144+gNullaryToJSONString = gToJSON defaultOptions . from
145+
146+gNullaryParseJSONString :: Value -> Parser Nullary
147+gNullaryParseJSONString = fmap to . gParseJSON defaultOptions
148+
149+
150+gNullaryToJSON2ElemArray :: Nullary -> Value
151+gNullaryToJSON2ElemArray = gToJSON opts2ElemArray . from
152+
153+gNullaryParseJSON2ElemArray :: Value -> Parser Nullary
154+gNullaryParseJSON2ElemArray = fmap to . gParseJSON opts2ElemArray
155+
156+
157+gNullaryToJSONObjectWithType :: Nullary -> Value
158+gNullaryToJSONObjectWithType = gToJSON optsObjectWithType . from
159+
160+gNullaryParseJSONObjectWithType :: Value -> Parser Nullary
161+gNullaryParseJSONObjectWithType = fmap to . gParseJSON optsObjectWithType
162+
163+
164+gNullaryToJSONObjectWithSingleField :: Nullary -> Value
165+gNullaryToJSONObjectWithSingleField = gToJSON optsObjectWithSingleField . from
166+
167+gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
168+gNullaryParseJSONObjectWithSingleField = fmap to . gParseJSON optsObjectWithSingleField
169+#endif
170+
171+--------------------------------------------------------------------------------
172+-- SomeType
173+--------------------------------------------------------------------------------
174+
175+data SomeType a = Nullary
176+ | Unary Int
177+ | Product String (Maybe Char) a
178+ | Record { testOne :: Double
179+ , testTwo :: Maybe Bool
180+ , testThree :: Maybe a
181+ } deriving (Eq, Show)
182+
183+instance Arbitrary a => Arbitrary (SomeType a) where
184+ arbitrary = oneof [ pure Nullary
185+ , Unary <$> arbitrary
186+ , Product <$> arbitrary <*> arbitrary <*> arbitrary
187+ , Record <$> arbitrary <*> arbitrary <*> arbitrary
188+ ]
189+
190+type SomeTypeToJSON = SomeType Int -> Value
191+
192+thSomeTypeToJSON2ElemArray :: ToJSON a => SomeType a -> Value
193+thSomeTypeToJSON2ElemArray = $(mkToJSON opts2ElemArray ''SomeType)
194+
195+thSomeTypeParseJSON2ElemArray :: FromJSON a => Value -> Parser (SomeType a)
196+thSomeTypeParseJSON2ElemArray = $(mkParseJSON opts2ElemArray ''SomeType)
197+
198+
199+thSomeTypeToJSONObjectWithType :: ToJSON a => SomeType a -> Value
200+thSomeTypeToJSONObjectWithType = $(mkToJSON optsObjectWithType ''SomeType)
201+
202+thSomeTypeParseJSONObjectWithType :: FromJSON a => Value -> Parser (SomeType a)
203+thSomeTypeParseJSONObjectWithType = $(mkParseJSON optsObjectWithType ''SomeType)
204+
205+
206+thSomeTypeToJSONObjectWithSingleField :: ToJSON a => SomeType a -> Value
207+thSomeTypeToJSONObjectWithSingleField = $(mkToJSON optsObjectWithSingleField ''SomeType)
208+
209+thSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)
210+thSomeTypeParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''SomeType)
211+
212+#ifdef GENERICS
213+deriving instance Generic (SomeType a)
214+
215+gSomeTypeToJSON2ElemArray :: ToJSON a => SomeType a -> Value
216+gSomeTypeToJSON2ElemArray = gToJSON opts2ElemArray . from
217+
218+gSomeTypeParseJSON2ElemArray :: FromJSON a => Value -> Parser (SomeType a)
219+gSomeTypeParseJSON2ElemArray = fmap to . gParseJSON opts2ElemArray
220+
221+
222+gSomeTypeToJSONObjectWithType :: ToJSON a => SomeType a -> Value
223+gSomeTypeToJSONObjectWithType = gToJSON optsObjectWithType . from
224+
225+gSomeTypeParseJSONObjectWithType :: FromJSON a => Value -> Parser (SomeType a)
226+gSomeTypeParseJSONObjectWithType = fmap to . gParseJSON optsObjectWithType
227+
228+
229+gSomeTypeToJSONObjectWithSingleField :: ToJSON a => SomeType a -> Value
230+gSomeTypeToJSONObjectWithSingleField = gToJSON optsObjectWithSingleField . from
231+
232+gSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)
233+gSomeTypeParseJSONObjectWithSingleField = fmap to . gParseJSON optsObjectWithSingleField
234+#endif
235+
236+--------------------------------------------------------------------------------
237+-- Value properties
238+--------------------------------------------------------------------------------
239+
240+isString :: Value -> Bool
241+isString (String _) = True
242+isString _ = False
243+
244+is2ElemArray :: Value -> Bool
245+is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)
246+is2ElemArray _ = False
247+
248+isObjectWithTypeValue :: Value -> Bool
249+isObjectWithTypeValue (Object obj) = "type" `H.member` obj &&
250+ "value" `H.member` obj
251+isObjectWithTypeValue _ = False
252+
253+isObjectWithType :: Value -> Bool
254+isObjectWithType (Object obj) = "type" `H.member` obj
255+isObjectWithType _ = False
256+
257+isObjectWithSingleField :: Value -> Bool
258+isObjectWithSingleField (Object obj) = H.size obj == 1
259+isObjectWithSingleField _ = False
260+
261+--------------------------------------------------------------------------------
262+
86263instance Eq Foo where
87264 a == b = fooInt a == fooInt b &&
88265 fooDouble a `approxEq` fooDouble b &&
@@ -182,5 +359,70 @@ tests = [
182359 ],
183360 testGroup "failure messages" [
184361 testProperty "modify failure" modifyFailureProp
362+ ],
363+ testGroup "template-haskell" [
364+ testGroup "Nullary" [
365+ testProperty "string" (isString . thNullaryToJSONString)
366+ , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
367+ , testProperty "ObjectWithType" (isObjectWithTypeValue . thNullaryToJSONObjectWithType)
368+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
369+
370+ , testGroup "roundTrip" [
371+ testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)
372+ , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
373+ , testProperty "ObjectWithType" (toParseJSON thNullaryParseJSONObjectWithType thNullaryToJSONObjectWithType)
374+ , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
375+ ]
376+ ]
377+ , testGroup "SomeType" [
378+ testProperty "2ElemArray" (is2ElemArray . (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
379+ , testProperty "ObjectWithType" (isObjectWithType . (thSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
380+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
381+
382+ , testGroup "roundTrip" [
383+ testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
384+ , testProperty "ObjectWithType" (toParseJSON thSomeTypeParseJSONObjectWithType (thSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
385+ , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
386+ ]
387+ ]
388+ ]
389+#ifdef GENERICS
390+ , testGroup "GHC-generics" [
391+ testGroup "Nullary" [
392+ testProperty "string" (isString . gNullaryToJSONString)
393+ , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
394+ , testProperty "ObjectWithType" (isObjectWithTypeValue . gNullaryToJSONObjectWithType)
395+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
396+
397+ , testGroup "eq" [
398+ testProperty "string" (\n -> gNullaryToJSONString n == thNullaryToJSONString n)
399+ , testProperty "2ElemArray" (\n -> gNullaryToJSON2ElemArray n == thNullaryToJSON2ElemArray n)
400+ , testProperty "ObjectWithType" (\n -> gNullaryToJSONObjectWithType n == thNullaryToJSONObjectWithType n)
401+ , testProperty "ObjectWithSingleField" (\n -> gNullaryToJSONObjectWithSingleField n == thNullaryToJSONObjectWithSingleField n)
402+ ]
403+ , testGroup "roundTrip" [
404+ testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
405+ , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
406+ , testProperty "ObjectWithType" (toParseJSON gNullaryParseJSONObjectWithType gNullaryToJSONObjectWithType)
407+ , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
408+ ]
409+ ]
410+ , testGroup "SomeType" [
411+ testProperty "2ElemArray" (is2ElemArray . (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
412+ , testProperty "ObjectWithType" (isObjectWithType . (gSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
413+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
414+
415+ , testGroup "eq" [
416+ testProperty "2ElemArray" (\n -> (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON) n == thSomeTypeToJSON2ElemArray n)
417+ , testProperty "ObjectWithType" (\n -> (gSomeTypeToJSONObjectWithType :: SomeTypeToJSON) n == thSomeTypeToJSONObjectWithType n)
418+ , testProperty "ObjectWithSingleField" (\n -> (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON) n == thSomeTypeToJSONObjectWithSingleField n)
419+ ]
420+ , testGroup "roundTrip" [
421+ testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
422+ , testProperty "ObjectWithType" (toParseJSON gSomeTypeParseJSONObjectWithType (gSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
423+ , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
424+ ]
425+ ]
185426 ]
427+#endif
186428 ]