git.iko.soy/typeable/aeson
on master help sign in
Generic derivation using Encoding api
1252956Oleg Grenrus
Data/Aeson/Encoding.hs+6
compare with master
unifiedsplit
@@ -7,6 +7,8 @@ module Data.Aeson.Encoding
7 , unsafeToEncoding
7 , unsafeToEncoding
8 , Series (..) -- TODO: don't export constructor
8 , Series (..) -- TODO: don't export constructor
9 , pairs
9 , pairs
10+ -- * Predicates
11+ , nullEncoding
10 -- * Encoding constructors
12 -- * Encoding constructors
11 , emptyArray_
13 , emptyArray_
12 , emptyObject_
14 , emptyObject_
@@ -27,6 +29,7 @@ import Data.Semigroup (Semigroup((<>)))
27import Data.ByteString.Builder.Prim (primBounded)
29import Data.ByteString.Builder.Prim (primBounded)
28import Data.Typeable (Typeable)
30import Data.Typeable (Typeable)
29
31
32+import qualified Data.ByteString.Lazy as BSL
30import qualified Data.Aeson.Encode.Builder as B
33import qualified Data.Aeson.Encode.Builder as B
31
34
32-- | An encoding of a JSON value.
35-- | An encoding of a JSON value.
@@ -79,6 +82,9 @@ instance Monoid Series where
79 mempty = Empty
82 mempty = Empty
80 mappend = (<>)
83 mappend = (<>)
81
84
85+nullEncoding :: Encoding -> Bool
86+nullEncoding = BSL.null . toLazyByteString . fromEncoding
87+
82emptyArray_ :: Encoding
88emptyArray_ :: Encoding
83emptyArray_ = Encoding B.emptyArray_
89emptyArray_ = Encoding B.emptyArray_
84
90
Data/Aeson/Types/Generic.hs+50−56
@@ -24,14 +24,11 @@ module Data.Aeson.Types.Generic ( ) where
24import Control.Applicative ((<|>))
24import Control.Applicative ((<|>))
25import Control.Monad ((<=<))
25import Control.Monad ((<=<))
26import Control.Monad.ST (ST)
26import Control.Monad.ST (ST)
27−import Data.Aeson.Encoding (Encoding (..), emptyArray_)
27+import Data.Aeson.Encoding (Encoding, (>*<))
28−import Data.Aeson.Encode.Functions (builder)
28+import qualified Data.Aeson.Encoding as E
29import Data.Aeson.Types.Instances
29import Data.Aeson.Types.Instances
30−import Data.Aeson.Encoding ((>*<), tuple)
31import Data.Aeson.Types.Internal
30import Data.Aeson.Types.Internal
32import Data.Bits (unsafeShiftR)
31import Data.Bits (unsafeShiftR)
33−import Data.ByteString.Builder as B
34−import qualified Data.ByteString.Lazy as BSL (null)
35import Data.DList (DList, toList, empty)
32import Data.DList (DList, toList, empty)
36import Data.Maybe (fromMaybe)
33import Data.Maybe (fromMaybe)
37import Data.Monoid ((<>))
34import Data.Monoid ((<>))
@@ -102,28 +99,27 @@ instance (ToJSON a) => GToEncoding (K1 i a) where
102
99
103instance GToEncoding U1 where
100instance GToEncoding U1 where
104 -- Empty constructors are encoded to an empty array:
101 -- Empty constructors are encoded to an empty array:
105− gToEncoding _opts _ = emptyArray_
102+ gToEncoding _opts _ = E.emptyArray_
106
103
107instance (ConsToEncoding a) => GToEncoding (C1 c a) where
104instance (ConsToEncoding a) => GToEncoding (C1 c a) where
108 -- Constructors need to be encoded differently depending on whether they're
105 -- Constructors need to be encoded differently depending on whether they're
109 -- a record or not. This distinction is made by 'consToEncoding':
106 -- a record or not. This distinction is made by 'consToEncoding':
110− gToEncoding opts = Encoding . consToEncoding opts . unM1
107+ gToEncoding opts = consToEncoding opts . unM1
111
108
112instance ( EncodeProduct a, EncodeProduct b ) => GToEncoding (a :*: b) where
109instance ( EncodeProduct a, EncodeProduct b ) => GToEncoding (a :*: b) where
113 -- Products are encoded to an array. Here we allocate a mutable vector of
110 -- Products are encoded to an array. Here we allocate a mutable vector of
114 -- the same size as the product and write the product's elements to it using
111 -- the same size as the product and write the product's elements to it using
115 -- 'encodeProduct':
112 -- 'encodeProduct':
116− gToEncoding opts p = Encoding $
117− B.char7 '[' <> encodeProduct opts p <> B.char7 ']'
113+ gToEncoding opts p = E.tuple $ encodeProduct opts p
118
114
119instance ( AllNullary (a :+: b) allNullary
115instance ( AllNullary (a :+: b) allNullary
120 , SumToEncoding (a :+: b) allNullary ) => GToEncoding (a :+: b) where
116 , SumToEncoding (a :+: b) allNullary ) => GToEncoding (a :+: b) where
121 -- If all constructors of a sum datatype are nullary and the
117 -- If all constructors of a sum datatype are nullary and the
122 -- 'allNullaryToStringTag' option is set they are encoded to
118 -- 'allNullaryToStringTag' option is set they are encoded to
123 -- strings. This distinction is made by 'sumToEncoding':
119 -- strings. This distinction is made by 'sumToEncoding':
124− gToEncoding opts = Encoding .
120+ gToEncoding opts
125− (unTagged :: Tagged allNullary B.Builder -> B.Builder) .
121+ = (unTagged :: Tagged allNullary Encoding -> Encoding)
126− sumToEncoding opts
122+ . sumToEncoding opts
127
123
128--------------------------------------------------------------------------------
124--------------------------------------------------------------------------------
129
125
@@ -158,14 +154,14 @@ nonAllNullarySumToJSON opts =
158--------------------------------------------------------------------------------
154--------------------------------------------------------------------------------
159
155
160class SumToEncoding f allNullary where
156class SumToEncoding f allNullary where
161− sumToEncoding :: Options -> f a -> Tagged allNullary B.Builder
157+ sumToEncoding :: Options -> f a -> Tagged allNullary Encoding
162
158
163instance ( GetConName f
159instance ( GetConName f
164 , TaggedObjectEnc f
160 , TaggedObjectEnc f
165 , ObjectWithSingleFieldEnc f
161 , ObjectWithSingleFieldEnc f
166 , TwoElemArrayEnc f ) => SumToEncoding f True where
162 , TwoElemArrayEnc f ) => SumToEncoding f True where
167 sumToEncoding opts
163 sumToEncoding opts
168− | allNullaryToStringTag opts = Tagged . builder .
164+ | allNullaryToStringTag opts = Tagged . toEncoding .
169 constructorTagModifier opts . getConName
165 constructorTagModifier opts . getConName
170 | otherwise = Tagged . nonAllNullarySumToEncoding opts
166 | otherwise = Tagged . nonAllNullarySumToEncoding opts
171
167
@@ -177,7 +173,7 @@ instance ( TwoElemArrayEnc f
177nonAllNullarySumToEncoding :: ( TwoElemArrayEnc f
173nonAllNullarySumToEncoding :: ( TwoElemArrayEnc f
178 , TaggedObjectEnc f
174 , TaggedObjectEnc f
179 , ObjectWithSingleFieldEnc f
175 , ObjectWithSingleFieldEnc f
180− ) => Options -> f a -> B.Builder
176+ ) => Options -> f a -> Encoding
181nonAllNullarySumToEncoding opts =
177nonAllNullarySumToEncoding opts =
182 case sumEncoding opts of
178 case sumEncoding opts of
183 TaggedObject{..} ->
179 TaggedObject{..} ->
@@ -222,7 +218,7 @@ instance (GToJSON f) => TaggedObjectPairs' f False where
222--------------------------------------------------------------------------------
218--------------------------------------------------------------------------------
223
219
224class TaggedObjectEnc f where
220class TaggedObjectEnc f where
225− taggedObjectEnc :: Options -> String -> String -> f a -> B.Builder
221+ taggedObjectEnc :: Options -> String -> String -> f a -> Encoding
226
222
227instance ( TaggedObjectEnc a
223instance ( TaggedObjectEnc a
228 , TaggedObjectEnc b ) => TaggedObjectEnc (a :+: b) where
224 , TaggedObjectEnc b ) => TaggedObjectEnc (a :+: b) where
@@ -235,27 +231,27 @@ instance ( IsRecord a isRecord
235 , TaggedObjectEnc' a isRecord
231 , TaggedObjectEnc' a isRecord
236 , Constructor c ) => TaggedObjectEnc (C1 c a) where
232 , Constructor c ) => TaggedObjectEnc (C1 c a) where
237 taggedObjectEnc opts tagFieldName contentsFieldName v =
233 taggedObjectEnc opts tagFieldName contentsFieldName v =
238− B.char7 '{' <>
234+ E.openCurly <>
239− (builder tagFieldName <>
235+ (toEncoding tagFieldName <>
240− B.char7 ':' <>
236+ E.colon <>
241− builder (constructorTagModifier opts (conName (undefined :: t c a p)))) <>
237+ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))) <>
242− ((unTagged :: Tagged isRecord B.Builder -> B.Builder) .
238+ ((unTagged :: Tagged isRecord Encoding -> Encoding) .
243 taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>
239 taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>
244− B.char7 '}'
240+ E.closeCurly
245
241
246class TaggedObjectEnc' f isRecord where
242class TaggedObjectEnc' f isRecord where
247− taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord B.Builder
243+ taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord Encoding
248
244
249instance OVERLAPPING_ TaggedObjectEnc' U1 False where
245instance OVERLAPPING_ TaggedObjectEnc' U1 False where
250 taggedObjectEnc' _ _ _ = Tagged mempty
246 taggedObjectEnc' _ _ _ = Tagged mempty
251
247
252instance (RecordToEncoding f) => TaggedObjectEnc' f True where
248instance (RecordToEncoding f) => TaggedObjectEnc' f True where
253− taggedObjectEnc' opts _ = Tagged . (B.char7 ',' <>) . fst . recordToEncoding opts
249+ taggedObjectEnc' opts _ = Tagged . (E.comma <>) . fst . recordToEncoding opts
254
250
255instance (GToEncoding f) => TaggedObjectEnc' f False where
251instance (GToEncoding f) => TaggedObjectEnc' f False where
256 taggedObjectEnc' opts contentsFieldName =
252 taggedObjectEnc' opts contentsFieldName =
257− Tagged . (\z -> B.char7 ',' <> builder contentsFieldName <> B.char7 ':' <> z) .
253+ Tagged . (\z -> E.comma <> toEncoding contentsFieldName <> E.colon <> z) .
258− gbuilder opts
254+ gToEncoding opts
259
255
260--------------------------------------------------------------------------------
256--------------------------------------------------------------------------------
261
257
@@ -291,7 +287,7 @@ instance ( GToJSON a, ConsToJSON a
291--------------------------------------------------------------------------------
287--------------------------------------------------------------------------------
292
288
293class TwoElemArrayEnc f where
289class TwoElemArrayEnc f where
294− twoElemArrayEnc :: Options -> f a -> B.Builder
290+ twoElemArrayEnc :: Options -> f a -> Encoding
295
291
296instance (TwoElemArrayEnc a, TwoElemArrayEnc b) => TwoElemArrayEnc (a :+: b) where
292instance (TwoElemArrayEnc a, TwoElemArrayEnc b) => TwoElemArrayEnc (a :+: b) where
297 twoElemArrayEnc opts (L1 x) = twoElemArrayEnc opts x
293 twoElemArrayEnc opts (L1 x) = twoElemArrayEnc opts x
@@ -299,7 +295,7 @@ instance (TwoElemArrayEnc a, TwoElemArrayEnc b) => TwoElemArrayEnc (a :+: b) whe
299
295
300instance ( GToEncoding a, ConsToEncoding a
296instance ( GToEncoding a, ConsToEncoding a
301 , Constructor c ) => TwoElemArrayEnc (C1 c a) where
297 , Constructor c ) => TwoElemArrayEnc (C1 c a) where
302− twoElemArrayEnc opts x = fromEncoding . tuple $
298+ twoElemArrayEnc opts x = E.tuple $
303 toEncoding (constructorTagModifier opts (conName (undefined :: t c a p))) >*<
299 toEncoding (constructorTagModifier opts (conName (undefined :: t c a p))) >*<
304 gToEncoding opts x
300 gToEncoding opts x
305
301
@@ -330,15 +326,15 @@ instance GToJSON f => ConsToJSON' f False where
330--------------------------------------------------------------------------------
326--------------------------------------------------------------------------------
331
327
332class ConsToEncoding f where
328class ConsToEncoding f where
333− consToEncoding :: Options -> f a -> B.Builder
329+ consToEncoding :: Options -> f a -> Encoding
334
330
335class ConsToEncoding' f isRecord where
331class ConsToEncoding' f isRecord where
336 consToEncoding' :: Options -> Bool -- ^ Are we a record with one field?
332 consToEncoding' :: Options -> Bool -- ^ Are we a record with one field?
337− -> f a -> Tagged isRecord B.Builder
333+ -> f a -> Tagged isRecord Encoding
338
334
339instance ( IsRecord f isRecord
335instance ( IsRecord f isRecord
340 , ConsToEncoding' f isRecord ) => ConsToEncoding f where
336 , ConsToEncoding' f isRecord ) => ConsToEncoding f where
341− consToEncoding opts = (unTagged :: Tagged isRecord B.Builder -> B.Builder)
337+ consToEncoding opts = (unTagged :: Tagged isRecord Encoding -> Encoding)
342 . consToEncoding' opts (isUnary (undefined :: f a))
338 . consToEncoding' opts (isUnary (undefined :: f a))
343
339
344instance (RecordToEncoding f) => ConsToEncoding' f True where
340instance (RecordToEncoding f) => ConsToEncoding' f True where
@@ -346,10 +342,10 @@ instance (RecordToEncoding f) => ConsToEncoding' f True where
346 let (enc, mbVal) = recordToEncoding opts x
342 let (enc, mbVal) = recordToEncoding opts x
347 in case (unwrapUnaryRecords opts, isUn, mbVal) of
343 in case (unwrapUnaryRecords opts, isUn, mbVal) of
348 (True, True, Just val) -> Tagged val
344 (True, True, Just val) -> Tagged val
349− _ -> Tagged $ B.char7 '{' <> enc <> B.char7 '}'
345+ _ -> Tagged $ E.wrapObject enc
350
346
351instance GToEncoding f => ConsToEncoding' f False where
347instance GToEncoding f => ConsToEncoding' f False where
352− consToEncoding' opts _ = Tagged . gbuilder opts
348+ consToEncoding' opts _ = Tagged . gToEncoding opts
353
349
354--------------------------------------------------------------------------------
350--------------------------------------------------------------------------------
355
351
@@ -380,16 +376,16 @@ class RecordToEncoding f where
380 -- 1st element: whole thing
376 -- 1st element: whole thing
381 -- 2nd element: in case the record has only 1 field, just the value
377 -- 2nd element: in case the record has only 1 field, just the value
382 -- of the field (without the key); 'Nothing' otherwise
378 -- of the field (without the key); 'Nothing' otherwise
383− recordToEncoding :: Options -> f a -> (B.Builder, Maybe B.Builder)
379+ recordToEncoding :: Options -> f a -> (Encoding, Maybe Encoding)
384
380
385instance (RecordToEncoding a, RecordToEncoding b) => RecordToEncoding (a :*: b) where
381instance (RecordToEncoding a, RecordToEncoding b) => RecordToEncoding (a :*: b) where
386 recordToEncoding opts (a :*: b) | omitNothingFields opts =
382 recordToEncoding opts (a :*: b) | omitNothingFields opts =
387− (mconcat $ intersperse (B.char7 ',') $
383+ (mconcat $ intersperse E.comma $
388− filter (not . BSL.null . B.toLazyByteString)
384+ filter (not . E.nullEncoding)
389 [fst (recordToEncoding opts a), fst (recordToEncoding opts b)]
385 [fst (recordToEncoding opts a), fst (recordToEncoding opts b)]
390 , Nothing)
386 , Nothing)
391 recordToEncoding opts (a :*: b) =
387 recordToEncoding opts (a :*: b) =
392− (fst (recordToEncoding opts a) <> B.char7 ',' <>
388+ (fst (recordToEncoding opts a) <> E.comma <>
393 fst (recordToEncoding opts b),
389 fst (recordToEncoding opts b),
394 Nothing)
390 Nothing)
395
391
@@ -402,11 +398,11 @@ instance OVERLAPPING_ (Selector s, ToJSON a) =>
402 , K1 Nothing <- k1 = (mempty, Nothing)
398 , K1 Nothing <- k1 = (mempty, Nothing)
403 recordToEncoding opts m1 = fieldToEncoding opts m1
399 recordToEncoding opts m1 = fieldToEncoding opts m1
404
400
405−fieldToEncoding :: (Selector s, GToEncoding a) => Options -> S1 s a p -> (B.Builder, Maybe B.Builder)
401+fieldToEncoding :: (Selector s, GToEncoding a) => Options -> S1 s a p -> (Encoding, Maybe Encoding)
406fieldToEncoding opts m1 =
402fieldToEncoding opts m1 =
407− let keyBuilder = builder (fieldLabelModifier opts $ selName m1)
403+ let keyBuilder = toEncoding (fieldLabelModifier opts $ selName m1)
408− valueBuilder = gbuilder opts (unM1 m1)
404+ valueBuilder = gToEncoding opts (unM1 m1)
409− in (keyBuilder <> B.char7 ':' <> valueBuilder, Just valueBuilder)
405+ in (keyBuilder <> E.colon <> valueBuilder, Just valueBuilder)
410
406
411--------------------------------------------------------------------------------
407--------------------------------------------------------------------------------
412
408
@@ -434,20 +430,20 @@ instance OVERLAPPABLE_ (GToJSON a) => WriteProduct a where
434--------------------------------------------------------------------------------
430--------------------------------------------------------------------------------
435
431
436class EncodeProduct f where
432class EncodeProduct f where
437− encodeProduct :: Options -> f a -> B.Builder
433+ encodeProduct :: Options -> f a -> Encoding
438
434
439instance ( EncodeProduct a
435instance ( EncodeProduct a
440 , EncodeProduct b ) => EncodeProduct (a :*: b) where
436 , EncodeProduct b ) => EncodeProduct (a :*: b) where
441 encodeProduct opts (a :*: b) | omitNothingFields opts =
437 encodeProduct opts (a :*: b) | omitNothingFields opts =
442− mconcat $ intersperse (B.char7 ',') $
438+ mconcat $ intersperse E.comma $
443− filter (not . BSL.null . B.toLazyByteString)
439+ filter (not . E.nullEncoding)
444 [encodeProduct opts a, encodeProduct opts b]
440 [encodeProduct opts a, encodeProduct opts b]
445 encodeProduct opts (a :*: b) = encodeProduct opts a <>
441 encodeProduct opts (a :*: b) = encodeProduct opts a <>
446− B.char7 ',' <>
442+ E.comma <>
447 encodeProduct opts b
443 encodeProduct opts b
448
444
449instance OVERLAPPABLE_ (GToEncoding a) => EncodeProduct a where
445instance OVERLAPPABLE_ (GToEncoding a) => EncodeProduct a where
450− encodeProduct opts = gbuilder opts
446+ encodeProduct opts = gToEncoding opts
451
447
452--------------------------------------------------------------------------------
448--------------------------------------------------------------------------------
453
449
@@ -469,7 +465,7 @@ instance ( GToJSON a, ConsToJSON a
469--------------------------------------------------------------------------------
465--------------------------------------------------------------------------------
470
466
471class ObjectWithSingleFieldEnc f where
467class ObjectWithSingleFieldEnc f where
472− objectWithSingleFieldEnc :: Options -> f a -> B.Builder
468+ objectWithSingleFieldEnc :: Options -> f a -> Encoding
473
469
474instance ( ObjectWithSingleFieldEnc a
470instance ( ObjectWithSingleFieldEnc a
475 , ObjectWithSingleFieldEnc b ) => ObjectWithSingleFieldEnc (a :+: b) where
471 , ObjectWithSingleFieldEnc b ) => ObjectWithSingleFieldEnc (a :+: b) where
@@ -479,15 +475,13 @@ instance ( ObjectWithSingleFieldEnc a
479instance ( GToEncoding a, ConsToEncoding a
475instance ( GToEncoding a, ConsToEncoding a
480 , Constructor c ) => ObjectWithSingleFieldEnc (C1 c a) where
476 , Constructor c ) => ObjectWithSingleFieldEnc (C1 c a) where
481 objectWithSingleFieldEnc opts v =
477 objectWithSingleFieldEnc opts v =
482− B.char7 '{' <>
478+ E.openCurly <>
479+ toEncoding
483− builder (constructorTagModifier opts
480+ (constructorTagModifier opts
484− (conName (undefined :: t c a p))) <>
481+ (conName (undefined :: t c a p))) <>
485− B.char7 ':' <>
482+ E.colon <>
486− gbuilder opts v <>
487− B.char7 '}'
488−
489−gbuilder :: GToEncoding f => Options -> f a -> Builder
490−gbuilder opts = fromEncoding . gToEncoding opts
483+ gToEncoding opts v <>
484+ E.closeCurly
491
485
492--------------------------------------------------------------------------------
486--------------------------------------------------------------------------------
493-- Generic parseJSON
487-- Generic parseJSON