@@ -1,36 +1,47 @@
1−{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
1+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards,
2+ ScopedTypeVariables #-}
3+{-# OPTIONS_GHC -fno-warn-orphans #-}
24
5+import Control.Monad
6+import Control.Applicative
37import Data.Aeson.Encode
48import Data.Aeson.Parser (value)
59import Data.Aeson.Types
610import Data.Attoparsec.Number
11+import Data.Data (Typeable, Data)
12+import Data.Text (Text)
713import Test.Framework (Test, defaultMain, testGroup)
814import Test.Framework.Providers.QuickCheck2 (testProperty)
9−import Test.QuickCheck (Arbitrary)
10−import qualified Data.ByteString.Lazy.Char8 as L
15+import Test.QuickCheck (Arbitrary(..))
16+import qualified Data.Aeson.Generic as G
1117import qualified Data.Attoparsec.Lazy as L
18+import qualified Data.ByteString.Lazy.Char8 as L
19+import qualified Data.Text as T
20+import qualified Data.Map as Map
1221
1322encodeDouble :: Double -> Double -> Bool
1423encodeDouble num denom
1524 | isInfinite d || isNaN d = encode (Number (D d)) == "null"
16− | otherwise = encode (Number (D d)) == L.pack (show d)
25+ | otherwise = (read . L.unpack . encode . Number . D) d == d
1726 where d = num / denom
1827
1928encodeInteger :: Integer -> Bool
2029encodeInteger i = encode (Number (I i)) == L.pack (show i)
2130
22−roundTrip :: (FromJSON a, ToJSON a) => (a -> a -> Bool) -> a -> Bool
23−roundTrip eq i =
31+roundTrip :: (FromJSON a, ToJSON a) => (a -> a -> Bool) -> a -> a -> Bool
32+roundTrip eq _ i =
2433 case fmap fromJSON . L.parse value . encode . toJSON $ i of
2534 L.Done _ (Success v) -> v `eq` i
2635 _ -> False
2736
28−roundTripBool :: Bool -> Bool
29−roundTripBool = roundTrip (==)
30−roundTripDouble :: Double -> Bool
31−roundTripDouble = roundTrip approxEq
32−roundTripInteger :: Integer -> Bool
33−roundTripInteger = roundTrip (==)
37+roundTripEq :: (Eq a, FromJSON a, ToJSON a) => a -> a -> Bool
38+roundTripEq x y = roundTrip (==) x y
39+
40+genericTo :: (Data a, ToJSON a) => a -> a -> Bool
41+genericTo _ v = G.toJSON v == toJSON v
42+
43+genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool
44+genericFrom _ v = G.fromJSON (toJSON v) == Success v
3445
3546approxEq :: Double -> Double -> Bool
3647approxEq a b = a == b ||
@@ -45,6 +56,42 @@ toFromJSON x = case fromJSON . toJSON $ x of
4556 Error _ -> False
4657 Success x' -> x == x'
4758
59+data Foo = Foo {
60+ fooInt :: Int
61+ , fooDouble :: Double
62+ , fooTuple :: (String, Text, Int)
63+ , fooMap :: Map.Map String Foo
64+ } deriving (Show, Typeable, Data)
65+
66+instance Eq Foo where
67+ a == b = fooInt a == fooInt b &&
68+ fooDouble a `approxEq` fooDouble b &&
69+ fooTuple a == fooTuple b
70+
71+instance ToJSON Foo where
72+ toJSON Foo{..} = object [ "fooInt" .= fooInt
73+ , "fooDouble" .= fooDouble
74+ , "fooTuple" .= fooTuple
75+ , "fooMap" .= fooMap
76+ ]
77+
78+instance FromJSON Foo where
79+ parseJSON (Object v) = Foo <$>
80+ v .: "fooInt" <*>
81+ v .: "fooDouble" <*>
82+ v .: "fooTuple" <*>
83+ v .: "fooMap"
84+ parseJSON _ = empty
85+
86+instance Arbitrary Text where
87+ arbitrary = T.pack <$> arbitrary
88+
89+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where
90+ arbitrary = Map.fromList <$> arbitrary
91+
92+instance Arbitrary Foo where
93+ arbitrary = liftM4 Foo arbitrary arbitrary arbitrary arbitrary
94+
4895main :: IO ()
4996main = defaultMain tests
5097
@@ -54,10 +101,26 @@ tests = [
54101 testProperty "encodeDouble" encodeDouble
55102 , testProperty "encodeInteger" encodeInteger
56103 ],
104+ testGroup "genericFrom" [
105+ testProperty "Bool" $ genericFrom True
106+ , testProperty "Double" $ genericFrom (1::Double)
107+ , testProperty "Int" $ genericFrom (1::Int)
108+ , testProperty "Foo" $ genericFrom (undefined::Foo)
109+ ],
110+ testGroup "genericTo" [
111+ testProperty "Bool" $ genericTo True
112+ , testProperty "Double" $ genericTo (1::Double)
113+ , testProperty "Int" $ genericTo (1::Int)
114+ , testProperty "Foo" $ genericTo (undefined::Foo)
115+ ],
57116 testGroup "roundTrip" [
58− testProperty "roundTripBool" roundTripBool
59− , testProperty "roundTripDouble" roundTripDouble
60− , testProperty "roundTripInteger" roundTripInteger
117+ testProperty "Bool" $ roundTripEq True
118+ , testProperty "Double" $ roundTrip approxEq (1::Double)
119+ , testProperty "Int" $ roundTripEq (1::Int)
120+ , testProperty "Integer" $ roundTripEq (1::Integer)
121+ , testProperty "String" $ roundTripEq (""::String)
122+ , testProperty "Text" $ roundTripEq T.empty
123+ , testProperty "Foo" $ roundTripEq (undefined::Foo)
61124 ],
62125 testGroup "toFromJSON" [
63126 testProperty "Integer" (toFromJSON :: Integer -> Bool)