git.iko.soy/typeable/aeson
on master help sign in
Merge pull request #307 from devwout/nullary_constructor_encoding
commit0ee8f7976ccefc4e11585a2a1bc78eb55d8bc39c authorAdam Bergmark <adam@bergmark.nl> dateFri 6 May 2016, 18:58 (10 years ago) parente45303dc072f7a
5 files changed+112−9
compare with master
unifiedsplit
Data/Aeson/TH.hs+21−4 Data/Aeson/Types/Generic.hs+11−3 tests/DataFamilies/Properties.hs+1−1 tests/Encoders.hs+27 tests/Properties.hs+52−1
Data/Aeson/TH.hs+21−4
@@ -323,6 +323,15 @@ sumToValue opts multiCons conName exp
323323
324324 | otherwise = exp
325325
326+nullarySumToValue :: Options -> Bool -> Name -> Q Exp
327+nullarySumToValue opts multiCons conName =
328+ case sumEncoding opts of
329+ TaggedObject{tagFieldName} ->
330+ [|A.object|] `appE` listE
331+ [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
332+ ]
333+ _ -> sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]
334+
326335-- | Generates code to generate the JSON encoding of a single constructor.
327336argsToValue :: Options -> Bool -> Con -> Q Match
328337-- Nullary constructors. Generates code that explicitly matches against the
@@ -330,7 +339,7 @@ argsToValue :: Options -> Bool -> Con -> Q Match
330339-- type errors.
331340argsToValue opts multiCons (NormalC conName []) =
332341 match (conP conName [])
333− (normalB (sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]))
342+ (normalB (nullarySumToValue opts multiCons conName))
334343 []
335344
336345-- Polyadic constructors with special case for unary constructors.
@@ -478,6 +487,14 @@ sumToEncoding opts multiCons conName exp
478487
479488 | otherwise = exp
480489
490+nullarySumToEncoding :: Options -> Bool -> Name -> Q Exp
491+nullarySumToEncoding opts multiCons conName =
492+ case sumEncoding opts of
493+ TaggedObject{tagFieldName} ->
494+ object $
495+ ([|E.text (T.pack tagFieldName)|] <:> encStr opts conName)
496+ _ -> sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]
497+
481498-- | Generates code to generate the JSON encoding of a single constructor.
482499argsToEncoding :: Options -> Bool -> Con -> Q Match
483500-- Nullary constructors. Generates code that explicitly matches against the
@@ -485,7 +502,7 @@ argsToEncoding :: Options -> Bool -> Con -> Q Match
485502-- type errors.
486503argsToEncoding opts multiCons (NormalC conName []) =
487504 match (conP conName [])
488− (normalB (sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]))
505+ (normalB (nullarySumToEncoding opts multiCons conName))
489506 []
490507
491508-- Polyadic constructors with special case for unary constructors.
@@ -873,8 +890,8 @@ parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
873890 -- Right valName
874891 -> Q Exp
875892-- Nullary constructors.
876−parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) =
877− getValField obj valFieldName $ parseNullaryMatches tName conName
893+parseArgs _ _ (NormalC conName []) (Left _) =
894+ [|pure|] `appE` conE conName
878895parseArgs tName _ (NormalC conName []) (Right valName) =
879896 caseE (varE valName) $ parseNullaryMatches tName conName
880897
Data/Aeson/Types/Generic.hs+11−3
@@ -206,6 +206,9 @@ instance ( IsRecord a isRecord
206206class TaggedObjectPairs' f isRecord where
207207 taggedObjectPairs' :: Options -> String -> f a -> Tagged isRecord [Pair]
208208
209+instance OVERLAPPING_ TaggedObjectPairs' U1 False where
210+ taggedObjectPairs' _ _ _ = Tagged []
211+
209212instance (RecordToPairs f) => TaggedObjectPairs' f True where
210213 taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts
211214
@@ -233,7 +236,6 @@ instance ( IsRecord a isRecord
233236 (builder tagFieldName <>
234237 B.char7 ':' <>
235238 builder (constructorTagModifier opts (conName (undefined :: t c a p)))) <>
236− B.char7 ',' <>
237239 ((unTagged :: Tagged isRecord B.Builder -> B.Builder) .
238240 taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>
239241 B.char7 '}'
@@ -241,12 +243,15 @@ instance ( IsRecord a isRecord
241243class TaggedObjectEnc' f isRecord where
242244 taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord B.Builder
243245
246+instance OVERLAPPING_ TaggedObjectEnc' U1 False where
247+ taggedObjectEnc' _ _ _ = Tagged mempty
248+
244249instance (RecordToEncoding f) => TaggedObjectEnc' f True where
245− taggedObjectEnc' opts _ = Tagged . recordToEncoding opts
250+ taggedObjectEnc' opts _ = Tagged . (\z -> B.char7 ',' <> recordToEncoding opts z)
246251
247252instance (GToEncoding f) => TaggedObjectEnc' f False where
248253 taggedObjectEnc' opts contentsFieldName =
249− Tagged . (\z -> builder contentsFieldName <> B.char7 ':' <> z) .
254+ Tagged . (\z -> B.char7 ',' <> builder contentsFieldName <> B.char7 ':' <> z) .
250255 gbuilder opts
251256
252257--------------------------------------------------------------------------------
@@ -627,6 +632,9 @@ instance (GFromJSON f) => FromTaggedObject'' f False where
627632 parseFromTaggedObject'' opts contentsFieldName = Tagged .
628633 (gParseJSON opts <=< (.: pack contentsFieldName))
629634
635+instance OVERLAPPING_ FromTaggedObject'' U1 False where
636+ parseFromTaggedObject'' _ _ _ = Tagged (pure U1)
637+
630638--------------------------------------------------------------------------------
631639
632640class ConsFromJSON f where
tests/DataFamilies/Properties.hs+1−1
@@ -17,7 +17,7 @@ tests = testGroup "data families" [
1717 testGroup "Nullary" [
1818 testProperty "string" (isString . thNullaryToJSONString)
1919 , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
20− , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)
20+ , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
2121 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
2222
2323 , testGroup "roundTrip" [
tests/Encoders.hs+27
@@ -56,6 +56,9 @@ thNullaryParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleFiel
5656gNullaryToJSONString :: Nullary -> Value
5757gNullaryToJSONString = genericToJSON defaultOptions
5858
59+gNullaryToEncodingString :: Nullary -> Encoding
60+gNullaryToEncodingString = genericToEncoding defaultOptions
61+
5962gNullaryParseJSONString :: Value -> Parser Nullary
6063gNullaryParseJSONString = genericParseJSON defaultOptions
6164
@@ -63,6 +66,9 @@ gNullaryParseJSONString = genericParseJSON defaultOptions
6366gNullaryToJSON2ElemArray :: Nullary -> Value
6467gNullaryToJSON2ElemArray = genericToJSON opts2ElemArray
6568
69+gNullaryToEncoding2ElemArray :: Nullary -> Encoding
70+gNullaryToEncoding2ElemArray = genericToEncoding opts2ElemArray
71+
6672gNullaryParseJSON2ElemArray :: Value -> Parser Nullary
6773gNullaryParseJSON2ElemArray = genericParseJSON opts2ElemArray
6874
@@ -70,6 +76,9 @@ gNullaryParseJSON2ElemArray = genericParseJSON opts2ElemArray
7076gNullaryToJSONTaggedObject :: Nullary -> Value
7177gNullaryToJSONTaggedObject = genericToJSON optsTaggedObject
7278
79+gNullaryToEncodingTaggedObject :: Nullary -> Encoding
80+gNullaryToEncodingTaggedObject = genericToEncoding optsTaggedObject
81+
7382gNullaryParseJSONTaggedObject :: Value -> Parser Nullary
7483gNullaryParseJSONTaggedObject = genericParseJSON optsTaggedObject
7584
@@ -77,6 +86,9 @@ gNullaryParseJSONTaggedObject = genericParseJSON optsTaggedObject
7786gNullaryToJSONObjectWithSingleField :: Nullary -> Value
7887gNullaryToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField
7988
89+gNullaryToEncodingObjectWithSingleField :: Nullary -> Encoding
90+gNullaryToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingleField
91+
8092gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary
8193gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
8294
@@ -121,6 +133,9 @@ thSomeTypeParseJSONObjectWithSingleField =
121133gSomeTypeToJSON2ElemArray :: SomeType Int -> Value
122134gSomeTypeToJSON2ElemArray = genericToJSON opts2ElemArray
123135
136+gSomeTypeToEncoding2ElemArray :: SomeType Int -> Encoding
137+gSomeTypeToEncoding2ElemArray = genericToEncoding opts2ElemArray
138+
124139gSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType Int)
125140gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray
126141
@@ -128,6 +143,9 @@ gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray
128143gSomeTypeToJSONTaggedObject :: SomeType Int -> Value
129144gSomeTypeToJSONTaggedObject = genericToJSON optsTaggedObject
130145
146+gSomeTypeToEncodingTaggedObject :: SomeType Int -> Encoding
147+gSomeTypeToEncodingTaggedObject = genericToEncoding optsTaggedObject
148+
131149gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int)
132150gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject
133151
@@ -135,6 +153,9 @@ gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject
135153gSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value
136154gSomeTypeToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField
137155
156+gSomeTypeToEncodingObjectWithSingleField :: SomeType Int -> Encoding
157+gSomeTypeToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingleField
158+
138159gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int)
139160gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
140161
@@ -165,6 +186,9 @@ thApproxParseJSONDefault = $(mkParseJSON defaultOptions ''Approx)
165186gApproxToJSONUnwrap :: Approx String -> Value
166187gApproxToJSONUnwrap = genericToJSON optsUnwrapUnaryRecords
167188
189+gApproxToEncodingUnwrap :: Approx String -> Encoding
190+gApproxToEncodingUnwrap = genericToEncoding optsUnwrapUnaryRecords
191+
168192gApproxParseJSONUnwrap :: Value -> Parser (Approx String)
169193gApproxParseJSONUnwrap = genericParseJSON optsUnwrapUnaryRecords
170194
@@ -172,6 +196,9 @@ gApproxParseJSONUnwrap = genericParseJSON optsUnwrapUnaryRecords
172196gApproxToJSONDefault :: Approx String -> Value
173197gApproxToJSONDefault = genericToJSON defaultOptions
174198
199+gApproxToEncodingDefault :: Approx String -> Encoding
200+gApproxToEncodingDefault = genericToEncoding defaultOptions
201+
175202gApproxParseJSONDefault :: Value -> Parser (Approx String)
176203gApproxParseJSONDefault = genericParseJSON defaultOptions
177204
tests/Properties.hs+52−1
@@ -112,6 +112,9 @@ isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&
112112 "contents" `H.member` obj
113113isTaggedObjectValue _ = False
114114
115+isNullaryTaggedObject :: Value -> Bool
116+isNullaryTaggedObject obj = isTaggedObject obj && isObjectWithSingleField obj
117+
115118isTaggedObject :: Value -> Bool
116119isTaggedObject (Object obj) = "tag" `H.member` obj
117120isTaggedObject _ = False
@@ -166,12 +169,60 @@ tests = testGroup "properties" [
166169 , testGroup "failure messages" [
167170 testProperty "modify failure" modifyFailureProp
168171 ]
172+ , testGroup "generic" [
173+ testGroup "toJSON" [
174+ testGroup "Nullary" [
175+ testProperty "string" (isString . gNullaryToJSONString)
176+ , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
177+ , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)
178+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
179+ , testGroup "roundTrip" [
180+ testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
181+ , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
182+ , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)
183+ , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
184+ ]
185+ ]
186+ , testGroup "SomeType" [
187+ testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)
188+ , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)
189+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gSomeTypeToJSONObjectWithSingleField)
190+ , testGroup "roundTrip" [
191+ testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)
192+ , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)
193+ , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)
194+ ]
195+ ]
196+ ]
197+ , testGroup "toEncoding" [
198+ testProperty "NullaryString" $
199+ gNullaryToJSONString `sameAs` gNullaryToEncodingString
200+ , testProperty "Nullary2ElemArray" $
201+ gNullaryToJSON2ElemArray `sameAs` gNullaryToEncoding2ElemArray
202+ , testProperty "NullaryTaggedObject" $
203+ gNullaryToJSONTaggedObject `sameAs` gNullaryToEncodingTaggedObject
204+ , testProperty "NullaryObjectWithSingleField" $
205+ gNullaryToJSONObjectWithSingleField `sameAs`
206+ gNullaryToEncodingObjectWithSingleField
207+ -- , testProperty "ApproxUnwrap" $
208+ -- gApproxToJSONUnwrap `sameAs` gApproxToEncodingUnwrap
209+ , testProperty "ApproxDefault" $
210+ gApproxToJSONDefault `sameAs` gApproxToEncodingDefault
211+ , testProperty "SomeType2ElemArray" $
212+ gSomeTypeToJSON2ElemArray `sameAsV` gSomeTypeToEncoding2ElemArray
213+ , testProperty "SomeTypeTaggedObject" $
214+ gSomeTypeToJSONTaggedObject `sameAsV` gSomeTypeToEncodingTaggedObject
215+ , testProperty "SomeTypeObjectWithSingleField" $
216+ gSomeTypeToJSONObjectWithSingleField `sameAsV`
217+ gSomeTypeToEncodingObjectWithSingleField
218+ ]
219+ ]
169220 , testGroup "template-haskell" [
170221 testGroup "toJSON" [
171222 testGroup "Nullary" [
172223 testProperty "string" (isString . thNullaryToJSONString)
173224 , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
174− , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)
225+ , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
175226 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
176227
177228 , testGroup "roundTrip" [