Add tests for Option fields

Author: Lysxia

Data/Aeson/TH.hs

@@ -85,7 +85,6 @@ $('deriveJSON' 'defaultOptions' ''(,,,))
 @
 
 -}
-
 module Data.Aeson.TH
     (
       -- * Encoding configuration
@@ -160,6 +159,7 @@ import qualified Data.Text as T (Text, pack, unpack)
 import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)
 import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)
 
+{-# ANN module "Hlint: ignore Reduce duplication" #-}
 
 --------------------------------------------------------------------------------
 -- Convenience

tests/Encoders.hs

@@ -235,6 +235,33 @@ gSomeTypeToJSONOmitNothingFields = genericToJSON optsOmitNothingFields
 gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding
 gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields
 
+
+--------------------------------------------------------------------------------
+-- Option fields
+--------------------------------------------------------------------------------
+
+thOptionFieldToJSON :: OptionField -> Value
+thOptionFieldToJSON = $(mkToJSON optsOptionField 'OptionField)
+
+thOptionFieldToEncoding :: OptionField -> Encoding
+thOptionFieldToEncoding = $(mkToEncoding optsOptionField 'OptionField)
+
+thOptionFieldParseJSON :: Value -> Parser OptionField
+thOptionFieldParseJSON = $(mkParseJSON optsOptionField 'OptionField)
+
+gOptionFieldToJSON :: OptionField -> Value
+gOptionFieldToJSON = genericToJSON optsOptionField
+
+gOptionFieldToEncoding :: OptionField -> Encoding
+gOptionFieldToEncoding = genericToEncoding optsOptionField
+
+gOptionFieldParseJSON :: Value -> Parser OptionField
+gOptionFieldParseJSON = genericParseJSON optsOptionField
+
+thMaybeFieldToJSON :: MaybeField -> Value
+thMaybeFieldToJSON = $(mkToJSON optsOptionField 'MaybeField)
+
+
 --------------------------------------------------------------------------------
 -- IncoherentInstancesNeeded
 --------------------------------------------------------------------------------

tests/Instances.hs

@@ -28,8 +28,6 @@ import Test.QuickCheck.Instances ()
 import Data.Hashable.Time ()
 #endif
 
-{-# ANN module ("HLint: ignore Use fewer imports"::String) #-}
-
 -- "System" types.
 
 instance Arbitrary DotNetTime where
@@ -157,17 +155,15 @@ instance Arbitrary EitherTextInt where
 instance Arbitrary (GADT String) where
     arbitrary = GADT <$> arbitrary
 
+instance Arbitrary OptionField where
+    arbitrary = OptionField <$> arbitrary
+
+
 instance ApproxEq Char where
     (=~) = (==)
 
 instance (ApproxEq a) => ApproxEq [a] where
     a =~ b = length a == length b && all (uncurry (=~)) (zip a b)
 
--- Version tags are deprecated, so we avoid using them in the Arbitrary
--- instance. However, the recommended constructor 'makeVersion' is not
--- exported by "Data.Version" until base-4.8.0.0. For previous versions,
--- a definition is given below.
-
-
 instance Arbitrary a => Arbitrary (DList.DList a) where
     arbitrary = DList.fromList <$> arbitrary

tests/Options.hs

@@ -48,3 +48,9 @@ optsTagSingleConstructors = optsDefault
                             { tagSingleConstructors = True
                             , allNullaryToStringTag = False
                             }
+
+optsOptionField :: Options
+optsOptionField = optsDefault
+                  { fieldLabelModifier = const "field"
+                  , omitNothingFields = True
+                  }

tests/Properties.hs

@@ -25,6 +25,7 @@ import Data.List.NonEmpty (NonEmpty)
 import Data.Map (Map)
 import Data.Proxy (Proxy)
 import Data.Ratio (Ratio)
+import Data.Semigroup (Option(..))
 import Data.Sequence (Seq)
 import Data.Tagged (Tagged)
 import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
@@ -376,6 +377,11 @@ tests = testGroup "properties" [
           , testProperty "Tagged"  (toParseJSON gOneConstructorParseJSONTagged  gOneConstructorToJSONTagged)
           ]
         ]
+      , testGroup "OptionField" [
+          testProperty "like Maybe" $
+          \x -> gOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)
+        , testProperty "roundTrip" (toParseJSON gOptionFieldParseJSON gOptionFieldToJSON)
+        ]
       ]
     , testGroup "toEncoding" [
         testProperty "NullaryString" $
@@ -429,6 +435,9 @@ tests = testGroup "properties" [
         gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault
       , testProperty "OneConstructorTagged" $
         gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged
+
+      , testProperty "OptionField" $
+        gOptionFieldToJSON `sameAs` gOptionFieldToEncoding
       ]
     ]
   , testGroup "template-haskell" [
@@ -489,6 +498,11 @@ tests = testGroup "properties" [
           , testProperty "Tagged"  (toParseJSON thOneConstructorParseJSONTagged  thOneConstructorToJSONTagged)
           ]
         ]
+      , testGroup "OptionField" [
+          testProperty "like Maybe" $
+          \x -> thOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)
+        , testProperty "roundTrip" (toParseJSON thOptionFieldParseJSON thOptionFieldToJSON)
+        ]
       ]
     , testGroup "toEncoding" [
         testProperty "NullaryString" $
@@ -533,6 +547,9 @@ tests = testGroup "properties" [
         thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault
       , testProperty "OneConstructorTagged" $
         thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged
+
+      , testProperty "OptionField" $
+        thOptionFieldToJSON `sameAs` thOptionFieldToEncoding
       ]
     ]
   ]

tests/Types.hs

@@ -17,6 +17,7 @@ import Data.Data
 import Data.Functor.Compose (Compose (..))
 import Data.Functor.Identity (Identity (..))
 import Data.Hashable (Hashable (..))
+import Data.Semigroup (Option)
 import Data.Text
 import Data.Time (Day (..), fromGregorian)
 import GHC.Generics
@@ -104,6 +105,10 @@ deriving instance Data (GADT String)
 deriving instance Eq   (GADT a)
 deriving instance Show (GADT a)
 
+newtype MaybeField = MaybeField { maybeField :: Maybe Int }
+newtype OptionField = OptionField { optionField :: Option Int }
+  deriving (Eq, Show)
+
 deriving instance Generic Foo
 deriving instance Generic UFoo
 deriving instance Generic OneConstructor
@@ -116,6 +121,7 @@ deriving instance Generic (SomeType a)
 #if __GLASGOW_HASKELL__ >= 706
 deriving instance Generic1 SomeType
 #endif
+deriving instance Generic OptionField
 deriving instance Generic EitherTextInt
 
 failure :: Show a => String -> String -> a -> Property