From a2ebcde65e54e2f36617425eecaa3fba05bf69c0 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 29 Jan 2022 15:08:09 +0000 Subject: [PATCH 1/8] an option to encode nullary constructors as empty objects --- src/Data/Aeson/Types/Internal.hs | 8 +++++++- src/Data/Aeson/Types/ToJSON.hs | 2 +- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs index 8cf962b91..e8ccd301c 100644 --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -63,6 +63,7 @@ module Data.Aeson.Types.Internal fieldLabelModifier , constructorTagModifier , allNullaryToStringTag + , nullaryToObject , omitNothingFields , sumEncoding , unwrapUnaryRecords @@ -702,6 +703,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 @@ -766,12 +770,13 @@ data Options = Options } instance Show Options where - show (Options f c a o s u t r) = + show (Options f c a n o s u t r) = "Options {" ++ intercalate ", " [ "fieldLabelModifier =~ " ++ show (f "exampleField") , "constructorTagModifier =~ " ++ show (c "ExampleConstructor") , "allNullaryToStringTag = " ++ show a + , "nullaryToObject = " ++ show n , "omitNothingFields = " ++ show o , "sumEncoding = " ++ show s , "unwrapUnaryRecords = " ++ show u @@ -866,6 +871,7 @@ defaultOptions = Options { fieldLabelModifier = id , constructorTagModifier = id , allNullaryToStringTag = True + , nullaryToObject = False , omitNothingFields = False , sumEncoding = defaultTaggedObject , unwrapUnaryRecords = False diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index 3cdafb6c2..c8dc643d1 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -818,7 +818,7 @@ instance ToJSON1 f => GToJSON' Encoding One (Rec1 f) where instance GToJSON' Encoding arity U1 where -- Empty constructors are encoded to an empty array: - gToJSON _opts _ _ = E.emptyArray_ + gToJSON opts _ _ = if nullaryToObject opts then E.emptyObject_ else E.emptyArray_ {-# INLINE gToJSON #-} instance ( EncodeProduct arity a From cf20b10b1a38e47789b019d23bd588149e5f8750 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 29 Jan 2022 15:35:37 +0000 Subject: [PATCH 2/8] export nullaryToObject --- src/Data/Aeson.hs | 1 + src/Data/Aeson/Types.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/src/Data/Aeson.hs b/src/Data/Aeson.hs index 3f6461d22..7f3e73a55 100644 --- a/src/Data/Aeson.hs +++ b/src/Data/Aeson.hs @@ -110,6 +110,7 @@ module Data.Aeson , fieldLabelModifier , constructorTagModifier , allNullaryToStringTag + , nullaryToObject , omitNothingFields , sumEncoding , unwrapUnaryRecords diff --git a/src/Data/Aeson/Types.hs b/src/Data/Aeson/Types.hs index b83dcbfc2..6da7e281c 100644 --- a/src/Data/Aeson/Types.hs +++ b/src/Data/Aeson/Types.hs @@ -124,6 +124,7 @@ module Data.Aeson.Types , fieldLabelModifier , constructorTagModifier , allNullaryToStringTag + , nullaryToObject , omitNothingFields , sumEncoding , unwrapUnaryRecords From bd59bc67b2b2f6fd1b08ab60e2ea25972359a1d5 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 29 Jan 2022 17:33:37 +0000 Subject: [PATCH 3/8] use nullaryToObject option in ToJSON --- src/Data/Aeson/Types/FromJSON.hs | 15 ++++++++++----- tests/UnitTests.hs | 1 + 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index e6996ebf9..a4059b334 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1242,11 +1242,16 @@ 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 + consParseJSON' (cname :* tname :* opts :* _) v = + Tagged . contextCons cname tname $ + if nullaryToObject opts + then case v of + Object _ -> pure U1 + _ -> 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 " ++ diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index d10cc6d44..cbb2f3b87 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -492,6 +492,7 @@ showOptions = ++ "fieldLabelModifier =~ \"exampleField\"" ++ ", constructorTagModifier =~ \"ExampleConstructor\"" ++ ", allNullaryToStringTag = True" + ++ ", nullaryToObject = False" ++ ", omitNothingFields = False" ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}" ++ ", unwrapUnaryRecords = False" From 3eb66f9a68f103b5f1489382aad89f5712a64db7 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 29 Jan 2022 17:45:00 +0000 Subject: [PATCH 4/8] change if to guards, comments --- src/Data/Aeson/Types/FromJSON.hs | 4 +++- src/Data/Aeson/Types/ToJSON.hs | 7 +++++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index a4059b334..3560c68af 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1241,7 +1241,9 @@ 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: + -- Empty constructors are expected to be encoded as an empty array or an object, + -- depending on nullaryToObject option (default is array) + -- TODO probably, with rejectUnknownFields option, the object should be empty to pass. consParseJSON' (cname :* tname :* opts :* _) v = Tagged . contextCons cname tname $ if nullaryToObject opts diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index c8dc643d1..a7b61874b 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -817,8 +817,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 _ _ = if nullaryToObject opts then E.emptyObject_ else 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 From 2cd8d944649d195e129e638af6660a7b02ba0ad8 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 6 Oct 2023 00:21:24 +0100 Subject: [PATCH 5/8] fix nullaryToObject option for toJSON, add TH toJSON/toEncoding support, add tests (TODO support TH parsing) --- src/Data/Aeson/TH.hs | 6 ++++-- src/Data/Aeson/Types/ToJSON.hs | 8 ++++++-- tests/Encoders.hs | 18 ++++++++++++++++++ tests/Options.hs | 7 +++++++ tests/UnitTests/NullaryConstructors.hs | 10 +++++++++- 5 files changed, 44 insertions(+), 5 deletions(-) diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index 088b1fbae..ac73a9d5a 100644 --- a/src/Data/Aeson/TH.hs +++ b/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) diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index 51c7deaa4..1fabc07c6 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/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 diff --git a/tests/Encoders.hs b/tests/Encoders.hs index d8099331f..8c218a104 100644 --- a/tests/Encoders.hs +++ b/tests/Encoders.hs @@ -60,6 +60,15 @@ thNullaryToEncodingObjectWithSingleField = thNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary thNullaryParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''Nullary) +thNullaryToJSONOWSFNullaryToObject :: Nullary -> Value +thNullaryToJSONOWSFNullaryToObject = $(mkToJSON optsOWSFNullaryToObject ''Nullary) + +thNullaryToEncodingOWSFNullaryToObject :: Nullary -> Encoding +thNullaryToEncodingOWSFNullaryToObject = $(mkToEncoding optsOWSFNullaryToObject ''Nullary) + +thNullaryParseJSONOWSFNullaryToObject :: Value -> Parser Nullary +thNullaryParseJSONOWSFNullaryToObject = $(mkParseJSON optsOWSFNullaryToObject ''Nullary) + gNullaryToJSONString :: Nullary -> Value gNullaryToJSONString = genericToJSON defaultOptions @@ -99,6 +108,15 @@ gNullaryToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingle gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField +gNullaryToJSONOWSFNullaryToObject :: Nullary -> Value +gNullaryToJSONOWSFNullaryToObject = genericToJSON optsOWSFNullaryToObject + +gNullaryToEncodingOWSFNullaryToObject :: Nullary -> Encoding +gNullaryToEncodingOWSFNullaryToObject = genericToEncoding optsOWSFNullaryToObject + +gNullaryParseJSONOWSFNullaryToObject :: Value -> Parser Nullary +gNullaryParseJSONOWSFNullaryToObject = genericParseJSON optsOWSFNullaryToObject + keyOptions :: JSONKeyOptions keyOptions = defaultJSONKeyOptions { keyModifier = ('k' :) } diff --git a/tests/Options.hs b/tests/Options.hs index 8618750e7..290c9f84c 100644 --- a/tests/Options.hs +++ b/tests/Options.hs @@ -34,6 +34,13 @@ optsObjectWithSingleField = optsDefault , sumEncoding = ObjectWithSingleField } +optsOWSFNullaryToObject :: Options +optsOWSFNullaryToObject = optsDefault + { allNullaryToStringTag = False + , sumEncoding = ObjectWithSingleField + , nullaryToObject = True + } + optsOmitNothingFields :: Options optsOmitNothingFields = optsDefault { omitNothingFields = True diff --git a/tests/UnitTests/NullaryConstructors.hs b/tests/UnitTests/NullaryConstructors.hs index 820f3c82c..b4791732b 100644 --- a/tests/UnitTests/NullaryConstructors.hs +++ b/tests/UnitTests/NullaryConstructors.hs @@ -26,6 +26,8 @@ nullaryConstructors = , dec "\"C1\"" @=? gNullaryToJSONString C1 , dec "{\"c1\":[]}" @=? thNullaryToJSONObjectWithSingleField C1 , dec "{\"c1\":[]}" @=? gNullaryToJSONObjectWithSingleField C1 + , dec "{\"c1\":{}}" @=? gNullaryToJSONOWSFNullaryToObject C1 + , dec "{\"c1\":{}}" @=? thNullaryToJSONOWSFNullaryToObject C1 , dec "[\"c1\",[]]" @=? gNullaryToJSON2ElemArray C1 , dec "[\"c1\",[]]" @=? thNullaryToJSON2ElemArray C1 , dec "{\"tag\":\"c1\"}" @=? thNullaryToJSONTaggedObject C1 @@ -37,6 +39,8 @@ nullaryConstructors = , decE "[\"c1\",[]]" @=? enc (thNullaryToEncoding2ElemArray C1) , decE "{\"c1\":[]}" @=? enc (thNullaryToEncodingObjectWithSingleField C1) , decE "{\"c1\":[]}" @=? enc (gNullaryToEncodingObjectWithSingleField C1) + , decE "{\"c1\":{}}" @=? enc (gNullaryToEncodingOWSFNullaryToObject C1) + , decE "{\"c1\":{}}" @=? enc (thNullaryToEncodingOWSFNullaryToObject C1) , decE "{\"tag\":\"c1\"}" @=? enc (thNullaryToEncodingTaggedObject C1) , decE "{\"tag\":\"c1\"}" @=? enc (gNullaryToEncodingTaggedObject C1) @@ -49,9 +53,13 @@ nullaryConstructors = , ISuccess C1 @=? parse gNullaryParseJSON2ElemArray (dec "[\"c1\",[]]") , ISuccess C1 @=? parse thNullaryParseJSONObjectWithSingleField (dec "{\"c1\":[]}") , ISuccess C1 @=? parse gNullaryParseJSONObjectWithSingleField (dec "{\"c1\":[]}") - -- Make sure that the old `"contents" : []' is still allowed + , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{}}") + -- TODO , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{}}") + -- Make sure that the old `"contents" : []` is still allowed (and also `"contents" : {}`) , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}") , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}") + , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":{}}") + , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":{}}") , for_ [("kC1", C1), ("kC2", C2), ("kC3", C3)] $ \(jkey, key) -> do Right jkey @=? gNullaryToJSONKey key From 787e4a8105da9e592fe335d5dce7ad1689e2dd95 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 6 Oct 2023 11:41:10 +0100 Subject: [PATCH 6/8] add TH parsing support for nullaryToObject, fail on non-empty objects with rejectUnknownFields, more tests --- src/Data/Aeson/TH.hs | 27 +++++++++++++--- src/Data/Aeson/Types/FromJSON.hs | 21 ++++++------ tests/Encoders.hs | 44 ++++++++++++++++++++++++++ tests/Options.hs | 23 +++++++++++--- tests/UnitTests/NullaryConstructors.hs | 32 +++++++++++++++++-- 5 files changed, 125 insertions(+), 22 deletions(-) diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index ac73a9d5a..4f20932d0 100644 --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -875,8 +875,8 @@ consFromJSON jc tName opts instTys cons = do [] ] -parseNullaryMatches :: Name -> Name -> [Q Match] -parseNullaryMatches tName conName = +parseNullaryMatches :: Name -> Name -> Options -> [Q Match] +parseNullaryMatches tName conName opts = [ do arr <- newName "arr" match (conP 'Array [varP arr]) (guardedB @@ -893,8 +893,27 @@ parseNullaryMatches tName conName = ] ) [] + , do obj <- newName "obj" + match (conP 'Object [varP obj]) + (if rejectUnknownFields opts then matchEmptyObject obj else matchAnyObject) + [] , matchFailed tName conName "Array" ] + where + matchAnyObject = normalB $ [|pure|] `appE` conE conName + matchEmptyObject 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 = @@ -988,12 +1007,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 _ _ diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 183928c29..22c93ed49 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1346,21 +1346,20 @@ instance {-# OVERLAPPING #-} ConsFromJSON' arity U1 False where -- Empty constructors are expected to be encoded as an empty array or an object, -- depending on nullaryToObject option (default is array) - -- TODO probably, with rejectUnknownFields option, the object should be empty to pass. consParseJSON' (cname :* tname :* opts :* _) v = - Tagged . contextCons cname tname $ - if nullaryToObject opts - then case v of - Object _ -> pure U1 - _ -> typeMismatch "Object" v - else case v of - Array a | V.null a -> pure U1 - | otherwise -> fail_ a - _ -> typeMismatch "Array" v + Tagged . contextCons cname tname $ case v of + Array a | V.null a -> pure U1 + | otherwise -> failArr_ a + Object o | KM.null o || not (rejectUnknownFields opts) -> pure U1 + | otherwise -> failObj_ o + _ -> typeMismatch "Array" v where - fail_ a = fail $ + failArr_ 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 #-} diff --git a/tests/Encoders.hs b/tests/Encoders.hs index 8c218a104..783c8e5d6 100644 --- a/tests/Encoders.hs +++ b/tests/Encoders.hs @@ -60,6 +60,17 @@ 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) @@ -69,6 +80,17 @@ thNullaryToEncodingOWSFNullaryToObject = $(mkToEncoding optsOWSFNullaryToObject 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 @@ -108,6 +130,17 @@ 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 @@ -117,6 +150,17 @@ gNullaryToEncodingOWSFNullaryToObject = genericToEncoding optsOWSFNullaryToObjec 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' :) } diff --git a/tests/Options.hs b/tests/Options.hs index 290c9f84c..2f636dad7 100644 --- a/tests/Options.hs +++ b/tests/Options.hs @@ -34,12 +34,27 @@ optsObjectWithSingleField = optsDefault , sumEncoding = ObjectWithSingleField } +optsOWSFRejectUnknown :: Options +optsOWSFRejectUnknown = optsDefault + { allNullaryToStringTag = False + , rejectUnknownFields = True + , sumEncoding = ObjectWithSingleField + } + optsOWSFNullaryToObject :: Options optsOWSFNullaryToObject = optsDefault - { allNullaryToStringTag = False - , sumEncoding = ObjectWithSingleField - , nullaryToObject = True - } + { allNullaryToStringTag = False + , sumEncoding = ObjectWithSingleField + , nullaryToObject = True + } + +optsOWSFNullaryToObjectRejectUnknown :: Options +optsOWSFNullaryToObjectRejectUnknown = optsDefault + { allNullaryToStringTag = False + , rejectUnknownFields = True + , sumEncoding = ObjectWithSingleField + , nullaryToObject = True + } optsOmitNothingFields :: Options optsOmitNothingFields = optsDefault diff --git a/tests/UnitTests/NullaryConstructors.hs b/tests/UnitTests/NullaryConstructors.hs index b4791732b..1cdea68de 100644 --- a/tests/UnitTests/NullaryConstructors.hs +++ b/tests/UnitTests/NullaryConstructors.hs @@ -11,7 +11,7 @@ module UnitTests.NullaryConstructors import Prelude.Compat import Data.Aeson (decode, eitherDecode, fromEncoding, Value) -import Data.Aeson.Types (Parser, IResult (..), iparse) +import Data.Aeson.Types (Parser, IResult (..), JSONPathElement (..), iparse) import Data.ByteString.Builder (toLazyByteString) import Data.Foldable (for_) import Data.Maybe (fromJust) @@ -51,15 +51,37 @@ nullaryConstructors = , ISuccess C1 @=? parse gNullaryParseJSONString (dec "\"C1\"") , ISuccess C1 @=? parse thNullaryParseJSON2ElemArray (dec "[\"c1\",[]]") , ISuccess C1 @=? parse gNullaryParseJSON2ElemArray (dec "[\"c1\",[]]") + -- both object and empty array are accepted irrespective of the nullaryToObject flag option , ISuccess C1 @=? parse thNullaryParseJSONObjectWithSingleField (dec "{\"c1\":[]}") , ISuccess C1 @=? parse gNullaryParseJSONObjectWithSingleField (dec "{\"c1\":[]}") + , ISuccess C1 @=? parse thNullaryParseJSONObjectWithSingleField (dec "{\"c1\":{}}") + , ISuccess C1 @=? parse gNullaryParseJSONObjectWithSingleField (dec "{\"c1\":{}}") + , ISuccess C1 @=? parse thNullaryParseJSONObjectWithSingleField (dec "{\"c1\":{\"extra\":1}}") + , ISuccess C1 @=? parse gNullaryParseJSONObjectWithSingleField (dec "{\"c1\":{\"extra\":1}}") + , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":[]}") + , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":[]}") + , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{}}") , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{}}") - -- TODO , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{}}") - -- Make sure that the old `"contents" : []` is still allowed (and also `"contents" : {}`) + , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{\"extra\":1}}") + , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{\"extra\":1}}") + -- Make sure that the old `"contents" : []` is still allowed (and also `"contents" : {}`) , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}") , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}") , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":{}}") , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":{}}") + -- with rejectUnknownFields object must be empty + , ISuccess C1 @=? parse thNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":[]}") + , ISuccess C1 @=? parse gNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":[]}") + , ISuccess C1 @=? parse thNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":{}}") + , ISuccess C1 @=? parse gNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":{}}") + , IError [] thUnknown @=? parse thNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":{\"extra\":1}}") + , IError [Key "c1"] gUnknown @=? parse gNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":{\"extra\":1}}") + , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":[]}") + , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":[]}") + , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{}}") + , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{}}") + , IError [] thUnknown @=? parse thNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{\"extra\":1}}") + , IError [Key "c1"] gUnknown @=? parse gNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{\"extra\":1}}") , for_ [("kC1", C1), ("kC2", C2), ("kC3", C3)] $ \(jkey, key) -> do Right jkey @=? gNullaryToJSONKey key @@ -73,3 +95,7 @@ nullaryConstructors = decE = eitherDecode parse :: (a -> Parser b) -> a -> IResult b parse parsejson v = iparse parsejson v + thUnknown :: String + thUnknown = "When parsing the constructor C1 of type Types.Nullary expected an empty Object but got Object of size 1." + gUnknown :: String + gUnknown = "parsing Types.Nullary(C1) failed, expected an empty Object but encountered Object of size 1" From 7cdbd01c638efa9e5e1f6f134ea1e842845bb75b Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 6 Oct 2023 11:54:23 +0100 Subject: [PATCH 7/8] remove unused name from TH, update comment --- src/Data/Aeson/TH.hs | 42 ++++++++++++++++++-------------- src/Data/Aeson/Types/FromJSON.hs | 7 +++--- 2 files changed, 28 insertions(+), 21 deletions(-) diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index 4f20932d0..8655d31a5 100644 --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -893,27 +893,33 @@ parseNullaryMatches tName conName opts = ] ) [] - , do obj <- newName "obj" - match (conP 'Object [varP obj]) - (if rejectUnknownFields opts then matchEmptyObject obj else matchAnyObject) - [] + , if rejectUnknownFields opts then matchEmptyObject else matchAnyObject , matchFailed tName conName "Array" ] where - matchAnyObject = normalB $ [|pure|] `appE` conE conName - matchEmptyObject 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) - ) - ) - ] + 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 = diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 22c93ed49..2d00270d2 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1345,16 +1345,17 @@ 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 or an object, - -- depending on nullaryToObject option (default is array) + -- independent of nullaryToObject option. + -- With rejectUnknownFields an object must be empty. consParseJSON' (cname :* tname :* opts :* _) v = Tagged . contextCons cname tname $ case v of Array a | V.null a -> pure U1 - | otherwise -> failArr_ a + | otherwise -> fail_ a Object o | KM.null o || not (rejectUnknownFields opts) -> pure U1 | otherwise -> failObj_ o _ -> typeMismatch "Array" v where - failArr_ a = fail $ + fail_ a = fail $ "expected an empty Array, but encountered an Array of length " ++ show (V.length a) failObj_ o = fail $ From 049feff16b9621084034cfc1b2c97f11d3e4f21e Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 6 Oct 2023 19:17:47 +0100 Subject: [PATCH 8/8] make parsers depend on nullaryToObject option (do not relax default parsers) --- src/Data/Aeson/TH.hs | 27 +++++++++++------ src/Data/Aeson/Types/FromJSON.hs | 16 ++++++---- tests/UnitTests/NullaryConstructors.hs | 42 ++++++++++++-------------- 3 files changed, 47 insertions(+), 38 deletions(-) diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index 8655d31a5..4d43a67c5 100644 --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -876,10 +876,21 @@ consFromJSON jc tName opts instTys cons = do ] parseNullaryMatches :: Name -> Name -> Options -> [Q Match] -parseNullaryMatches tName conName opts = - [ do arr <- newName "arr" - match (conP 'Array [varP arr]) - (guardedB +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|]) @@ -891,12 +902,8 @@ parseNullaryMatches tName conName opts = ) ) ] - ) - [] - , if rejectUnknownFields opts then matchEmptyObject else matchAnyObject - , matchFailed tName conName "Array" - ] - where + ) + [] matchAnyObject = do match (conP 'Object [wildP]) diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 2d00270d2..f01e0f2c7 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -1348,12 +1348,16 @@ instance {-# OVERLAPPING #-} -- independent of nullaryToObject option. -- With rejectUnknownFields an object must be empty. consParseJSON' (cname :* tname :* opts :* _) v = - Tagged . contextCons cname tname $ case v of - Array a | V.null a -> pure U1 - | otherwise -> fail_ a - Object o | KM.null o || not (rejectUnknownFields opts) -> pure U1 - | otherwise -> failObj_ o - _ -> typeMismatch "Array" 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 " ++ diff --git a/tests/UnitTests/NullaryConstructors.hs b/tests/UnitTests/NullaryConstructors.hs index 1cdea68de..4d3c051be 100644 --- a/tests/UnitTests/NullaryConstructors.hs +++ b/tests/UnitTests/NullaryConstructors.hs @@ -54,12 +54,10 @@ nullaryConstructors = -- both object and empty array are accepted irrespective of the nullaryToObject flag option , ISuccess C1 @=? parse thNullaryParseJSONObjectWithSingleField (dec "{\"c1\":[]}") , ISuccess C1 @=? parse gNullaryParseJSONObjectWithSingleField (dec "{\"c1\":[]}") - , ISuccess C1 @=? parse thNullaryParseJSONObjectWithSingleField (dec "{\"c1\":{}}") - , ISuccess C1 @=? parse gNullaryParseJSONObjectWithSingleField (dec "{\"c1\":{}}") - , ISuccess C1 @=? parse thNullaryParseJSONObjectWithSingleField (dec "{\"c1\":{\"extra\":1}}") - , ISuccess C1 @=? parse gNullaryParseJSONObjectWithSingleField (dec "{\"c1\":{\"extra\":1}}") - , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":[]}") - , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":[]}") + , thErrObject @=? parse thNullaryParseJSONObjectWithSingleField (dec "{\"c1\":{}}") + , gErrObject @=? parse gNullaryParseJSONObjectWithSingleField (dec "{\"c1\":{}}") + , thErrArray @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":[]}") + , gErrArray @=? parse gNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":[]}") , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{}}") , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{}}") , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{\"extra\":1}}") @@ -70,18 +68,16 @@ nullaryConstructors = , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":{}}") , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":{}}") -- with rejectUnknownFields object must be empty - , ISuccess C1 @=? parse thNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":[]}") - , ISuccess C1 @=? parse gNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":[]}") - , ISuccess C1 @=? parse thNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":{}}") - , ISuccess C1 @=? parse gNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":{}}") - , IError [] thUnknown @=? parse thNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":{\"extra\":1}}") - , IError [Key "c1"] gUnknown @=? parse gNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":{\"extra\":1}}") - , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":[]}") - , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":[]}") - , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{}}") - , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{}}") - , IError [] thUnknown @=? parse thNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{\"extra\":1}}") - , IError [Key "c1"] gUnknown @=? parse gNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{\"extra\":1}}") + , ISuccess C1 @=? parse thNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":[]}") + , ISuccess C1 @=? parse gNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":[]}") + , thErrObject @=? parse thNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":{}}") + , gErrObject @=? parse gNullaryParseJSONOWSFRejectUnknown (dec "{\"c1\":{}}") + , thErrArray @=? parse thNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":[]}") + , gErrArray @=? parse gNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":[]}") + , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{}}") + , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{}}") + , thErrUnknown @=? parse thNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{\"extra\":1}}") + , gErrUnknown @=? parse gNullaryParseJSONOWSFNullaryToObjectRejectUnknown (dec "{\"c1\":{\"extra\":1}}") , for_ [("kC1", C1), ("kC2", C2), ("kC3", C3)] $ \(jkey, key) -> do Right jkey @=? gNullaryToJSONKey key @@ -95,7 +91,9 @@ nullaryConstructors = decE = eitherDecode parse :: (a -> Parser b) -> a -> IResult b parse parsejson v = iparse parsejson v - thUnknown :: String - thUnknown = "When parsing the constructor C1 of type Types.Nullary expected an empty Object but got Object of size 1." - gUnknown :: String - gUnknown = "parsing Types.Nullary(C1) failed, expected an empty Object but encountered Object of size 1" + thErrObject = IError [] "When parsing the constructor C1 of type Types.Nullary expected Array but got Object." + gErrObject = IError [Key "c1"] "parsing Types.Nullary(C1) failed, expected Array, but encountered Object" + thErrArray = IError [] "When parsing the constructor C1 of type Types.Nullary expected Object but got Array." + gErrArray = IError [Key "c1"] "parsing Types.Nullary(C1) failed, expected Object, but encountered Array" + thErrUnknown = IError [] "When parsing the constructor C1 of type Types.Nullary expected an empty Object but got Object of size 1." + gErrUnknown = IError [Key "c1"] "parsing Types.Nullary(C1) failed, expected an empty Object but encountered Object of size 1"