git.iko.soy/typeable/aeson
on master help sign in
Add some basic tests for roundtrips via GHC generics
commit271f4dc40bf1ff53d920e8e26fa5f5687741331b authorBryan O'Sullivan <bos@serpentine.com> dateFri 19 Apr 2013, 09:44 (13 years ago) parentf796b58
3 files changed+97−19
compare with master
unifiedsplit
tests/Instances.hs+54−1 tests/Properties.hs+14−15 tests/Types.hs+29−3
tests/Instances.hs+54−1
@@ -4,8 +4,9 @@
44module Instances where
55
66import Types
7+import Data.Function (on)
78import Control.Monad
8−import Test.QuickCheck (Arbitrary(..), choose, Gen)
9+import Test.QuickCheck (Arbitrary(..), Gen, choose, oneof)
910import Data.Time.Clock (DiffTime, UTCTime(..), picosecondsToDiffTime)
1011import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..),
1112 hoursToTimeZone, Day(..), TimeOfDay(..))
@@ -49,6 +50,18 @@ instance Arbitrary ZonedTime where
4950
5051deriving instance Eq ZonedTime
5152
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+
5265-- Test-related types.
5366
5467instance Arbitrary Foo where
@@ -77,3 +90,43 @@ instance FromJSON Foo where
7790instance Arbitrary UFoo where
7891 arbitrary = UFoo <$> arbitrary <*> arbitrary
7992 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)
55import Data.Aeson.Types
66import Data.Attoparsec.Number
77import Data.Data (Data)
8−import Data.Function (on)
8+import Data.Int
99import Test.Framework (Test, defaultMain, testGroup)
1010import Test.Framework.Providers.QuickCheck2 (testProperty)
1111import Test.QuickCheck (Arbitrary(..))
@@ -17,8 +17,8 @@ import qualified Data.Map as Map
1717import Data.Time.Clock (UTCTime(..))
1818import Data.Time (ZonedTime(..))
1919import Types (Foo(..), UFoo(..))
20−import Functions
2120import Instances ()
21+import Types (Approx(..), OneConstructor(..), Product2, Product6, Sum4)
2222
2323encodeDouble :: Double -> Double -> Bool
2424encodeDouble num denom
@@ -44,16 +44,6 @@ genericTo _ v = G.toJSON v == toJSON v
4444genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool
4545genericFrom _ v = G.fromJSON (toJSON v) == Success v
4646
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−
5747toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a) => a -> Bool
5848toFromJSON x = case fromJSON . toJSON $ x of
5949 Error _ -> False
@@ -79,6 +69,9 @@ modifyFailureProp orig added =
7969main :: IO ()
8070main = defaultMain tests
8171
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+
8275tests :: [Test]
8376tests = [
8477 testGroup "regression" [
@@ -104,15 +97,21 @@ tests = [
10497 ],
10598 testGroup "roundTrip" [
10699 testProperty "Bool" $ roundTripEq True
107− , testProperty "Double" $ roundTrip approxEq (1::Double)
100+ , testProperty "Double" $ roundTripEq (1 :: Approx Double)
108101 , testProperty "Int" $ roundTripEq (1::Int)
109102 , testProperty "Integer" $ roundTripEq (1::Integer)
110103 , testProperty "String" $ roundTripEq (""::String)
111104 , testProperty "Text" $ roundTripEq T.empty
112105 , testProperty "Foo" $ roundTripEq (undefined::Foo)
113− , testProperty "DotNetTime" $ roundTrip approxEqNet undefined
114− , testProperty "UTCTime" $ roundTrip approxEqUTC undefined
106+ , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)
107+ , testProperty "UTCTime" $ roundTripEq (undefined :: Approx UTCTime)
115108 , 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+ ]
116115 ],
117116 testGroup "toFromJSON" [
118117 testProperty "Integer" (toFromJSON :: Integer -> Bool)
tests/Types.hs+29−3
@@ -1,10 +1,12 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
1+{-# LANGUAGE DefaultSignatures, DeriveDataTypeable, DeriveGeneric,
2+ GeneralizedNewtypeDeriving #-}
23
34module Types where
45
56import qualified Data.Map as Map
67import Data.Data
78import Data.Text
9+import GHC.Generics
810
911data Foo = Foo {
1012 fooInt :: Int
@@ -13,9 +15,33 @@ data Foo = Foo {
1315 -- This definition causes an infinite loop in genericTo and genericFrom!
1416 -- , fooMap :: Map.Map String Foo
1517 , fooMap :: Map.Map String (Text,Int)
16− } deriving (Show, Typeable, Data)
18+ } deriving (Show, Typeable, Data, Generic)
1719
1820data UFoo = UFoo {
1921 _UFooInt :: Int
2022 , 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