@@ -78,7 +78,7 @@ module Data.Aeson.TH
7878--------------------------------------------------------------------------------
7979
8080-- from aeson:
81−import Data.Aeson ( toJSON, Object, object, (.=), (.:), (.:?)
81+import Data.Aeson ( toJSON, Object, (.=), (.:), (.:?)
8282 , ToJSON, toEncoding, toJSON
8383 , FromJSON, parseJSON
8484 )
@@ -88,6 +88,10 @@ import Data.Aeson.Types ( Value(..), Parser
8888 , defaultOptions
8989 , defaultTaggedObject
9090 )
91+import Data.Aeson.Types.Internal (Encoding(..))
92+import qualified Data.Aeson.Encode.Builder as E
93+import qualified Data.Aeson.Encode.Functions as E
94+import qualified Data.Aeson as A
9195-- from base:
9296import Control.Applicative ( pure, (<$>), (<*>) )
9397import Control.Monad ( return, mapM, liftM2, fail )
@@ -97,11 +101,12 @@ import Data.Function ( ($), (.) )
97101import Data.Functor ( fmap )
98102import Data.Int ( Int )
99103import Data.Either ( Either(Left, Right) )
100−import Data.List ( (++), foldl, foldl', intercalate
104+import Data.List ( (++), foldl, foldl', intercalate, intersperse
101105 , length, map, zip, genericLength, all, partition
102106 )
103107import Data.Maybe ( Maybe(Nothing, Just), catMaybes )
104−import Prelude ( String, (-), Integer, fromIntegral, error )
108+import Data.Monoid ( (<>), mconcat )
109+import Prelude ( String, (-), Integer, error, foldr1, fromIntegral )
105110import Text.Printf ( printf )
106111import Text.Show ( show )
107112-- from unordered-containers:
@@ -224,6 +229,15 @@ consToValue opts cons = do
224229 ]
225230 | otherwise = [argsToValue opts True con | con <- cons]
226231
232+conStr :: Options -> Name -> Q Exp
233+conStr opts = appE [|String|] . conTxt opts
234+
235+conTxt :: Options -> Name -> Q Exp
236+conTxt opts = appE [|T.pack|] . conStringE opts
237+
238+conStringE :: Options -> Name -> Q Exp
239+conStringE opts = stringE . constructorTagModifier opts . nameBase
240+
227241-- | Helper function used by both 'deriveToJSON' and 'mkToEncoding'. Generates
228242-- code to write out a value for a number of constructors. All constructors
229243-- must be from the same type.
@@ -242,26 +256,23 @@ consToEncoding opts [con] = do
242256 value <- newName "value"
243257 lam1E (varP value) $ caseE (varE value) [argsToEncoding opts False con]
244258
259+-- Encode just the name of the constructor of a sum type iff all the
260+-- constructors are nullary.
245261consToEncoding opts cons = do
246262 value <- newName "value"
247263 lam1E (varP value) $ caseE (varE value) matches
248264 where
249265 matches
250266 | allNullaryToStringTag opts && all isNullary cons =
251− [ match (conP conName []) (normalB $ conStr opts conName) []
267+ [ match (conP conName [])
268+ (normalB $ [|Encoding|] `appE` encStr opts conName) []
252269 | con <- cons
253270 , let conName = getConName con
254271 ]
255272 | otherwise = [argsToEncoding opts True con | con <- cons]
256273
257−conStr :: Options -> Name -> Q Exp
258−conStr opts = appE [|String|] . conTxt opts
259−
260−conTxt :: Options -> Name -> Q Exp
261−conTxt opts = appE [|T.pack|] . conStringE opts
262−
263−conStringE :: Options -> Name -> Q Exp
264−conStringE opts = stringE . constructorTagModifier opts . nameBase
274+encStr :: Options -> Name -> Q Exp
275+encStr opts = appE [|E.text|] . conTxt opts
265276
266277-- | If constructor is nullary.
267278isNullary :: Con -> Bool
@@ -275,12 +286,12 @@ sumToValue opts multiCons conName exp
275286 TwoElemArray ->
276287 [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])
277288 TaggedObject{tagFieldName, contentsFieldName} ->
278− [|object|] `appE` listE
289+ [|A.object|] `appE` listE
279290 [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
280291 , infixApp [|T.pack contentsFieldName|] [|(.=)|] exp
281292 ]
282293 ObjectWithSingleField ->
283− [|object|] `appE` listE
294+ [|A.object|] `appE` listE
284295 [ infixApp (conTxt opts conName) [|(.=)|] exp
285296 ]
286297
@@ -329,7 +340,7 @@ argsToValue opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, no
329340 (True,True,[(_,st,ty)]) -> argsToValue opts multiCons (NormalC conName [(st,ty)])
330341 _ -> do
331342 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
332− let exp = [|object|] `appE` pairs
343+ let exp = [|A.object|] `appE` pairs
333344
334345 pairs | omitNothingFields opts = infixApp maybeFields
335346 [|(++)|]
@@ -367,7 +378,7 @@ argsToValue opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, no
367378 then case sumEncoding opts of
368379 TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
369380 TaggedObject{tagFieldName} ->
370− [|object|] `appE`
381+ [|A.object|] `appE`
371382 -- TODO: Maybe throw an error in case
372383 -- tagFieldName overwrites a field in pairs.
373384 infixApp (infixApp [|T.pack tagFieldName|]
@@ -376,7 +387,7 @@ argsToValue opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, no
376387 [|(:)|]
377388 pairs
378389 ObjectWithSingleField ->
379− [|object|] `appE` listE
390+ [|A.object|] `appE` listE
380391 [ infixApp (conTxt opts conName) [|(.=)|] exp ]
381392 else exp
382393 ) []
@@ -397,21 +408,36 @@ argsToValue opts multiCons (InfixC _ conName _) = do
397408argsToValue opts multiCons (ForallC _ _ con) =
398409 argsToValue opts multiCons con
399410
411+(<^>) :: ExpQ -> ExpQ -> ExpQ
412+(<^>) a b = infixApp a [|(<>)|] b
413+infixr 6 <^>
414+
415+(<:>) :: ExpQ -> ExpQ -> ExpQ
416+(<:>) a b = a <^> [|E.char7 ':'|] <^> b
417+infixr 5 <:>
418+
419+(<%>) :: ExpQ -> ExpQ -> ExpQ
420+(<%>) a b = a <^> [|E.char7 ','|] <^> b
421+infixr 4 <%>
422+
423+array :: ExpQ -> ExpQ
424+array exp = [|Encoding|] `appE` ([|E.char7 '['|] <^> exp <^> [|E.char7 ']'|])
425+
426+object :: ExpQ -> ExpQ
427+object exp = [|Encoding|] `appE` ([|E.char7 '{'|] <^> exp <^> [|E.char7 '}'|])
428+
400429sumToEncoding :: Options -> Bool -> Name -> Q Exp -> Q Exp
401430sumToEncoding opts multiCons conName exp
402431 | multiCons =
403432 case sumEncoding opts of
404433 TwoElemArray ->
405− [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])
434+ array (encStr opts conName <%> exp)
406435 TaggedObject{tagFieldName, contentsFieldName} ->
407− [|object|] `appE` listE
408− [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
409− , infixApp [|T.pack contentsFieldName|] [|(.=)|] exp
410− ]
436+ object $
437+ ([|E.builder tagFieldName|] <:> encStr opts conName) <%>
438+ ([|E.builder contentsFieldName|] <:> [|fromEncoding|] `appE` exp)
411439 ObjectWithSingleField ->
412− [|object|] `appE` listE
413− [ infixApp (conTxt opts conName) [|(.=)|] exp
414− ]
440+ object (conTxt opts conName <:> [|fromEncoding|] `appE` exp)
415441
416442 | otherwise = exp
417443
@@ -422,33 +448,19 @@ argsToEncoding :: Options -> Bool -> Con -> Q Match
422448-- type errors.
423449argsToEncoding opts multiCons (NormalC conName []) =
424450 match (conP conName [])
425− (normalB (sumToEncoding opts multiCons conName [e|toJSON ([] :: [()])|]))
451+ (normalB (sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]))
426452 []
427453
428454-- Polyadic constructors with special case for unary constructors.
429455argsToEncoding opts multiCons (NormalC conName ts) = do
430456 let len = length ts
431457 args <- mapM newName ["arg" ++ show n | n <- [1..len]]
432− js <- case [[|toJSON|] `appE` varE arg | arg <- args] of
458+ js <- case args of
433459 -- Single argument is directly converted.
434− [e] -> return e
460+ [e] -> return ([|toEncoding|] `appE` varE e)
435461 -- Multiple arguments are converted to a JSON array.
436− es -> do
437− mv <- newName "mv"
438− let newMV = bindS (varP mv)
439− ([|VM.unsafeNew|] `appE`
440− litE (integerL $ fromIntegral len))
441− stmts = [ noBindS $
442− [|VM.unsafeWrite|] `appE`
443− (varE mv) `appE`
444− litE (integerL ix) `appE`
445− e
446− | (ix, e) <- zip [(0::Integer)..] es
447− ]
448− ret = noBindS $ [|return|] `appE` varE mv
449− return $ [|Array|] `appE`
450− (varE 'V.create `appE`
451− doE (newMV:stmts++[ret]))
462+ es ->
463+ return (array (foldr1 (<%>) [[|E.builder|] `appE` varE x | x <- es]))
452464 match (conP conName $ map varP args)
453465 (normalB $ sumToEncoding opts multiCons conName js)
454466 []
@@ -458,18 +470,21 @@ argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts,
458470 (True,True,[(_,st,ty)]) -> argsToEncoding opts multiCons (NormalC conName [(st,ty)])
459471 _ -> do
460472 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
461− let exp = [|object|] `appE` pairs
462473
474+ let exp = object objBody
475+
476+ objBody = [|mconcat|] `appE`
477+ ([|intersperse (E.char7 ',')|] `appE` pairs)
463478 pairs | omitNothingFields opts = infixApp maybeFields
464− [|(++)|]
479+ [|(<>)|]
465480 restFields
466− | otherwise = listE $ map toPair argCons
481+ | otherwise = listE (map toPair argCons)
467482
468483 argCons = zip args ts
469484
470485 maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
471486
472− restFields = listE $ map toPair rest
487+ restFields = listE (map toPair rest)
473488
474489 (maybes, rest) = partition isMaybe argCons
475490
@@ -484,29 +499,21 @@ argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts,
484499 (varE arg)
485500
486501 toPair (arg, (field, _, _)) =
487− infixApp (toFieldName field)
488− [|(.=)|]
489− (varE arg)
502+ toFieldName field <:> [|E.builder|] `appE` varE arg
490503
491− toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
504+ toFieldName field = [|E.builder|] `appE` fieldLabelExp opts field
492505
493506 match (conP conName $ map varP args)
494507 ( normalB
495508 $ if multiCons
496509 then case sumEncoding opts of
497− TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
498− TaggedObject{tagFieldName} ->
499− [|object|] `appE`
500− -- TODO: Maybe throw an error in case
501− -- tagFieldName overwrites a field in pairs.
502− infixApp (infixApp [|T.pack tagFieldName|]
503− [|(.=)|]
504− (conStr opts conName))
505− [|(:)|]
506− pairs
507− ObjectWithSingleField ->
508− [|object|] `appE` listE
509− [ infixApp (conTxt opts conName) [|(.=)|] exp ]
510+ TwoElemArray -> array $
511+ encStr opts conName <%> [|fromEncoding|] `appE` exp
512+ TaggedObject{tagFieldName} -> object $
513+ ([|E.builder tagFieldName|] <:> encStr opts conName) <%>
514+ objBody
515+ ObjectWithSingleField -> object $
516+ encStr opts conName <:> [|fromEncoding|] `appE` exp
510517 else exp
511518 ) []
512519
@@ -517,9 +524,9 @@ argsToEncoding opts multiCons (InfixC _ conName _) = do
517524 match (infixP (varP al) conName (varP ar))
518525 ( normalB
519526 $ sumToEncoding opts multiCons conName
520− $ [|toJSON|] `appE` listE [ [|toJSON|] `appE` varE a
521− | a <- [al,ar]
522− ]
527+ $ [|toEncoding|] `appE` listE [ [|toJSON|] `appE` varE a
528+ | a <- [al,ar]
529+ ]
523530 )
524531 []
525532-- Existentially quantified constructors.