@@ -120,10 +120,11 @@ import Prelude ()
120120import Prelude.Compat hiding (exp)
121121
122122import Control.Applicative ((<|>))
123−import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
123+import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
124124import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
125125import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
126126import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
127+import Data.Aeson.Types.ToJSON (fromPairs, pair)
127128import Control.Monad (liftM2, unless, when)
128129import Data.Foldable (foldr')
129130#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
@@ -133,6 +134,7 @@ import Data.List (foldl', genericLength, intercalate, partition, union)
133134import Data.List.NonEmpty ((<|), NonEmpty((:|)))
134135import Data.Map (Map)
135136import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
137+import qualified Data.Monoid as Monoid
136138import Data.Set (Set)
137139#if MIN_VERSION_template_haskell(2,8,0)
138140import Language.Haskell.TH hiding (Arity)
@@ -147,7 +149,6 @@ import Language.Haskell.TH.Lib (starK)
147149import Language.Haskell.TH.Syntax (mkNameG_tc)
148150#endif
149151import Text.Printf (printf)
150−import qualified Data.Aeson as A
151152import qualified Data.Aeson.Encoding.Internal as E
152153import qualified Data.Foldable as F (all)
153154import qualified Data.HashMap.Strict as H (lookup, toList)
@@ -382,13 +383,13 @@ opaqueSumToValue target opts multiCons nullary conName value =
382383 value
383384 pairs
384385 where
385− pairs contentsFieldName = listE [toPair target contentsFieldName value]
386+ pairs contentsFieldName = pairE contentsFieldName value
386387
387388-- | Wrap fields of a record constructor. See 'sumToValue'.
388389recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
389390recordSumToValue target opts multiCons nullary conName pairs =
390391 sumToValue target opts multiCons nullary conName
391− (objectExp target pairs)
392+ (fromPairsE pairs)
392393 (const pairs)
393394
394395-- | Wrap fields of a constructor.
@@ -423,12 +424,12 @@ sumToValue target opts multiCons nullary conName value pairs
423424 TaggedObject{tagFieldName, contentsFieldName} ->
424425 -- TODO: Maybe throw an error in case
425426 -- tagFieldName overwrites a field in pairs.
426− let tag = toPair target tagFieldName (conStr target opts conName)
427+ let tag = pairE tagFieldName (conStr target opts conName)
427428 content = pairs contentsFieldName
428− in objectExp target $
429− if nullary then listE [tag] else infixApp tag [|(:)|] content
429+ in fromPairsE $
430+ if nullary then tag else infixApp tag [|(Monoid.<>)|] content
430431 ObjectWithSingleField ->
431− object target [(conString opts conName, value)]
432+ objectE [(conString opts conName, value)]
432433 UntaggedValue | nullary -> conStr target opts conName
433434 UntaggedValue -> value
434435 | otherwise = value
@@ -469,15 +470,15 @@ argsToValue target jc tvMap opts multiCons
469470 argTys' <- mapM resolveTypeSynonyms argTys
470471 args <- newNameList "arg" $ length argTys'
471472 let pairs | omitNothingFields opts = infixApp maybeFields
472− [|(++)|]
473+ [|(Monoid.<>)|]
473474 restFields
474− | otherwise = listE $ map pureToPair argCons
475+ | otherwise = mconcatE (map pureToPair argCons)
475476
476477 argCons = zip3 (map varE args) argTys' fields
477478
478− maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
479+ maybeFields = mconcatE (map maybeToPair maybes)
479480
480− restFields = listE $ map pureToPair rest
481+ restFields = mconcatE (map pureToPair rest)
481482
482483 (maybes0, rest0) = partition isMaybe argCons
483484 (options, rest) = partition isOption rest0
@@ -489,11 +490,11 @@ argsToValue target jc tvMap opts multiCons
489490 toPairLifted lifted (arg, argTy, field) =
490491 let toValue = dispatchToJSON target jc conName tvMap argTy
491492 fieldName = fieldLabel opts field
492− e arg' = toPair target fieldName (toValue `appE` arg')
493+ e arg' = pairE fieldName (toValue `appE` arg')
493494 in if lifted
494495 then do
495496 x <- newName "x"
496− infixApp (lam1E (varP x) (e (varE x))) [|(<$>)|] arg
497+ [|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg
497498 else e arg
498499
499500 match (conP conName $ map varP args)
@@ -534,10 +535,6 @@ optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)
534535(<^>) a b = infixApp a [|(E.><)|] b
535536infixr 6 <^>
536537
537−(<:>) :: ExpQ -> ExpQ -> ExpQ
538−(<:>) a b = a <^> [|E.colon|] <^> b
539−infixr 5 <:>
540−
541538(<%>) :: ExpQ -> ExpQ -> ExpQ
542539(<%>) a b = a <^> [|E.comma|] <^> b
543540infixr 4 <%>
@@ -565,62 +562,25 @@ array Value es = do
565562 doE (newMV:stmts++[ret]))
566563
567564-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.
568−object :: ToJSONFun -> [(String, ExpQ)] -> ExpQ
569−object target = wrapObject target . catPairs target . fmap (uncurry (toPair target))
570−
571−-- |
572−-- - When deriving 'ToJSON', map a list of quoted key-value pairs to an
573−-- expression of the list of pairs.
574−-- - When deriving 'ToEncoding', map a list of quoted 'Encoding's representing
575−-- key-value pairs to a comma-separated 'Encoding' of them.
576−--
577−-- > catPairs Value [ [|(k0,v0)|], [|(k1,v1)|] ] = [| [(k0,v0), (k1,v1)] |]
578−-- > catPairs Encoding [ [|"\"k0\":v0"|], [|"\"k1\":v1"|] ] = [| "\"k0\":v0,\"k1\":v1" |]
579−catPairs :: ToJSONFun -> [ExpQ] -> ExpQ
580−catPairs Value = listE
581−catPairs Encoding = foldr1 (<%>)
582−
583−-- |
584−-- - When deriving 'ToJSON', wrap a quoted list of key-value pairs in an 'Object'.
585−-- - When deriving 'ToEncoding', wrap a quoted list of encoded key-value pairs
586−-- in an encoded 'Object'.
587−--
588−-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]
589−-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "{\"k0\":v0,\"k1\":v1}" |]
590−objectExp :: ToJSONFun -> ExpQ -> ExpQ
591−objectExp target = wrapObject target . catPairsExp target
592−
593−-- | Counterpart of 'catPairsExp' when the list of pairs is already quoted.
594−--
595−-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| [(k0,v0), (k1,v1)] |]
596−-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "\"k0\":v0,\"k1\":v1" |]
597−catPairsExp :: ToJSONFun -> ExpQ -> ExpQ
598−catPairsExp Value e = e
599−catPairsExp Encoding e = [|commaSep|] `appE` e
565+objectE :: [(String, ExpQ)] -> ExpQ
566+objectE = fromPairsE . mconcatE . fmap (uncurry pairE)
600567
601−-- | Create (an encoding of) a key-value pair.
568+-- | 'mconcat' a list of fixed length.
602569--
603−-- > toPair Value "k" [|v|] = [|("k",v)|] -- The quoted string is actually Text.
604−-- > toPair Encoding "k" [|"v"|] = [|"\"k\":v"|]
605−toPair :: ToJSONFun -> String -> ExpQ -> ExpQ
606−toPair Value k v = infixApp [|T.pack k|] [|(.=)|] v
607−toPair Encoding k v = [|E.string k|] <:> v
570+-- > mconcatE [ [|x|], [|y|], [|z|] ] = [| x <> (y <> z) |]
571+mconcatE :: [ExpQ] -> ExpQ
572+mconcatE [] = [|Monoid.mempty|]
573+mconcatE [x] = x
574+mconcatE (x : xs) = infixApp x [|(Monoid.<>)|] (mconcatE xs)
608575
609−-- | Map an associative list in an 'Object'.
610−--
611−-- > wrapObject Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]
612−-- > wrapObject Encoding [| "\"k0\":v0,\"k1\":v1" |] = [| "{\"k0\":v0,\"k1\":v1}" |]
613−wrapObject :: ToJSONFun -> ExpQ -> ExpQ
614−wrapObject Value e = [|A.object|] `appE` e
615−wrapObject Encoding e = [|E.wrapObject|] `appE` e
576+fromPairsE :: ExpQ -> ExpQ
577+fromPairsE = ([|fromPairs|] `appE`)
616578
617−-- | Separate 'Encoding's by commas.
579+-- | Create (an encoding of) a key-value pair.
618580--
619−-- > commaSep ["a","b","c"] = "a,b,c"
620−commaSep :: [E.Encoding] -> E.Encoding
621−commaSep [] = E.empty
622−commaSep [x] = x
623−commaSep (x : xs) = x E.>< E.comma E.>< commaSep xs
581+-- > pairE "k" [|v|] = [|pair "k" v|]
582+pairE :: String -> ExpQ -> ExpQ
583+pairE k v = [|pair k|] `appE` v
624584
625585--------------------------------------------------------------------------------
626586-- FromJSON