git.iko.soy/typeable/aeson
on master help sign in
Merge pull request #335 from RyanGlScott/master
ac6b303Bryan O'Sullivan
Data/Aeson.hs+1
compare with master
unifiedsplit
@@ -60,6 +60,7 @@ module Data.Aeson
60 -- ** Generic JSON classes and options
60 -- ** Generic JSON classes and options
61 , GFromJSON(..)
61 , GFromJSON(..)
62 , GToJSON(..)
62 , GToJSON(..)
63+ , GToEncoding(..)
63 , genericToJSON
64 , genericToJSON
64 , genericToEncoding
65 , genericToEncoding
65 , genericParseJSON
66 , genericParseJSON
Data/Aeson/Types.hs+1
@@ -39,6 +39,7 @@ module Data.Aeson.Types
39 -- ** Generic JSON classes
39 -- ** Generic JSON classes
40 , GFromJSON(..)
40 , GFromJSON(..)
41 , GToJSON(..)
41 , GToJSON(..)
42+ , GToEncoding(..)
42 , genericToJSON
43 , genericToJSON
43 , genericToEncoding
44 , genericToEncoding
44 , genericParseJSON
45 , genericParseJSON
Data/Aeson/Types/Class.hs+5−1
@@ -19,6 +19,7 @@ module Data.Aeson.Types.Class
19 -- * Generic JSON classes
19 -- * Generic JSON classes
20 , GFromJSON(..)
20 , GFromJSON(..)
21 , GToJSON(..)
21 , GToJSON(..)
22+ , GToEncoding(..)
22 , genericToJSON
23 , genericToJSON
23 , genericToEncoding
24 , genericToEncoding
24 , genericParseJSON
25 , genericParseJSON
@@ -40,6 +41,9 @@ class GToJSON f where
40 -- default generic implementation of 'toJSON'.
41 -- default generic implementation of 'toJSON'.
41 gToJSON :: Options -> f a -> Value
42 gToJSON :: Options -> f a -> Value
42
43
44+-- | Class of generic representation types ('Rep') that can be converted to
45+-- a JSON 'Encoding'.
46+class GToEncoding f where
43 -- | This method (applied to 'defaultOptions') can be used as the
47 -- | This method (applied to 'defaultOptions') can be used as the
44 -- default generic implementation of 'toEncoding'.
48 -- default generic implementation of 'toEncoding'.
45 gToEncoding :: Options -> f a -> Encoding
49 gToEncoding :: Options -> f a -> Encoding
@@ -59,7 +63,7 @@ genericToJSON opts = gToJSON opts . from
59-- | A configurable generic JSON encoder. This function applied to
63-- | A configurable generic JSON encoder. This function applied to
60-- 'defaultOptions' is used as the default for 'toEncoding' when the type
64-- 'defaultOptions' is used as the default for 'toEncoding' when the type
61-- is an instance of 'Generic'.
65-- is an instance of 'Generic'.
62−genericToEncoding :: (Generic a, GToJSON (Rep a)) => Options -> a -> Encoding
66+genericToEncoding :: (Generic a, GToEncoding (Rep a)) => Options -> a -> Encoding
63genericToEncoding opts = gToEncoding opts . from
67genericToEncoding opts = gToEncoding opts . from
64
68
65-- | A configurable generic JSON decoder. This function applied to
69-- | A configurable generic JSON decoder. This function applied to
Data/Aeson/Types/Generic.hs+187−182
@@ -50,35 +50,19 @@ import Data.Monoid (mempty)
50instance OVERLAPPABLE_ (GToJSON a) => GToJSON (M1 i c a) where
50instance OVERLAPPABLE_ (GToJSON a) => GToJSON (M1 i c a) where
51 -- Meta-information, which is not handled elsewhere, is ignored:
51 -- Meta-information, which is not handled elsewhere, is ignored:
52 gToJSON opts = gToJSON opts . unM1
52 gToJSON opts = gToJSON opts . unM1
53− {-# INLINE gToJSON #-}
54−
55− gToEncoding opts = gToEncoding opts . unM1
56− {-# INLINE gToEncoding #-}
57
53
58instance (ToJSON a) => GToJSON (K1 i a) where
54instance (ToJSON a) => GToJSON (K1 i a) where
59 -- Constant values are encoded using their ToJSON instance:
55 -- Constant values are encoded using their ToJSON instance:
60 gToJSON _opts = toJSON . unK1
56 gToJSON _opts = toJSON . unK1
61− {-# INLINE gToJSON #-}
62−
63− gToEncoding _opts = toEncoding . unK1
64− {-# INLINE gToEncoding #-}
65
57
66instance GToJSON U1 where
58instance GToJSON U1 where
67 -- Empty constructors are encoded to an empty array:
59 -- Empty constructors are encoded to an empty array:
68 gToJSON _opts _ = emptyArray
60 gToJSON _opts _ = emptyArray
69− {-# INLINE gToJSON #-}
70−
71− gToEncoding _opts _ = emptyArray_
72− {-# INLINE gToEncoding #-}
73
61
74instance (ConsToJSON a) => GToJSON (C1 c a) where
62instance (ConsToJSON a) => GToJSON (C1 c a) where
75 -- Constructors need to be encoded differently depending on whether they're
63 -- Constructors need to be encoded differently depending on whether they're
76 -- a record or not. This distinction is made by 'consToJSON':
64 -- a record or not. This distinction is made by 'consToJSON':
77 gToJSON opts = consToJSON opts . unM1
65 gToJSON opts = consToJSON opts . unM1
78− {-# INLINE gToJSON #-}
79−
80− gToEncoding opts = Encoding . consToEncoding opts . unM1
81− {-# INLINE gToEncoding #-}
82
66
83instance ( WriteProduct a, WriteProduct b
67instance ( WriteProduct a, WriteProduct b
84 , ProductSize a, ProductSize b ) => GToJSON (a :*: b) where
68 , ProductSize a, ProductSize b ) => GToJSON (a :*: b) where
@@ -93,10 +77,6 @@ instance ( WriteProduct a, WriteProduct b
93 where
77 where
94 lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
78 lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
95 productSize
79 productSize
96− {-# INLINE gToJSON #-}
97−
98− gToEncoding opts p = Encoding $
99− B.char7 '[' <> encodeProduct opts p <> B.char7 ']'
100
80
101instance ( AllNullary (a :+: b) allNullary
81instance ( AllNullary (a :+: b) allNullary
102 , SumToJSON (a :+: b) allNullary ) => GToJSON (a :+: b) where
82 , SumToJSON (a :+: b) allNullary ) => GToJSON (a :+: b) where
@@ -105,46 +85,65 @@ instance ( AllNullary (a :+: b) allNullary
105 -- strings. This distinction is made by 'sumToJSON':
85 -- strings. This distinction is made by 'sumToJSON':
106 gToJSON opts = (unTagged :: Tagged allNullary Value -> Value)
86 gToJSON opts = (unTagged :: Tagged allNullary Value -> Value)
107 . sumToJSON opts
87 . sumToJSON opts
108− {-# INLINE gToJSON #-}
109
88
89+--------------------------------------------------------------------------------
90+-- Generic toEncoding
91+
92+instance OVERLAPPABLE_ (GToEncoding a) => GToEncoding (M1 i c a) where
93+ -- Meta-information, which is not handled elsewhere, is ignored:
94+ gToEncoding opts = gToEncoding opts . unM1
95+
96+instance (ToJSON a) => GToEncoding (K1 i a) where
97+ -- Constant values are encoded using their ToJSON instance:
98+ gToEncoding _opts = toEncoding . unK1
99+
100+instance GToEncoding U1 where
101+ -- Empty constructors are encoded to an empty array:
102+ gToEncoding _opts _ = emptyArray_
103+
104+instance (ConsToEncoding a) => GToEncoding (C1 c a) where
105+ -- Constructors need to be encoded differently depending on whether they're
106+ -- a record or not. This distinction is made by 'consToEncoding':
107+ gToEncoding opts = Encoding . consToEncoding opts . unM1
108+
109+instance ( EncodeProduct a, EncodeProduct b ) => GToEncoding (a :*: b) where
110+ -- Products are encoded to an array. Here we allocate a mutable vector of
111+ -- the same size as the product and write the product's elements to it using
112+ -- 'encodeProduct':
113+ gToEncoding opts p = Encoding $
114+ B.char7 '[' <> encodeProduct opts p <> B.char7 ']'
115+
116+instance ( AllNullary (a :+: b) allNullary
117+ , SumToEncoding (a :+: b) allNullary ) => GToEncoding (a :+: b) where
118+ -- If all constructors of a sum datatype are nullary and the
119+ -- 'allNullaryToStringTag' option is set they are encoded to
120+ -- strings. This distinction is made by 'sumToEncoding':
110 gToEncoding opts = Encoding .
121 gToEncoding opts = Encoding .
111 (unTagged :: Tagged allNullary B.Builder -> B.Builder) .
122 (unTagged :: Tagged allNullary B.Builder -> B.Builder) .
112 sumToEncoding opts
123 sumToEncoding opts
113− {-# INLINE gToEncoding #-}
114
124
115--------------------------------------------------------------------------------
125--------------------------------------------------------------------------------
116
126
117class SumToJSON f allNullary where
127class SumToJSON f allNullary where
118 sumToJSON :: Options -> f a -> Tagged allNullary Value
128 sumToJSON :: Options -> f a -> Tagged allNullary Value
119− sumToEncoding :: Options -> f a -> Tagged allNullary B.Builder
120
129
121−instance ( GetConName f
130+instance ( GetConName f
122− , TaggedObject f
131+ , TaggedObjectPairs f
123− , ObjectWithSingleField f
132+ , ObjectWithSingleFieldObj f
124− , TwoElemArray f ) => SumToJSON f True where
133+ , TwoElemArrayObj f ) => SumToJSON f True where
125 sumToJSON opts
134 sumToJSON opts
126 | allNullaryToStringTag opts = Tagged . String . pack
135 | allNullaryToStringTag opts = Tagged . String . pack
127 . constructorTagModifier opts . getConName
136 . constructorTagModifier opts . getConName
128 | otherwise = Tagged . nonAllNullarySumToJSON opts
137 | otherwise = Tagged . nonAllNullarySumToJSON opts
129− {-# INLINE sumToJSON #-}
130−
131− sumToEncoding opts
132− | allNullaryToStringTag opts = Tagged . builder .
133− constructorTagModifier opts . getConName
134− | otherwise = Tagged . nonAllNullarySumToEncoding opts
135− {-# INLINE sumToEncoding #-}
136
138
137−instance ( TwoElemArray f
139+instance ( TwoElemArrayObj f
138− , TaggedObject f
140+ , TaggedObjectPairs f
139− , ObjectWithSingleField f ) => SumToJSON f False where
141+ , ObjectWithSingleFieldObj f ) => SumToJSON f False where
140 sumToJSON opts = Tagged . nonAllNullarySumToJSON opts
142 sumToJSON opts = Tagged . nonAllNullarySumToJSON opts
141− {-# INLINE sumToJSON #-}
142− sumToEncoding opts = Tagged . nonAllNullarySumToEncoding opts
143− {-# INLINE sumToEncoding #-}
144
143
145−nonAllNullarySumToJSON :: ( TwoElemArray f
144+nonAllNullarySumToJSON :: ( TwoElemArrayObj f
146− , TaggedObject f
145+ , TaggedObjectPairs f
147− , ObjectWithSingleField f
146+ , ObjectWithSingleFieldObj f
148 ) => Options -> f a -> Value
147 ) => Options -> f a -> Value
149nonAllNullarySumToJSON opts =
148nonAllNullarySumToJSON opts =
150 case sumEncoding opts of
149 case sumEncoding opts of
@@ -152,50 +151,83 @@ nonAllNullarySumToJSON opts =
152 object . taggedObjectPairs opts tagFieldName contentsFieldName
151 object . taggedObjectPairs opts tagFieldName contentsFieldName
153 ObjectWithSingleField -> Object . objectWithSingleFieldObj opts
152 ObjectWithSingleField -> Object . objectWithSingleFieldObj opts
154 TwoElemArray -> Array . twoElemArrayObj opts
153 TwoElemArray -> Array . twoElemArrayObj opts
155−{-# INLINE nonAllNullarySumToJSON #-}
156
154
155+--------------------------------------------------------------------------------
156+
157+class SumToEncoding f allNullary where
158+ sumToEncoding :: Options -> f a -> Tagged allNullary B.Builder
159+
160+instance ( GetConName f
161+ , TaggedObjectEnc f
162+ , ObjectWithSingleFieldEnc f
163+ , TwoElemArrayEnc f ) => SumToEncoding f True where
164+ sumToEncoding opts
165+ | allNullaryToStringTag opts = Tagged . builder .
166+ constructorTagModifier opts . getConName
157−nonAllNullarySumToEncoding :: ( TwoElemArray f
167+ | otherwise = Tagged . nonAllNullarySumToEncoding opts
158− , TaggedObject f
168+
159− , ObjectWithSingleField f
169+instance ( TwoElemArrayEnc f
170+ , TaggedObjectEnc f
171+ , ObjectWithSingleFieldEnc f ) => SumToEncoding f False where
172+ sumToEncoding opts = Tagged . nonAllNullarySumToEncoding opts
173+
174+nonAllNullarySumToEncoding :: ( TwoElemArrayEnc f
175+ , TaggedObjectEnc f
176+ , ObjectWithSingleFieldEnc f
160− ) => Options -> f a -> B.Builder
177+ ) => Options -> f a -> B.Builder
161nonAllNullarySumToEncoding opts =
178nonAllNullarySumToEncoding opts =
162 case sumEncoding opts of
179 case sumEncoding opts of
163 TaggedObject{..} ->
180 TaggedObject{..} ->
164 taggedObjectEnc opts tagFieldName contentsFieldName
181 taggedObjectEnc opts tagFieldName contentsFieldName
165 ObjectWithSingleField -> objectWithSingleFieldEnc opts
182 ObjectWithSingleField -> objectWithSingleFieldEnc opts
166 TwoElemArray -> twoElemArrayEnc opts
183 TwoElemArray -> twoElemArrayEnc opts
167−{-# INLINE nonAllNullarySumToEncoding #-}
168
184
169--------------------------------------------------------------------------------
185--------------------------------------------------------------------------------
170
186
171−class TaggedObject f where
187+class TaggedObjectPairs f where
172 taggedObjectPairs :: Options -> String -> String -> f a -> [Pair]
188 taggedObjectPairs :: Options -> String -> String -> f a -> [Pair]
173− taggedObjectEnc :: Options -> String -> String -> f a -> B.Builder
174
189
175−instance ( TaggedObject a
190+instance ( TaggedObjectPairs a
176− , TaggedObject b ) => TaggedObject (a :+: b) where
191+ , TaggedObjectPairs b ) => TaggedObjectPairs (a :+: b) where
177 taggedObjectPairs opts tagFieldName contentsFieldName (L1 x) =
192 taggedObjectPairs opts tagFieldName contentsFieldName (L1 x) =
178 taggedObjectPairs opts tagFieldName contentsFieldName x
193 taggedObjectPairs opts tagFieldName contentsFieldName x
179 taggedObjectPairs opts tagFieldName contentsFieldName (R1 x) =
194 taggedObjectPairs opts tagFieldName contentsFieldName (R1 x) =
180 taggedObjectPairs opts tagFieldName contentsFieldName x
195 taggedObjectPairs opts tagFieldName contentsFieldName x
181− {-# INLINE taggedObjectPairs #-}
182−
183− taggedObjectEnc opts tagFieldName contentsFieldName (L1 x) =
184− taggedObjectEnc opts tagFieldName contentsFieldName x
185− taggedObjectEnc opts tagFieldName contentsFieldName (R1 x) =
186− taggedObjectEnc opts tagFieldName contentsFieldName x
187− {-# INLINE taggedObjectEnc #-}
188
196
189−instance ( IsRecord a isRecord
197+instance ( IsRecord a isRecord
190− , TaggedObject' a isRecord
198+ , TaggedObjectPairs' a isRecord
191− , Constructor c ) => TaggedObject (C1 c a) where
199+ , Constructor c ) => TaggedObjectPairs (C1 c a) where
192 taggedObjectPairs opts tagFieldName contentsFieldName =
200 taggedObjectPairs opts tagFieldName contentsFieldName =
193 (pack tagFieldName .= constructorTagModifier opts
201 (pack tagFieldName .= constructorTagModifier opts
194 (conName (undefined :: t c a p)) :) .
202 (conName (undefined :: t c a p)) :) .
195 (unTagged :: Tagged isRecord [Pair] -> [Pair]) .
203 (unTagged :: Tagged isRecord [Pair] -> [Pair]) .
196 taggedObjectPairs' opts contentsFieldName . unM1
204 taggedObjectPairs' opts contentsFieldName . unM1
197− {-# INLINE taggedObjectPairs #-}
198
205
206+class TaggedObjectPairs' f isRecord where
207+ taggedObjectPairs' :: Options -> String -> f a -> Tagged isRecord [Pair]
208+
209+instance (RecordToPairs f) => TaggedObjectPairs' f True where
210+ taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts
211+
212+instance (GToJSON f) => TaggedObjectPairs' f False where
213+ taggedObjectPairs' opts contentsFieldName =
214+ Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts
215+
216+--------------------------------------------------------------------------------
217+
218+class TaggedObjectEnc f where
219+ taggedObjectEnc :: Options -> String -> String -> f a -> B.Builder
220+
221+instance ( TaggedObjectEnc a
222+ , TaggedObjectEnc b ) => TaggedObjectEnc (a :+: b) where
223+ taggedObjectEnc opts tagFieldName contentsFieldName (L1 x) =
224+ taggedObjectEnc opts tagFieldName contentsFieldName x
225+ taggedObjectEnc opts tagFieldName contentsFieldName (R1 x) =
226+ taggedObjectEnc opts tagFieldName contentsFieldName x
227+
228+instance ( IsRecord a isRecord
229+ , TaggedObjectEnc' a isRecord
230+ , Constructor c ) => TaggedObjectEnc (C1 c a) where
199 taggedObjectEnc opts tagFieldName contentsFieldName v =
231 taggedObjectEnc opts tagFieldName contentsFieldName v =
200 B.char7 '{' <>
232 B.char7 '{' <>
201 (builder tagFieldName <>
233 (builder tagFieldName <>
@@ -205,28 +237,17 @@ instance ( IsRecord a isRecord
205 ((unTagged :: Tagged isRecord B.Builder -> B.Builder) .
237 ((unTagged :: Tagged isRecord B.Builder -> B.Builder) .
206 taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>
238 taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>
207 B.char7 '}'
239 B.char7 '}'
208− {-# INLINE taggedObjectEnc #-}
209
240
210−class TaggedObject' f isRecord where
241+class TaggedObjectEnc' f isRecord where
211− taggedObjectPairs' :: Options -> String -> f a -> Tagged isRecord [Pair]
212 taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord B.Builder
242 taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord B.Builder
213
243
214−instance (RecordTo f) => TaggedObject' f True where
244+instance (RecordToEncoding f) => TaggedObjectEnc' f True where
215− taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts
216− {-# INLINE taggedObjectPairs' #-}
217−
218 taggedObjectEnc' opts _ = Tagged . recordToEncoding opts
245 taggedObjectEnc' opts _ = Tagged . recordToEncoding opts
219− {-# INLINE taggedObjectEnc' #-}
220−
221−instance (GToJSON f) => TaggedObject' f False where
222− taggedObjectPairs' opts contentsFieldName =
223− Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts
224− {-# INLINE taggedObjectPairs' #-}
225
246
247+instance (GToEncoding f) => TaggedObjectEnc' f False where
226 taggedObjectEnc' opts contentsFieldName =
248 taggedObjectEnc' opts contentsFieldName =
227 Tagged . (\z -> builder contentsFieldName <> B.char7 ':' <> z) .
249 Tagged . (\z -> builder contentsFieldName <> B.char7 ':' <> z) .
228 gbuilder opts
250 gbuilder opts
229− {-# INLINE taggedObjectEnc' #-}
230
251
231--------------------------------------------------------------------------------
252--------------------------------------------------------------------------------
232
253
@@ -237,133 +258,139 @@ class GetConName f where
237instance (GetConName a, GetConName b) => GetConName (a :+: b) where
258instance (GetConName a, GetConName b) => GetConName (a :+: b) where
238 getConName (L1 x) = getConName x
259 getConName (L1 x) = getConName x
239 getConName (R1 x) = getConName x
260 getConName (R1 x) = getConName x
240− {-# INLINE getConName #-}
241
261
242−instance (Constructor c, GToJSON a, ConsToJSON a) => GetConName (C1 c a) where
262+instance (Constructor c) => GetConName (C1 c a) where
243 getConName = conName
263 getConName = conName
244− {-# INLINE getConName #-}
245
264
246--------------------------------------------------------------------------------
265--------------------------------------------------------------------------------
247
266
248−class TwoElemArray f where
267+class TwoElemArrayObj f where
249 twoElemArrayObj :: Options -> f a -> V.Vector Value
268 twoElemArrayObj :: Options -> f a -> V.Vector Value
250− twoElemArrayEnc :: Options -> f a -> B.Builder
251
269
252−instance (TwoElemArray a, TwoElemArray b) => TwoElemArray (a :+: b) where
270+instance (TwoElemArrayObj a, TwoElemArrayObj b) => TwoElemArrayObj (a :+: b) where
253 twoElemArrayObj opts (L1 x) = twoElemArrayObj opts x
271 twoElemArrayObj opts (L1 x) = twoElemArrayObj opts x
254 twoElemArrayObj opts (R1 x) = twoElemArrayObj opts x
272 twoElemArrayObj opts (R1 x) = twoElemArrayObj opts x
255− {-# INLINE twoElemArrayObj #-}
256−
257− twoElemArrayEnc opts (L1 x) = twoElemArrayEnc opts x
258− twoElemArrayEnc opts (R1 x) = twoElemArrayEnc opts x
259− {-# INLINE twoElemArrayEnc #-}
260
273
261instance ( GToJSON a, ConsToJSON a
274instance ( GToJSON a, ConsToJSON a
262− , Constructor c ) => TwoElemArray (C1 c a) where
275+ , Constructor c ) => TwoElemArrayObj (C1 c a) where
263 twoElemArrayObj opts x = V.create $ do
276 twoElemArrayObj opts x = V.create $ do
264 mv <- VM.unsafeNew 2
277 mv <- VM.unsafeNew 2
265 VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts
278 VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts
266 $ conName (undefined :: t c a p)
279 $ conName (undefined :: t c a p)
267 VM.unsafeWrite mv 1 $ gToJSON opts x
280 VM.unsafeWrite mv 1 $ gToJSON opts x
268 return mv
281 return mv
269− {-# INLINE twoElemArrayObj #-}
270
282
283+--------------------------------------------------------------------------------
284+
285+class TwoElemArrayEnc f where
286+ twoElemArrayEnc :: Options -> f a -> B.Builder
287+
288+instance (TwoElemArrayEnc a, TwoElemArrayEnc b) => TwoElemArrayEnc (a :+: b) where
289+ twoElemArrayEnc opts (L1 x) = twoElemArrayEnc opts x
290+ twoElemArrayEnc opts (R1 x) = twoElemArrayEnc opts x
291+
292+instance ( GToEncoding a, ConsToEncoding a
293+ , Constructor c ) => TwoElemArrayEnc (C1 c a) where
271 twoElemArrayEnc opts x = fromEncoding . tuple $
294 twoElemArrayEnc opts x = fromEncoding . tuple $
272 builder (constructorTagModifier opts (conName (undefined :: t c a p))) >*<
295 builder (constructorTagModifier opts (conName (undefined :: t c a p))) >*<
273 gbuilder opts x
296 gbuilder opts x
274− {-# INLINE twoElemArrayEnc #-}
275
297
276--------------------------------------------------------------------------------
298--------------------------------------------------------------------------------
277
299
278class ConsToJSON f where
300class ConsToJSON f where
279 consToJSON :: Options -> f a -> Value
301 consToJSON :: Options -> f a -> Value
280− consToEncoding :: Options -> f a -> B.Builder
281
302
282class ConsToJSON' f isRecord where
303class ConsToJSON' f isRecord where
283 consToJSON' :: Options -> Bool -- ^ Are we a record with one field?
304 consToJSON' :: Options -> Bool -- ^ Are we a record with one field?
284 -> f a -> Tagged isRecord Value
305 -> f a -> Tagged isRecord Value
285− consToEncoding' :: Options -> Bool -- ^ Are we a record with one field?
286− -> f a -> Tagged isRecord B.Builder
287
306
288instance ( IsRecord f isRecord
307instance ( IsRecord f isRecord
289 , ConsToJSON' f isRecord ) => ConsToJSON f where
308 , ConsToJSON' f isRecord ) => ConsToJSON f where
290 consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)
309 consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)
291 . consToJSON' opts (isUnary (undefined :: f a))
310 . consToJSON' opts (isUnary (undefined :: f a))
292− {-# INLINE consToJSON #-}
293−
294− consToEncoding opts = (unTagged :: Tagged isRecord B.Builder -> B.Builder)
295− . consToEncoding' opts (isUnary (undefined :: f a))
296− {-# INLINE consToEncoding #-}
297
311
298−instance (RecordTo f) => ConsToJSON' f True where
312+instance (RecordToPairs f) => ConsToJSON' f True where
299 consToJSON' opts isUn f = let
313 consToJSON' opts isUn f = let
300 vals = toList $ recordToPairs opts f
314 vals = toList $ recordToPairs opts f
301 in case (unwrapUnaryRecords opts,isUn,vals) of
315 in case (unwrapUnaryRecords opts,isUn,vals) of
302 (True,True,[(_,val)]) -> Tagged val
316 (True,True,[(_,val)]) -> Tagged val
303 _ -> Tagged $ object vals
317 _ -> Tagged $ object vals
304− {-# INLINE consToJSON' #-}
305
318
319+instance GToJSON f => ConsToJSON' f False where
320+ consToJSON' opts _ = Tagged . gToJSON opts
321+
322+--------------------------------------------------------------------------------
323+
324+class ConsToEncoding f where
325+ consToEncoding :: Options -> f a -> B.Builder
326+
327+class ConsToEncoding' f isRecord where
328+ consToEncoding' :: Options -> Bool -- ^ Are we a record with one field?
329+ -> f a -> Tagged isRecord B.Builder
330+
331+instance ( IsRecord f isRecord
332+ , ConsToEncoding' f isRecord ) => ConsToEncoding f where
333+ consToEncoding opts = (unTagged :: Tagged isRecord B.Builder -> B.Builder)
334+ . consToEncoding' opts (isUnary (undefined :: f a))
335+
336+instance (RecordToEncoding f) => ConsToEncoding' f True where
306 consToEncoding' opts isUn x
337 consToEncoding' opts isUn x
307 | (True,True) <- (unwrapUnaryRecords opts,isUn) = Tagged $ recordToEncoding opts x
338 | (True,True) <- (unwrapUnaryRecords opts,isUn) = Tagged $ recordToEncoding opts x
308 | otherwise = Tagged $
339 | otherwise = Tagged $
309 B.char7 '{' <>
340 B.char7 '{' <>
310 recordToEncoding opts x <>
341 recordToEncoding opts x <>
311 B.char7 '}'
342 B.char7 '}'
312− {-# INLINE consToEncoding' #-}
313
343
314−instance GToJSON f => ConsToJSON' f False where
344+instance GToEncoding f => ConsToEncoding' f False where
315− consToJSON' opts _ = Tagged . gToJSON opts
316− {-# INLINE consToJSON' #-}
317 consToEncoding' opts _ = Tagged . gbuilder opts
345 consToEncoding' opts _ = Tagged . gbuilder opts
318− {-# INLINE consToEncoding' #-}
319
346
320--------------------------------------------------------------------------------
347--------------------------------------------------------------------------------
321
348
322−class RecordTo f where
349+class RecordToPairs f where
323 recordToPairs :: Options -> f a -> DList Pair
350 recordToPairs :: Options -> f a -> DList Pair
324− recordToEncoding :: Options -> f a -> B.Builder
325
351
326−instance (RecordTo a, RecordTo b) => RecordTo (a :*: b) where
352+instance (RecordToPairs a, RecordToPairs b) => RecordToPairs (a :*: b) where
327 recordToPairs opts (a :*: b) = recordToPairs opts a <>
353 recordToPairs opts (a :*: b) = recordToPairs opts a <>
328 recordToPairs opts b
354 recordToPairs opts b
329− {-# INLINE recordToPairs #-}
330−
331− recordToEncoding opts (a :*: b) = recordToEncoding opts a <>
332− B.char7 ',' <>
333− recordToEncoding opts b
334− {-# INLINE recordToEncoding #-}
335
355
336−instance (Selector s, GToJSON a) => RecordTo (S1 s a) where
356+instance (Selector s, GToJSON a) => RecordToPairs (S1 s a) where
337 recordToPairs = fieldToPair
357 recordToPairs = fieldToPair
338− {-# INLINE recordToPairs #-}
339−
340− recordToEncoding = fieldToEncoding
341− {-# INLINE recordToEncoding #-}
342
358
343instance OVERLAPPING_ (Selector s, ToJSON a) =>
359instance OVERLAPPING_ (Selector s, ToJSON a) =>
344− RecordTo (S1 s (K1 i (Maybe a))) where
360+ RecordToPairs (S1 s (K1 i (Maybe a))) where
345 recordToPairs opts (M1 k1) | omitNothingFields opts
361 recordToPairs opts (M1 k1) | omitNothingFields opts
346 , K1 Nothing <- k1 = empty
362 , K1 Nothing <- k1 = empty
347 recordToPairs opts m1 = fieldToPair opts m1
363 recordToPairs opts m1 = fieldToPair opts m1
348− {-# INLINE recordToPairs #-}
349−
350− recordToEncoding opts (M1 k1) | omitNothingFields opts
351− , K1 Nothing <- k1 = mempty
352− recordToEncoding opts m1 = fieldToEncoding opts m1
353− {-# INLINE recordToEncoding #-}
354
364
355fieldToPair :: (Selector s, GToJSON a) => Options -> S1 s a p -> DList Pair
365fieldToPair :: (Selector s, GToJSON a) => Options -> S1 s a p -> DList Pair
356fieldToPair opts m1 = pure ( pack $ fieldLabelModifier opts $ selName m1
366fieldToPair opts m1 = pure ( pack $ fieldLabelModifier opts $ selName m1
357 , gToJSON opts (unM1 m1)
367 , gToJSON opts (unM1 m1)
358 )
368 )
359−{-# INLINE fieldToPair #-}
360
369
370+--------------------------------------------------------------------------------
371+
372+class RecordToEncoding f where
373+ recordToEncoding :: Options -> f a -> B.Builder
374+
375+instance (RecordToEncoding a, RecordToEncoding b) => RecordToEncoding (a :*: b) where
376+ recordToEncoding opts (a :*: b) = recordToEncoding opts a <>
377+ B.char7 ',' <>
378+ recordToEncoding opts b
379+
380+instance (Selector s, GToEncoding a) => RecordToEncoding (S1 s a) where
381+ recordToEncoding = fieldToEncoding
382+
383+instance OVERLAPPING_ (Selector s, ToJSON a) =>
384+ RecordToEncoding (S1 s (K1 i (Maybe a))) where
385+ recordToEncoding opts (M1 k1) | omitNothingFields opts
386+ , K1 Nothing <- k1 = mempty
387+ recordToEncoding opts m1 = fieldToEncoding opts m1
388+
361−fieldToEncoding :: (Selector s, GToJSON a) => Options -> S1 s a p -> B.Builder
389+fieldToEncoding :: (Selector s, GToEncoding a) => Options -> S1 s a p -> B.Builder
362fieldToEncoding opts m1 =
390fieldToEncoding opts m1 =
363 builder (fieldLabelModifier opts $ selName m1) <>
391 builder (fieldLabelModifier opts $ selName m1) <>
364 B.char7 ':' <>
392 B.char7 ':' <>
365 gbuilder opts (unM1 m1)
393 gbuilder opts (unM1 m1)
366−{-# INLINE fieldToEncoding #-}
367
394
368--------------------------------------------------------------------------------
395--------------------------------------------------------------------------------
369
396
@@ -374,7 +401,6 @@ class WriteProduct f where
374 -> Int -- ^ length
401 -> Int -- ^ length
375 -> f a
402 -> f a
376 -> ST s ()
403 -> ST s ()
377− encodeProduct :: Options -> f a -> B.Builder
378
404
379instance ( WriteProduct a
405instance ( WriteProduct a
380 , WriteProduct b ) => WriteProduct (a :*: b) where
406 , WriteProduct b ) => WriteProduct (a :*: b) where
@@ -385,44 +411,53 @@ instance ( WriteProduct a
385 lenL = len `unsafeShiftR` 1
411 lenL = len `unsafeShiftR` 1
386 lenR = len - lenL
412 lenR = len - lenL
387 ixR = ix + lenL
413 ixR = ix + lenL
388− {-# INLINE writeProduct #-}
389
414
415+instance OVERLAPPABLE_ (GToJSON a) => WriteProduct a where
416+ writeProduct opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts
417+
418+--------------------------------------------------------------------------------
419+
420+class EncodeProduct f where
421+ encodeProduct :: Options -> f a -> B.Builder
422+
423+instance ( EncodeProduct a
424+ , EncodeProduct b ) => EncodeProduct (a :*: b) where
390 encodeProduct opts (a :*: b) = encodeProduct opts a <>
425 encodeProduct opts (a :*: b) = encodeProduct opts a <>
391 B.char7 ',' <>
426 B.char7 ',' <>
392 encodeProduct opts b
427 encodeProduct opts b
393− {-# INLINE encodeProduct #-}
394−
395−instance OVERLAPPABLE_ (GToJSON a) => WriteProduct a where
396− writeProduct opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts
397− {-# INLINE writeProduct #-}
398
428
429+instance OVERLAPPABLE_ (GToEncoding a) => EncodeProduct a where
399 encodeProduct opts = gbuilder opts
430 encodeProduct opts = gbuilder opts
400− {-# INLINE encodeProduct #-}
401
431
402--------------------------------------------------------------------------------
432--------------------------------------------------------------------------------
403
433
404−class ObjectWithSingleField f where
434+class ObjectWithSingleFieldObj f where
405 objectWithSingleFieldObj :: Options -> f a -> Object
435 objectWithSingleFieldObj :: Options -> f a -> Object
406− objectWithSingleFieldEnc :: Options -> f a -> B.Builder
407
436
408−instance ( ObjectWithSingleField a
437+instance ( ObjectWithSingleFieldObj a
409− , ObjectWithSingleField b ) => ObjectWithSingleField (a :+: b) where
438+ , ObjectWithSingleFieldObj b ) => ObjectWithSingleFieldObj (a :+: b) where
410 objectWithSingleFieldObj opts (L1 x) = objectWithSingleFieldObj opts x
439 objectWithSingleFieldObj opts (L1 x) = objectWithSingleFieldObj opts x
411 objectWithSingleFieldObj opts (R1 x) = objectWithSingleFieldObj opts x
440 objectWithSingleFieldObj opts (R1 x) = objectWithSingleFieldObj opts x
412− {-# INLINE objectWithSingleFieldObj #-}
413−
414− objectWithSingleFieldEnc opts (L1 x) = objectWithSingleFieldEnc opts x
415− objectWithSingleFieldEnc opts (R1 x) = objectWithSingleFieldEnc opts x
416− {-# INLINE objectWithSingleFieldEnc #-}
417
441
418instance ( GToJSON a, ConsToJSON a
442instance ( GToJSON a, ConsToJSON a
419− , Constructor c ) => ObjectWithSingleField (C1 c a) where
443+ , Constructor c ) => ObjectWithSingleFieldObj (C1 c a) where
420 objectWithSingleFieldObj opts = H.singleton typ . gToJSON opts
444 objectWithSingleFieldObj opts = H.singleton typ . gToJSON opts
421 where
445 where
422 typ = pack $ constructorTagModifier opts $
446 typ = pack $ constructorTagModifier opts $
423 conName (undefined :: t c a p)
447 conName (undefined :: t c a p)
424− {-# INLINE objectWithSingleFieldObj #-}
425
448
449+--------------------------------------------------------------------------------
450+
451+class ObjectWithSingleFieldEnc f where
452+ objectWithSingleFieldEnc :: Options -> f a -> B.Builder
453+
454+instance ( ObjectWithSingleFieldEnc a
455+ , ObjectWithSingleFieldEnc b ) => ObjectWithSingleFieldEnc (a :+: b) where
456+ objectWithSingleFieldEnc opts (L1 x) = objectWithSingleFieldEnc opts x
457+ objectWithSingleFieldEnc opts (R1 x) = objectWithSingleFieldEnc opts x
458+
459+instance ( GToEncoding a, ConsToEncoding a
460+ , Constructor c ) => ObjectWithSingleFieldEnc (C1 c a) where
426 objectWithSingleFieldEnc opts v =
461 objectWithSingleFieldEnc opts v =
427 B.char7 '{' <>
462 B.char7 '{' <>
428 builder (constructorTagModifier opts
463 builder (constructorTagModifier opts
@@ -430,9 +465,8 @@ instance ( GToJSON a, ConsToJSON a
430 B.char7 ':' <>
465 B.char7 ':' <>
431 gbuilder opts v <>
466 gbuilder opts v <>
432 B.char7 '}'
467 B.char7 '}'
433− {-# INLINE objectWithSingleFieldEnc #-}
434
468
435−gbuilder :: GToJSON f => Options -> f a -> Builder
469+gbuilder :: GToEncoding f => Options -> f a -> Builder
436gbuilder opts = fromEncoding . gToEncoding opts
470gbuilder opts = fromEncoding . gToEncoding opts
437
471
438--------------------------------------------------------------------------------
472--------------------------------------------------------------------------------
@@ -442,25 +476,21 @@ instance OVERLAPPABLE_ (GFromJSON a) => GFromJSON (M1 i c a) where
442 -- Meta-information, which is not handled elsewhere, is just added to the
476 -- Meta-information, which is not handled elsewhere, is just added to the
443 -- parsed value:
477 -- parsed value:
444 gParseJSON opts = fmap M1 . gParseJSON opts
478 gParseJSON opts = fmap M1 . gParseJSON opts
445− {-# INLINE gParseJSON #-}
446
479
447instance (FromJSON a) => GFromJSON (K1 i a) where
480instance (FromJSON a) => GFromJSON (K1 i a) where
448 -- Constant values are decoded using their FromJSON instance:
481 -- Constant values are decoded using their FromJSON instance:
449 gParseJSON _opts = fmap K1 . parseJSON
482 gParseJSON _opts = fmap K1 . parseJSON
450− {-# INLINE gParseJSON #-}
451
483
452instance GFromJSON U1 where
484instance GFromJSON U1 where
453 -- Empty constructors are expected to be encoded as an empty array:
485 -- Empty constructors are expected to be encoded as an empty array:
454 gParseJSON _opts v
486 gParseJSON _opts v
455 | isEmptyArray v = pure U1
487 | isEmptyArray v = pure U1
456 | otherwise = typeMismatch "unit constructor (U1)" v
488 | otherwise = typeMismatch "unit constructor (U1)" v
457− {-# INLINE gParseJSON #-}
458
489
459instance (ConsFromJSON a) => GFromJSON (C1 c a) where
490instance (ConsFromJSON a) => GFromJSON (C1 c a) where
460 -- Constructors need to be decoded differently depending on whether they're
491 -- Constructors need to be decoded differently depending on whether they're
461 -- a record or not. This distinction is made by consParseJSON:
492 -- a record or not. This distinction is made by consParseJSON:
462 gParseJSON opts = fmap M1 . consParseJSON opts
493 gParseJSON opts = fmap M1 . consParseJSON opts
463− {-# INLINE gParseJSON #-}
464
494
465instance ( FromProduct a, FromProduct b
495instance ( FromProduct a, FromProduct b
466 , ProductSize a, ProductSize b ) => GFromJSON (a :*: b) where
496 , ProductSize a, ProductSize b ) => GFromJSON (a :*: b) where
@@ -476,7 +506,6 @@ instance ( FromProduct a, FromProduct b
476 else fail $ "When expecting a product of " ++ show lenProduct ++
506 else fail $ "When expecting a product of " ++ show lenProduct ++
477 " values, encountered an Array of " ++ show lenArray ++
507 " values, encountered an Array of " ++ show lenArray ++
478 " elements instead"
508 " elements instead"
479− {-# INLINE gParseJSON #-}
480
509
481instance ( AllNullary (a :+: b) allNullary
510instance ( AllNullary (a :+: b) allNullary
482 , ParseSum (a :+: b) allNullary ) => GFromJSON (a :+: b) where
511 , ParseSum (a :+: b) allNullary ) => GFromJSON (a :+: b) where
@@ -486,7 +515,6 @@ instance ( AllNullary (a :+: b) allNullary
486 gParseJSON opts = (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->
515 gParseJSON opts = (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->
487 (Parser ((a :+: b) d)))
516 (Parser ((a :+: b) d)))
488 . parseSum opts
517 . parseSum opts
489− {-# INLINE gParseJSON #-}
490
518
491--------------------------------------------------------------------------------
519--------------------------------------------------------------------------------
492
520
@@ -499,12 +527,10 @@ instance ( SumFromString (a :+: b)
499 parseSum opts
527 parseSum opts
500 | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts
528 | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts
501 | otherwise = Tagged . parseNonAllNullarySum opts
529 | otherwise = Tagged . parseNonAllNullarySum opts
502− {-# INLINE parseSum #-}
503
530
504instance ( FromPair (a :+: b)
531instance ( FromPair (a :+: b)
505 , FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) False where
532 , FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) False where
506 parseSum opts = Tagged . parseNonAllNullarySum opts
533 parseSum opts = Tagged . parseNonAllNullarySum opts
507− {-# INLINE parseSum #-}
508
534
509--------------------------------------------------------------------------------
535--------------------------------------------------------------------------------
510
536
@@ -512,7 +538,6 @@ parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)
512parseAllNullarySum opts = withText "Text" $ \key ->
538parseAllNullarySum opts = withText "Text" $ \key ->
513 maybe (notFound $ unpack key) return $
539 maybe (notFound $ unpack key) return $
514 parseSumFromString opts key
540 parseSumFromString opts key
515−{-# INLINE parseAllNullarySum #-}
516
541
517class SumFromString f where
542class SumFromString f where
518 parseSumFromString :: Options -> Text -> Maybe (f a)
543 parseSumFromString :: Options -> Text -> Maybe (f a)
@@ -520,7 +545,6 @@ class SumFromString f where
520instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
545instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
521 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
546 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
522 (R1 <$> parseSumFromString opts key)
547 (R1 <$> parseSumFromString opts key)
523− {-# INLINE parseSumFromString #-}
524
548
525instance (Constructor c) => SumFromString (C1 c U1) where
549instance (Constructor c) => SumFromString (C1 c U1) where
526 parseSumFromString opts key | key == name = Just $ M1 U1
550 parseSumFromString opts key | key == name = Just $ M1 U1
@@ -528,7 +552,6 @@ instance (Constructor c) => SumFromString (C1 c U1) where
528 where
552 where
529 name = pack $ constructorTagModifier opts $
553 name = pack $ constructorTagModifier opts $
530 conName (undefined :: t c U1 p)
554 conName (undefined :: t c U1 p)
531− {-# INLINE parseSumFromString #-}
532
555
533--------------------------------------------------------------------------------
556--------------------------------------------------------------------------------
534
557
@@ -558,7 +581,6 @@ parseNonAllNullarySum opts =
558 parsePair opts (tag, V.unsafeIndex arr 1)
581 parsePair opts (tag, V.unsafeIndex arr 1)
559 _ -> fail "First element is not a String"
582 _ -> fail "First element is not a String"
560 else fail "Array doesn't have 2 elements"
583 else fail "Array doesn't have 2 elements"
561−{-# INLINE parseNonAllNullarySum #-}
562
584
563--------------------------------------------------------------------------------
585--------------------------------------------------------------------------------
564
586
@@ -571,7 +593,6 @@ instance (FromTaggedObject a, FromTaggedObject b) =>
571 parseFromTaggedObject opts contentsFieldName obj tag =
593 parseFromTaggedObject opts contentsFieldName obj tag =
572 (fmap L1 <$> parseFromTaggedObject opts contentsFieldName obj tag) <|>
594 (fmap L1 <$> parseFromTaggedObject opts contentsFieldName obj tag) <|>
573 (fmap R1 <$> parseFromTaggedObject opts contentsFieldName obj tag)
595 (fmap R1 <$> parseFromTaggedObject opts contentsFieldName obj tag)
574− {-# INLINE parseFromTaggedObject #-}
575
596
576instance ( FromTaggedObject' f
597instance ( FromTaggedObject' f
577 , Constructor c ) => FromTaggedObject (C1 c f) where
598 , Constructor c ) => FromTaggedObject (C1 c f) where
@@ -582,7 +603,6 @@ instance ( FromTaggedObject' f
582 where
603 where
583 name = pack $ constructorTagModifier opts $
604 name = pack $ constructorTagModifier opts $
584 conName (undefined :: t c f p)
605 conName (undefined :: t c f p)
585− {-# INLINE parseFromTaggedObject #-}
586
606
587--------------------------------------------------------------------------------
607--------------------------------------------------------------------------------
588
608
@@ -599,16 +619,13 @@ instance ( IsRecord f isRecord
599 parseFromTaggedObject' opts contentsFieldName =
619 parseFromTaggedObject' opts contentsFieldName =
600 (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
620 (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
601 parseFromTaggedObject'' opts contentsFieldName
621 parseFromTaggedObject'' opts contentsFieldName
602− {-# INLINE parseFromTaggedObject' #-}
603
622
604instance (FromRecord f) => FromTaggedObject'' f True where
623instance (FromRecord f) => FromTaggedObject'' f True where
605 parseFromTaggedObject'' opts _ = Tagged . parseRecord opts Nothing
624 parseFromTaggedObject'' opts _ = Tagged . parseRecord opts Nothing
606− {-# INLINE parseFromTaggedObject'' #-}
607
625
608instance (GFromJSON f) => FromTaggedObject'' f False where
626instance (GFromJSON f) => FromTaggedObject'' f False where
609 parseFromTaggedObject'' opts contentsFieldName = Tagged .
627 parseFromTaggedObject'' opts contentsFieldName = Tagged .
610 (gParseJSON opts <=< (.: pack contentsFieldName))
628 (gParseJSON opts <=< (.: pack contentsFieldName))
611− {-# INLINE parseFromTaggedObject'' #-}
612
629
613--------------------------------------------------------------------------------
630--------------------------------------------------------------------------------
614
631
@@ -630,17 +647,14 @@ instance ( IsRecord f isRecord
630 _ ->(v,Nothing)
647 _ ->(v,Nothing)
631 in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
648 in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
632 $ consParseJSON' opts lab v2
649 $ consParseJSON' opts lab v2
633− {-# INLINE consParseJSON #-}
634
650
635
651
636instance (FromRecord f) => ConsFromJSON' f True where
652instance (FromRecord f) => ConsFromJSON' f True where
637 consParseJSON' opts mlab = Tagged . (withObject "record (:*:)"
653 consParseJSON' opts mlab = Tagged . (withObject "record (:*:)"
638 $ parseRecord opts mlab)
654 $ parseRecord opts mlab)
639− {-# INLINE consParseJSON' #-}
640
655
641instance (GFromJSON f) => ConsFromJSON' f False where
656instance (GFromJSON f) => ConsFromJSON' f False where
642 consParseJSON' opts _ = Tagged . gParseJSON opts
657 consParseJSON' opts _ = Tagged . gParseJSON opts
643− {-# INLINE consParseJSON' #-}
644
658
645--------------------------------------------------------------------------------
659--------------------------------------------------------------------------------
646
660
@@ -652,7 +666,6 @@ class FromRecord f where
652instance (FromRecord a, FromRecord b) => FromRecord (a :*: b) where
666instance (FromRecord a, FromRecord b) => FromRecord (a :*: b) where
653 parseRecord opts _ obj = (:*:) <$> parseRecord opts Nothing obj
667 parseRecord opts _ obj = (:*:) <$> parseRecord opts Nothing obj
654 <*> parseRecord opts Nothing obj
668 <*> parseRecord opts Nothing obj
655− {-# INLINE parseRecord #-}
656
669
657instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where
670instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where
658 parseRecord opts (Just lab) = maybe (notFound $ unpack lab)
671 parseRecord opts (Just lab) = maybe (notFound $ unpack lab)
@@ -661,7 +674,6 @@ instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where
661 (gParseJSON opts) . H.lookup (pack label)
674 (gParseJSON opts) . H.lookup (pack label)
662 where
675 where
663 label = fieldLabelModifier opts $ selName (undefined :: t s a p)
676 label = fieldLabelModifier opts $ selName (undefined :: t s a p)
664− {-# INLINE parseRecord #-}
665
677
666instance OVERLAPPING_ (Selector s, FromJSON a) =>
678instance OVERLAPPING_ (Selector s, FromJSON a) =>
667 FromRecord (S1 s (K1 i (Maybe a))) where
679 FromRecord (S1 s (K1 i (Maybe a))) where
@@ -670,7 +682,6 @@ instance OVERLAPPING_ (Selector s, FromJSON a) =>
670 where
682 where
671 label = fieldLabelModifier opts $
683 label = fieldLabelModifier opts $
672 selName (undefined :: t s (K1 i (Maybe a)) p)
684 selName (undefined :: t s (K1 i (Maybe a)) p)
673− {-# INLINE parseRecord #-}
674
685
675--------------------------------------------------------------------------------
686--------------------------------------------------------------------------------
676
687
@@ -680,11 +691,9 @@ class ProductSize f where
680instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
691instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
681 productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +
692 productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +
682 unTagged2 (productSize :: Tagged2 b Int)
693 unTagged2 (productSize :: Tagged2 b Int)
683− {-# INLINE productSize #-}
684
694
685instance ProductSize (S1 s a) where
695instance ProductSize (S1 s a) where
686 productSize = Tagged2 1
696 productSize = Tagged2 1
687− {-# INLINE productSize #-}
688
697
689--------------------------------------------------------------------------------
698--------------------------------------------------------------------------------
690
699
@@ -699,11 +708,9 @@ instance (FromProduct a, FromProduct b) => FromProduct (a :*: b) where
699 lenL = len `unsafeShiftR` 1
708 lenL = len `unsafeShiftR` 1
700 ixR = ix + lenL
709 ixR = ix + lenL
701 lenR = len - lenL
710 lenR = len - lenL
702− {-# INLINE parseProduct #-}
703
711
704instance (GFromJSON a) => FromProduct (S1 s a) where
712instance (GFromJSON a) => FromProduct (S1 s a) where
705 parseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix
713 parseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix
706− {-# INLINE parseProduct #-}
707
714
708--------------------------------------------------------------------------------
715--------------------------------------------------------------------------------
709
716
@@ -713,7 +720,6 @@ class FromPair f where
713instance (FromPair a, FromPair b) => FromPair (a :+: b) where
720instance (FromPair a, FromPair b) => FromPair (a :+: b) where
714 parsePair opts pair = (fmap L1 <$> parsePair opts pair) <|>
721 parsePair opts pair = (fmap L1 <$> parsePair opts pair) <|>
715 (fmap R1 <$> parsePair opts pair)
722 (fmap R1 <$> parsePair opts pair)
716− {-# INLINE parsePair #-}
717
723
718instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where
724instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where
719 parsePair opts (tag, value)
725 parsePair opts (tag, value)
@@ -722,7 +728,6 @@ instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where
722 where
728 where
723 tag' = pack $ constructorTagModifier opts $
729 tag' = pack $ constructorTagModifier opts $
724 conName (undefined :: t c a p)
730 conName (undefined :: t c a p)
725− {-# INLINE parsePair #-}
726
731
727--------------------------------------------------------------------------------
732--------------------------------------------------------------------------------
728
733
@@ -734,7 +739,7 @@ class IsRecord (f :: * -> *) isRecord | f -> isRecord
734instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
739instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
735 where isUnary = const False
740 where isUnary = const False
736#if MIN_VERSION_base(4,9,0)
741#if MIN_VERSION_base(4,9,0)
737−instance OVERLAPPING_ IsRecord (M1 S (MetaSel Nothing u ss ds) f) False
742+instance OVERLAPPING_ IsRecord (M1 S ('MetaSel 'Nothing u ss ds) f) False
738#else
743#else
739instance OVERLAPPING_ IsRecord (M1 S NoSelector f) False
744instance OVERLAPPING_ IsRecord (M1 S NoSelector f) False
740#endif
745#endif
Data/Aeson/Types/Instances.hs+1
@@ -32,6 +32,7 @@ module Data.Aeson.Types.Instances
32 -- ** Generic JSON classes
32 -- ** Generic JSON classes
33 , GFromJSON(..)
33 , GFromJSON(..)
34 , GToJSON(..)
34 , GToJSON(..)
35+ , GToEncoding(..)
35 , genericToJSON
36 , genericToJSON
36 , genericToEncoding
37 , genericToEncoding
37 , genericParseJSON
38 , genericParseJSON