Skip to content

Commit 07564d8

Browse files
bergmarkbergmark
authored
Merge pull request #596 from Lysxia/opti-th-encode
Optimize TH toEncoding
2 parents 8e58f82 + 87ba098 commit 07564d8

File tree

2 files changed

+53
-87
lines changed

2 files changed

+53
-87
lines changed

‎Data/Aeson/TH.hs

Lines changed: 29 additions & 69 deletions
Original file line numberDiff line numberDiff line change
@@ -120,10 +120,11 @@ import Prelude ()
120120
import Prelude.Compat hiding (exp)
121121

122122
import Control.Applicative ((<|>))
123-
import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
123+
import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
124124
import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
125125
import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
126126
import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
127+
import Data.Aeson.Types.ToJSON (fromPairs, pair)
127128
import Control.Monad (liftM2, unless, when)
128129
import 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)
133134
import Data.List.NonEmpty ((<|), NonEmpty((:|)))
134135
import Data.Map (Map)
135136
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
137+
import qualified Data.Monoid as Monoid
136138
import Data.Set (Set)
137139
#if MIN_VERSION_template_haskell(2,8,0)
138140
import Language.Haskell.TH hiding (Arity)
@@ -147,7 +149,6 @@ import Language.Haskell.TH.Lib (starK)
147149
import Language.Haskell.TH.Syntax (mkNameG_tc)
148150
#endif
149151
import Text.Printf (printf)
150-
import qualified Data.Aeson as A
151152
import qualified Data.Aeson.Encoding.Internal as E
152153
import qualified Data.Foldable as F (all)
153154
import 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'.
388389
recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
389390
recordSumToValue 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
535536
infixr 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
543540
infixr 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

‎Data/Aeson/Types/ToJSON.hs

Lines changed: 24 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -50,6 +50,8 @@ module Data.Aeson.Types.ToJSON
5050
, contramapToJSONKeyFunction
5151
-- * Object key-value pairs
5252
, KeyValue(..)
53+
, KeyValuePair(..)
54+
, FromPairs(..)
5355
-- * Functions needed for documentation
5456
-- * Encoding functions
5557
, listEncoding
@@ -853,14 +855,14 @@ instance ( IsRecord a isRecord
853855
, TaggedObject' enc pairs arity a isRecord
854856
, FromPairs enc pairs
855857
, FromString enc
856-
, GKeyValue enc pairs
858+
, KeyValuePair enc pairs
857859
, Constructor c
858860
) => TaggedObject enc arity (C1 c a)
859861
where
860862
taggedObject opts targs tagFieldName contentsFieldName =
861863
fromPairs . (tag <>) . contents
862864
where
863-
tag = tagFieldName `gPair`
865+
tag = tagFieldName `pair`
864866
(fromString (constructorTagModifier opts (conName (undefined :: t c a p)))
865867
:: enc)
866868
contents =
@@ -872,11 +874,11 @@ class TaggedObject' enc pairs arity f isRecord where
872874
-> String -> f a -> Tagged isRecord pairs
873875

874876
instance ( GToJSON enc arity f
875-
, GKeyValue enc pairs
877+
, KeyValuePair enc pairs
876878
) => TaggedObject' enc pairs arity f False
877879
where
878880
taggedObject' opts targs contentsFieldName =
879-
Tagged . (contentsFieldName `gPair`) . gToJSON opts targs
881+
Tagged . (contentsFieldName `pair`) . gToJSON opts targs
880882

881883
instance OVERLAPPING_ Monoid pairs => TaggedObject' enc pairs arity U1 False where
882884
taggedObject' _ _ _ _ = Tagged mempty
@@ -1005,7 +1007,7 @@ instance ( Monoid pairs
10051007

10061008
instance ( Selector s
10071009
, GToJSON enc arity a
1008-
, GKeyValue enc pairs
1010+
, KeyValuePair enc pairs
10091011
) => RecordToPairs enc pairs arity (S1 s a)
10101012
where
10111013
recordToPairs = fieldToPair
@@ -1014,7 +1016,7 @@ instance ( Selector s
10141016
instance INCOHERENT_
10151017
( Selector s
10161018
, GToJSON enc arity (K1 i (Maybe a))
1017-
, GKeyValue enc pairs
1019+
, KeyValuePair enc pairs
10181020
, Monoid pairs
10191021
) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a)))
10201022
where
@@ -1026,7 +1028,7 @@ instance INCOHERENT_
10261028
instance INCOHERENT_
10271029
( Selector s
10281030
, GToJSON enc arity (K1 i (Maybe a))
1029-
, GKeyValue enc pairs
1031+
, KeyValuePair enc pairs
10301032
, Monoid pairs
10311033
) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))
10321034
where
@@ -1038,13 +1040,13 @@ instance INCOHERENT_
10381040

10391041
fieldToPair :: (Selector s
10401042
, GToJSON enc arity a
1041-
, GKeyValue enc pairs)
1043+
, KeyValuePair enc pairs)
10421044
=> Options -> ToArgs enc arity p
10431045
-> S1 s a p -> pairs
10441046
fieldToPair opts targs m1 =
10451047
let key = fieldLabelModifier opts (selName m1)
10461048
value = gToJSON opts targs (unM1 m1)
1047-
in key `gPair` value
1049+
in key `pair` value
10481050
{-# INLINE fieldToPair #-}
10491051

10501052
--------------------------------------------------------------------------------
@@ -1098,12 +1100,12 @@ instance OVERLAPPABLE_ (GToJSON Encoding arity a) => EncodeProduct arity a where
10981100
instance ( GToJSON enc arity a
10991101
, ConsToJSON enc arity a
11001102
, FromPairs enc pairs
1101-
, GKeyValue enc pairs
1103+
, KeyValuePair enc pairs
11021104
, Constructor c
11031105
) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)
11041106
where
11051107
sumToJSON' opts targs =
1106-
Tagged . fromPairs . (typ `gPair`) . gToJSON opts targs
1108+
Tagged . fromPairs . (typ `pair`) . gToJSON opts targs
11071109
where
11081110
typ = constructorTagModifier opts $
11091111
conName (undefined :: t c a p)
@@ -2716,20 +2718,24 @@ packChunks lbs =
27162718

27172719
--------------------------------------------------------------------------------
27182720

2721+
-- | Wrap a list of pairs as an object.
27192722
class Monoid pairs => FromPairs enc pairs | enc -> pairs where
27202723
fromPairs :: pairs -> enc
27212724

2722-
instance FromPairs Encoding Series where
2725+
instance (a ~ Value) => FromPairs (Encoding' a) Series where
27232726
fromPairs = E.pairs
27242727

27252728
instance FromPairs Value (DList Pair) where
27262729
fromPairs = object . toList
27272730

2728-
class Monoid kv => GKeyValue v kv where
2729-
gPair :: String -> v -> kv
2731+
-- | Like 'KeyValue' but the value is already converted to JSON
2732+
-- ('Value' or 'Encoding'), and the result actually represents lists of pairs
2733+
-- so it can be readily concatenated.
2734+
class Monoid kv => KeyValuePair v kv where
2735+
pair :: String -> v -> kv
27302736

2731-
instance ToJSON v => GKeyValue v (DList Pair) where
2732-
gPair k v = DList.singleton (pack k .= v)
2737+
instance (v ~ Value) => KeyValuePair v (DList Pair) where
2738+
pair k v = DList.singleton (pack k .= v)
27332739

2734-
instance GKeyValue Encoding Series where
2735-
gPair = E.pairStr
2740+
instance (e ~ Encoding) => KeyValuePair e Series where
2741+
pair = E.pairStr

0 commit comments

Comments
 (0)