git.iko.soy/typeable/aeson
on master help sign in
Merged master
79d4e98Bas van Dijk
Data/Aeson.hs+7−6
compare with master
unifiedsplit
@@ -278,10 +278,11 @@ eitherDecode' = eitherDecodeWith json' fromJSON
278-- $pitfalls
278-- $pitfalls
279-- #pitfalls#
279-- #pitfalls#
280--
280--
281−-- Note that the JSON standard only allows arrays or objects of things
281+-- Note that the JSON standard requires that the top-level value be
282−-- at the top-level. Since this library follows the standard, calling
282+-- either an array or an object. If you try to use 'decode' with a
283+-- result type that is /not/ represented in JSON as an array or
283−-- 'decode' on an unsupported result type will typecheck, but will
284+-- object, your code will typecheck, but it will always \"fail\" at
284−-- always \"fail\":
285+-- runtime:
285--
286--
286-- > >>> decode "1" :: Maybe Int
287-- > >>> decode "1" :: Maybe Int
287-- > Nothing
288-- > Nothing
@@ -323,5 +324,5 @@ eitherDecode' = eitherDecodeWith json' fromJSON
323-- converted to an AST, then the 'FromJSON' class is used to convert
324-- converted to an AST, then the 'FromJSON' class is used to convert
324-- to the desired type.
325-- to the desired type.
325--
326--
326−-- For convenience, the 'encode' and
327+-- For convenience, the 'encode' and 'decode' functions combine both
327−-- 'decode' functions combine both steps for convenience.
328+-- steps.
aeson.cabal+7−7
@@ -86,7 +86,6 @@ extra-source-files:
86 benchmarks/json-data/*.json
86 benchmarks/json-data/*.json
87 examples/*.hs
87 examples/*.hs
88 release-notes.markdown
88 release-notes.markdown
89− tests/Properties.hs
90
89
91flag developer
90flag developer
92 description: operate in developer mode
91 description: operate in developer mode
@@ -140,15 +139,15 @@ test-suite tests
140 type: exitcode-stdio-1.0
139 type: exitcode-stdio-1.0
141 hs-source-dirs: tests
140 hs-source-dirs: tests
142 main-is: Properties.hs
141 main-is: Properties.hs
143− other-modules: Options
142+ other-modules: Functions
143+ Instances
144+ Types
145+ Options
146+ Encoders
144
147
145 ghc-options:
148 ghc-options:
146 -Wall -threaded -rtsopts
149 -Wall -threaded -rtsopts
147
150
148− if impl(ghc >= 7.2.1)
149− cpp-options: -DGENERICS
150− build-depends: ghc-prim >= 0.2
151−
152 build-depends:
151 build-depends:
153 QuickCheck,
152 QuickCheck,
154 aeson,
153 aeson,
@@ -162,7 +161,8 @@ test-suite tests
162 text,
161 text,
163 time,
162 time,
164 unordered-containers,
163 unordered-containers,
165− vector
164+ vector,
165+ ghc-prim >= 0.2
166
166
167source-repository head
167source-repository head
168 type: git
168 type: git
tests/Functions.hsnew file+10
@@ -0,0 +1,10 @@
1+module Functions where
2+
3+approxEq :: (Fractional a, Ord a) => a -> a -> Bool
4+approxEq = approxEqWith 1e-15 1e-15
5+
6+approxEqWith :: (Fractional a, Ord a) => a -> a -> a -> a -> Bool
7+approxEqWith maxAbsoluteError maxRelativeError a b =
8+ a == b || d < maxAbsoluteError ||
9+ d / max (abs b) (abs a) <= maxRelativeError
10+ where d = abs (a - b)
tests/Instances.hsnew file+142
@@ -0,0 +1,142 @@
1+{-# Language OverloadedStrings, RecordWildCards, StandaloneDeriving #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+
4+module Instances where
5+
6+import Types
7+import Data.Function (on)
8+import Control.Monad
9+import Test.QuickCheck (Arbitrary(..), Gen, choose, oneof, elements)
10+import Data.Time.Clock (DiffTime, UTCTime(..), picosecondsToDiffTime)
11+import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..),
12+ hoursToTimeZone, Day(..), TimeOfDay(..))
13+import qualified Data.Text as T
14+import qualified Data.Map as Map
15+import Data.Text (Text)
16+import Data.Aeson.Types
17+import Control.Applicative
18+import Functions
19+
20+-- "System" types.
21+
22+instance Arbitrary Text where
23+ arbitrary = T.pack <$> arbitrary
24+
25+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where
26+ arbitrary = Map.fromList <$> arbitrary
27+
28+instance Arbitrary LocalTime where
29+ arbitrary = return $ LocalTime (ModifiedJulianDay 1) (TimeOfDay 1 2 3)
30+
31+instance Arbitrary TimeZone where
32+ arbitrary = do
33+ offset <- choose (0,2) :: Gen Int
34+ return $ hoursToTimeZone offset
35+
36+instance Arbitrary Day where
37+ arbitrary = ModifiedJulianDay `liftM` arbitrary
38+
39+instance Arbitrary DiffTime where
40+ arbitrary = picosecondsToDiffTime `liftM` choose (0, 86400000000000000)
41+
42+instance Arbitrary UTCTime where
43+ arbitrary = liftM2 UTCTime arbitrary arbitrary
44+
45+instance Arbitrary DotNetTime where
46+ arbitrary = DotNetTime `liftM` arbitrary
47+
48+instance Arbitrary ZonedTime where
49+ arbitrary = liftM2 ZonedTime arbitrary arbitrary
50+
51+deriving instance Eq ZonedTime
52+
53+-- Compare equality to within a millisecond, allowing for rounding
54+-- error (ECMA 262 requires milliseconds to rounded to zero, not
55+-- rounded to nearest).
56+instance ApproxEq UTCTime where
57+ a =~ b = ((==) `on` utctDay) a b &&
58+ (approxEqWith 1 1 `on` ((* 1e3) . utctDayTime)) a b
59+
60+instance ApproxEq DotNetTime
61+
62+instance ApproxEq Double where
63+ (=~) = approxEq
64+
65+-- Test-related types.
66+
67+instance Arbitrary Foo where
68+ arbitrary = liftM4 Foo arbitrary arbitrary arbitrary arbitrary
69+
70+instance Eq Foo where
71+ a == b = fooInt a == fooInt b &&
72+ fooDouble a `approxEq` fooDouble b &&
73+ fooTuple a == fooTuple b
74+
75+instance ToJSON Foo where
76+ toJSON Foo{..} = object [ "fooInt" .= fooInt
77+ , "fooDouble" .= fooDouble
78+ , "fooTuple" .= fooTuple
79+ , "fooMap" .= fooMap
80+ ]
81+
82+instance FromJSON Foo where
83+ parseJSON (Object v) = Foo <$>
84+ v .: "fooInt" <*>
85+ v .: "fooDouble" <*>
86+ v .: "fooTuple" <*>
87+ v .: "fooMap"
88+ parseJSON _ = empty
89+
90+instance Arbitrary UFoo where
91+ arbitrary = UFoo <$> arbitrary <*> arbitrary
92+ where _ = uFooInt
93+
94+instance Arbitrary OneConstructor where
95+ arbitrary = return OneConstructor
96+
97+instance FromJSON OneConstructor
98+instance ToJSON OneConstructor
99+
100+instance (Arbitrary a, Arbitrary b) => Arbitrary (Product2 a b) where
101+ arbitrary = liftM2 Product2 arbitrary arbitrary
102+
103+instance (FromJSON a, FromJSON b) => FromJSON (Product2 a b)
104+instance (ToJSON a, ToJSON b) => ToJSON (Product2 a b)
105+
106+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,
107+ Arbitrary f) => Arbitrary (Product6 a b c d e f) where
108+ arbitrary = Product6 <$> arbitrary <*> arbitrary <*> arbitrary <*>
109+ arbitrary <*> arbitrary <*> arbitrary
110+
111+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,
112+ FromJSON f) => FromJSON (Product6 a b c d e f)
113+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e,
114+ ToJSON f) => ToJSON (Product6 a b c d e f)
115+
116+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
117+ => Arbitrary (Sum4 a b c d) where
118+ arbitrary = oneof [Alt1 <$> arbitrary, Alt2 <$> arbitrary,
119+ Alt3 <$> arbitrary, Alt4 <$> arbitrary]
120+
121+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d)
122+ => FromJSON (Sum4 a b c d)
123+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (Sum4 a b c d)
124+
125+instance (Arbitrary a) => Arbitrary (Approx a) where
126+ arbitrary = Approx <$> arbitrary
127+
128+instance (FromJSON a) => FromJSON (Approx a) where
129+ parseJSON a = Approx <$> parseJSON a
130+
131+instance (ToJSON a) => ToJSON (Approx a) where
132+ toJSON = toJSON . fromApprox
133+
134+instance Arbitrary Nullary where
135+ arbitrary = elements [C1, C2, C3]
136+
137+instance Arbitrary a => Arbitrary (SomeType a) where
138+ arbitrary = oneof [ pure Nullary
139+ , Unary <$> arbitrary
140+ , Product <$> arbitrary <*> arbitrary <*> arbitrary
141+ , Record <$> arbitrary <*> arbitrary <*> arbitrary
142+ ]
tests/Options.hs+9−8
@@ -4,19 +4,20 @@ import Data.Aeson.Types
4import Data.Char
4import Data.Char
5
5
6optsDefault :: Options
6optsDefault :: Options
7+optsDefault = defaultOptions
7−optsDefault = defaultOptions{ fieldNameModifier = map toLower
8+ { fieldNameModifier = map toLower
8− , constructorNameModifier = map toLower
9+ , constructorNameModifier = map toLower
9− , sumEncoding = TwoElemArray
10− }
10+ }
11
11
12opts2ElemArray :: Options
12opts2ElemArray :: Options
13−opts2ElemArray = optsDefault{ nullaryToString = False }
13+opts2ElemArray = optsDefault
14+ { nullaryToString = False
15+ , sumEncoding = TwoElemArray
16+ }
14
17
15optsObjectWithType :: Options
18optsObjectWithType :: Options
16optsObjectWithType = optsDefault
19optsObjectWithType = optsDefault
17− { nullaryToString = False
20+ { nullaryToString = False }
18− , sumEncoding = defaultObjectWithType
19− }
20
21
21optsObjectWithSingleField :: Options
22optsObjectWithSingleField :: Options
22optsObjectWithSingleField = optsDefault
23optsObjectWithSingleField = optsDefault
tests/Properties.hs+69−297
@@ -1,24 +1,14 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings, RecordWildCards,
1+{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
2− ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}
3−{-# OPTIONS_GHC -fno-warn-orphans #-}
4
2
5−#ifdef GENERICS
6−{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}
7−#endif
8−
9−import Control.Monad
10−import Control.Applicative
11import Data.Aeson.Encode
3import Data.Aeson.Encode
12import Data.Aeson.Parser (value)
4import Data.Aeson.Parser (value)
13import Data.Aeson.Types
5import Data.Aeson.Types
14−import Data.Aeson.TH
15import Data.Attoparsec.Number
6import Data.Attoparsec.Number
16−import Data.Data (Typeable, Data)
7+import Data.Data (Data)
17−import Data.Function (on)
8+import Data.Int
18−import Data.Text (Text)
19import Test.Framework (Test, defaultMain, testGroup)
9import Test.Framework (Test, defaultMain, testGroup)
20import Test.Framework.Providers.QuickCheck2 (testProperty)
10import Test.Framework.Providers.QuickCheck2 (testProperty)
21−import Test.QuickCheck (Arbitrary(..), choose, oneof, elements, Gen)
11+import Test.QuickCheck (Arbitrary(..))
22import qualified Data.Vector as V
12import qualified Data.Vector as V
23import qualified Data.Aeson.Generic as G
13import qualified Data.Aeson.Generic as G
24import qualified Data.Attoparsec.Lazy as L
14import qualified Data.Attoparsec.Lazy as L
@@ -26,15 +16,13 @@ import qualified Data.ByteString.Lazy.Char8 as L
26import qualified Data.Text as T
16import qualified Data.Text as T
27import qualified Data.Map as Map
17import qualified Data.Map as Map
28import qualified Data.HashMap.Strict as H
18import qualified Data.HashMap.Strict as H
29−import Data.Time.Calendar (Day)
19+import Data.Time.Clock (UTCTime(..))
30−import Data.Time.Clock (DiffTime, UTCTime(..), picosecondsToDiffTime)
31−import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..),
20+import Data.Time (ZonedTime(..))
32− hoursToTimeZone, Day(..), TimeOfDay(..))
21+import Types (Foo(..), UFoo(..))
22+import Instances ()
23+import Types (Approx(..), OneConstructor(..), Product2, Product6, Sum4)
33−import Options
24+import Encoders
34
25
35−#ifdef GENERICS
36−import GHC.Generics
37−#endif
38
26
39encodeDouble :: Double -> Double -> Bool
27encodeDouble :: Double -> Double -> Bool
40encodeDouble num denom
28encodeDouble num denom
@@ -45,6 +33,12 @@ encodeDouble num denom
45encodeInteger :: Integer -> Bool
33encodeInteger :: Integer -> Bool
46encodeInteger i = encode (Number (I i)) == L.pack (show i)
34encodeInteger i = encode (Number (I i)) == L.pack (show i)
47
35
36+toParseJSON :: (Arbitrary a, Eq a) => (Value -> Parser a) -> (a -> Value) -> a -> Bool
37+toParseJSON parsejson tojson x =
38+ case parse parsejson . tojson $ x of
39+ Error _ -> False
40+ Success x' -> x == x'
41+
48roundTrip :: (FromJSON a, ToJSON a) => (a -> a -> Bool) -> a -> a -> Bool
42roundTrip :: (FromJSON a, ToJSON a) => (a -> a -> Bool) -> a -> a -> Bool
49roundTrip eq _ i =
43roundTrip eq _ i =
50 case fmap fromJSON . L.parse value . encode . toJSON $ i of
44 case fmap fromJSON . L.parse value . encode . toJSON $ i of
@@ -60,25 +54,6 @@ genericTo _ v = G.toJSON v == toJSON v
60genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool
54genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool
61genericFrom _ v = G.fromJSON (toJSON v) == Success v
55genericFrom _ v = G.fromJSON (toJSON v) == Success v
62
56
63−approxEq :: (Fractional a, Ord a) => a -> a -> Bool
64−approxEq = approxEqWith 1e-15 1e-15
65−
66−approxEqWith :: (Fractional a, Ord a) => a -> a -> a -> a -> Bool
67−approxEqWith maxAbsoluteError maxRelativeError a b =
68− a == b || d < maxAbsoluteError ||
69− d / max (abs b) (abs a) <= maxRelativeError
70− where d = abs (a - b)
71−
72−-- Compare equality to within a millisecond, allowing for rounding
73−-- error (ECMA 262 requires milliseconds to rounded to zero, not
74−-- rounded to nearest).
75−approxEqUTC :: UTCTime -> UTCTime -> Bool
76−approxEqUTC a b = ((==) `on` utctDay) a b &&
77− (approxEqWith 1 1 `on` ((* 1e3) . utctDayTime)) a b
78−
79−approxEqNet :: DotNetTime -> DotNetTime -> Bool
80−approxEqNet (DotNetTime a) (DotNetTime b) = approxEqUTC a b
81−
82toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a) => a -> Bool
57toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a) => a -> Bool
83toFromJSON x = case fromJSON . toJSON $ x of
58toFromJSON x = case fromJSON . toJSON $ x of
84 Error _ -> False
59 Error _ -> False
@@ -89,11 +64,6 @@ genericToFromJSON x = case G.fromJSON . G.toJSON $ x of
89 Error _ -> False
64 Error _ -> False
90 Success x' -> x == x'
65 Success x' -> x == x'
91
66
92−toParseJSON :: (Arbitrary a, Eq a) => (Value -> Parser a) -> (a -> Value) -> a -> Bool
93−toParseJSON parsejson tojson x = case parse parsejson . tojson $ x of
94− Error _ -> False
95− Success x' -> x == x'
96−
97regress_gh72 :: [(String, Maybe String)] -> Bool
67regress_gh72 :: [(String, Maybe String)] -> Bool
98regress_gh72 ys = G.decode (G.encode m) == Just m
68regress_gh72 ys = G.decode (G.encode m) == Just m
99 where m = Map.fromList ys
69 where m = Map.fromList ys
@@ -106,146 +76,11 @@ modifyFailureProp orig added =
106 result :: Result ()
76 result :: Result ()
107 result = parse parser ()
77 result = parse parser ()
108
78
109−data Foo = Foo {
79+main :: IO ()
110− fooInt :: Int
80+main = defaultMain tests
111− , fooDouble :: Double
112− , fooTuple :: (String, Text, Int)
113− -- This definition causes an infinite loop in genericTo and genericFrom!
114− -- , fooMap :: Map.Map String Foo
115− , fooMap :: Map.Map String (Text,Int)
116− } deriving (Show, Typeable, Data)
117−
118−--------------------------------------------------------------------------------
119−-- Nullary
120−--------------------------------------------------------------------------------
121−
122−data Nullary = C1 | C2 | C3 deriving (Eq, Show)
123−
124−instance Arbitrary Nullary where
125− arbitrary = elements [C1, C2, C3]
126−
127−thNullaryToJSONString :: Nullary -> Value
128−thNullaryToJSONString = $(mkToJSON optsDefault ''Nullary)
129−
130−thNullaryParseJSONString :: Value -> Parser Nullary
131−thNullaryParseJSONString = $(mkParseJSON optsDefault ''Nullary)
132−
133−
134−thNullaryToJSON2ElemArray :: Nullary -> Value
135−thNullaryToJSON2ElemArray = $(mkToJSON opts2ElemArray ''Nullary)
136−
137−thNullaryParseJSON2ElemArray :: Value -> Parser Nullary
138−thNullaryParseJSON2ElemArray = $(mkParseJSON opts2ElemArray ''Nullary)
139−
140−
141−thNullaryToJSONObjectWithType :: Nullary -> Value
142−thNullaryToJSONObjectWithType = $(mkToJSON optsObjectWithType ''Nullary)
143−
144−thNullaryParseJSONObjectWithType :: Value -> Parser Nullary
145−thNullaryParseJSONObjectWithType = $(mkParseJSON optsObjectWithType ''Nullary)
146−
147−
148−thNullaryToJSONObjectWithSingleField :: Nullary -> Value
149−thNullaryToJSONObjectWithSingleField = $(mkToJSON optsObjectWithSingleField ''Nullary)
150−
151−thNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
152−thNullaryParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''Nullary)
153−
154−#ifdef GENERICS
155−deriving instance Generic Nullary
156−
157−gNullaryToJSONString :: Nullary -> Value
158−gNullaryToJSONString = gToJSON optsDefault . from
159−
160−gNullaryParseJSONString :: Value -> Parser Nullary
161−gNullaryParseJSONString = fmap to . gParseJSON optsDefault
162−
163−
164−gNullaryToJSON2ElemArray :: Nullary -> Value
165−gNullaryToJSON2ElemArray = gToJSON opts2ElemArray . from
166−
167−gNullaryParseJSON2ElemArray :: Value -> Parser Nullary
168−gNullaryParseJSON2ElemArray = fmap to . gParseJSON opts2ElemArray
169−
170−
171−gNullaryToJSONObjectWithType :: Nullary -> Value
172−gNullaryToJSONObjectWithType = gToJSON optsObjectWithType . from
173−
174−gNullaryParseJSONObjectWithType :: Value -> Parser Nullary
175−gNullaryParseJSONObjectWithType = fmap to . gParseJSON optsObjectWithType
176−
177−
178−gNullaryToJSONObjectWithSingleField :: Nullary -> Value
179−gNullaryToJSONObjectWithSingleField = gToJSON optsObjectWithSingleField . from
180−
181−gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
182−gNullaryParseJSONObjectWithSingleField = fmap to . gParseJSON optsObjectWithSingleField
183−#endif
184−
185−--------------------------------------------------------------------------------
186−-- SomeType
187−--------------------------------------------------------------------------------
188−
189−data SomeType a = Nullary
190− | Unary Int
191− | Product String (Maybe Char) a
192− | Record { testOne :: Double
193− , testTwo :: Maybe Bool
194− , testThree :: Maybe a
195− } deriving (Eq, Show)
196−
197−instance Arbitrary a => Arbitrary (SomeType a) where
198− arbitrary = oneof [ pure Nullary
199− , Unary <$> arbitrary
200− , Product <$> arbitrary <*> arbitrary <*> arbitrary
201− , Record <$> arbitrary <*> arbitrary <*> arbitrary
202− ]
203−
204−type SomeTypeToJSON = SomeType Int -> Value
205−
206−thSomeTypeToJSON2ElemArray :: ToJSON a => SomeType a -> Value
207−thSomeTypeToJSON2ElemArray = $(mkToJSON opts2ElemArray ''SomeType)
208−
209−thSomeTypeParseJSON2ElemArray :: FromJSON a => Value -> Parser (SomeType a)
210−thSomeTypeParseJSON2ElemArray = $(mkParseJSON opts2ElemArray ''SomeType)
211−
212−
213−thSomeTypeToJSONObjectWithType :: ToJSON a => SomeType a -> Value
214−thSomeTypeToJSONObjectWithType = $(mkToJSON optsObjectWithType ''SomeType)
215−
216−thSomeTypeParseJSONObjectWithType :: FromJSON a => Value -> Parser (SomeType a)
217−thSomeTypeParseJSONObjectWithType = $(mkParseJSON optsObjectWithType ''SomeType)
218−
219−
220−thSomeTypeToJSONObjectWithSingleField :: ToJSON a => SomeType a -> Value
221−thSomeTypeToJSONObjectWithSingleField = $(mkToJSON optsObjectWithSingleField ''SomeType)
222−
223−thSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)
224−thSomeTypeParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''SomeType)
225−
226−#ifdef GENERICS
227−deriving instance Generic (SomeType a)
228−
229−gSomeTypeToJSON2ElemArray :: ToJSON a => SomeType a -> Value
230−gSomeTypeToJSON2ElemArray = gToJSON opts2ElemArray . from
231−
232−gSomeTypeParseJSON2ElemArray :: FromJSON a => Value -> Parser (SomeType a)
233−gSomeTypeParseJSON2ElemArray = fmap to . gParseJSON opts2ElemArray
234−
235−
236−gSomeTypeToJSONObjectWithType :: ToJSON a => SomeType a -> Value
237−gSomeTypeToJSONObjectWithType = gToJSON optsObjectWithType . from
238−
239−gSomeTypeParseJSONObjectWithType :: FromJSON a => Value -> Parser (SomeType a)
240−gSomeTypeParseJSONObjectWithType = fmap to . gParseJSON optsObjectWithType
241−
242−
243−gSomeTypeToJSONObjectWithSingleField :: ToJSON a => SomeType a -> Value
244−gSomeTypeToJSONObjectWithSingleField = gToJSON optsObjectWithSingleField . from
245
81
246−gSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)
82+type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()
247−gSomeTypeParseJSONObjectWithSingleField = fmap to . gParseJSON optsObjectWithSingleField
83+type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)
248−#endif
249
84
250--------------------------------------------------------------------------------
85--------------------------------------------------------------------------------
251-- Value properties
86-- Value properties
@@ -265,7 +100,7 @@ isObjectWithTypeValue (Object obj) = "type" `H.member` obj &&
265isObjectWithTypeValue _ = False
100isObjectWithTypeValue _ = False
266
101
267isObjectWithType :: Value -> Bool
102isObjectWithType :: Value -> Bool
268−isObjectWithType (Object obj) = "type" `H.member` obj
103+isObjectWithType (Object obj) = "type" `H.member` obj
269isObjectWithType _ = False
104isObjectWithType _ = False
270
105
271isObjectWithSingleField :: Value -> Bool
106isObjectWithSingleField :: Value -> Bool
@@ -274,72 +109,6 @@ isObjectWithSingleField _ = False
274
109
275--------------------------------------------------------------------------------
110--------------------------------------------------------------------------------
276
111
277−instance Eq Foo where
278− a == b = fooInt a == fooInt b &&
279− fooDouble a `approxEq` fooDouble b &&
280− fooTuple a == fooTuple b
281−
282−instance ToJSON Foo where
283− toJSON Foo{..} = object [ "fooInt" .= fooInt
284− , "fooDouble" .= fooDouble
285− , "fooTuple" .= fooTuple
286− , "fooMap" .= fooMap
287− ]
288−
289−instance FromJSON Foo where
290− parseJSON (Object v) = Foo <$>
291− v .: "fooInt" <*>
292− v .: "fooDouble" <*>
293− v .: "fooTuple" <*>
294− v .: "fooMap"
295− parseJSON _ = empty
296−
297−instance Arbitrary Text where
298− arbitrary = T.pack <$> arbitrary
299−
300−instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where
301− arbitrary = Map.fromList <$> arbitrary
302−
303−instance Arbitrary Foo where
304− arbitrary = liftM4 Foo arbitrary arbitrary arbitrary arbitrary
305−
306−instance Arbitrary LocalTime where
307− arbitrary = return $ LocalTime (ModifiedJulianDay 1) (TimeOfDay 1 2 3)
308−
309−instance Arbitrary TimeZone where
310− arbitrary = do
311− offset <- choose (0,2) :: Gen Int
312− return $ hoursToTimeZone offset
313−
314−instance Arbitrary Day where
315− arbitrary = ModifiedJulianDay `liftM` arbitrary
316−
317−instance Arbitrary DiffTime where
318− arbitrary = picosecondsToDiffTime `liftM` choose (0, 86400000000000000)
319−
320−instance Arbitrary UTCTime where
321− arbitrary = liftM2 UTCTime arbitrary arbitrary
322−
323−instance Arbitrary DotNetTime where
324− arbitrary = DotNetTime `liftM` arbitrary
325−
326−instance Arbitrary ZonedTime where
327− arbitrary = liftM2 ZonedTime arbitrary arbitrary
328−
329−data UFoo = UFoo {
330− _UFooInt :: Int
331− , uFooInt :: Int
332− } deriving (Show, Eq, Data, Typeable)
333−
334−instance Arbitrary UFoo where
335− arbitrary = UFoo <$> arbitrary <*> arbitrary
336− where _ = uFooInt
337−
338−main :: IO ()
339−main = defaultMain tests
340−
341−deriving instance Eq ZonedTime
342−
343tests :: [Test]
112tests :: [Test]
344tests = [
113tests = [
345 testGroup "regression" [
114 testGroup "regression" [
@@ -365,15 +134,21 @@ tests = [
365 ],
134 ],
366 testGroup "roundTrip" [
135 testGroup "roundTrip" [
367 testProperty "Bool" $ roundTripEq True
136 testProperty "Bool" $ roundTripEq True
368− , testProperty "Double" $ roundTrip approxEq (1::Double)
137+ , testProperty "Double" $ roundTripEq (1 :: Approx Double)
369 , testProperty "Int" $ roundTripEq (1::Int)
138 , testProperty "Int" $ roundTripEq (1::Int)
370 , testProperty "Integer" $ roundTripEq (1::Integer)
139 , testProperty "Integer" $ roundTripEq (1::Integer)
371 , testProperty "String" $ roundTripEq (""::String)
140 , testProperty "String" $ roundTripEq (""::String)
372 , testProperty "Text" $ roundTripEq T.empty
141 , testProperty "Text" $ roundTripEq T.empty
373 , testProperty "Foo" $ roundTripEq (undefined::Foo)
142 , testProperty "Foo" $ roundTripEq (undefined::Foo)
374− , testProperty "DotNetTime" $ roundTrip approxEqNet undefined
143+ , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)
375− , testProperty "UTCTime" $ roundTrip approxEqUTC undefined
144+ , testProperty "UTCTime" $ roundTripEq (undefined :: Approx UTCTime)
376 , testProperty "ZonedTime" $ roundTripEq (undefined::ZonedTime)
145 , testProperty "ZonedTime" $ roundTripEq (undefined::ZonedTime)
146+ , testGroup "ghcGenerics" [
147+ testProperty "OneConstructor" $ roundTripEq OneConstructor
148+ , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)
149+ , testProperty "Product6" $ roundTripEq (undefined :: P6)
150+ , testProperty "Sum4" $ roundTripEq (undefined :: S4)
151+ ]
377 ],
152 ],
378 testGroup "toFromJSON" [
153 testGroup "toFromJSON" [
379 testProperty "Integer" (toFromJSON :: Integer -> Bool)
154 testProperty "Integer" (toFromJSON :: Integer -> Bool)
@@ -389,52 +164,50 @@ tests = [
389 testProperty "modify failure" modifyFailureProp
164 testProperty "modify failure" modifyFailureProp
390 ],
165 ],
391 testGroup "template-haskell" [
166 testGroup "template-haskell" [
392− testGroup "Nullary" [
167+ testGroup "Nullary" [
393− testProperty "string" (isString . thNullaryToJSONString)
168+ testProperty "string" (isString . thNullaryToJSONString)
394− , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
169+ , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
395− , testProperty "ObjectWithType" (isObjectWithTypeValue . thNullaryToJSONObjectWithType)
170+ , testProperty "ObjectWithType" (isObjectWithTypeValue . thNullaryToJSONObjectWithType)
396− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
171+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
397
172
398− , testGroup "roundTrip" [
173+ , testGroup "roundTrip" [
399− testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)
174+ testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)
400− , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
175+ , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
401− , testProperty "ObjectWithType" (toParseJSON thNullaryParseJSONObjectWithType thNullaryToJSONObjectWithType)
176+ , testProperty "ObjectWithType" (toParseJSON thNullaryParseJSONObjectWithType thNullaryToJSONObjectWithType)
402− , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
177+ , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
178+ ]
403 ]
179 ]
404− ]
405− , testGroup "SomeType" [
180+ , testGroup "SomeType" [
406− testProperty "2ElemArray" (is2ElemArray . (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
181+ testProperty "2ElemArray" (is2ElemArray . (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
407− , testProperty "ObjectWithType" (isObjectWithType . (thSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
182+ , testProperty "ObjectWithType" (isObjectWithType . (thSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
408− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
183+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
409
184
410− , testGroup "roundTrip" [
185+ , testGroup "roundTrip" [
411− testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
186+ testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
412− , testProperty "ObjectWithType" (toParseJSON thSomeTypeParseJSONObjectWithType (thSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
187+ , testProperty "ObjectWithType" (toParseJSON thSomeTypeParseJSONObjectWithType (thSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
413− , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
188+ , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
414− ]
189+ ]
415− ]
190+ ]
416 ]
191 ]
417−#ifdef GENERICS
418 , testGroup "GHC-generics" [
192 , testGroup "GHC-generics" [
419− testGroup "Nullary" [
193+ testGroup "Nullary" [
420− testProperty "string" (isString . gNullaryToJSONString)
194+ testProperty "string" (isString . gNullaryToJSONString)
421− , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
195+ , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
422− , testProperty "ObjectWithType" (isObjectWithTypeValue . gNullaryToJSONObjectWithType)
196+ , testProperty "ObjectWithType" (isObjectWithTypeValue . gNullaryToJSONObjectWithType)
423− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
197+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
424−
425− , testGroup "eq" [
198+ , testGroup "eq" [
426− testProperty "string" (\n -> gNullaryToJSONString n == thNullaryToJSONString n)
199+ testProperty "string" (\n -> gNullaryToJSONString n == thNullaryToJSONString n)
427− , testProperty "2ElemArray" (\n -> gNullaryToJSON2ElemArray n == thNullaryToJSON2ElemArray n)
200+ , testProperty "2ElemArray" (\n -> gNullaryToJSON2ElemArray n == thNullaryToJSON2ElemArray n)
428− , testProperty "ObjectWithType" (\n -> gNullaryToJSONObjectWithType n == thNullaryToJSONObjectWithType n)
201+ , testProperty "ObjectWithType" (\n -> gNullaryToJSONObjectWithType n == thNullaryToJSONObjectWithType n)
429− , testProperty "ObjectWithSingleField" (\n -> gNullaryToJSONObjectWithSingleField n == thNullaryToJSONObjectWithSingleField n)
202+ , testProperty "ObjectWithSingleField" (\n -> gNullaryToJSONObjectWithSingleField n == thNullaryToJSONObjectWithSingleField n)
430− ]
203+ ]
431− , testGroup "roundTrip" [
204+ , testGroup "roundTrip" [
432− testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
205+ testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
433− , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
206+ , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
434− , testProperty "ObjectWithType" (toParseJSON gNullaryParseJSONObjectWithType gNullaryToJSONObjectWithType)
207+ , testProperty "ObjectWithType" (toParseJSON gNullaryParseJSONObjectWithType gNullaryToJSONObjectWithType)
435− , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
208+ , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
209+ ]
436 ]
210 ]
437− ]
438 , testGroup "SomeType" [
211 , testGroup "SomeType" [
439 testProperty "2ElemArray" (is2ElemArray . (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
212 testProperty "2ElemArray" (is2ElemArray . (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
440 , testProperty "ObjectWithType" (isObjectWithType . (gSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
213 , testProperty "ObjectWithType" (isObjectWithType . (gSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
@@ -450,7 +223,6 @@ tests = [
450 , testProperty "ObjectWithType" (toParseJSON gSomeTypeParseJSONObjectWithType (gSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
223 , testProperty "ObjectWithType" (toParseJSON gSomeTypeParseJSONObjectWithType (gSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
451 , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
224 , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
452 ]
225 ]
453− ]
226+ ]
454 ]
227 ]
455−#endif
456 ]
228 ]
tests/Types.hsnew file+57
@@ -0,0 +1,57 @@
1+{-# LANGUAGE DefaultSignatures, DeriveDataTypeable, DeriveGeneric,
2+ GeneralizedNewtypeDeriving #-}
3+
4+module Types where
5+
6+import qualified Data.Map as Map
7+import Data.Data
8+import Data.Text
9+import GHC.Generics
10+
11+data Foo = Foo {
12+ fooInt :: Int
13+ , fooDouble :: Double
14+ , fooTuple :: (String, Text, Int)
15+ -- This definition causes an infinite loop in genericTo and genericFrom!
16+ -- , fooMap :: Map.Map String Foo
17+ , fooMap :: Map.Map String (Text,Int)
18+ } deriving (Show, Typeable, Data, Generic)
19+
20+data UFoo = UFoo {
21+ _UFooInt :: Int
22+ , uFooInt :: Int
23+ } deriving (Show, Eq, Data, Typeable, Generic)
24+
25+data OneConstructor = OneConstructor
26+ deriving (Show, Eq, Typeable, Data, Generic)
27+
28+data Product2 a b = Product2 a b
29+ deriving (Show, Eq, Typeable, Data, Generic)
30+
31+data Product6 a b c d e f = Product6 a b c d e f
32+ deriving (Show, Eq, Typeable, Data, Generic)
33+
34+data Sum4 a b c d = Alt1 a | Alt2 b | Alt3 c | Alt4 d
35+ deriving (Show, Eq, Typeable, Data, Generic)
36+
37+class ApproxEq a where
38+ (=~) :: a -> a -> Bool
39+
40+ default (=~) :: (Eq a) => a -> a -> Bool
41+ (=~) = (==)
42+
43+newtype Approx a = Approx { fromApprox :: a }
44+ deriving (Show, Data, Typeable, Generic, ApproxEq, Num)
45+
46+instance (ApproxEq a) => Eq (Approx a) where
47+ Approx a == Approx b = a =~ b
48+
49+data Nullary = C1 | C2 | C3 deriving (Eq, Show, Generic)
50+
51+data SomeType a = Nullary
52+ | Unary Int
53+ | Product String (Maybe Char) a
54+ | Record { testOne :: Double
55+ , testTwo :: Maybe Bool
56+ , testThree :: Maybe a
57+ } deriving (Eq, Show, Generic)