Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Option nullaryToObject to encode/decode nullary constructors as empty objects #926

Open
wants to merge 10 commits into
base: master
Choose a base branch
from
1 change: 1 addition & 0 deletions src/Data/Aeson.hs
Original file line number Diff line number Diff line change
Expand Up @@ -127,6 +127,7 @@ module Data.Aeson
, fieldLabelModifier
, constructorTagModifier
, allNullaryToStringTag
, nullaryToObject
, omitNothingFields
, allowOmittedFields
, sumEncoding
Expand Down
39 changes: 33 additions & 6 deletions src/Data/Aeson/TH.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -873,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
Expand All @@ -891,8 +893,33 @@ parseNullaryMatches tName conName =
]
)
[]
, if rejectUnknownFields opts then matchEmptyObject else matchAnyObject
, matchFailed tName conName "Array"
]
where
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 =
Expand Down Expand Up @@ -986,12 +1013,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 _ _
Expand Down
1 change: 1 addition & 0 deletions src/Data/Aeson/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -142,6 +142,7 @@ module Data.Aeson.Types
, fieldLabelModifier
, constructorTagModifier
, allNullaryToStringTag
, nullaryToObject
, omitNothingFields
, allowOmittedFields
, sumEncoding
Expand Down
11 changes: 9 additions & 2 deletions src/Data/Aeson/Types/FromJSON.hs
Original file line number Diff line number Diff line change
Expand Up @@ -1344,16 +1344,23 @@ 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 =
-- 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 $ case v of
Array a | V.null a -> pure U1
| otherwise -> fail_ a
Object o | KM.null o || not (rejectUnknownFields opts) -> pure U1
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is not right. You accept {} even if nullaryToObject is False, i.e. relaxing the parser. And vice versa, nullaryToObject = True case will accept [].

As I said, I'm not a fan of extending the kitchen-sink existing deriving mechanism. There are just too many interacting options.

I really suggest that you create your own generic serializing/deserializing fit for your needs. It will be

  • faster to compile
  • produce faster code

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is not right. You accept {} even if nullaryToObject is False, i.e. relaxing the parser.

That's right, it was intended - what's the harm here?
But happy to make it follow the option - I will do that, it's easy.

I really suggest that you create your own generic serializing/deserializing fit for your needs.

Well, our needs are very close to what aeson does, it's not our job to make a better JSON library.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@phadej so now these parsers depend on this option, so the default parsers are not relaxed. Tests are amended too.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Well, our needs are very close to what aeson does,

aeson is not just Generic deriving. Generic deriving is just a (smalL) part (and IMO the not very great part) of a library, and is redone in other libraries, like https://hackage.haskell.org/package/deriving-aeson , https://hackage.haskell.org/package/autodocodec-0.2.1.0/docs/Autodocodec-Aeson.html, https://hackage.haskell.org/package/json-sop

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

that's ok, it amends TH too. We will be switching to TH anyway.

| otherwise -> failObj_ o
_ -> 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 #-}
Expand Down
8 changes: 7 additions & 1 deletion src/Data/Aeson/Types/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -56,6 +56,7 @@ module Data.Aeson.Types.Internal
fieldLabelModifier
, constructorTagModifier
, allNullaryToStringTag
, nullaryToObject
, omitNothingFields
, allowOmittedFields
, sumEncoding
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -846,6 +851,7 @@ defaultOptions = Options
{ fieldLabelModifier = id
, constructorTagModifier = id
, allNullaryToStringTag = True
, nullaryToObject = False
, omitNothingFields = False
, allowOmittedFields = True
, sumEncoding = defaultTaggedObject
Expand Down
15 changes: 11 additions & 4 deletions src/Data/Aeson/Types/ToJSON.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
62 changes: 62 additions & 0 deletions tests/Encoders.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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' :) }

Expand Down
22 changes: 22 additions & 0 deletions tests/Options.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions tests/UnitTests.hs
Original file line number Diff line number Diff line change
Expand Up @@ -277,6 +277,7 @@ showOptions =
++ "fieldLabelModifier =~ \"exampleField\""
++ ", constructorTagModifier =~ \"ExampleConstructor\""
++ ", allNullaryToStringTag = True"
++ ", nullaryToObject = False"
++ ", omitNothingFields = False"
++ ", allowOmittedFields = True"
++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
Expand Down
38 changes: 36 additions & 2 deletions tests/UnitTests/NullaryConstructors.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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
Expand All @@ -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)

Expand All @@ -47,11 +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\":[]}")
-- Make sure that the old `"contents" : []' is still allowed
, 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\":{}}")
, 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
Expand All @@ -65,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"