Handle Functor Composition in Generic Instances

aeson.cabal

@@ -175,6 +175,7 @@ test-suite aeson-tests
     Regression.Issue571
     Regression.Issue687
     Regression.Issue967
+    Regression.Issue1059
     RFC8785
     SerializationFormatSpec
     Types

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').
@@ -1025,18 +1028,31 @@ 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
+    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 #-}
+
 --------------------------------------------------------------------------------
 
 instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where
@@ -1423,57 +1439,20 @@ 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 (Selector s, GFromJSON arity a, GOmitFromJSON arity a) => RecordFromJSON' arity (S1 s a) where
+    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
 
-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
+            label = Key.fromString $ fieldLabelModifier opts sname
+            sname = selName (undefined :: M1 _i s _f _p)
+            mdef = guard (allowOmittedFields opts) >> gOmittedField fargs
     {-# 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
-    {-# 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
-
-    label = Key.fromString $ fieldLabelModifier opts sname
-    sname = selName (undefined :: M1 _i s _f _p)
-{-# INLINE recordParseJSONImpl #-}
-
 --------------------------------------------------------------------------------
 
 productParseJSON0

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
 
@@ -865,14 +884,15 @@ 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
     -- composed types, it is encoded by using the outermost type's ToJSON1
     -- 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 #-}
 
 --------------------------------------------------------------------------------
@@ -912,14 +932,15 @@ 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
     -- composed types, it is encoded by using the outermost type's ToJSON1
     -- 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 #-}
 
 --------------------------------------------------------------------------------
@@ -1170,47 +1191,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 =

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

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