git.iko.soy/typeable/aeson
on master help sign in
Merge pull request #522 from Lysxia/feature-473

Option to encode single-constructor types as tagged sums

commit22064e4f7160c3c256588e7d287e16f1b7539272 authorAdam Bergmark <adam@bergmark.nl> dateFri 7 Apr 2017, 14:59 (10 years ago) parente92c3dc3392b6d
8 files changed+110−22
compare with master
unifiedsplit
Data/Aeson/TH.hs+5−3 Data/Aeson/Types/FromJSON.hs+26−13 Data/Aeson/Types/Internal.hs+7−1 Data/Aeson/Types/ToJSON.hs+12 tests/Encoders.hs+28 tests/Options.hs+6 tests/Properties.hs+25−5 tests/UnitTests.hs+1
Data/Aeson/TH.hs+5−3
@@ -341,7 +341,7 @@ consToValue jc opts cons = do
341341 matches tjs = case cons of
342342 -- A single constructor is directly encoded. The constructor itself may be
343343 -- forgotten.
344− [con] -> [argsToValue jc tjs opts False con]
344+ [con] | not (tagSingleConstructors opts) -> [argsToValue jc tjs opts False con]
345345 _ | allNullaryToStringTag opts && all isNullary cons ->
346346 [ match (conP conName []) (normalB $ conStr opts conName) []
347347 | con <- cons
@@ -384,7 +384,7 @@ consToEncoding jc opts cons = do
384384 matches tes = case cons of
385385 -- A single constructor is directly encoded. The constructor itself may be
386386 -- forgotten.
387− [con] -> [argsToEncoding jc tes opts False con]
387+ [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tes opts False con]
388388 -- Encode just the name of the constructor of a sum type iff all the
389389 -- constructors are nullary.
390390 _ | allNullaryToStringTag opts && all isNullary cons ->
@@ -792,7 +792,9 @@ consFromJSON jc tName opts cons = do
792792
793793 where
794794 lamExpr value pjs = case cons of
795− [con] -> parseArgs jc pjs tName opts con (Right value)
795+ [con]
796+ | not (tagSingleConstructors opts)
797+ -> parseArgs jc pjs tName opts con (Right value)
796798 _ | sumEncoding opts == UntaggedValue
797799 -> parseUntaggedValue pjs cons value
798800 | otherwise
Data/Aeson/Types/FromJSON.hs+26−13
@@ -791,6 +791,19 @@ instance GFromJSON arity U1 where
791791 | isEmptyArray v = pure U1
792792 | otherwise = typeMismatch "unit constructor (U1)" v
793793
794+instance ( ConsFromJSON arity a
795+ , AllNullary (C1 c a) allNullary
796+ , ParseSum arity (C1 c a) allNullary
797+ ) => GFromJSON arity (D1 d (C1 c a)) where
798+ -- The option 'tagSingleConstructors' determines whether to wrap
799+ -- a single-constructor type.
800+ gParseJSON opts fargs
801+ | tagSingleConstructors opts
802+ = fmap M1
803+ . (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))
804+ . parseSum opts fargs
805+ | otherwise = fmap M1 . fmap M1 . consParseJSON opts fargs
806+
794807instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where
795808 -- Constructors need to be decoded differently depending on whether they're
796809 -- a record or not. This distinction is made by consParseJSON:
@@ -837,19 +850,19 @@ class ParseSum arity f allNullary where
837850 parseSum :: Options -> FromArgs arity a
838851 -> Value -> Tagged allNullary (Parser (f a))
839852
840−instance ( SumFromString (a :+: b)
841− , FromPair arity (a :+: b)
842− , FromTaggedObject arity (a :+: b)
843− , FromUntaggedValue arity (a :+: b)
844− ) => ParseSum arity (a :+: b) True where
853+instance ( SumFromString f
854+ , FromPair arity f
855+ , FromTaggedObject arity f
856+ , FromUntaggedValue arity f
857+ ) => ParseSum arity f True where
845858 parseSum opts fargs
846859 | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts
847860 | otherwise = Tagged . parseNonAllNullarySum opts fargs
848861
849−instance ( FromPair arity (a :+: b)
850− , FromTaggedObject arity (a :+: b)
851− , FromUntaggedValue arity (a :+: b)
852− ) => ParseSum arity (a :+: b) False where
862+instance ( FromPair arity f
863+ , FromTaggedObject arity f
864+ , FromUntaggedValue arity f
865+ ) => ParseSum arity f False where
853866 parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs
854867
855868--------------------------------------------------------------------------------
@@ -875,11 +888,11 @@ instance (Constructor c) => SumFromString (C1 c U1) where
875888
876889--------------------------------------------------------------------------------
877890
878−parseNonAllNullarySum :: ( FromPair arity (a :+: b)
879− , FromTaggedObject arity (a :+: b)
880− , FromUntaggedValue arity (a :+: b)
891+parseNonAllNullarySum :: ( FromPair arity f
892+ , FromTaggedObject arity f
893+ , FromUntaggedValue arity f
881894 ) => Options -> FromArgs arity c
882− -> Value -> Parser ((a :+: b) c)
895+ -> Value -> Parser (f c)
883896parseNonAllNullarySum opts fargs =
884897 case sumEncoding opts of
885898 TaggedObject{..} ->
Data/Aeson/Types/Internal.hs+7−1
@@ -524,10 +524,13 @@ data Options = Options
524524 , unwrapUnaryRecords :: Bool
525525 -- ^ Hide the field name when a record constructor has only one
526526 -- field, like a newtype.
527+ , tagSingleConstructors :: Bool
528+ -- ^ Encode types with a single constructor as sums,
529+ -- so that `allNullaryToStringTag` and `sumEncoding` apply.
527530 }
528531
529532instance Show Options where
530− show (Options f c a o s u) =
533+ show (Options f c a o s u t) =
531534 "Options {"
532535 ++ intercalate ", "
533536 [ "fieldLabelModifier =~ " ++ show (f "exampleField")
@@ -536,6 +539,7 @@ instance Show Options where
536539 , "omitNothingFields = " ++ show o
537540 , "sumEncoding = " ++ show s
538541 , "unwrapUnaryRecords = " ++ show u
542+ , "tagSingleConstructors = " ++ show t
539543 ]
540544 ++ "}"
541545
@@ -589,6 +593,7 @@ data SumEncoding =
589593-- , 'omitNothingFields' = False
590594-- , 'sumEncoding' = 'defaultTaggedObject'
591595-- , 'unwrapUnaryRecords' = False
596+-- , 'tagSingleConstructors' = False
592597-- }
593598-- @
594599defaultOptions :: Options
@@ -599,6 +604,7 @@ defaultOptions = Options
599604 , omitNothingFields = False
600605 , sumEncoding = defaultTaggedObject
601606 , unwrapUnaryRecords = False
607+ , tagSingleConstructors = False
602608 }
603609
604610-- | Default 'TaggedObject' 'SumEncoding' options:
Data/Aeson/Types/ToJSON.hs+12
@@ -659,6 +659,18 @@ instance GToJSON enc One Par1 where
659659 -- function passed in as an argument:
660660 gToJSON _opts (To1Args tj _) = tj . unPar1
661661
662+instance ( ConsToJSON enc arity a
663+ , AllNullary (C1 c a) allNullary
664+ , SumToJSON enc arity (C1 c a) allNullary
665+ ) => GToJSON enc arity (D1 d (C1 c a)) where
666+ -- The option 'tagSingleConstructors' determines whether to wrap
667+ -- a single-constructor type.
668+ gToJSON opts targs
669+ | tagSingleConstructors opts = (unTagged :: Tagged allNullary enc -> enc)
670+ . sumToJSON opts targs
671+ . unM1
672+ | otherwise = consToJSON opts targs . unM1 . unM1
673+
662674instance (ConsToJSON enc arity a) => GToJSON enc arity (C1 c a) where
663675 -- Constructors need to be encoded differently depending on whether they're
664676 -- a record or not. This distinction is made by 'consToJSON':
tests/Encoders.hs+28
@@ -354,3 +354,31 @@ thOneConstructorToEncodingDefault = $(mkToEncoding defaultOptions ''OneConstruct
354354
355355thOneConstructorParseJSONDefault :: Value -> Parser OneConstructor
356356thOneConstructorParseJSONDefault = $(mkParseJSON defaultOptions ''OneConstructor)
357+
358+thOneConstructorToJSONTagged :: OneConstructor -> Value
359+thOneConstructorToJSONTagged = $(mkToJSON optsTagSingleConstructors ''OneConstructor)
360+
361+thOneConstructorToEncodingTagged :: OneConstructor -> Encoding
362+thOneConstructorToEncodingTagged = $(mkToEncoding optsTagSingleConstructors ''OneConstructor)
363+
364+thOneConstructorParseJSONTagged :: Value -> Parser OneConstructor
365+thOneConstructorParseJSONTagged = $(mkParseJSON optsTagSingleConstructors ''OneConstructor)
366+
367+
368+gOneConstructorToJSONDefault :: OneConstructor -> Value
369+gOneConstructorToJSONDefault = genericToJSON defaultOptions
370+
371+gOneConstructorToEncodingDefault :: OneConstructor -> Encoding
372+gOneConstructorToEncodingDefault = genericToEncoding defaultOptions
373+
374+gOneConstructorParseJSONDefault :: Value -> Parser OneConstructor
375+gOneConstructorParseJSONDefault = genericParseJSON defaultOptions
376+
377+gOneConstructorToJSONTagged :: OneConstructor -> Value
378+gOneConstructorToJSONTagged = genericToJSON optsTagSingleConstructors
379+
380+gOneConstructorToEncodingTagged :: OneConstructor -> Encoding
381+gOneConstructorToEncodingTagged = genericToEncoding optsTagSingleConstructors
382+
383+gOneConstructorParseJSONTagged :: Value -> Parser OneConstructor
384+gOneConstructorParseJSONTagged = genericParseJSON optsTagSingleConstructors
tests/Options.hs+6
@@ -42,3 +42,9 @@ optsUntaggedValue :: Options
4242optsUntaggedValue = optsDefault
4343 { sumEncoding = UntaggedValue
4444 }
45+
46+optsTagSingleConstructors :: Options
47+optsTagSingleConstructors = optsDefault
48+ { tagSingleConstructors = True
49+ , allNullaryToStringTag = False
50+ }
tests/Properties.hs+25−5
@@ -168,11 +168,14 @@ isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&
168168isTaggedObjectValue _ = False
169169
170170isNullaryTaggedObject :: Value -> Bool
171−isNullaryTaggedObject obj = isTaggedObject obj && isObjectWithSingleField obj
171+isNullaryTaggedObject obj = isTaggedObject' obj && isObjectWithSingleField obj
172172
173−isTaggedObject :: Value -> Bool
174−isTaggedObject (Object obj) = "tag" `H.member` obj
175−isTaggedObject _ = False
173+isTaggedObject :: Value -> Property
174+isTaggedObject = checkValue isTaggedObject'
175+
176+isTaggedObject' :: Value -> Bool
177+isTaggedObject' (Object obj) = "tag" `H.member` obj
178+isTaggedObject' _ = False
176179
177180isObjectWithSingleField :: Value -> Bool
178181isObjectWithSingleField (Object obj) = H.size obj == 1
@@ -338,6 +341,14 @@ tests = testGroup "properties" [
338341#endif
339342 ]
340343 ]
344+ , testGroup "OneConstructor" [
345+ testProperty "default" (isEmptyArray . gOneConstructorToJSONDefault)
346+ , testProperty "Tagged" (isTaggedObject . gOneConstructorToJSONTagged)
347+ , testGroup "roundTrip" [
348+ testProperty "default" (toParseJSON gOneConstructorParseJSONDefault gOneConstructorToJSONDefault)
349+ , testProperty "Tagged" (toParseJSON gOneConstructorParseJSONTagged gOneConstructorToJSONTagged)
350+ ]
351+ ]
341352 ]
342353 , testGroup "toEncoding" [
343354 testProperty "NullaryString" $
@@ -386,6 +397,11 @@ tests = testGroup "properties" [
386397
387398 , testProperty "SomeTypeOmitNothingFields" $
388399 gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields
400+
401+ , testProperty "OneConstructorDefault" $
402+ gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault
403+ , testProperty "OneConstructorTagged" $
404+ gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged
389405 ]
390406 ]
391407 , testGroup "template-haskell" [
@@ -440,8 +456,10 @@ tests = testGroup "properties" [
440456 ]
441457 , testGroup "OneConstructor" [
442458 testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)
459+ , testProperty "Tagged" (isTaggedObject . thOneConstructorToJSONTagged)
443460 , testGroup "roundTrip" [
444461 testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)
462+ , testProperty "Tagged" (toParseJSON thOneConstructorParseJSONTagged thOneConstructorToJSONTagged)
445463 ]
446464 ]
447465 ]
@@ -484,8 +502,10 @@ tests = testGroup "properties" [
484502 , testProperty "SomeTypeObjectWithSingleField unary agree" $
485503 thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField
486504
487− , testProperty "OneConstructor" $
505+ , testProperty "OneConstructorDefault" $
488506 thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault
507+ , testProperty "OneConstructorTagged" $
508+ thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged
489509 ]
490510 ]
491511 ]
tests/UnitTests.hs+1
@@ -494,6 +494,7 @@ showOptions =
494494 ++ ", omitNothingFields = False"
495495 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
496496 ++ ", unwrapUnaryRecords = False"
497+ ++ ", tagSingleConstructors = False"
497498 ++ "}")
498499 (show defaultOptions)
499500