Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Optimize TH toEncoding #596

Merged
merged 2 commits into from Oct 18, 2017
Merged

Optimize TH toEncoding #596

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
5a8e763
Export FromPairs and KeyValuePairs from Types.ToJSON
Lysxia Oct 8, 2017
87ba098
Unroll conversion of pair lists to JSON in TH
Lysxia Oct 8, 2017
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
98 changes: 29 additions & 69 deletions Data/Aeson/TH.hs
View file
Open in desktop
Expand Up @@ -120,10 +120,11 @@ import Prelude ()
import Prelude.Compat hiding (exp)

import Control.Applicative ((<|>))
import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
import Data.Aeson.Types.ToJSON (fromPairs, pair)
import Control.Monad (liftM2, unless, when)
import Data.Foldable (foldr')
#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
Expand All @@ -133,6 +134,7 @@ import Data.List (foldl', genericLength, intercalate, partition, union)
import Data.List.NonEmpty ((<|), NonEmpty((:|)))
import Data.Map (Map)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import qualified Data.Monoid as Monoid
import Data.Set (Set)
#if MIN_VERSION_template_haskell(2,8,0)
import Language.Haskell.TH hiding (Arity)
Expand All @@ -147,7 +149,6 @@ import Language.Haskell.TH.Lib (starK)
import Language.Haskell.TH.Syntax (mkNameG_tc)
#endif
import Text.Printf (printf)
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding.Internal as E
import qualified Data.Foldable as F (all)
import qualified Data.HashMap.Strict as H (lookup, toList)
Expand Down Expand Up @@ -382,13 +383,13 @@ opaqueSumToValue target opts multiCons nullary conName value =
value
pairs
where
pairs contentsFieldName = listE [toPair target contentsFieldName value]
pairs contentsFieldName = pairE contentsFieldName value

-- | Wrap fields of a record constructor. See 'sumToValue'.
recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
recordSumToValue target opts multiCons nullary conName pairs =
sumToValue target opts multiCons nullary conName
(objectExp target pairs)
(fromPairsE pairs)
(const pairs)

-- | Wrap fields of a constructor.
Expand Down Expand Up @@ -423,12 +424,12 @@ sumToValue target opts multiCons nullary conName value pairs
TaggedObject{tagFieldName, contentsFieldName} ->
-- TODO: Maybe throw an error in case
-- tagFieldName overwrites a field in pairs.
let tag = toPair target tagFieldName (conStr target opts conName)
let tag = pairE tagFieldName (conStr target opts conName)
content = pairs contentsFieldName
in objectExp target $
if nullary then listE [tag] else infixApp tag [|(:)|] content
in fromPairsE $
if nullary then tag else infixApp tag [|(Monoid.<>)|] content
ObjectWithSingleField ->
object target [(conString opts conName, value)]
objectE [(conString opts conName, value)]
UntaggedValue | nullary -> conStr target opts conName
UntaggedValue -> value
| otherwise = value
Expand Down Expand Up @@ -469,15 +470,15 @@ argsToValue target jc tvMap opts multiCons
argTys' <- mapM resolveTypeSynonyms argTys
args <- newNameList "arg" $ length argTys'
let pairs | omitNothingFields opts = infixApp maybeFields
[|(++)|]
[|(Monoid.<>)|]
restFields
| otherwise = listE $ map pureToPair argCons
| otherwise = mconcatE (map pureToPair argCons)

argCons = zip3 (map varE args) argTys' fields

maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
maybeFields = mconcatE (map maybeToPair maybes)

restFields = listE $ map pureToPair rest
restFields = mconcatE (map pureToPair rest)

(maybes0, rest0) = partition isMaybe argCons
(options, rest) = partition isOption rest0
Expand All @@ -489,11 +490,11 @@ argsToValue target jc tvMap opts multiCons
toPairLifted lifted (arg, argTy, field) =
let toValue = dispatchToJSON target jc conName tvMap argTy
fieldName = fieldLabel opts field
e arg' = toPair target fieldName (toValue `appE` arg')
e arg' = pairE fieldName (toValue `appE` arg')
in if lifted
then do
x <- newName "x"
infixApp (lam1E (varP x) (e (varE x))) [|(<$>)|] arg
[|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg
else e arg

match (conP conName $ map varP args)
Expand Down Expand Up @@ -534,10 +535,6 @@ optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)
(<^>) a b = infixApp a [|(E.><)|] b
infixr 6 <^>

(<:>) :: ExpQ -> ExpQ -> ExpQ
(<:>) a b = a <^> [|E.colon|] <^> b
infixr 5 <:>

(<%>) :: ExpQ -> ExpQ -> ExpQ
(<%>) a b = a <^> [|E.comma|] <^> b
infixr 4 <%>
Expand Down Expand Up @@ -565,62 +562,25 @@ array Value es = do
doE (newMV:stmts++[ret]))

-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.
object :: ToJSONFun -> [(String, ExpQ)] -> ExpQ
object target = wrapObject target . catPairs target . fmap (uncurry (toPair target))

-- |
-- - When deriving 'ToJSON', map a list of quoted key-value pairs to an
-- expression of the list of pairs.
-- - When deriving 'ToEncoding', map a list of quoted 'Encoding's representing
-- key-value pairs to a comma-separated 'Encoding' of them.
--
-- > catPairs Value [ [|(k0,v0)|], [|(k1,v1)|] ] = [| [(k0,v0), (k1,v1)] |]
-- > catPairs Encoding [ [|"\"k0\":v0"|], [|"\"k1\":v1"|] ] = [| "\"k0\":v0,\"k1\":v1" |]
catPairs :: ToJSONFun -> [ExpQ] -> ExpQ
catPairs Value = listE
catPairs Encoding = foldr1 (<%>)

-- |
-- - When deriving 'ToJSON', wrap a quoted list of key-value pairs in an 'Object'.
-- - When deriving 'ToEncoding', wrap a quoted list of encoded key-value pairs
-- in an encoded 'Object'.
--
-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]
-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "{\"k0\":v0,\"k1\":v1}" |]
objectExp :: ToJSONFun -> ExpQ -> ExpQ
objectExp target = wrapObject target . catPairsExp target

-- | Counterpart of 'catPairsExp' when the list of pairs is already quoted.
--
-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| [(k0,v0), (k1,v1)] |]
-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "\"k0\":v0,\"k1\":v1" |]
catPairsExp :: ToJSONFun -> ExpQ -> ExpQ
catPairsExp Value e = e
catPairsExp Encoding e = [|commaSep|] `appE` e
objectE :: [(String, ExpQ)] -> ExpQ
objectE = fromPairsE . mconcatE . fmap (uncurry pairE)

-- | Create (an encoding of) a key-value pair.
-- | 'mconcat' a list of fixed length.
--
-- > toPair Value "k" [|v|] = [|("k",v)|] -- The quoted string is actually Text.
-- > toPair Encoding "k" [|"v"|] = [|"\"k\":v"|]
toPair :: ToJSONFun -> String -> ExpQ -> ExpQ
toPair Value k v = infixApp [|T.pack k|] [|(.=)|] v
toPair Encoding k v = [|E.string k|] <:> v
-- > mconcatE [ [|x|], [|y|], [|z|] ] = [| x <> (y <> z) |]
mconcatE :: [ExpQ] -> ExpQ
mconcatE [] = [|Monoid.mempty|]
mconcatE [x] = x
mconcatE (x : xs) = infixApp x [|(Monoid.<>)|] (mconcatE xs)

-- | Map an associative list in an 'Object'.
--
-- > wrapObject Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]
-- > wrapObject Encoding [| "\"k0\":v0,\"k1\":v1" |] = [| "{\"k0\":v0,\"k1\":v1}" |]
wrapObject :: ToJSONFun -> ExpQ -> ExpQ
wrapObject Value e = [|A.object|] `appE` e
wrapObject Encoding e = [|E.wrapObject|] `appE` e
fromPairsE :: ExpQ -> ExpQ
fromPairsE = ([|fromPairs|] `appE`)

-- | Separate 'Encoding's by commas.
-- | Create (an encoding of) a key-value pair.
--
-- > commaSep ["a","b","c"] = "a,b,c"
commaSep :: [E.Encoding] -> E.Encoding
commaSep [] = E.empty
commaSep [x] = x
commaSep (x : xs) = x E.>< E.comma E.>< commaSep xs
-- > pairE "k" [|v|] = [|pair "k" v|]
pairE :: String -> ExpQ -> ExpQ
pairE k v = [|pair k|] `appE` v

--------------------------------------------------------------------------------
-- FromJSON
Expand Down
42 changes: 24 additions & 18 deletions Data/Aeson/Types/ToJSON.hs
View file
Open in desktop
Expand Up @@ -50,6 +50,8 @@ module Data.Aeson.Types.ToJSON
, contramapToJSONKeyFunction
-- * Object key-value pairs
, KeyValue(..)
, KeyValuePair(..)
, FromPairs(..)
-- * Functions needed for documentation
-- * Encoding functions
, listEncoding
Expand Down Expand Up @@ -853,14 +855,14 @@ instance ( IsRecord a isRecord
, TaggedObject' enc pairs arity a isRecord
, FromPairs enc pairs
, FromString enc
, GKeyValue enc pairs
, KeyValuePair enc pairs
, Constructor c
) => TaggedObject enc arity (C1 c a)
where
taggedObject opts targs tagFieldName contentsFieldName =
fromPairs . (tag <>) . contents
where
tag = tagFieldName `gPair`
tag = tagFieldName `pair`
(fromString (constructorTagModifier opts (conName (undefined :: t c a p)))
:: enc)
contents =
Expand All @@ -872,11 +874,11 @@ class TaggedObject' enc pairs arity f isRecord where
-> String -> f a -> Tagged isRecord pairs

instance ( GToJSON enc arity f
, GKeyValue enc pairs
, KeyValuePair enc pairs
) => TaggedObject' enc pairs arity f False
where
taggedObject' opts targs contentsFieldName =
Tagged . (contentsFieldName `gPair`) . gToJSON opts targs
Tagged . (contentsFieldName `pair`) . gToJSON opts targs

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

instance ( Selector s
, GToJSON enc arity a
, GKeyValue enc pairs
, KeyValuePair enc pairs
) => RecordToPairs enc pairs arity (S1 s a)
where
recordToPairs = fieldToPair
Expand All @@ -1014,7 +1016,7 @@ instance ( Selector s
instance INCOHERENT_
( Selector s
, GToJSON enc arity (K1 i (Maybe a))
, GKeyValue enc pairs
, KeyValuePair enc pairs
, Monoid pairs
) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a)))
where
Expand All @@ -1026,7 +1028,7 @@ instance INCOHERENT_
instance INCOHERENT_
( Selector s
, GToJSON enc arity (K1 i (Maybe a))
, GKeyValue enc pairs
, KeyValuePair enc pairs
, Monoid pairs
) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))
where
Expand All @@ -1038,13 +1040,13 @@ instance INCOHERENT_

fieldToPair :: (Selector s
, GToJSON enc arity a
, GKeyValue enc pairs)
, KeyValuePair enc pairs)
=> Options -> ToArgs enc arity p
-> S1 s a p -> pairs
fieldToPair opts targs m1 =
let key = fieldLabelModifier opts (selName m1)
value = gToJSON opts targs (unM1 m1)
in key `gPair` value
in key `pair` value
{-# INLINE fieldToPair #-}

--------------------------------------------------------------------------------
Expand Down Expand Up @@ -1098,12 +1100,12 @@ instance OVERLAPPABLE_ (GToJSON Encoding arity a) => EncodeProduct arity a where
instance ( GToJSON enc arity a
, ConsToJSON enc arity a
, FromPairs enc pairs
, GKeyValue enc pairs
, KeyValuePair enc pairs
, Constructor c
) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)
where
sumToJSON' opts targs =
Tagged . fromPairs . (typ `gPair`) . gToJSON opts targs
Tagged . fromPairs . (typ `pair`) . gToJSON opts targs
where
typ = constructorTagModifier opts $
conName (undefined :: t c a p)
Expand Down Expand Up @@ -2716,20 +2718,24 @@ packChunks lbs =

--------------------------------------------------------------------------------

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

instance FromPairs Encoding Series where
instance (a ~ Value) => FromPairs (Encoding' a) Series where
fromPairs = E.pairs

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

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

instance ToJSON v => GKeyValue v (DList Pair) where
gPair k v = DList.singleton (pack k .= v)
instance (v ~ Value) => KeyValuePair v (DList Pair) where
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is there a reason this isn't KeyValuePair Value (DList Pair) ?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It improves type inference. Otherwise the TH deriving results in ambiguous type variables and we would need more type annotations.

pair k v = DList.singleton (pack k .= v)

instance GKeyValue Encoding Series where
gPair = E.pairStr
instance (e ~ Encoding) => KeyValuePair e Series where
pair = E.pairStr