git.iko.soy/typeable/aeson
on master help sign in
Merge pull request #366 from neongreen/master

Fix a bug with generics and single-field records

commit5f93374bde438480a607f833e3ecb97caf4bdc0f authorAdam Bergmark <adam@bergmark.nl> dateSat 7 May 2016, 11:32 (10 years ago) parent29d300ff57c3d3
4 files changed+211−28
compare with master
unifiedsplit
Data/Aeson/Types/Generic.hs+19−16 tests/DataFamilies/Encoders.hs+102 tests/DataFamilies/Properties.hs+74−12 tests/DataFamilies/Types.hs+16
Data/Aeson/Types/Generic.hs+19−16
@@ -247,7 +247,7 @@ instance OVERLAPPING_ TaggedObjectEnc' U1 False where
247247 taggedObjectEnc' _ _ _ = Tagged mempty
248248
249249instance (RecordToEncoding f) => TaggedObjectEnc' f True where
250− taggedObjectEnc' opts _ = Tagged . (\z -> B.char7 ',' <> recordToEncoding opts z)
250+ taggedObjectEnc' opts _ = Tagged . (B.char7 ',' <>) . fst . recordToEncoding opts
251251
252252instance (GToEncoding f) => TaggedObjectEnc' f False where
253253 taggedObjectEnc' opts contentsFieldName =
@@ -339,12 +339,11 @@ instance ( IsRecord f isRecord
339339 . consToEncoding' opts (isUnary (undefined :: f a))
340340
341341instance (RecordToEncoding f) => ConsToEncoding' f True where
342− consToEncoding' opts isUn x
343− | (True,True) <- (unwrapUnaryRecords opts,isUn) = Tagged $ recordToEncoding opts x
344− | otherwise = Tagged $
345− B.char7 '{' <>
346− recordToEncoding opts x <>
347− B.char7 '}'
342+ consToEncoding' opts isUn x =
343+ let (enc, mbVal) = recordToEncoding opts x
344+ in case (unwrapUnaryRecords opts, isUn, mbVal) of
345+ (True, True, Just val) -> Tagged val
346+ _ -> Tagged $ B.char7 '{' <> enc <> B.char7 '}'
348347
349348instance GToEncoding f => ConsToEncoding' f False where
350349 consToEncoding' opts _ = Tagged . gbuilder opts
@@ -375,12 +374,16 @@ fieldToPair opts m1 = pure ( pack $ fieldLabelModifier opts $ selName m1
375374--------------------------------------------------------------------------------
376375
377376class RecordToEncoding f where
378− recordToEncoding :: Options -> f a -> B.Builder
377+ -- 1st element: whole thing
378+ -- 2nd element: in case the record has only 1 field, just the value
379+ -- of the field (without the key); 'Nothing' otherwise
380+ recordToEncoding :: Options -> f a -> (B.Builder, Maybe B.Builder)
379381
380382instance (RecordToEncoding a, RecordToEncoding b) => RecordToEncoding (a :*: b) where
381− recordToEncoding opts (a :*: b) = recordToEncoding opts a <>
382− B.char7 ',' <>
383− recordToEncoding opts b
383+ recordToEncoding opts (a :*: b) =
384+ (fst (recordToEncoding opts a) <> B.char7 ',' <>
385+ fst (recordToEncoding opts b),
386+ Nothing)
384387
385388instance (Selector s, GToEncoding a) => RecordToEncoding (S1 s a) where
386389 recordToEncoding = fieldToEncoding
@@ -388,14 +391,14 @@ instance (Selector s, GToEncoding a) => RecordToEncoding (S1 s a) where
388391instance OVERLAPPING_ (Selector s, ToJSON a) =>
389392 RecordToEncoding (S1 s (K1 i (Maybe a))) where
390393 recordToEncoding opts (M1 k1) | omitNothingFields opts
391− , K1 Nothing <- k1 = mempty
394+ , K1 Nothing <- k1 = (mempty, Nothing)
392395 recordToEncoding opts m1 = fieldToEncoding opts m1
393396
394−fieldToEncoding :: (Selector s, GToEncoding a) => Options -> S1 s a p -> B.Builder
397+fieldToEncoding :: (Selector s, GToEncoding a) => Options -> S1 s a p -> (B.Builder, Maybe B.Builder)
395398fieldToEncoding opts m1 =
396− builder (fieldLabelModifier opts $ selName m1) <>
397− B.char7 ':' <>
398− gbuilder opts (unM1 m1)
399+ let keyBuilder = builder (fieldLabelModifier opts $ selName m1)
400+ valueBuilder = gbuilder opts (unM1 m1)
401+ in (keyBuilder <> B.char7 ':' <> valueBuilder, Just valueBuilder)
399402
400403--------------------------------------------------------------------------------
401404
tests/DataFamilies/Encoders.hs+102
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE GADTs #-}
23{-# LANGUAGE TemplateHaskell #-}
34
@@ -136,3 +137,104 @@ thGADTToEncodingDefault = $(mkToEncoding defaultOptions 'GADT)
136137
137138thGADTParseJSONDefault :: Value -> Parser (GADT String)
138139thGADTParseJSONDefault = $(mkParseJSON defaultOptions 'GADT)
140+
141+--------------------------------------------------------------------------------
142+-- Generic encoders/decoders
143+--------------------------------------------------------------------------------
144+
145+#if __GLASGOW_HASKELL__ >= 706
146+
147+-- Nullary
148+
149+gNullaryToJSONString :: Nullary Int -> Value
150+gNullaryToJSONString = genericToJSON defaultOptions
151+
152+gNullaryToEncodingString :: Nullary Int -> Encoding
153+gNullaryToEncodingString = genericToEncoding defaultOptions
154+
155+gNullaryParseJSONString :: Value -> Parser (Nullary Int)
156+gNullaryParseJSONString = genericParseJSON defaultOptions
157+
158+
159+gNullaryToJSON2ElemArray :: Nullary Int -> Value
160+gNullaryToJSON2ElemArray = genericToJSON opts2ElemArray
161+
162+gNullaryToEncoding2ElemArray :: Nullary Int -> Encoding
163+gNullaryToEncoding2ElemArray = genericToEncoding opts2ElemArray
164+
165+gNullaryParseJSON2ElemArray :: Value -> Parser (Nullary Int)
166+gNullaryParseJSON2ElemArray = genericParseJSON opts2ElemArray
167+
168+
169+gNullaryToJSONTaggedObject :: Nullary Int -> Value
170+gNullaryToJSONTaggedObject = genericToJSON optsTaggedObject
171+
172+gNullaryToEncodingTaggedObject :: Nullary Int -> Encoding
173+gNullaryToEncodingTaggedObject = genericToEncoding optsTaggedObject
174+
175+gNullaryParseJSONTaggedObject :: Value -> Parser (Nullary Int)
176+gNullaryParseJSONTaggedObject = genericParseJSON optsTaggedObject
177+
178+
179+gNullaryToJSONObjectWithSingleField :: Nullary Int -> Value
180+gNullaryToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField
181+
182+gNullaryToEncodingObjectWithSingleField :: Nullary Int -> Encoding
183+gNullaryToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingleField
184+
185+gNullaryParseJSONObjectWithSingleField :: Value -> Parser (Nullary Int)
186+gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
187+
188+-- SomeType
189+
190+gSomeTypeToJSON2ElemArray :: SomeType c () Int -> Value
191+gSomeTypeToJSON2ElemArray = genericToJSON opts2ElemArray
192+
193+gSomeTypeToEncoding2ElemArray :: SomeType c () Int -> Encoding
194+gSomeTypeToEncoding2ElemArray = genericToEncoding opts2ElemArray
195+
196+gSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType c () Int)
197+gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray
198+
199+
200+gSomeTypeToJSONTaggedObject :: SomeType c () Int -> Value
201+gSomeTypeToJSONTaggedObject = genericToJSON optsTaggedObject
202+
203+gSomeTypeToEncodingTaggedObject :: SomeType c () Int -> Encoding
204+gSomeTypeToEncodingTaggedObject = genericToEncoding optsTaggedObject
205+
206+gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType c () Int)
207+gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject
208+
209+
210+gSomeTypeToJSONObjectWithSingleField :: SomeType c () Int -> Value
211+gSomeTypeToJSONObjectWithSingleField = genericToJSON optsObjectWithSingleField
212+
213+gSomeTypeToEncodingObjectWithSingleField :: SomeType c () Int -> Encoding
214+gSomeTypeToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingleField
215+
216+gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType c () Int)
217+gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField
218+
219+-- Approx
220+
221+gApproxToJSONUnwrap :: Approx String -> Value
222+gApproxToJSONUnwrap = genericToJSON optsUnwrapUnaryRecords
223+
224+gApproxToEncodingUnwrap :: Approx String -> Encoding
225+gApproxToEncodingUnwrap = genericToEncoding optsUnwrapUnaryRecords
226+
227+gApproxParseJSONUnwrap :: Value -> Parser (Approx String)
228+gApproxParseJSONUnwrap = genericParseJSON optsUnwrapUnaryRecords
229+
230+
231+gApproxToJSONDefault :: Approx String -> Value
232+gApproxToJSONDefault = genericToJSON defaultOptions
233+
234+gApproxToEncodingDefault :: Approx String -> Encoding
235+gApproxToEncodingDefault = genericToEncoding defaultOptions
236+
237+gApproxParseJSONDefault :: Value -> Parser (Approx String)
238+gApproxParseJSONDefault = genericParseJSON defaultOptions
239+
240+#endif
tests/DataFamilies/Properties.hs+74−12
@@ -1,3 +1,5 @@
1+{-# LANGUAGE CPP #-}
2+
13module DataFamilies.Properties (tests) where
24
35import DataFamilies.Encoders
@@ -12,14 +14,13 @@ import Test.Framework.Providers.QuickCheck2 (testProperty)
1214
1315tests :: Test
1416tests = testGroup "data families" [
15− testGroup "template-haskell" [
17+ testGroup "template-haskell" [
1618 testGroup "toJSON" [
1719 testGroup "Nullary" [
1820 testProperty "string" (isString . thNullaryToJSONString)
1921 , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
2022 , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
2123 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
22−
2324 , testGroup "roundTrip" [
2425 testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)
2526 , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
@@ -36,21 +37,21 @@ tests = testGroup "data families" [
3637 , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)
3738 , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)
3839 ]
40+ ]
3941 , testGroup "Approx" [
40− testProperty "string" (isString . thApproxToJSONUnwrap)
41− , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)
42− , testGroup "roundTrip" [
43− testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)
44− , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
45− ]
46− ]
42+ testProperty "string" (isString . thApproxToJSONUnwrap)
43+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)
44+ , testGroup "roundTrip" [
45+ testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)
46+ , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
47+ ]
48+ ]
4749 , testGroup "GADT" [
4850 testProperty "string" (isString . thGADTToJSONUnwrap)
4951 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)
5052 , testGroup "roundTrip" [
51− testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)
52− , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)
53− ]
53+ testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)
54+ , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)
5455 ]
5556 ]
5657 ]
@@ -77,4 +78,65 @@ tests = testGroup "data families" [
7778 thSomeTypeToEncodingObjectWithSingleField
7879 ]
7980 ]
81+
82+-- We only test generic instances for GHC 7.6 and higher because GHC 7.4 has
83+-- a bug concerning generics and data families
84+#if __GLASGOW_HASKELL__ >= 706
85+ , testGroup "generics" [
86+ testGroup "toJSON" [
87+ testGroup "Nullary" [
88+ testProperty "string" (isString . gNullaryToJSONString)
89+ , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)
90+ , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)
91+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)
92+ , testGroup "roundTrip" [
93+ testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)
94+ , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)
95+ , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)
96+ , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)
97+ ]
98+ ]
99+ , testGroup "SomeType" [
100+ testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)
101+ , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)
102+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gSomeTypeToJSONObjectWithSingleField)
103+ , testGroup "roundTrip" [
104+ testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)
105+ , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)
106+ , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)
107+ ]
108+ ]
109+ , testGroup "Approx" [
110+ testProperty "string" (isString . gApproxToJSONUnwrap)
111+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gApproxToJSONDefault)
112+ , testGroup "roundTrip" [
113+ testProperty "string" (toParseJSON gApproxParseJSONUnwrap gApproxToJSONUnwrap)
114+ , testProperty "ObjectWithSingleField" (toParseJSON gApproxParseJSONDefault gApproxToJSONDefault)
115+ ]
116+ ]
117+ ]
118+ , testGroup "toEncoding" [
119+ testProperty "NullaryString" $
120+ gNullaryToJSONString `sameAs` gNullaryToEncodingString
121+ , testProperty "Nullary2ElemArray" $
122+ gNullaryToJSON2ElemArray `sameAs` gNullaryToEncoding2ElemArray
123+ , testProperty "NullaryTaggedObject" $
124+ gNullaryToJSONTaggedObject `sameAs` gNullaryToEncodingTaggedObject
125+ , testProperty "NullaryObjectWithSingleField" $
126+ gNullaryToJSONObjectWithSingleField `sameAs`
127+ gNullaryToEncodingObjectWithSingleField
128+ , testProperty "ApproxUnwrap" $
129+ gApproxToJSONUnwrap `sameAs` gApproxToEncodingUnwrap
130+ , testProperty "ApproxDefault" $
131+ gApproxToJSONDefault `sameAs` gApproxToEncodingDefault
132+ , testProperty "SomeType2ElemArray" $
133+ gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray
134+ , testProperty "SomeTypeTaggedObject" $
135+ gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject
136+ , testProperty "SomeTypeObjectWithSingleField" $
137+ gSomeTypeToJSONObjectWithSingleField `sameAs`
138+ gSomeTypeToEncodingObjectWithSingleField
139+ ]
140+ ]
141+#endif
80142 ]
tests/DataFamilies/Types.hs+16
@@ -1,13 +1,19 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE FlexibleInstances #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE GeneralizedNewtypeDeriving #-}
45{-# LANGUAGE StandaloneDeriving #-}
6+{-# LANGUAGE DeriveGeneric #-}
57{-# LANGUAGE TypeFamilies #-}
68
79module DataFamilies.Types where
810
911import Types (ApproxEq(..))
1012
13+#if __GLASGOW_HASKELL__ >= 706
14+import GHC.Generics
15+#endif
16+
1117data family Nullary a
1218data instance Nullary Int = C1 | C2 | C3 deriving (Eq, Show)
1319data instance Nullary Char = C4 deriving (Eq, Show)
@@ -34,3 +40,13 @@ data instance GADT a where
3440
3541deriving instance Eq (GADT a)
3642deriving instance Show (GADT a)
43+
44+-- We only derive instances for GHC 7.6 and higher because GHC 7.4 has a bug
45+-- concerning generics and data families
46+
47+#if __GLASGOW_HASKELL__ >= 706
48+deriving instance Generic (Nullary Int)
49+deriving instance Generic (Nullary Char)
50+deriving instance Generic (SomeType c () a)
51+deriving instance Generic (Approx a)
52+#endif