basvandijk avatar basvandijk committed 766a4b8

Added TH and GHC Generics tests to the test suite

Comments (0)

Files changed (2)

   type:           exitcode-stdio-1.0
   hs-source-dirs: tests
   main-is:        Properties.hs
+  other-modules:  Options
 
   ghc-options:
     -Wall -threaded -rtsopts
 
+  if impl(ghc >= 7.2.1)
+    cpp-options: -DGENERICS
+    build-depends: ghc-prim >= 0.2
+
   build-depends:
     QuickCheck,
     aeson,
     test-framework,
     test-framework-quickcheck2,
     text,
-    time
+    time,
+    unordered-containers,
+    vector
 
 source-repository head
   type:     git

tests/Properties.hs

-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards,
-    ScopedTypeVariables, StandaloneDeriving #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings, RecordWildCards,
+    ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
+#ifdef GENERICS
+{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}
+#endif
+
 import Control.Monad
 import Control.Applicative
 import Data.Aeson.Encode
 import Data.Aeson.Parser (value)
 import Data.Aeson.Types
+import Data.Aeson.TH
 import Data.Attoparsec.Number
 import Data.Data (Typeable, Data)
 import Data.Text (Text)
 import Test.Framework (Test, defaultMain, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.QuickCheck (Arbitrary(..), choose, Gen)
+import Test.QuickCheck (Arbitrary(..), choose, oneof, elements, Gen)
+import qualified Data.Vector as V
 import qualified Data.Aeson.Generic as G
 import qualified Data.Attoparsec.Lazy as L
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Text as T
 import qualified Data.Map as Map
+import qualified Data.HashMap.Strict as H
 import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..), hoursToTimeZone, Day(..), TimeOfDay(..))
 
+import Options
+
+#ifdef GENERICS
+import GHC.Generics
+#endif
+
 encodeDouble :: Double -> Double -> Bool
 encodeDouble num denom
     | isInfinite d || isNaN d = encode (Number (D d)) == "null"
                 Error _ -> False
                 Success x' -> x == x'
 
+toParseJSON :: (Arbitrary a, Eq a) => (Value -> Parser a) -> (a -> Value) -> a -> Bool
+toParseJSON parsejson tojson x = case parse parsejson . tojson $ x of
+                Error _ -> False
+                Success x' -> x == x'
+
 regress_gh72 :: [(String, Maybe String)] -> Bool
 regress_gh72 ys = G.decode (G.encode m) == Just m
     where m = Map.fromList ys
     , fooMap :: Map.Map String (Text,Int)
     } deriving (Show, Typeable, Data)
 
+--------------------------------------------------------------------------------
+-- Nullary
+--------------------------------------------------------------------------------
+
+data Nullary = C1 | C2 | C3 deriving (Eq, Show)
+
+instance Arbitrary Nullary where
+    arbitrary = elements [C1, C2, C3]
+
+thNullaryToJSONString :: Nullary -> Value
+thNullaryToJSONString = $(mkToJSON defaultOptions ''Nullary)
+
+thNullaryParseJSONString :: Value -> Parser Nullary
+thNullaryParseJSONString = $(mkParseJSON defaultOptions ''Nullary)
+
+
+thNullaryToJSON2ElemArray :: Nullary -> Value
+thNullaryToJSON2ElemArray = $(mkToJSON opts2ElemArray ''Nullary)
+
+thNullaryParseJSON2ElemArray :: Value -> Parser Nullary
+thNullaryParseJSON2ElemArray = $(mkParseJSON opts2ElemArray ''Nullary)
+
+
+thNullaryToJSONObjectWithType :: Nullary -> Value
+thNullaryToJSONObjectWithType = $(mkToJSON optsObjectWithType ''Nullary)
+
+thNullaryParseJSONObjectWithType :: Value -> Parser Nullary
+thNullaryParseJSONObjectWithType = $(mkParseJSON optsObjectWithType ''Nullary)
+
+
+thNullaryToJSONObjectWithSingleField :: Nullary -> Value
+thNullaryToJSONObjectWithSingleField = $(mkToJSON optsObjectWithSingleField ''Nullary)
+
+thNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
+thNullaryParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''Nullary)
+
+#ifdef GENERICS
+deriving instance Generic Nullary
+
+gNullaryToJSONString :: Nullary -> Value
+gNullaryToJSONString = gToJSON defaultOptions . from
+
+gNullaryParseJSONString :: Value -> Parser Nullary
+gNullaryParseJSONString = fmap to . gParseJSON defaultOptions
+
+
+gNullaryToJSON2ElemArray :: Nullary -> Value
+gNullaryToJSON2ElemArray = gToJSON opts2ElemArray . from
+
+gNullaryParseJSON2ElemArray :: Value -> Parser Nullary
+gNullaryParseJSON2ElemArray = fmap to . gParseJSON opts2ElemArray
+
+
+gNullaryToJSONObjectWithType :: Nullary -> Value
+gNullaryToJSONObjectWithType = gToJSON optsObjectWithType . from
+
+gNullaryParseJSONObjectWithType :: Value -> Parser Nullary
+gNullaryParseJSONObjectWithType = fmap to . gParseJSON optsObjectWithType
+
+
+gNullaryToJSONObjectWithSingleField :: Nullary -> Value
+gNullaryToJSONObjectWithSingleField = gToJSON optsObjectWithSingleField . from
+
+gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
+gNullaryParseJSONObjectWithSingleField = fmap to . gParseJSON optsObjectWithSingleField
+#endif
+
+--------------------------------------------------------------------------------
+-- SomeType
+--------------------------------------------------------------------------------
+
+data SomeType a = Nullary
+                | Unary Int
+                | Product String (Maybe Char) a
+                | Record { testOne   :: Double
+                         , testTwo   :: Maybe Bool
+                         , testThree :: Maybe a
+                         } deriving (Eq, Show)
+
+instance Arbitrary a => Arbitrary (SomeType a) where
+    arbitrary = oneof [ pure Nullary
+                      , Unary   <$> arbitrary
+                      , Product <$> arbitrary <*> arbitrary <*> arbitrary
+                      , Record  <$> arbitrary <*> arbitrary <*> arbitrary
+                      ]
+
+type SomeTypeToJSON = SomeType Int -> Value
+
+thSomeTypeToJSON2ElemArray :: ToJSON a => SomeType a -> Value
+thSomeTypeToJSON2ElemArray = $(mkToJSON opts2ElemArray ''SomeType)
+
+thSomeTypeParseJSON2ElemArray :: FromJSON a => Value -> Parser (SomeType a)
+thSomeTypeParseJSON2ElemArray = $(mkParseJSON opts2ElemArray ''SomeType)
+
+
+thSomeTypeToJSONObjectWithType :: ToJSON a => SomeType a -> Value
+thSomeTypeToJSONObjectWithType = $(mkToJSON optsObjectWithType ''SomeType)
+
+thSomeTypeParseJSONObjectWithType :: FromJSON a => Value -> Parser (SomeType a)
+thSomeTypeParseJSONObjectWithType = $(mkParseJSON optsObjectWithType ''SomeType)
+
+
+thSomeTypeToJSONObjectWithSingleField :: ToJSON a => SomeType a -> Value
+thSomeTypeToJSONObjectWithSingleField = $(mkToJSON optsObjectWithSingleField ''SomeType)
+
+thSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)
+thSomeTypeParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''SomeType)
+
+#ifdef GENERICS
+deriving instance Generic (SomeType a)
+
+gSomeTypeToJSON2ElemArray :: ToJSON a => SomeType a -> Value
+gSomeTypeToJSON2ElemArray = gToJSON opts2ElemArray . from
+
+gSomeTypeParseJSON2ElemArray :: FromJSON a => Value -> Parser (SomeType a)
+gSomeTypeParseJSON2ElemArray = fmap to . gParseJSON opts2ElemArray
+
+
+gSomeTypeToJSONObjectWithType :: ToJSON a => SomeType a -> Value
+gSomeTypeToJSONObjectWithType = gToJSON optsObjectWithType . from
+
+gSomeTypeParseJSONObjectWithType :: FromJSON a => Value -> Parser (SomeType a)
+gSomeTypeParseJSONObjectWithType = fmap to . gParseJSON optsObjectWithType
+
+
+gSomeTypeToJSONObjectWithSingleField :: ToJSON a => SomeType a -> Value
+gSomeTypeToJSONObjectWithSingleField = gToJSON optsObjectWithSingleField . from
+
+gSomeTypeParseJSONObjectWithSingleField :: FromJSON a => Value -> Parser (SomeType a)
+gSomeTypeParseJSONObjectWithSingleField = fmap to . gParseJSON optsObjectWithSingleField
+#endif
+
+--------------------------------------------------------------------------------
+-- Value properties
+--------------------------------------------------------------------------------
+
+isString :: Value -> Bool
+isString (String _) = True
+isString _          = False
+
+is2ElemArray :: Value -> Bool
+is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)
+is2ElemArray _         = False
+
+isObjectWithTypeValue :: Value -> Bool
+isObjectWithTypeValue (Object obj) = "type"  `H.member` obj &&
+                                     "value" `H.member` obj
+isObjectWithTypeValue _            = False
+
+isObjectWithType :: Value -> Bool
+isObjectWithType (Object obj) = "type"  `H.member` obj
+isObjectWithType _            = False
+
+isObjectWithSingleField :: Value -> Bool
+isObjectWithSingleField (Object obj) = H.size obj == 1
+isObjectWithSingleField _            = False
+
+--------------------------------------------------------------------------------
+
 instance Eq Foo where
     a == b = fooInt a == fooInt b &&
              fooDouble a `approxEq` fooDouble b &&
     ],
   testGroup "failure messages" [
       testProperty "modify failure" modifyFailureProp
+    ],
+  testGroup "template-haskell" [
+    testGroup "Nullary" [
+        testProperty "string"                (isString                . thNullaryToJSONString)
+      , testProperty "2ElemArray"            (is2ElemArray            . thNullaryToJSON2ElemArray)
+      , testProperty "ObjectWithType"        (isObjectWithTypeValue   . thNullaryToJSONObjectWithType)
+      , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
+
+      , testGroup "roundTrip" [
+            testProperty "string"                (toParseJSON thNullaryParseJSONString                thNullaryToJSONString)
+          , testProperty "2ElemArray"            (toParseJSON thNullaryParseJSON2ElemArray            thNullaryToJSON2ElemArray)
+          , testProperty "ObjectWithType"        (toParseJSON thNullaryParseJSONObjectWithType        thNullaryToJSONObjectWithType)
+          , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
+        ]
+      ]
+   , testGroup "SomeType" [
+        testProperty "2ElemArray"            (is2ElemArray            . (thSomeTypeToJSON2ElemArray            :: SomeTypeToJSON))
+      , testProperty "ObjectWithType"        (isObjectWithType        . (thSomeTypeToJSONObjectWithType        :: SomeTypeToJSON))
+      , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
+
+      , testGroup "roundTrip" [
+            testProperty "2ElemArray"            (toParseJSON thSomeTypeParseJSON2ElemArray            (thSomeTypeToJSON2ElemArray            :: SomeTypeToJSON))
+          , testProperty "ObjectWithType"        (toParseJSON thSomeTypeParseJSONObjectWithType        (thSomeTypeToJSONObjectWithType        :: SomeTypeToJSON))
+          , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField (thSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
+        ]
     ]
+    ]
+#ifdef GENERICS
+  , testGroup "GHC-generics" [
+      testGroup "Nullary" [
+          testProperty "string"                (isString                . gNullaryToJSONString)
+        , testProperty "2ElemArray"            (is2ElemArray            . gNullaryToJSON2ElemArray)
+        , testProperty "ObjectWithType"        (isObjectWithTypeValue   . gNullaryToJSONObjectWithType)
+        , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
+
+        , testGroup "eq" [
+              testProperty "string"                (\n -> gNullaryToJSONString                n == thNullaryToJSONString                n)
+            , testProperty "2ElemArray"            (\n -> gNullaryToJSON2ElemArray            n == thNullaryToJSON2ElemArray            n)
+            , testProperty "ObjectWithType"        (\n -> gNullaryToJSONObjectWithType        n == thNullaryToJSONObjectWithType        n)
+            , testProperty "ObjectWithSingleField" (\n -> gNullaryToJSONObjectWithSingleField n == thNullaryToJSONObjectWithSingleField n)
+          ]
+        , testGroup "roundTrip" [
+            testProperty "string"                (toParseJSON gNullaryParseJSONString                gNullaryToJSONString)
+          , testProperty "2ElemArray"            (toParseJSON gNullaryParseJSON2ElemArray            gNullaryToJSON2ElemArray)
+          , testProperty "ObjectWithType"        (toParseJSON gNullaryParseJSONObjectWithType        gNullaryToJSONObjectWithType)
+          , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
+          ]
+        ]
+    , testGroup "SomeType" [
+          testProperty "2ElemArray"            (is2ElemArray            . (gSomeTypeToJSON2ElemArray            :: SomeTypeToJSON))
+        , testProperty "ObjectWithType"        (isObjectWithType        . (gSomeTypeToJSONObjectWithType        :: SomeTypeToJSON))
+        , testProperty "ObjectWithSingleField" (isObjectWithSingleField . (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
+
+        , testGroup "eq" [
+              testProperty "2ElemArray"            (\n -> (gSomeTypeToJSON2ElemArray            :: SomeTypeToJSON) n == thSomeTypeToJSON2ElemArray            n)
+            , testProperty "ObjectWithType"        (\n -> (gSomeTypeToJSONObjectWithType        :: SomeTypeToJSON) n == thSomeTypeToJSONObjectWithType        n)
+            , testProperty "ObjectWithSingleField" (\n -> (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON) n == thSomeTypeToJSONObjectWithSingleField n)
+          ]
+        , testGroup "roundTrip" [
+            testProperty "2ElemArray"            (toParseJSON gSomeTypeParseJSON2ElemArray            (gSomeTypeToJSON2ElemArray            :: SomeTypeToJSON))
+          , testProperty "ObjectWithType"        (toParseJSON gSomeTypeParseJSONObjectWithType        (gSomeTypeToJSONObjectWithType        :: SomeTypeToJSON))
+          , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField (gSomeTypeToJSONObjectWithSingleField :: SomeTypeToJSON))
+          ]
+        ]
+    ]
+#endif
   ]
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.