From 6350e9a45adfbb0ab86eefb3d6e5a04461ae5f1a Mon Sep 17 00:00:00 2001 From: Julian Brunner Date: Mon, 10 Jun 2024 15:34:12 +0200 Subject: [PATCH 1/6] class-based composition for parsing side --- src/Data/Aeson/Types/FromJSON.hs | 52 ++++++++++++++------------------ 1 file changed, 22 insertions(+), 30 deletions(-) diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 7fbacaea..6fe56a9a 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -249,6 +249,9 @@ class GFromJSON arity f where -- or 'liftParseJSON' (if the @arity@ is 'One'). gParseJSON :: Options -> FromArgs arity a -> Value -> Parser (f a) +class GOmitFromJSON arity f where + gOmittedField :: FromArgs arity a -> Maybe (f a) + -- | A 'FromArgs' value either stores nothing (for 'FromJSON') or it stores the -- three function arguments that decode occurrences of the type parameter (for -- 'FromJSON1'). @@ -1013,18 +1016,30 @@ instance (FromJSON a) => GFromJSON arity (K1 i a) where gParseJSON _opts _ = fmap K1 . parseJSON {-# INLINE gParseJSON #-} +instance FromJSON a => GOmitFromJSON arity (K1 i a) where + gOmittedField _ = fmap K1 omittedField + {-# INLINE gOmittedField #-} + instance GFromJSON One Par1 where -- Direct occurrences of the last type parameter are decoded with the -- function passed in as an argument: gParseJSON _opts (From1Args _ pj _) = fmap Par1 . pj {-# INLINE gParseJSON #-} +instance GOmitFromJSON One Par1 where + gOmittedField (From1Args o _ _) = fmap Par1 o + {-# INLINE gOmittedField #-} + instance (FromJSON1 f) => GFromJSON One (Rec1 f) where -- Recursive occurrences of the last type parameter are decoded using their -- FromJSON1 instance: gParseJSON _opts (From1Args o pj pjl) = fmap Rec1 . liftParseJSON o pj pjl {-# INLINE gParseJSON #-} +instance FromJSON1 f => GOmitFromJSON One (Rec1 f) where + gOmittedField (From1Args o _ _) = fmap Rec1 $ liftOmittedField o + {-# INLINE gOmittedField #-} + instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where -- If an occurrence of the last type parameter is nested inside two -- composed types, it is decoded by using the outermost type's FromJSON1 @@ -1037,6 +1052,10 @@ instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where in fmap Comp1 . liftParseJSON Nothing gpj (listParser gpj) {-# INLINE gParseJSON #-} +instance (FromJSON1 f, GOmitFromJSON One g) => GOmitFromJSON One (f :.: g) where + gOmittedField = fmap Comp1 . liftOmittedField . gOmittedField + {-# INLINE gOmittedField #-} + -------------------------------------------------------------------------------- instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where @@ -1423,36 +1442,9 @@ instance ( RecordFromJSON' arity a <*> recordParseJSON' p obj {-# INLINE recordParseJSON' #-} -instance {-# OVERLAPPABLE #-} - RecordFromJSON' arity f => RecordFromJSON' arity (M1 i s f) where - recordParseJSON' args obj = M1 <$> recordParseJSON' args obj - {-# INLINE recordParseJSON' #-} - -instance (Selector s, FromJSON a, Generic a, K1 i a ~ Rep a) => - RecordFromJSON' arity (S1 s (K1 i a)) where - recordParseJSON' args@(_ :* _ :* opts :* _) obj = - recordParseJSONImpl (guard (allowOmittedFields opts) >> fmap K1 omittedField) gParseJSON args obj - {-# INLINE recordParseJSON' #-} - -instance {-# OVERLAPPING #-} - (Selector s, FromJSON a) => - RecordFromJSON' arity (S1 s (Rec0 a)) where - recordParseJSON' args@(_ :* _ :* opts :* _) obj = - recordParseJSONImpl (guard (allowOmittedFields opts) >> fmap K1 omittedField) gParseJSON args obj - {-# INLINE recordParseJSON' #-} - -instance {-# OVERLAPPING #-} - (Selector s, GFromJSON One (Rec1 f), FromJSON1 f) => - RecordFromJSON' One (S1 s (Rec1 f)) where - recordParseJSON' args@(_ :* _ :* opts :* From1Args o _ _) obj = - recordParseJSONImpl (guard (allowOmittedFields opts) >> fmap Rec1 (liftOmittedField o)) gParseJSON args obj - {-# INLINE recordParseJSON' #-} - -instance {-# OVERLAPPING #-} - (Selector s, GFromJSON One Par1) => - RecordFromJSON' One (S1 s Par1) where - recordParseJSON' args@(_ :* _ :* opts :* From1Args o _ _) obj = - recordParseJSONImpl (guard (allowOmittedFields opts) >> fmap Par1 o) gParseJSON args obj +instance (Selector s, GFromJSON arity a, GOmitFromJSON arity a) => RecordFromJSON' arity (S1 s a) where + recordParseJSON' args@(_ :* _ :* opts :* fargs) obj = + recordParseJSONImpl (guard (allowOmittedFields opts) >> gOmittedField fargs) gParseJSON args obj {-# INLINE recordParseJSON' #-} From c56cfc1b954346f539c7b1e2f4fdf9728133044d Mon Sep 17 00:00:00 2001 From: Julian Brunner Date: Tue, 11 Jun 2024 14:17:30 +0200 Subject: [PATCH 2/6] class-based composition for printing side --- src/Data/Aeson/Types/ToJSON.hs | 60 +++++++++++++--------------------- 1 file changed, 23 insertions(+), 37 deletions(-) diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index a0900ed3..e0d0550a 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -165,6 +165,9 @@ class GToJSON' enc arity f where -- and 'liftToEncoding' (if the @arity@ is 'One'). gToJSON :: Options -> ToArgs enc arity a -> f a -> enc +class GOmitToJSON enc arity f where + gOmitField :: ToArgs enc arity a -> f a -> Bool + -- | A 'ToArgs' value either stores nothing (for 'ToJSON') or it stores the three -- function arguments that encode occurrences of the type parameter (for -- 'ToJSON1'). @@ -817,6 +820,22 @@ instance ( AllNullary (a :+: b) allNullary . sumToJSON opts targs {-# INLINE gToJSON #-} +instance ToJSON a => GOmitToJSON enc arity (K1 i a) where + gOmitField _ = omitField . unK1 + {-# INLINE gOmitField #-} + +instance GOmitToJSON enc One Par1 where + gOmitField (To1Args o _ _) = o . unPar1 + {-# INLINE gOmitField #-} + +instance ToJSON1 f => GOmitToJSON enc One (Rec1 f) where + gOmitField (To1Args o _ _) = liftOmitField o . unRec1 + {-# INLINE gOmitField #-} + +instance (ToJSON1 f, GOmitToJSON enc One g) => GOmitToJSON enc One (f :.: g) where + gOmitField targs = liftOmitField (gOmitField targs) . unComp1 + {-# INLINE gOmitField #-} + -------------------------------------------------------------------------------- -- Generic toJSON @@ -1170,47 +1189,14 @@ instance ( Monoid pairs {-# INLINE recordToPairs #-} instance ( Selector s - , GToJSON' enc arity (K1 i t) + , GToJSON' enc arity a + , GOmitToJSON enc arity a , KeyValuePair enc pairs - , ToJSON t - ) => RecordToPairs enc pairs arity (S1 s (K1 i t)) + ) => RecordToPairs enc pairs arity (S1 s a) where recordToPairs opts targs m1 | omitNothingFields opts - , omitField (unK1 $ unM1 m1 :: t) - = mempty - - | otherwise = - let key = Key.fromString $ fieldLabelModifier opts (selName m1) - value = gToJSON opts targs (unM1 m1) - in key `pair` value - {-# INLINE recordToPairs #-} - -instance ( Selector s - , GToJSON' enc One (Rec1 f) - , KeyValuePair enc pairs - , ToJSON1 f - ) => RecordToPairs enc pairs One (S1 s (Rec1 f)) - where - recordToPairs opts targs@(To1Args o _ _) m1 - | omitNothingFields opts - , liftOmitField o $ unRec1 $ unM1 m1 - = mempty - - | otherwise = - let key = Key.fromString $ fieldLabelModifier opts (selName m1) - value = gToJSON opts targs (unM1 m1) - in key `pair` value - {-# INLINE recordToPairs #-} - -instance ( Selector s - , GToJSON' enc One Par1 - , KeyValuePair enc pairs - ) => RecordToPairs enc pairs One (S1 s Par1) - where - recordToPairs opts targs@(To1Args o _ _) m1 - | omitNothingFields opts - , o (unPar1 (unM1 m1)) + , gOmitField targs $ unM1 m1 = mempty | otherwise = From 0f36b7793e928aee2dc52bbc5dfc13f7f6fb2525 Mon Sep 17 00:00:00 2001 From: Julian Brunner Date: Tue, 11 Jun 2024 14:17:45 +0200 Subject: [PATCH 3/6] collect GOmitFromJSON instances --- src/Data/Aeson/Types/FromJSON.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 6fe56a9a..5e33d7f3 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1016,30 +1016,18 @@ instance (FromJSON a) => GFromJSON arity (K1 i a) where gParseJSON _opts _ = fmap K1 . parseJSON {-# INLINE gParseJSON #-} -instance FromJSON a => GOmitFromJSON arity (K1 i a) where - gOmittedField _ = fmap K1 omittedField - {-# INLINE gOmittedField #-} - instance GFromJSON One Par1 where -- Direct occurrences of the last type parameter are decoded with the -- function passed in as an argument: gParseJSON _opts (From1Args _ pj _) = fmap Par1 . pj {-# INLINE gParseJSON #-} -instance GOmitFromJSON One Par1 where - gOmittedField (From1Args o _ _) = fmap Par1 o - {-# INLINE gOmittedField #-} - instance (FromJSON1 f) => GFromJSON One (Rec1 f) where -- Recursive occurrences of the last type parameter are decoded using their -- FromJSON1 instance: gParseJSON _opts (From1Args o pj pjl) = fmap Rec1 . liftParseJSON o pj pjl {-# INLINE gParseJSON #-} -instance FromJSON1 f => GOmitFromJSON One (Rec1 f) where - gOmittedField (From1Args o _ _) = fmap Rec1 $ liftOmittedField o - {-# INLINE gOmittedField #-} - instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where -- If an occurrence of the last type parameter is nested inside two -- composed types, it is decoded by using the outermost type's FromJSON1 @@ -1052,6 +1040,18 @@ instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where in fmap Comp1 . liftParseJSON Nothing gpj (listParser gpj) {-# INLINE gParseJSON #-} +instance FromJSON a => GOmitFromJSON arity (K1 i a) where + gOmittedField _ = fmap K1 omittedField + {-# INLINE gOmittedField #-} + +instance GOmitFromJSON One Par1 where + gOmittedField (From1Args o _ _) = fmap Par1 o + {-# INLINE gOmittedField #-} + +instance FromJSON1 f => GOmitFromJSON One (Rec1 f) where + gOmittedField (From1Args o _ _) = fmap Rec1 $ liftOmittedField o + {-# INLINE gOmittedField #-} + instance (FromJSON1 f, GOmitFromJSON One g) => GOmitFromJSON One (f :.: g) where gOmittedField = fmap Comp1 . liftOmittedField . gOmittedField {-# INLINE gOmittedField #-} From c1f6c145b465549613452b95ef562b641b8dfe0f Mon Sep 17 00:00:00 2001 From: Julian Brunner Date: Thu, 19 Dec 2024 12:53:03 +0100 Subject: [PATCH 4/6] handle omitted field propagation for comp1 --- src/Data/Aeson/Types/FromJSON.hs | 7 ++----- src/Data/Aeson/Types/ToJSON.hs | 6 ++++-- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 5e33d7f3..0b7276bb 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1028,16 +1028,13 @@ instance (FromJSON1 f) => GFromJSON One (Rec1 f) where gParseJSON _opts (From1Args o pj pjl) = fmap Rec1 . liftParseJSON o pj pjl {-# INLINE gParseJSON #-} -instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where +instance (FromJSON1 f, GFromJSON One g, GOmitFromJSON One g) => GFromJSON One (f :.: g) where -- If an occurrence of the last type parameter is nested inside two -- composed types, it is decoded by using the outermost type's FromJSON1 -- instance to generically decode the innermost type: - -- - -- Note: the ommitedField is not passed here. - -- This might be related for :.: associated the wrong way in Generics Rep. gParseJSON opts fargs = let gpj = gParseJSON opts fargs - in fmap Comp1 . liftParseJSON Nothing gpj (listParser gpj) + in fmap Comp1 . liftParseJSON (gOmittedField fargs) gpj (listParser gpj) {-# INLINE gParseJSON #-} instance FromJSON a => GOmitFromJSON arity (K1 i a) where diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index e0d0550a..756928aa 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -884,6 +884,7 @@ instance ( WriteProduct arity a, WriteProduct arity b instance ( ToJSON1 f , GToJSON' Value One g + , GOmitToJSON Value One g ) => GToJSON' Value One (f :.: g) where -- If an occurrence of the last type parameter is nested inside two @@ -891,7 +892,7 @@ instance ( ToJSON1 f -- instance to generically encode the innermost type: gToJSON opts targs = let gtj = gToJSON opts targs in - liftToJSON (const False) gtj (listValue gtj) . unComp1 + liftToJSON (gOmitField targs) gtj (listValue gtj) . unComp1 {-# INLINE gToJSON #-} -------------------------------------------------------------------------------- @@ -931,6 +932,7 @@ instance ( EncodeProduct arity a instance ( ToJSON1 f , GToJSON' Encoding One g + , GOmitToJSON Encoding One g ) => GToJSON' Encoding One (f :.: g) where -- If an occurrence of the last type parameter is nested inside two @@ -938,7 +940,7 @@ instance ( ToJSON1 f -- instance to generically encode the innermost type: gToJSON opts targs = let gte = gToJSON opts targs in - liftToEncoding (const False) gte (listEncoding gte) . unComp1 + liftToEncoding (gOmitField targs) gte (listEncoding gte) . unComp1 {-# INLINE gToJSON #-} -------------------------------------------------------------------------------- From 66d68f5f05dec0742b1f547b7bfeb5dbb641ad18 Mon Sep 17 00:00:00 2001 From: Julian Brunner Date: Thu, 19 Dec 2024 13:15:57 +0100 Subject: [PATCH 5/6] add regression test for #1059 --- aeson.cabal | 1 + tests/Regression/Issue1059.hs | 38 +++++++++++++++++++++++++++++++++++ tests/UnitTests.hs | 2 ++ 3 files changed, 41 insertions(+) create mode 100644 tests/Regression/Issue1059.hs diff --git a/aeson.cabal b/aeson.cabal index 1b25c577..4f0a5e7d 100644 --- a/aeson.cabal +++ b/aeson.cabal @@ -175,6 +175,7 @@ test-suite aeson-tests Regression.Issue571 Regression.Issue687 Regression.Issue967 + Regression.Issue1059 RFC8785 SerializationFormatSpec Types diff --git a/tests/Regression/Issue1059.hs b/tests/Regression/Issue1059.hs new file mode 100644 index 00000000..d3b417c3 --- /dev/null +++ b/tests/Regression/Issue1059.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Regression.Issue1059 (issue1059) where + +import GHC.Generics +import Data.Aeson +import Test.Tasty +import Test.Tasty.HUnit + +data Item f a = Item { rec0 :: Int, par1 :: a, rec1 :: f a, comp1 :: f (f a) } deriving (Functor, Generic1) + +deriving instance (Eq a, Eq (f a), Eq (f (f a))) => Eq (Item f a) +deriving instance (Show a, Show (f a), Show (f (f a))) => Show (Item f a) + +instance (Functor f, FromJSON1 f) => FromJSON1 (Item f) where + liftParseJSON = genericLiftParseJSON $ defaultOptions { allowOmittedFields = True } +instance (Functor f, ToJSON1 f) => ToJSON1 (Item f) where + liftToJSON = genericLiftToJSON $ defaultOptions { omitNothingFields = True } +instance (Functor f, FromJSON1 f, FromJSON a) => FromJSON (Item f a) where parseJSON = parseJSON1 +instance (Functor f, ToJSON1 f, ToJSON a) => ToJSON (Item f a) where toJSON = toJSON1 + +data Test a = Test { a :: Item [] (Maybe a), b :: Item Maybe a } deriving (Eq, Show, Generic1) + +instance FromJSON1 Test where liftParseJSON = genericLiftParseJSON defaultOptions +instance ToJSON1 Test where liftToJSON = genericLiftToJSON defaultOptions +instance FromJSON a => FromJSON (Test a) where parseJSON = parseJSON1 +instance ToJSON a => ToJSON (Test a) where toJSON = toJSON1 + +issue1059 :: TestTree +issue1059 = testCase "issue1059" $ do + let value = Test (Item 0 Nothing [] []) (Item 0 1 Nothing Nothing) :: Test Int + let code = "{\"a\":{\"comp1\":[],\"rec0\":0,\"rec1\":[]},\"b\":{\"par1\":1,\"rec0\":0}}" + encode value @?= code + decode code @?= Just value diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index 227504bb..a64acfc4 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -64,6 +64,7 @@ import Regression.Issue351 import Regression.Issue571 import Regression.Issue687 import Regression.Issue967 +import Regression.Issue1059 import UnitTests.OmitNothingFieldsNote import UnitTests.FromJSONKey import UnitTests.Hashable @@ -568,6 +569,7 @@ tests = testGroup "unit" [ , issue571 , issue687 , issue967 + , issue1059 , keyMapInsertWithTests , omitNothingFieldsNoteTests , noThunksTests From 59571288ce508ec119a067dfedf3f3269c038c5b Mon Sep 17 00:00:00 2001 From: Julian Brunner Date: Thu, 19 Dec 2024 13:24:01 +0100 Subject: [PATCH 6/6] inline recordParseJSONImpl --- src/Data/Aeson/Types/FromJSON.hs | 32 +++++++++++--------------------- 1 file changed, 11 insertions(+), 21 deletions(-) diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 0b7276bb..dbd63026 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1440,28 +1440,18 @@ instance ( RecordFromJSON' arity a {-# INLINE recordParseJSON' #-} instance (Selector s, GFromJSON arity a, GOmitFromJSON arity a) => RecordFromJSON' arity (S1 s a) where - recordParseJSON' args@(_ :* _ :* opts :* fargs) obj = - recordParseJSONImpl (guard (allowOmittedFields opts) >> gOmittedField fargs) gParseJSON args obj - {-# INLINE recordParseJSON' #-} - - -recordParseJSONImpl :: forall s arity a f i - . (Selector s) - => Maybe (f a) - -> (Options -> FromArgs arity a -> Value -> Parser (f a)) - -> (ConName :* TypeName :* Options :* FromArgs arity a) - -> Object -> Parser (M1 i s f a) -recordParseJSONImpl mdef parseVal (cname :* tname :* opts :* fargs) obj = - handleMissingKey (M1 <$> mdef) $ do - fv <- contextCons cname tname (obj .: label) - M1 <$> parseVal opts fargs fv Key label - where - handleMissingKey Nothing p = p - handleMissingKey (Just def) p = if label `KM.member` obj then p else pure def + recordParseJSON' (cname :* tname :* opts :* fargs) obj = + handleMissingKey (M1 <$> mdef) $ do + fv <- contextCons cname tname (obj .: label) + M1 <$> gParseJSON opts fargs fv Key label + where + handleMissingKey Nothing p = p + handleMissingKey (Just def) p = if label `KM.member` obj then p else pure def - label = Key.fromString $ fieldLabelModifier opts sname - sname = selName (undefined :: M1 _i s _f _p) -{-# INLINE recordParseJSONImpl #-} + label = Key.fromString $ fieldLabelModifier opts sname + sname = selName (undefined :: M1 _i s _f _p) + mdef = guard (allowOmittedFields opts) >> gOmittedField fargs + {-# INLINE recordParseJSON' #-} --------------------------------------------------------------------------------