class-based composition for parsing side

Author: julmb

src/Data/Aeson/Types/FromJSON.hs

@@ -246,6 +246,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').
@@ -1010,18 +1013,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
@@ -1034,6 +1049,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
@@ -1420,36 +1439,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' #-}