diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs --- a/Data/Aeson/Types/FromJSON.hs +++ b/Data/Aeson/Types/FromJSON.hs @@ -92,6 +92,7 @@ import Data.Functor.Identity (Identity(..)) import Data.Functor.Product (Product(..)) import Data.Functor.Sum (Sum(..)) +import Data.Functor.These (These1 (..)) import Data.Hashable (Hashable(..)) import Data.Int (Int16, Int32, Int64, Int8) import Data.List.NonEmpty (NonEmpty(..)) @@ -101,6 +102,7 @@ import Data.Scientific (Scientific, base10Exponent) import Data.Tagged (Tagged(..)) import Data.Text (Text, pack, unpack) +import Data.These (These (..)) import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..)) import Data.Time.LocalTime.Compat (CalendarDiffTime (..)) @@ -2256,6 +2258,54 @@ instance FromJSONKey b => FromJSONKey (Tagged a b) where fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b) fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList + +------------------------------------------------------------------------------- +-- these +------------------------------------------------------------------------------- + +-- | @since 1.5.1.0 +instance (FromJSON a, FromJSON b) => FromJSON (These a b) where + parseJSON = withObject "These a b" (p . H.toList) + where + p [("This", a), ("That", b)] = These <$> parseJSON a <*> parseJSON b + p [("That", b), ("This", a)] = These <$> parseJSON a <*> parseJSON b + p [("This", a)] = This <$> parseJSON a + p [("That", b)] = That <$> parseJSON b + p _ = fail "Expected object with 'This' and 'That' keys only" + +-- | @since 1.5.1.0 +instance FromJSON a => FromJSON1 (These a) where + liftParseJSON pb _ = withObject "These a b" (p . H.toList) + where + p [("This", a), ("That", b)] = These <$> parseJSON a <*> pb b + p [("That", b), ("This", a)] = These <$> parseJSON a <*> pb b + p [("This", a)] = This <$> parseJSON a + p [("That", b)] = That <$> pb b + p _ = fail "Expected object with 'This' and 'That' keys only" + +-- | @since 1.5.1.0 +instance FromJSON2 These where + liftParseJSON2 pa _ pb _ = withObject "These a b" (p . H.toList) + where + p [("This", a), ("That", b)] = These <$> pa a <*> pb b + p [("That", b), ("This", a)] = These <$> pa a <*> pb b + p [("This", a)] = This <$> pa a + p [("That", b)] = That <$> pb b + p _ = fail "Expected object with 'This' and 'That' keys only" + +-- | @since 1.5.1.0 +instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (These1 f g) where + liftParseJSON px pl = withObject "These1" (p . H.toList) + where + p [("This", a), ("That", b)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b + p [("That", b), ("This", a)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b + p [("This", a)] = This1 <$> liftParseJSON px pl a + p [("That", b)] = That1 <$> liftParseJSON px pl b + p _ = fail "Expected object with 'This' and 'That' keys only" + +-- | @since 1.5.1.0 +instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (These1 f g a) where + parseJSON = parseJSON1 ------------------------------------------------------------------------------- -- Instances for converting from map keys diff --git a/Data/Aeson/Types/ToJSON.hs b/Data/Aeson/Types/ToJSON.hs --- a/Data/Aeson/Types/ToJSON.hs +++ b/Data/Aeson/Types/ToJSON.hs @@ -76,6 +76,7 @@ import Data.Functor.Identity (Identity(..)) import Data.Functor.Product (Product(..)) import Data.Functor.Sum (Sum(..)) +import Data.Functor.These (These1 (..)) import Data.Int (Int16, Int32, Int64, Int8) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty(..)) @@ -84,6 +85,7 @@ import Data.Scientific (Scientific) import Data.Tagged (Tagged(..)) import Data.Text (Text, pack) +import Data.These (These (..)) import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..)) import Data.Time.LocalTime.Compat (CalendarDiffTime (..)) @@ -2283,6 +2285,57 @@ instance ToJSONKey b => ToJSONKey (Tagged a b) where toJSONKey = contramapToJSONKeyFunction unTagged toJSONKey toJSONKeyList = contramapToJSONKeyFunction (fmap unTagged) toJSONKeyList + +------------------------------------------------------------------------------- +-- these +------------------------------------------------------------------------------- + +-- | @since 1.5.1.0 +instance (ToJSON a, ToJSON b) => ToJSON (These a b) where + toJSON (This a) = object [ "This" .= a ] + toJSON (That b) = object [ "That" .= b ] + toJSON (These a b) = object [ "This" .= a, "That" .= b ] + + toEncoding (This a) = E.pairs $ "This" .= a + toEncoding (That b) = E.pairs $ "That" .= b + toEncoding (These a b) = E.pairs $ "This" .= a <> "That" .= b + +-- | @since 1.5.1.0 +instance ToJSON2 These where + liftToJSON2 toa _ _tob _ (This a) = object [ "This" .= toa a ] + liftToJSON2 _toa _ tob _ (That b) = object [ "That" .= tob b ] + liftToJSON2 toa _ tob _ (These a b) = object [ "This" .= toa a, "That" .= tob b ] + + liftToEncoding2 toa _ _tob _ (This a) = E.pairs $ E.pair "This" (toa a) + liftToEncoding2 _toa _ tob _ (That b) = E.pairs $ E.pair "That" (tob b) + liftToEncoding2 toa _ tob _ (These a b) = E.pairs $ E.pair "This" (toa a) <> E.pair "That" (tob b) + +-- | @since 1.5.1.0 +instance ToJSON a => ToJSON1 (These a) where + liftToJSON _tob _ (This a) = object [ "This" .= a ] + liftToJSON tob _ (That b) = object [ "That" .= tob b ] + liftToJSON tob _ (These a b) = object [ "This" .= a, "That" .= tob b ] + + liftToEncoding _tob _ (This a) = E.pairs $ "This" .= a + liftToEncoding tob _ (That b) = E.pairs $ E.pair "That" (tob b) + liftToEncoding tob _ (These a b) = E.pairs $ "This" .= a <> E.pair "That" (tob b) + +-- | @since 1.5.1.0 +instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (These1 f g) where + liftToJSON tx tl (This1 a) = object [ "This" .= liftToJSON tx tl a ] + liftToJSON tx tl (That1 b) = object [ "That" .= liftToJSON tx tl b ] + liftToJSON tx tl (These1 a b) = object [ "This" .= liftToJSON tx tl a, "That" .= liftToJSON tx tl b ] + + liftToEncoding tx tl (This1 a) = E.pairs $ E.pair "This" (liftToEncoding tx tl a) + liftToEncoding tx tl (That1 b) = E.pairs $ E.pair "That" (liftToEncoding tx tl b) + liftToEncoding tx tl (These1 a b) = E.pairs $ + pair "This" (liftToEncoding tx tl a) `mappend` + pair "That" (liftToEncoding tx tl b) + +-- | @since 1.5.1.0 +instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (These1 f g a) where + toJSON = toJSON1 + toEncoding = toEncoding1 ------------------------------------------------------------------------------- -- Instances for converting t map keys diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,5 +1,5 @@ name: aeson -version: 1.5.0.0 +version: 1.5.1.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON @@ -148,9 +148,9 @@ hashable >= 1.2.7.0 && < 1.4, scientific >= 0.3.6.2 && < 0.4, th-abstraction >= 0.2.8.0 && < 0.4, + these >= 1.1 && < 1.2, uuid-types >= 1.0.3 && < 1.1, - vector >= 0.12.0.1 && < 0.13, - assoc + vector >= 0.12.0.1 && < 0.13 ghc-options: -Wall @@ -230,12 +230,13 @@ tasty-hunit, tasty-quickcheck, text, + these, time, time-compat, unordered-containers, uuid-types, vector, - quickcheck-instances >= 0.3.21 && <0.4 + quickcheck-instances >= 0.3.23 && <0.4 if flag(bytestring-builder) build-depends: bytestring >= 0.9 && < 0.10.4, diff --git a/benchmarks/aeson-benchmarks.cabal b/benchmarks/aeson-benchmarks.cabal --- a/benchmarks/aeson-benchmarks.cabal +++ b/benchmarks/aeson-benchmarks.cabal @@ -25,6 +25,7 @@ , template-haskell , text , th-abstraction + , these , time , time-compat , transformers diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,10 +1,14 @@ For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md). +### 1.5.1.0 + +* Add instances for `these`, thanks to Oleg Grenrus. + ## 1.5.0.0 * Fix bug in `rejectUnknownFields` not respecting `fieldLabelModifier`, thanks to Markus Schirp. * `GFromJSON` members are no longer exported from `Data.Aeson(.Types)`, if you are using `gParseJSON` consider switching to `gParseJSON'`, thanks to Oleg Grenrus. -* Aeson so longer accepts unescaped control characters, thanks to Oleg Grenrus. +* Aeson no longer accepts unescaped control characters, thanks to Oleg Grenrus. * Remove `CoerceText` since GHC >=7.8 has `Coercible`, thanks to Oleg Grenrus. * Rename the `GToJSON` class to `GToJSON'` and expose it, thanks to Oleg Grenrus. diff --git a/tests/PropertyRoundTrip.hs b/tests/PropertyRoundTrip.hs --- a/tests/PropertyRoundTrip.hs +++ b/tests/PropertyRoundTrip.hs @@ -12,6 +12,7 @@ import Data.Ratio (Ratio) import Data.Sequence (Seq) import Data.Tagged (Tagged) +import Data.These (These (..)) import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) import Data.Version (Version) import Data.Time.Calendar.Compat (CalendarDiffDays, DayOfWeek) @@ -64,6 +65,7 @@ , testProperty "Rational" $ roundTripEq (undefined :: Rational) , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int) , testProperty "UUID" $ roundTripEq UUID.nil + , testProperty "These" $ roundTripEq (These 'x' True) , roundTripFunctorsTests , testGroup "ghcGenerics" [ testProperty "OneConstructor" $ roundTripEq OneConstructor diff --git a/tests/SerializationFormatSpec.hs b/tests/SerializationFormatSpec.hs --- a/tests/SerializationFormatSpec.hs +++ b/tests/SerializationFormatSpec.hs @@ -29,6 +29,7 @@ import Data.Proxy (Proxy(..)) import Data.Scientific (Scientific) import Data.Tagged (Tagged(..)) +import Data.These (These (..)) import Data.Time (fromGregorian) import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..)) import Data.Time.LocalTime.Compat (CalendarDiffTime (..)) @@ -208,6 +209,15 @@ [ "{\"months\":12,\"days\":20}", "{\"days\":20,\"months\":12}" ] (CalendarDiffDays 12 20) , example "DayOfWeek" "\"monday\"" Monday + + -- these + , example "These: This" "{\"This\":\"x\"}" (This 'x' :: These Char Bool) + , example "These: That" "{\"That\":true}" (That True :: These Char Bool) + , ndExample "These" + [ "{\"This\":\"y\",\"That\":false}" + , "{\"That\":false,\"This\":\"y\"}" + ] + (These 'y' False) ] jsonEncodingExamples :: [Example]