TaggedObject encoding for Nullary constructor includes "contents"

[devwout]

Suppose I want to encode the following type as JSON using TaggedObject SumEncoding.

data MyType = Zero | One String
     deriving (Generic)
instance Aeson.ToJSON MyType

The output of converting One "bla" to JSON is { "tag": "One", "contents": ["bla"] } , which is sensible.

However, when converting Zero to JSON, you get { "tag": "Zero", "contents": [] }. While technically correct, the "contents" key is completely unnecessary. Worse even, the "contents" key is required for the type to be parsed again.

This is awkward if one wants to use the JSON format as an external interface. Of course, it is possible to manually implement the FromJSON and ToJSON instances for that type, but that is tedious work.

I cannot imagine a case where one would like the empty "contents" key to be there. Is this intended behavior? Is there something I am missing?

[devwout]

Below is a patch that changes the behavior of the generic implementation for Nullary constructors in the TaggedObject SumEncoding. Referring to my example above, it should encode Zero as { "tag": "Zero" }.

Does this make sense? I am pretty new to Haskell, so sorry if it doesn't.

diff --git a/Data/Aeson/Types/Generic.hs b/Data/Aeson/Types/Generic.hs
index 965fe30..669ee1b 100644
--- a/Data/Aeson/Types/Generic.hs
+++ b/Data/Aeson/Types/Generic.hs
@@ -344,6 +344,13 @@ instance (Selector s, ToJSON a) => RecordTo (S1 s (K1 i (Maybe a))) where
     recordToEncoding opts m1 = fieldToEncoding opts m1
     {-# INLINE recordToEncoding #-}

+instance RecordTo U1 where
+    recordToPairs _ U1 = empty
+    {-# INLINE recordToPairs #-}
+
+    recordToEncoding _ U1 = mempty
+    {-# INLINE recordToEncoding #-}
+
 fieldToPair :: (Selector s, GToJSON a) => Options -> S1 s a p -> DList Pair
 fieldToPair opts m1 = pure ( pack $ fieldLabelModifier opts $ selName m1
                            , gToJSON opts (unM1 m1)
@@ -663,6 +670,10 @@ instance (Selector s, FromJSON a) => FromRecord (S1 s (K1 i (Maybe a))) where
                     selName (undefined :: t s (K1 i (Maybe a)) p)
     {-# INLINE parseRecord #-}

+instance FromRecord U1 where
+    parseRecord _ _ obj = return U1
+    {-# INLINE parseRecord #-}
+
 --------------------------------------------------------------------------------

 class ProductSize f where
@@ -727,7 +738,7 @@ instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
 instance IsRecord (M1 S NoSelector f) False
 instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord
 instance IsRecord (K1 i c) True
-instance IsRecord U1 False
+instance IsRecord U1 True
   where isUnary = const False

 --------------------------------------------------------------------------------
diff --git a/tests/Properties.hs b/tests/Properties.hs
index 03c2640..6f25e38 100644
--- a/tests/Properties.hs
+++ b/tests/Properties.hs
@@ -95,6 +95,9 @@ isTaggedObjectValue (Object obj) = "tag"      `H.member` obj &&
                                    "contents" `H.member` obj
 isTaggedObjectValue _            = False

+isNullaryTaggedObject :: Value -> Bool
+isNullaryTaggedObject obj = isTaggedObject obj && isObjectWithSingleField obj
+
 isTaggedObject :: Value -> Bool
 isTaggedObject (Object obj) = "tag" `H.member` obj
 isTaggedObject _            = False
@@ -142,12 +145,26 @@ tests = testGroup "properties" [
   , testGroup "failure messages" [
       testProperty "modify failure" modifyFailureProp
     ]
+  , testGroup "generic" [
+      testGroup "toJSON" [
+        testGroup "Nullary" [
+            testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
+          , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)
+        ]
+      , testGroup "SomeType" [
+          testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)
+        , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)
+        , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gSomeTypeToJSONObjectWithSingleField)
+        ]
+      ]
+    ]
   , testGroup "template-haskell" [
       testGroup "toJSON" [
         testGroup "Nullary" [
             testProperty "string" (isString . thNullaryToJSONString)
           , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
-          , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)
+          , testProperty "TaggedObject" (isTaggedObject . thNullaryToJSONTaggedObject)
+          -- , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
           , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)

           , testGroup "roundTrip" [

[basvandijk]

I agree it's nicer if the encoding of nullary constructors doesn't contain the "contents" field.

It would be great if you can prepare a pull request which not only changes the GHC Generics implementation (like you've already done) but also the corresponding Template Haskell implementation. We always want these to match up.

[bergmark]

Merged as 0ee8f79