@@ -1,36 +1,47 @@
1+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards,
1−{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
2+ ScopedTypeVariables #-}
3+{-# OPTIONS_GHC -fno-warn-orphans #-}
6+import Control.Applicative
3import Data.Aeson.Encode
7import Data.Aeson.Encode
4import Data.Aeson.Parser (value)
8import Data.Aeson.Parser (value)
5import Data.Aeson.Types
9import Data.Aeson.Types
6import Data.Attoparsec.Number
10import Data.Attoparsec.Number
11+import Data.Data (Typeable, Data)
12+import Data.Text (Text)
7import Test.Framework (Test, defaultMain, testGroup)
13import Test.Framework (Test, defaultMain, testGroup)
8import Test.Framework.Providers.QuickCheck2 (testProperty)
14import Test.Framework.Providers.QuickCheck2 (testProperty)
9−import Test.QuickCheck (Arbitrary)
15+import Test.QuickCheck (Arbitrary(..))
10−import qualified Data.ByteString.Lazy.Char8 as L
16+import qualified Data.Aeson.Generic as G
11import qualified Data.Attoparsec.Lazy as L
17import 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
13encodeDouble :: Double -> Double -> Bool
22encodeDouble :: Double -> Double -> Bool
14encodeDouble num denom
23encodeDouble num denom
15 | isInfinite d || isNaN d = encode (Number (D d)) == "null"
24 | 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
17 where d = num / denom
26 where d = num / denom
19encodeInteger :: Integer -> Bool
28encodeInteger :: Integer -> Bool
20encodeInteger i = encode (Number (I i)) == L.pack (show i)
29encodeInteger i = encode (Number (I i)) == L.pack (show i)
22−roundTrip :: (FromJSON a, ToJSON a) => (a -> a -> Bool) -> a -> Bool
31+roundTrip :: (FromJSON a, ToJSON a) => (a -> a -> Bool) -> a -> a -> Bool
23−roundTrip eq i =
32+roundTrip eq _ i =
24 case fmap fromJSON . L.parse value . encode . toJSON $ i of
33 case fmap fromJSON . L.parse value . encode . toJSON $ i of
25 L.Done _ (Success v) -> v `eq` i
34 L.Done _ (Success v) -> v `eq` i
26 _ -> False
35 _ -> False
28−roundTripBool :: Bool -> Bool
37+roundTripEq :: (Eq a, FromJSON a, ToJSON a) => a -> a -> Bool
29−roundTripBool = roundTrip (==)
38+roundTripEq x y = roundTrip (==) x y
30−roundTripDouble :: Double -> Bool
39+
31−roundTripDouble = roundTrip approxEq
40+genericTo :: (Data a, ToJSON a) => a -> a -> Bool
32−roundTripInteger :: Integer -> Bool
41+genericTo _ v = G.toJSON v == toJSON v
33−roundTripInteger = roundTrip (==)
42+
43+genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool
44+genericFrom _ v = G.fromJSON (toJSON v) == Success v
35approxEq :: Double -> Double -> Bool
46approxEq :: Double -> Double -> Bool
36approxEq a b = a == b ||
47approxEq a b = a == b ||
@@ -45,6 +56,42 @@ toFromJSON x = case fromJSON . toJSON $ x of
45 Error _ -> False
56 Error _ -> False
46 Success x' -> x == x'
57 Success x' -> x == x'
61+ , fooDouble :: Double
62+ , fooTuple :: (String, Text, Int)
63+ , fooMap :: Map.Map String Foo
64+ } deriving (Show, Typeable, Data)
67+ a == b = fooInt a == fooInt b &&
68+ fooDouble a `approxEq` fooDouble b &&
69+ fooTuple a == fooTuple b
71+instance ToJSON Foo where
72+ toJSON Foo{..} = object [ "fooInt" .= fooInt
73+ , "fooDouble" .= fooDouble
74+ , "fooTuple" .= fooTuple
78+instance FromJSON Foo where
79+ parseJSON (Object v) = Foo <$>
86+instance Arbitrary Text where
87+ arbitrary = T.pack <$> arbitrary
89+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map.Map k v) where
90+ arbitrary = Map.fromList <$> arbitrary
92+instance Arbitrary Foo where
93+ arbitrary = liftM4 Foo arbitrary arbitrary arbitrary arbitrary
48main :: IO ()
95main :: IO ()
49main = defaultMain tests
96main = defaultMain tests
@@ -54,10 +101,26 @@ tests = [
54 testProperty "encodeDouble" encodeDouble
101 testProperty "encodeDouble" encodeDouble
55 , testProperty "encodeInteger" encodeInteger
102 , testProperty "encodeInteger" encodeInteger
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)
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)
57 testGroup "roundTrip" [
116 testGroup "roundTrip" [
58− testProperty "roundTripBool" roundTripBool
117+ testProperty "Bool" $ roundTripEq True
59− , testProperty "roundTripDouble" roundTripDouble
118+ , testProperty "Double" $ roundTrip approxEq (1::Double)
60− , testProperty "roundTripInteger" roundTripInteger
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)
62 testGroup "toFromJSON" [
125 testGroup "toFromJSON" [
63 testProperty "Integer" (toFromJSON :: Integer -> Bool)
126 testProperty "Integer" (toFromJSON :: Integer -> Bool)