git.iko.soy/typeable/aeson
on master help sign in
Merged master
commit79d4e985f115100512f82f3ec098db0380c42a7e authorBas van Dijk <v.dijk.bas@gmail.com> dateSat 20 Apr 2013, 17:27 (13 years ago) parent5f1b9c2271f4dc
7 files changed+301−318
compare with master
unifiedsplit
Data/Aeson.hs+7−6 aeson.cabal+7−7 tests/Functions.hs+10 tests/Instances.hs+142 tests/Options.hs+9−8 tests/Properties.hs+69−297 tests/Types.hs+57
Data/Aeson.hs+7−6
@@ -278,10 +278,11 @@ eitherDecode' = eitherDecodeWith json' fromJSON
278278-- $pitfalls
279279-- #pitfalls#
280280--
281−-- Note that the JSON standard only allows arrays or objects of things
282−-- at the top-level. Since this library follows the standard, calling
283−-- 'decode' on an unsupported result type will typecheck, but will
284−-- always \"fail\":
281+-- Note that the JSON standard requires that the top-level value be
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
284+-- object, your code will typecheck, but it will always \"fail\" at
285+-- runtime:
285286--
286287-- > >>> decode "1" :: Maybe Int
287288-- > Nothing
@@ -323,5 +324,5 @@ eitherDecode' = eitherDecodeWith json' fromJSON
323324-- converted to an AST, then the 'FromJSON' class is used to convert
324325-- to the desired type.
325326--
326−-- For convenience, the 'encode' and
327−-- 'decode' functions combine both steps for convenience.
327+-- For convenience, the 'encode' and 'decode' functions combine both
328+-- steps.
aeson.cabal+7−7
@@ -86,7 +86,6 @@ extra-source-files:
8686 benchmarks/json-data/*.json
8787 examples/*.hs
8888 release-notes.markdown
89− tests/Properties.hs
9089
9190flag developer
9291 description: operate in developer mode
@@ -140,15 +139,15 @@ test-suite tests
140139 type: exitcode-stdio-1.0
141140 hs-source-dirs: tests
142141 main-is: Properties.hs
143− other-modules: Options
142+ other-modules: Functions
143+ Instances
144+ Types
145+ Options
146+ Encoders
144147
145148 ghc-options:
146149 -Wall -threaded -rtsopts
147150
148− if impl(ghc >= 7.2.1)
149− cpp-options: -DGENERICS
150− build-depends: ghc-prim >= 0.2
151−
152151 build-depends:
153152 QuickCheck,
154153 aeson,
@@ -162,7 +161,8 @@ test-suite tests
162161 text,
163162 time,
164163 unordered-containers,
165− vector
164+ vector,
165+ ghc-prim >= 0.2
166166
167167source-repository head
168168 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
44import Data.Char
55
66optsDefault :: Options
7−optsDefault = defaultOptions{ fieldNameModifier = map toLower
8− , constructorNameModifier = map toLower
9− , sumEncoding = TwoElemArray
10− }
7+optsDefault = defaultOptions
8+ { fieldNameModifier = map toLower
9+ , constructorNameModifier = map toLower
10+ }
1111
1212opts2ElemArray :: Options
13−opts2ElemArray = optsDefault{ nullaryToString = False }
13+opts2ElemArray = optsDefault
14+ { nullaryToString = False
15+ , sumEncoding = TwoElemArray
16+ }
1417
1518optsObjectWithType :: Options
1619optsObjectWithType = optsDefault
17− { nullaryToString = False
18− , sumEncoding = defaultObjectWithType
19− }
20+ { nullaryToString = False }
2021
2122optsObjectWithSingleField :: Options
2223optsObjectWithSingleField = optsDefault
tests/Properties.hs+69−297
@@ -1,24 +1,14 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings, RecordWildCards,
2− ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}
3−{-# OPTIONS_GHC -fno-warn-orphans #-}
1+{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
42
5−#ifdef GENERICS
6−{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}
7−#endif
8−
9−import Control.Monad
10−import Control.Applicative
113import Data.Aeson.Encode
124import Data.Aeson.Parser (value)
135import Data.Aeson.Types
14−import Data.Aeson.TH
156import Data.Attoparsec.Number
16−import Data.Data (Typeable, Data)
17−import Data.Function (on)
18−import Data.Text (Text)
7+import Data.Data (Data)
8+import Data.Int
199import Test.Framework (Test, defaultMain, testGroup)
2010import Test.Framework.Providers.QuickCheck2 (testProperty)
21−import Test.QuickCheck (Arbitrary(..), choose, oneof, elements, Gen)
11+import Test.QuickCheck (Arbitrary(..))
2212import qualified Data.Vector as V
2313import qualified Data.Aeson.Generic as G
2414import qualified Data.Attoparsec.Lazy as L
@@ -26,15 +16,13 @@ import qualified Data.ByteString.Lazy.Char8 as L
2616import qualified Data.Text as T
2717import qualified Data.Map as Map
2818import qualified Data.HashMap.Strict as H
29−import Data.Time.Calendar (Day)
30−import Data.Time.Clock (DiffTime, UTCTime(..), picosecondsToDiffTime)
31−import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..),
32− hoursToTimeZone, Day(..), TimeOfDay(..))
33−import Options
19+import Data.Time.Clock (UTCTime(..))
20+import Data.Time (ZonedTime(..))
21+import Types (Foo(..), UFoo(..))
22+import Instances ()
23+import Types (Approx(..), OneConstructor(..), Product2, Product6, Sum4)
24+import Encoders
3425
35−#ifdef GENERICS
36−import GHC.Generics
37−#endif
3826
3927encodeDouble :: Double -> Double -> Bool
4028encodeDouble num denom
@@ -45,6 +33,12 @@ encodeDouble num denom
4533encodeInteger :: Integer -> Bool
4634encodeInteger i = encode (Number (I i)) == L.pack (show i)
4735
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+
4842roundTrip :: (FromJSON a, ToJSON a) => (a -> a -> Bool) -> a -> a -> Bool
4943roundTrip eq _ i =
5044 case fmap fromJSON . L.parse value . encode . toJSON $ i of
@@ -60,25 +54,6 @@ genericTo _ v = G.toJSON v == toJSON v
6054genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool
6155genericFrom _ v = G.fromJSON (toJSON v) == Success v
6256
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−
8257toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a) => a -> Bool
8358toFromJSON x = case fromJSON . toJSON $ x of
8459 Error _ -> False
@@ -89,11 +64,6 @@ genericToFromJSON x = case G.fromJSON . G.toJSON $ x of
8964 Error _ -> False
9065 Success x' -> x == x'
9166
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−
9767regress_gh72 :: [(String, Maybe String)] -> Bool
9868regress_gh72 ys = G.decode (G.encode m) == Just m
9969 where m = Map.fromList ys
@@ -106,146 +76,11 @@ modifyFailureProp orig added =
10676 result :: Result ()
10777 result = parse parser ()
10878
109−data Foo = Foo {
110− fooInt :: Int
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
79+main :: IO ()
80+main = defaultMain tests
24581
246−gSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)
247−gSomeTypeParseJSONObjectWithSingleField = fmap to . gParseJSON optsObjectWithSingleField
248−#endif
82+type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()
83+type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)
24984
25085--------------------------------------------------------------------------------
25186-- Value properties
@@ -265,7 +100,7 @@ isObjectWithTypeValue (Object obj) = "type" `H.member` obj &&
265100isObjectWithTypeValue _ = False
266101
267102isObjectWithType :: Value -> Bool
268−isObjectWithType (Object obj) = "type" `H.member` obj
103+isObjectWithType (Object obj) = "type" `H.member` obj
269104isObjectWithType _ = False
270105
271106isObjectWithSingleField :: Value -> Bool
@@ -274,72 +109,6 @@ isObjectWithSingleField _ = False
274109
275110--------------------------------------------------------------------------------
276111
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−
343112tests :: [Test]
344113tests = [
345114 testGroup "regression" [
@@ -365,15 +134,21 @@ tests = [
365134 ],
366135 testGroup "roundTrip" [
367136 testProperty "Bool" $ roundTripEq True
368− , testProperty "Double" $ roundTrip approxEq (1::Double)
137+ , testProperty "Double" $ roundTripEq (1 :: Approx Double)
369138 , testProperty "Int" $ roundTripEq (1::Int)
370139 , testProperty "Integer" $ roundTripEq (1::Integer)
371140 , testProperty "String" $ roundTripEq (""::String)
372141 , testProperty "Text" $ roundTripEq T.empty
373142 , testProperty "Foo" $ roundTripEq (undefined::Foo)
374− , testProperty "DotNetTime" $ roundTrip approxEqNet undefined
375− , testProperty "UTCTime" $ roundTrip approxEqUTC undefined
143+ , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)
144+ , testProperty "UTCTime" $ roundTripEq (undefined :: Approx UTCTime)
376145 , 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+ ]
377152 ],
378153 testGroup "toFromJSON" [
379154 testProperty "Integer" (toFromJSON :: Integer -> Bool)
@@ -389,52 +164,50 @@ tests = [
389164 testProperty "modify failure" modifyFailureProp
390165 ],
391166 testGroup "template-haskell" [
392− testGroup "Nullary" [
393− testProperty "string" (isString . thNullaryToJSONString)
394− , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
395− , testProperty "ObjectWithType" (isObjectWithTypeValue . thNullaryToJSONObjectWithType)
396− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
167+ testGroup "Nullary" [
168+ testProperty "string" (isString . thNullaryToJSONString)
169+ , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
170+ , testProperty "ObjectWithType" (isObjectWithTypeValue . thNullaryToJSONObjectWithType)
171+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
397172
398− , testGroup "roundTrip" [
399− testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)
400− , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
401− , testProperty "ObjectWithType" (toParseJSON thNullaryParseJSONObjectWithType thNullaryToJSONObjectWithType)
402− , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
173+ , testGroup "roundTrip" [
174+ testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)
175+ , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
176+ , testProperty "ObjectWithType" (toParseJSON thNullaryParseJSONObjectWithType thNullaryToJSONObjectWithType)
177+ , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
178+ ]
403179 ]
404− ]
405− , testGroup "SomeType" [
406− testProperty "2ElemArray" (is2ElemArray . (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
407− , testProperty "ObjectWithType" (isObjectWithType . (thSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
408− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
180+ , testGroup "SomeType" [
181+ testProperty "2ElemArray" (is2ElemArray . (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
182+ , testProperty "ObjectWithType" (isObjectWithType . (thSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
183+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
409184
410− , testGroup "roundTrip" [
411− testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
412− , testProperty "ObjectWithType" (toParseJSON thSomeTypeParseJSONObjectWithType (thSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
413− , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
414− ]
415− ]
185+ , testGroup "roundTrip" [
186+ testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray (thSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
187+ , testProperty "ObjectWithType" (toParseJSON thSomeTypeParseJSONObjectWithType (thSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
188+ , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
189+ ]
190+ ]
416191 ]
417−#ifdef GENERICS
418192 , testGroup "GHC-generics" [
419− testGroup "Nullary" [
420− testProperty "string" (isString . gNullaryToJSONString)
421− , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
422− , testProperty "ObjectWithType" (isObjectWithTypeValue . gNullaryToJSONObjectWithType)
423− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
424−
425− , testGroup "eq" [
426− testProperty "string" (\n -> gNullaryToJSONString n == thNullaryToJSONString n)
427− , testProperty "2ElemArray" (\n -> gNullaryToJSON2ElemArray n == thNullaryToJSON2ElemArray n)
428− , testProperty "ObjectWithType" (\n -> gNullaryToJSONObjectWithType n == thNullaryToJSONObjectWithType n)
429− , testProperty "ObjectWithSingleField" (\n -> gNullaryToJSONObjectWithSingleField n == thNullaryToJSONObjectWithSingleField n)
430− ]
431− , testGroup "roundTrip" [
432− testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
433− , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
434− , testProperty "ObjectWithType" (toParseJSON gNullaryParseJSONObjectWithType gNullaryToJSONObjectWithType)
435− , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
193+ testGroup "Nullary" [
194+ testProperty "string" (isString . gNullaryToJSONString)
195+ , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
196+ , testProperty "ObjectWithType" (isObjectWithTypeValue . gNullaryToJSONObjectWithType)
197+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
198+ , testGroup "eq" [
199+ testProperty "string" (\n -> gNullaryToJSONString n == thNullaryToJSONString n)
200+ , testProperty "2ElemArray" (\n -> gNullaryToJSON2ElemArray n == thNullaryToJSON2ElemArray n)
201+ , testProperty "ObjectWithType" (\n -> gNullaryToJSONObjectWithType n == thNullaryToJSONObjectWithType n)
202+ , testProperty "ObjectWithSingleField" (\n -> gNullaryToJSONObjectWithSingleField n == thNullaryToJSONObjectWithSingleField n)
203+ ]
204+ , testGroup "roundTrip" [
205+ testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
206+ , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
207+ , testProperty "ObjectWithType" (toParseJSON gNullaryParseJSONObjectWithType gNullaryToJSONObjectWithType)
208+ , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
209+ ]
436210 ]
437− ]
438211 , testGroup "SomeType" [
439212 testProperty "2ElemArray" (is2ElemArray . (gSomeTypeToJSON2ElemArray :: SomeTypeToJSON))
440213 , testProperty "ObjectWithType" (isObjectWithType . (gSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
@@ -450,7 +223,6 @@ tests = [
450223 , testProperty "ObjectWithType" (toParseJSON gSomeTypeParseJSONObjectWithType (gSomeTypeToJSONObjectWithType :: SomeTypeToJSON))
451224 , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
452225 ]
453− ]
226+ ]
454227 ]
455−#endif
456228 ]
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)