@@ -1,13 +1,18 @@
1−{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
1+{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
23
4+import Control.Applicative
35import Data.Aeson.Encode
46import Data.Aeson.Parser (value)
57import Data.Aeson.Types
68import Data.Attoparsec.Number
9+import Data.Text (Text)
710import Test.Framework (Test, defaultMain, testGroup)
811import Test.Framework.Providers.QuickCheck2 (testProperty)
9−import qualified Data.ByteString.Lazy.Char8 as L
12+import Test.QuickCheck (Arbitrary(..))
1013import qualified Data.Attoparsec.Lazy as L
14+import qualified Data.ByteString.Lazy.Char8 as L
15+import qualified Data.Text as T
1116
1217encodeDouble :: Double -> Double -> Bool
1318encodeDouble num denom
@@ -30,6 +35,8 @@ roundTripDouble :: Double -> Bool
3035roundTripDouble = roundTrip approxEq
3136roundTripInteger :: Integer -> Bool
3237roundTripInteger = roundTrip (==)
38+roundTripFoo :: Foo -> Bool
39+roundTripFoo = roundTrip (==)
3340
3441approxEq :: Double -> Double -> Bool
3542approxEq a b = a == b ||
@@ -39,6 +46,36 @@ approxEq a b = a == b ||
3946 maxAbsoluteError = 1e-15
4047 maxRelativeError = 1e-15
4148
49+data Foo = Foo {
50+ fooInt :: Int
51+ , fooDouble :: Double
52+ , fooTuple :: (String, Text)
53+ } deriving (Show)
54+
55+instance Eq Foo where
56+ a == b = fooInt a == fooInt b &&
57+ fooDouble a `approxEq` fooDouble b &&
58+ fooTuple a == fooTuple b
59+
60+instance ToJSON Foo where
61+ toJSON Foo{..} = object [ "int" .= fooInt
62+ , "double" .= fooDouble
63+ , "tuple" .= fooTuple
64+ ]
65+
66+instance FromJSON Foo where
67+ parseJSON (Object v) = Foo <$>
68+ v .: "int" <*>
69+ v .: "double" <*>
70+ v .: "tuple"
71+ parseJSON _ = empty
72+
73+instance Arbitrary Text where
74+ arbitrary = T.pack <$> arbitrary
75+
76+instance Arbitrary Foo where
77+ arbitrary = liftA3 Foo arbitrary arbitrary arbitrary
78+
4279main :: IO ()
4380main = defaultMain tests
4481
@@ -52,5 +89,6 @@ tests = [
5289 testProperty "roundTripBool" roundTripBool
5390 , testProperty "roundTripDouble" roundTripDouble
5491 , testProperty "roundTripInteger" roundTripInteger
92+ , testProperty "roundTripFoo" roundTripFoo
5593 ]
5694 ]