Option nullaryToObject to encode/decode nullary constructors as empty objects

src/Data/Aeson.hs

@@ -131,6 +131,7 @@ module Data.Aeson
     , fieldLabelModifier
     , constructorTagModifier
     , allNullaryToStringTag
+    , nullaryToObject
     , omitNothingFields
     , allowOmittedFields
     , sumEncoding

src/Data/Aeson/TH.hs

@@ -115,7 +115,7 @@ module Data.Aeson.TH
 import Data.Aeson.Internal.Prelude
 
 import Data.Char (ord)
-import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
+import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..), object)
 import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
 import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
 import Data.Aeson.Types.ToJSON (fromPairs, pair)
@@ -438,7 +438,9 @@ argsToValue letInsert target jc tvMap opts multiCons
                -- Single argument is directly converted.
                [e] -> e
                -- Zero and multiple arguments are converted to a JSON array.
-               es -> array target es
+               es
+                 | nullaryToObject opts && null es -> objectE letInsert target []
+                 | otherwise -> array target es
 
     match (conP conName $ map varP args)
           (normalB $ opaqueSumToValue letInsert target opts multiCons (null argTys') conName js)
@@ -873,11 +875,22 @@ consFromJSON jc tName opts instTys cons = do
                       []
               ]
 
-parseNullaryMatches :: Name -> Name -> [Q Match]
-parseNullaryMatches tName conName =
-    [ do arr <- newName "arr"
-         match (conP 'Array [varP arr])
-               (guardedB
+parseNullaryMatches :: Name -> Name -> Options -> [Q Match]
+parseNullaryMatches tName conName opts
+    | nullaryToObject opts =
+        [ if rejectUnknownFields opts then matchEmptyObject else matchAnyObject
+        , matchFailed tName conName "Object"
+        ]
+    | otherwise =
+        [ matchEmptyArray
+        , matchFailed tName conName "Array"
+        ]
+  where
+    matchEmptyArray = do
+        arr <- newName "arr"
+        match
+            (conP 'Array [varP arr])
+            (guardedB
                 [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)
                              ([|pure|] `appE` conE conName)
                 , liftM2 (,) (normalG [|otherwise|])
@@ -889,10 +902,31 @@ parseNullaryMatches tName conName =
                                 )
                              )
                 ]
-               )
-               []
-    , matchFailed tName conName "Array"
-    ]
+            )
+            []
+    matchAnyObject = do
+        match
+            (conP 'Object [wildP])
+            (normalB $ [|pure|] `appE` conE conName)
+            []
+    matchEmptyObject = do
+        obj <- newName "obj"
+        match
+            (conP 'Object [varP obj])
+            (guardedB
+                [ liftM2 (,) (normalG $ [|KM.null|] `appE` varE obj)
+                            ([|pure|] `appE` conE conName)
+                , liftM2 (,) (normalG [|otherwise|])
+                            (parseTypeMismatch tName conName
+                                (litE $ stringL "an empty Object")
+                                (infixApp (litE $ stringL "Object of size ")
+                                        [|(++)|]
+                                        ([|show . KM.size|] `appE` varE obj)
+                                )
+                            )
+                ]
+            )
+            []
 
 parseUnaryMatches :: JSONClass -> TyVarMap -> Type -> Name -> [Q Match]
 parseUnaryMatches jc tvMap argTy conName =
@@ -986,12 +1020,12 @@ parseArgs _ _ _ _
                   , constructorFields  = [] }
   (Left _) =
     [|pure|] `appE` conE conName
-parseArgs _ _ tName _
+parseArgs _ _ tName opts
   ConstructorInfo { constructorName    = conName
                   , constructorVariant = NormalConstructor
                   , constructorFields  = [] }
   (Right valName) =
-    caseE (varE valName) $ parseNullaryMatches tName conName
+    caseE (varE valName) $ parseNullaryMatches tName conName opts
 
 -- Unary constructors.
 parseArgs jc tvMap _ _

src/Data/Aeson/Types.hs

@@ -142,6 +142,7 @@ module Data.Aeson.Types
     , fieldLabelModifier
     , constructorTagModifier
     , allNullaryToStringTag
+    , nullaryToObject
     , omitNothingFields
     , allowOmittedFields
     , sumEncoding

src/Data/Aeson/Types/FromJSON.hs

@@ -1344,16 +1344,27 @@ instance RecordFromJSON arity f => ConsFromJSON' arity f True where
 
 instance {-# OVERLAPPING #-}
          ConsFromJSON' arity U1 False where
-    -- Empty constructors are expected to be encoded as an empty array:
-    consParseJSON' (cname :* tname :* _) v =
-        Tagged . contextCons cname tname $ case v of
-            Array a | V.null a -> pure U1
-                    | otherwise -> fail_ a
-            _ -> typeMismatch "Array" v
+    -- Empty constructors are expected to be encoded as an empty array or an object,
+    -- independent of nullaryToObject option.
+    -- With rejectUnknownFields an object must be empty.
+    consParseJSON' (cname :* tname :* opts :* _) v =
+        Tagged . contextCons cname tname $
+            if nullaryToObject opts
+                then case v of
+                    Object o | KM.null o || not (rejectUnknownFields opts) -> pure U1
+                             | otherwise -> failObj_ o
+                    _ -> typeMismatch "Object" v
+                else case v of
+                    Array a | V.null a -> pure U1
+                            | otherwise -> fail_ a
+                    _ -> typeMismatch "Array" v
       where
         fail_ a = fail $
             "expected an empty Array, but encountered an Array of length " ++
             show (V.length a)
+        failObj_ o = fail $
+            "expected an empty Object but encountered Object of size " ++
+            show (KM.size o)
     {-# INLINE consParseJSON' #-}
 
 instance {-# OVERLAPPING #-}

src/Data/Aeson/Types/Internal.hs

@@ -56,6 +56,7 @@ module Data.Aeson.Types.Internal
           fieldLabelModifier
         , constructorTagModifier
         , allNullaryToStringTag
+        , nullaryToObject
         , omitNothingFields
         , allowOmittedFields
         , sumEncoding
@@ -714,6 +715,9 @@ data Options = Options
       -- nullary constructors, will be encoded to just a string with
       -- the constructor tag. If 'False' the encoding will always
       -- follow the `sumEncoding`.
+    , nullaryToObject :: Bool
+      -- ^ If 'True', the nullary constructors will be encoded
+      -- as empty objects (the default is to encode them as empty arrays).
     , omitNothingFields :: Bool
       -- ^ If 'True', record fields with a 'Nothing' value will be
       -- omitted from the resulting object. If 'False', the resulting
@@ -744,12 +748,13 @@ data Options = Options
     }
 
 instance Show Options where
-  show (Options f c a o q s u t r) =
+  show (Options f c a n o q s u t r) =
        "Options {"
     ++ intercalate ", "
       [ "fieldLabelModifier =~ " ++ show (f "exampleField")
       , "constructorTagModifier =~ " ++ show (c "ExampleConstructor")
       , "allNullaryToStringTag = " ++ show a
+      , "nullaryToObject = " ++ show n
       , "omitNothingFields = " ++ show o
       , "allowOmittedFields = " ++ show q
       , "sumEncoding = " ++ show s
@@ -846,6 +851,7 @@ defaultOptions = Options
                  { fieldLabelModifier      = id
                  , constructorTagModifier  = id
                  , allNullaryToStringTag   = True
+                 , nullaryToObject         = False
                  , omitNothingFields       = False
                  , allowOmittedFields      = True
                  , sumEncoding             = defaultTaggedObject

src/Data/Aeson/Types/ToJSON.hs

@@ -839,8 +839,12 @@ instance ToJSON1 f => GToJSON' Value One (Rec1 f) where
     {-# INLINE gToJSON #-}
 
 instance GToJSON' Value arity U1 where
-    -- Empty constructors are encoded to an empty array:
-    gToJSON _opts _ _ = emptyArray
+    -- Empty constructors are encoded to an empty array or an empty object,
+    -- depending on nullaryToObject option (default is array)
+    gToJSON opts _ _
+        | nullaryToObject opts = emptyObject
+        | otherwise = emptyArray
+
     {-# INLINE gToJSON #-}
 
 instance ( WriteProduct arity a, WriteProduct arity b
@@ -893,8 +897,11 @@ instance ToJSON1 f => GToJSON' Encoding One (Rec1 f) where
     {-# INLINE gToJSON #-}
 
 instance GToJSON' Encoding arity U1 where
-    -- Empty constructors are encoded to an empty array:
-    gToJSON _opts _ _ = E.emptyArray_
+    -- Empty constructors are encoded to an empty array or an empty object,
+    -- depending on nullaryToObject option (default is array)
+    gToJSON opts _ _
+        | nullaryToObject opts = E.emptyObject_
+        | otherwise = E.emptyArray_
     {-# INLINE gToJSON #-}
 
 instance ( EncodeProduct  arity a

tests/Encoders.hs

@@ -60,6 +60,37 @@ thNullaryToEncodingObjectWithSingleField =
 thNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
 thNullaryParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''Nullary)
 
+
+thNullaryToJSONOWSFRejectUnknown :: Nullary -> Value
+thNullaryToJSONOWSFRejectUnknown = $(mkToJSON optsOWSFRejectUnknown ''Nullary)
+
+thNullaryToEncodingOWSFRejectUnknown :: Nullary -> Encoding
+thNullaryToEncodingOWSFRejectUnknown = $(mkToEncoding optsOWSFRejectUnknown ''Nullary)
+
+thNullaryParseJSONOWSFRejectUnknown :: Value -> Parser Nullary
+thNullaryParseJSONOWSFRejectUnknown = $(mkParseJSON optsOWSFRejectUnknown ''Nullary)
+
+
+thNullaryToJSONOWSFNullaryToObject :: Nullary -> Value
+thNullaryToJSONOWSFNullaryToObject = $(mkToJSON optsOWSFNullaryToObject ''Nullary)
+
+thNullaryToEncodingOWSFNullaryToObject :: Nullary -> Encoding
+thNullaryToEncodingOWSFNullaryToObject = $(mkToEncoding optsOWSFNullaryToObject ''Nullary)
+
+thNullaryParseJSONOWSFNullaryToObject :: Value -> Parser Nullary
+thNullaryParseJSONOWSFNullaryToObject = $(mkParseJSON optsOWSFNullaryToObject ''Nullary)
+
+
+thNullaryToJSONOWSFNullaryToObjectRejectUnknown :: Nullary -> Value
+thNullaryToJSONOWSFNullaryToObjectRejectUnknown = $(mkToJSON optsOWSFNullaryToObjectRejectUnknown ''Nullary)
+
+thNullaryToEncodingOWSFNullaryToObjectRejectUnknown :: Nullary -> Encoding
+thNullaryToEncodingOWSFNullaryToObjectRejectUnknown = $(mkToEncoding optsOWSFNullaryToObjectRejectUnknown ''Nullary)
+
+thNullaryParseJSONOWSFNullaryToObjectRejectUnknown :: Value -> Parser Nullary
+thNullaryParseJSONOWSFNullaryToObjectRejectUnknown = $(mkParseJSON optsOWSFNullaryToObjectRejectUnknown ''Nullary)
+
+
 gNullaryToJSONString :: Nullary -> Value
 gNullaryToJSONString = genericToJSON defaultOptions
 
@@ -99,6 +130,37 @@ gNullaryToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingle
 gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
 gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
 
+
+gNullaryToJSONOWSFRejectUnknown :: Nullary -> Value
+gNullaryToJSONOWSFRejectUnknown = genericToJSON optsOWSFRejectUnknown
+
+gNullaryToEncodingOWSFRejectUnknown :: Nullary -> Encoding
+gNullaryToEncodingOWSFRejectUnknown = genericToEncoding optsOWSFRejectUnknown
+
+gNullaryParseJSONOWSFRejectUnknown :: Value -> Parser Nullary
+gNullaryParseJSONOWSFRejectUnknown = genericParseJSON optsOWSFRejectUnknown
+
+
+gNullaryToJSONOWSFNullaryToObject :: Nullary -> Value
+gNullaryToJSONOWSFNullaryToObject = genericToJSON optsOWSFNullaryToObject
+
+gNullaryToEncodingOWSFNullaryToObject :: Nullary -> Encoding
+gNullaryToEncodingOWSFNullaryToObject = genericToEncoding optsOWSFNullaryToObject
+
+gNullaryParseJSONOWSFNullaryToObject :: Value -> Parser Nullary
+gNullaryParseJSONOWSFNullaryToObject = genericParseJSON optsOWSFNullaryToObject
+
+
+gNullaryToJSONOWSFNullaryToObjectRejectUnknown :: Nullary -> Value
+gNullaryToJSONOWSFNullaryToObjectRejectUnknown = genericToJSON optsOWSFNullaryToObjectRejectUnknown
+
+gNullaryToEncodingOWSFNullaryToObjectRejectUnknown :: Nullary -> Encoding
+gNullaryToEncodingOWSFNullaryToObjectRejectUnknown = genericToEncoding optsOWSFNullaryToObjectRejectUnknown
+
+gNullaryParseJSONOWSFNullaryToObjectRejectUnknown :: Value -> Parser Nullary
+gNullaryParseJSONOWSFNullaryToObjectRejectUnknown = genericParseJSON optsOWSFNullaryToObjectRejectUnknown
+
+
 keyOptions :: JSONKeyOptions
 keyOptions = defaultJSONKeyOptions { keyModifier = ('k' :) }
 

tests/Options.hs

@@ -34,6 +34,28 @@ optsObjectWithSingleField = optsDefault
                             , sumEncoding           = ObjectWithSingleField
                             }
 
+optsOWSFRejectUnknown :: Options
+optsOWSFRejectUnknown = optsDefault
+                        { allNullaryToStringTag = False
+                        , rejectUnknownFields = True
+                        , sumEncoding           = ObjectWithSingleField
+                        }
+
+optsOWSFNullaryToObject :: Options
+optsOWSFNullaryToObject = optsDefault
+                          { allNullaryToStringTag = False
+                          , sumEncoding           = ObjectWithSingleField
+                          , nullaryToObject       = True
+                          }
+
+optsOWSFNullaryToObjectRejectUnknown :: Options
+optsOWSFNullaryToObjectRejectUnknown = optsDefault
+                                       { allNullaryToStringTag = False
+                                       , rejectUnknownFields = True
+                                       , sumEncoding           = ObjectWithSingleField
+                                       , nullaryToObject       = True
+                                       }
+
 optsOmitNothingFields :: Options
 optsOmitNothingFields = optsDefault
                         { omitNothingFields = True

tests/UnitTests.hs

@@ -277,6 +277,7 @@ showOptions =
         ++   "fieldLabelModifier =~ \"exampleField\""
         ++ ", constructorTagModifier =~ \"ExampleConstructor\""
         ++ ", allNullaryToStringTag = True"
+        ++ ", nullaryToObject = False"
         ++ ", omitNothingFields = False"
         ++ ", allowOmittedFields = True"
         ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"