git.iko.soy/typeable/aeson
on master help sign in
Add some basic tests for roundtrips via GHC generics
271f4dcBryan O'Sullivan
tests/Instances.hs+54−1
compare with master
unifiedsplit
@@ -4,8 +4,9 @@
4module Instances where
4module Instances where
5
5
6import Types
6import Types
7+import Data.Function (on)
7import Control.Monad
8import Control.Monad
8−import Test.QuickCheck (Arbitrary(..), choose, Gen)
9+import Test.QuickCheck (Arbitrary(..), Gen, choose, oneof)
9import Data.Time.Clock (DiffTime, UTCTime(..), picosecondsToDiffTime)
10import Data.Time.Clock (DiffTime, UTCTime(..), picosecondsToDiffTime)
10import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..),
11import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..),
11 hoursToTimeZone, Day(..), TimeOfDay(..))
12 hoursToTimeZone, Day(..), TimeOfDay(..))
@@ -49,6 +50,18 @@ instance Arbitrary ZonedTime where
49
50
50deriving instance Eq ZonedTime
51deriving instance Eq ZonedTime
51
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+
52-- Test-related types.
65-- Test-related types.
53
66
54instance Arbitrary Foo where
67instance Arbitrary Foo where
@@ -77,3 +90,43 @@ instance FromJSON Foo where
77instance Arbitrary UFoo where
90instance Arbitrary UFoo where
78 arbitrary = UFoo <$> arbitrary <*> arbitrary
91 arbitrary = UFoo <$> arbitrary <*> arbitrary
79 where _ = uFooInt
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
tests/Properties.hs+14−15
@@ -5,7 +5,7 @@ import Data.Aeson.Parser (value)
5import Data.Aeson.Types
5import Data.Aeson.Types
6import Data.Attoparsec.Number
6import Data.Attoparsec.Number
7import Data.Data (Data)
7import Data.Data (Data)
8−import Data.Function (on)
8+import Data.Int
9import Test.Framework (Test, defaultMain, testGroup)
9import Test.Framework (Test, defaultMain, testGroup)
10import Test.Framework.Providers.QuickCheck2 (testProperty)
10import Test.Framework.Providers.QuickCheck2 (testProperty)
11import Test.QuickCheck (Arbitrary(..))
11import Test.QuickCheck (Arbitrary(..))
@@ -17,8 +17,8 @@ import qualified Data.Map as Map
17import Data.Time.Clock (UTCTime(..))
17import Data.Time.Clock (UTCTime(..))
18import Data.Time (ZonedTime(..))
18import Data.Time (ZonedTime(..))
19import Types (Foo(..), UFoo(..))
19import Types (Foo(..), UFoo(..))
20−import Functions
21import Instances ()
20import Instances ()
21+import Types (Approx(..), OneConstructor(..), Product2, Product6, Sum4)
22
22
23encodeDouble :: Double -> Double -> Bool
23encodeDouble :: Double -> Double -> Bool
24encodeDouble num denom
24encodeDouble num denom
@@ -44,16 +44,6 @@ genericTo _ v = G.toJSON v == toJSON v
44genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool
44genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool
45genericFrom _ v = G.fromJSON (toJSON v) == Success v
45genericFrom _ v = G.fromJSON (toJSON v) == Success v
46
46
47−-- Compare equality to within a millisecond, allowing for rounding
48−-- error (ECMA 262 requires milliseconds to rounded to zero, not
49−-- rounded to nearest).
50−approxEqUTC :: UTCTime -> UTCTime -> Bool
51−approxEqUTC a b = ((==) `on` utctDay) a b &&
52− (approxEqWith 1 1 `on` ((* 1e3) . utctDayTime)) a b
53−
54−approxEqNet :: DotNetTime -> DotNetTime -> Bool
55−approxEqNet (DotNetTime a) (DotNetTime b) = approxEqUTC a b
56−
57toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a) => a -> Bool
47toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a) => a -> Bool
58toFromJSON x = case fromJSON . toJSON $ x of
48toFromJSON x = case fromJSON . toJSON $ x of
59 Error _ -> False
49 Error _ -> False
@@ -79,6 +69,9 @@ modifyFailureProp orig added =
79main :: IO ()
69main :: IO ()
80main = defaultMain tests
70main = defaultMain tests
81
71
72+type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()
73+type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)
74+
82tests :: [Test]
75tests :: [Test]
83tests = [
76tests = [
84 testGroup "regression" [
77 testGroup "regression" [
@@ -104,15 +97,21 @@ tests = [
104 ],
97 ],
105 testGroup "roundTrip" [
98 testGroup "roundTrip" [
106 testProperty "Bool" $ roundTripEq True
99 testProperty "Bool" $ roundTripEq True
107− , testProperty "Double" $ roundTrip approxEq (1::Double)
100+ , testProperty "Double" $ roundTripEq (1 :: Approx Double)
108 , testProperty "Int" $ roundTripEq (1::Int)
101 , testProperty "Int" $ roundTripEq (1::Int)
109 , testProperty "Integer" $ roundTripEq (1::Integer)
102 , testProperty "Integer" $ roundTripEq (1::Integer)
110 , testProperty "String" $ roundTripEq (""::String)
103 , testProperty "String" $ roundTripEq (""::String)
111 , testProperty "Text" $ roundTripEq T.empty
104 , testProperty "Text" $ roundTripEq T.empty
112 , testProperty "Foo" $ roundTripEq (undefined::Foo)
105 , testProperty "Foo" $ roundTripEq (undefined::Foo)
113− , testProperty "DotNetTime" $ roundTrip approxEqNet undefined
106+ , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)
114− , testProperty "UTCTime" $ roundTrip approxEqUTC undefined
107+ , testProperty "UTCTime" $ roundTripEq (undefined :: Approx UTCTime)
115 , testProperty "ZonedTime" $ roundTripEq (undefined::ZonedTime)
108 , testProperty "ZonedTime" $ roundTripEq (undefined::ZonedTime)
109+ , testGroup "ghcGenerics" [
110+ testProperty "OneConstructor" $ roundTripEq OneConstructor
111+ , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)
112+ , testProperty "Product6" $ roundTripEq (undefined :: P6)
113+ , testProperty "Sum4" $ roundTripEq (undefined :: S4)
114+ ]
116 ],
115 ],
117 testGroup "toFromJSON" [
116 testGroup "toFromJSON" [
118 testProperty "Integer" (toFromJSON :: Integer -> Bool)
117 testProperty "Integer" (toFromJSON :: Integer -> Bool)
tests/Types.hs+29−3
@@ -1,10 +1,12 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
1+{-# LANGUAGE DefaultSignatures, DeriveDataTypeable, DeriveGeneric,
2+ GeneralizedNewtypeDeriving #-}
2
3
3module Types where
4module Types where
4
5
5import qualified Data.Map as Map
6import qualified Data.Map as Map
6import Data.Data
7import Data.Data
7import Data.Text
8import Data.Text
9+import GHC.Generics
8
10
9data Foo = Foo {
11data Foo = Foo {
10 fooInt :: Int
12 fooInt :: Int
@@ -13,9 +15,33 @@ data Foo = Foo {
13 -- This definition causes an infinite loop in genericTo and genericFrom!
15 -- This definition causes an infinite loop in genericTo and genericFrom!
14 -- , fooMap :: Map.Map String Foo
16 -- , fooMap :: Map.Map String Foo
15 , fooMap :: Map.Map String (Text,Int)
17 , fooMap :: Map.Map String (Text,Int)
16− } deriving (Show, Typeable, Data)
18+ } deriving (Show, Typeable, Data, Generic)
17
19
18data UFoo = UFoo {
20data UFoo = UFoo {
19 _UFooInt :: Int
21 _UFooInt :: Int
20 , uFooInt :: Int
22 , uFooInt :: Int
21− } deriving (Show, Eq, Data, Typeable)
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