Commits

Bryan O'Sullivan  committed ba6da2f

Add some basic tests for roundtrips via GHC generics

  • Participants
  • Parent commits d5c5f80

Comments (0)

Files changed (3)

File tests/Instances.hs

 module Instances where
 
 import Types
+import Data.Function (on)
 import Control.Monad
-import Test.QuickCheck (Arbitrary(..), choose, Gen)
+import Test.QuickCheck (Arbitrary(..), Gen, choose, oneof)
 import Data.Time.Clock (DiffTime, UTCTime(..), picosecondsToDiffTime)
 import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..),
                   hoursToTimeZone, Day(..), TimeOfDay(..))
 
 deriving instance Eq ZonedTime
 
+-- Compare equality to within a millisecond, allowing for rounding
+-- error (ECMA 262 requires milliseconds to rounded to zero, not
+-- rounded to nearest).
+instance ApproxEq UTCTime where
+    a =~ b = ((==) `on` utctDay) a b &&
+             (approxEqWith 1 1 `on` ((* 1e3) . utctDayTime)) a b
+
+instance ApproxEq DotNetTime
+
+instance ApproxEq Double where
+    (=~) = approxEq
+
 -- Test-related types.
 
 instance Arbitrary Foo where
 instance Arbitrary UFoo where
     arbitrary = UFoo <$> arbitrary <*> arbitrary
         where _ = uFooInt
+
+instance Arbitrary OneConstructor where
+    arbitrary = return OneConstructor
+
+instance FromJSON OneConstructor
+instance ToJSON OneConstructor
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Product2 a b) where
+    arbitrary = liftM2 Product2 arbitrary arbitrary
+
+instance (FromJSON a, FromJSON b) => FromJSON (Product2 a b)
+instance (ToJSON a, ToJSON b) => ToJSON (Product2 a b)
+
+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,
+          Arbitrary f) => Arbitrary (Product6 a b c d e f) where
+    arbitrary = Product6 <$> arbitrary <*> arbitrary <*> arbitrary <*>
+                             arbitrary <*> arbitrary <*> arbitrary
+
+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e,
+          FromJSON f) => FromJSON (Product6 a b c d e f)
+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e,
+          ToJSON f) => ToJSON (Product6 a b c d e f)
+
+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
+    => Arbitrary (Sum4 a b c d) where
+    arbitrary = oneof [Alt1 <$> arbitrary, Alt2 <$> arbitrary,
+                       Alt3 <$> arbitrary, Alt4 <$> arbitrary]
+
+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d)
+    => FromJSON (Sum4 a b c d)
+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (Sum4 a b c d)
+
+instance (Arbitrary a) => Arbitrary (Approx a) where
+    arbitrary = Approx <$> arbitrary
+
+instance (FromJSON a) => FromJSON (Approx a) where
+    parseJSON a = Approx <$> parseJSON a
+
+instance (ToJSON a) => ToJSON (Approx a) where
+    toJSON = toJSON . fromApprox

File tests/Properties.hs

 import Data.Aeson.Types
 import Data.Attoparsec.Number
 import Data.Data (Data)
-import Data.Function (on)
+import Data.Int
 import Test.Framework (Test, defaultMain, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
 import Test.QuickCheck (Arbitrary(..))
 import Data.Time.Clock (UTCTime(..))
 import Data.Time (ZonedTime(..))
 import Types (Foo(..), UFoo(..))
-import Functions
 import Instances ()
+import Types (Approx(..), OneConstructor(..), Product2, Product6, Sum4)
 
 encodeDouble :: Double -> Double -> Bool
 encodeDouble num denom
 genericFrom :: (Eq a, Data a, ToJSON a) => a -> a -> Bool
 genericFrom _ v = G.fromJSON (toJSON v) == Success v
 
--- Compare equality to within a millisecond, allowing for rounding
--- error (ECMA 262 requires milliseconds to rounded to zero, not
--- rounded to nearest).
-approxEqUTC :: UTCTime -> UTCTime -> Bool
-approxEqUTC a b = ((==) `on` utctDay) a b &&
-                  (approxEqWith 1 1 `on` ((* 1e3) . utctDayTime)) a b
-
-approxEqNet :: DotNetTime -> DotNetTime -> Bool
-approxEqNet (DotNetTime a) (DotNetTime b) = approxEqUTC a b
-
 toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a) => a -> Bool
 toFromJSON x = case fromJSON . toJSON $ x of
                 Error _ -> False
 main :: IO ()
 main = defaultMain tests
 
+type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()
+type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)
+
 tests :: [Test]
 tests = [
   testGroup "regression" [
     ],
   testGroup "roundTrip" [
       testProperty "Bool" $ roundTripEq True
-    , testProperty "Double" $ roundTrip approxEq (1::Double)
+    , testProperty "Double" $ roundTripEq (1 :: Approx Double)
     , testProperty "Int" $ roundTripEq (1::Int)
     , testProperty "Integer" $ roundTripEq (1::Integer)
     , testProperty "String" $ roundTripEq (""::String)
     , testProperty "Text" $ roundTripEq T.empty
     , testProperty "Foo" $ roundTripEq (undefined::Foo)
-    , testProperty "DotNetTime" $ roundTrip approxEqNet undefined
-    , testProperty "UTCTime" $ roundTrip approxEqUTC undefined
+    , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)
+    , testProperty "UTCTime" $ roundTripEq (undefined :: Approx UTCTime)
     , testProperty "ZonedTime" $ roundTripEq (undefined::ZonedTime)
+    , testGroup "ghcGenerics" [
+        testProperty "OneConstructor" $ roundTripEq OneConstructor
+      , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)
+      , testProperty "Product6" $ roundTripEq (undefined :: P6)
+      , testProperty "Sum4" $ roundTripEq (undefined :: S4)
+      ]
     ],
   testGroup "toFromJSON" [
       testProperty "Integer" (toFromJSON :: Integer -> Bool)

File tests/Types.hs

-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DefaultSignatures, DeriveDataTypeable, DeriveGeneric,
+    GeneralizedNewtypeDeriving #-}
 
 module Types where
 
 import qualified Data.Map as Map
 import Data.Data
 import Data.Text
+import GHC.Generics
 
 data Foo = Foo {
       fooInt :: Int
     -- This definition causes an infinite loop in genericTo and genericFrom!
     -- , fooMap :: Map.Map String Foo
     , fooMap :: Map.Map String (Text,Int)
-    } deriving (Show, Typeable, Data)
+    } deriving (Show, Typeable, Data, Generic)
 
 data UFoo = UFoo {
       _UFooInt :: Int
     , uFooInt :: Int
-    } deriving (Show, Eq, Data, Typeable)
+    } deriving (Show, Eq, Data, Typeable, Generic)
+
+data OneConstructor = OneConstructor
+                      deriving (Show, Eq, Typeable, Data, Generic)
+
+data Product2 a b = Product2 a b
+                    deriving (Show, Eq, Typeable, Data, Generic)
+
+data Product6 a b c d e f = Product6 a b c d e f
+                    deriving (Show, Eq, Typeable, Data, Generic)
+
+data Sum4 a b c d = Alt1 a | Alt2 b | Alt3 c | Alt4 d
+                    deriving (Show, Eq, Typeable, Data, Generic)
+
+class ApproxEq a where
+    (=~) :: a -> a -> Bool
+
+    default (=~) :: (Eq a) => a -> a -> Bool
+    (=~) = (==)
+
+newtype Approx a = Approx { fromApprox :: a }
+    deriving (Show, Data, Typeable, Generic, ApproxEq, Num)
+
+instance (ApproxEq a) => Eq (Approx a) where
+    Approx a == Approx b = a =~ b