07564d8 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Merge pull request #596 from Lysxia/opti-th-encode

07564d8Adam Bergmark9 years ago

Data/Aeson/TH.hs+29−69

compare with master

unifiedsplit

@@ -120,10 +120,11 @@ import Prelude ()

120import Prelude.Compat hiding (exp)

121

122import Control.Applicative ((<|>))

123−import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))

123+import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))

124import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)

125import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))

126import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)

127+import Data.Aeson.Types.ToJSON (fromPairs, pair)

127import Control.Monad (liftM2, unless, when)

128import Control.Monad (liftM2, unless, when)

128import Data.Foldable (foldr')

129import Data.Foldable (foldr')

129#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)

130#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)

133import Data.List.NonEmpty ((<|), NonEmpty((:|)))

134import Data.List.NonEmpty ((<|), NonEmpty((:|)))

134import Data.Map (Map)

135import Data.Map (Map)

135import Data.Maybe (catMaybes, fromMaybe, mapMaybe)

136import Data.Maybe (catMaybes, fromMaybe, mapMaybe)

137+import qualified Data.Monoid as Monoid

136import Data.Set (Set)

138import Data.Set (Set)

137#if MIN_VERSION_template_haskell(2,8,0)

139#if MIN_VERSION_template_haskell(2,8,0)

138import Language.Haskell.TH hiding (Arity)

140import Language.Haskell.TH hiding (Arity)

@@ -147,7 +149,6 @@ import Language.Haskell.TH.Lib (starK)

147import Language.Haskell.TH.Syntax (mkNameG_tc)

149import Language.Haskell.TH.Syntax (mkNameG_tc)

148#endif

150#endif

149import Text.Printf (printf)

151import Text.Printf (printf)

150−import qualified Data.Aeson as A

151import qualified Data.Aeson.Encoding.Internal as E

152import qualified Data.Aeson.Encoding.Internal as E

152import qualified Data.Foldable as F (all)

153import qualified Data.Foldable as F (all)

153import qualified Data.HashMap.Strict as H (lookup, toList)

154import qualified Data.HashMap.Strict as H (lookup, toList)

@@ -382,13 +383,13 @@ opaqueSumToValue target opts multiCons nullary conName value =

382 value

383 value

383 pairs

384 pairs

384 where

385 where

385− pairs contentsFieldName = listE [toPair target contentsFieldName value]

386+ pairs contentsFieldName = pairE contentsFieldName value

386

387

387-- | Wrap fields of a record constructor. See 'sumToValue'.

388-- | Wrap fields of a record constructor. See 'sumToValue'.

388recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ

389recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ

389recordSumToValue target opts multiCons nullary conName pairs =

390recordSumToValue target opts multiCons nullary conName pairs =

390 sumToValue target opts multiCons nullary conName

391 sumToValue target opts multiCons nullary conName

391− (objectExp target pairs)

392+ (fromPairsE pairs)

392 (const pairs)

393 (const pairs)

393

394

394-- | Wrap fields of a constructor.

395-- | Wrap fields of a constructor.

@@ -423,12 +424,12 @@ sumToValue target opts multiCons nullary conName value pairs

423 TaggedObject{tagFieldName, contentsFieldName} ->

424 TaggedObject{tagFieldName, contentsFieldName} ->

424 -- TODO: Maybe throw an error in case

425 -- TODO: Maybe throw an error in case

425 -- tagFieldName overwrites a field in pairs.

426 -- 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)

427 content = pairs contentsFieldName

428 content = pairs contentsFieldName

428− in objectExp target $

429+ in fromPairsE $

429− if nullary then listE [tag] else infixApp tag [|(:)|] content

430+ if nullary then tag else infixApp tag [|(Monoid.<>)|] content

430 ObjectWithSingleField ->

431 ObjectWithSingleField ->

431− object target [(conString opts conName, value)]

432+ objectE [(conString opts conName, value)]

432 UntaggedValue | nullary -> conStr target opts conName

433 UntaggedValue | nullary -> conStr target opts conName

433 UntaggedValue -> value

434 UntaggedValue -> value

434 | otherwise = value

435 | otherwise = value

@@ -469,15 +470,15 @@ argsToValue target jc tvMap opts multiCons

469 argTys' <- mapM resolveTypeSynonyms argTys

470 argTys' <- mapM resolveTypeSynonyms argTys

470 args <- newNameList "arg" $ length argTys'

471 args <- newNameList "arg" $ length argTys'

471 let pairs | omitNothingFields opts = infixApp maybeFields

472 let pairs | omitNothingFields opts = infixApp maybeFields

472− [|(++)|]

473+ [|(Monoid.<>)|]

473 restFields

474 restFields

474− | otherwise = listE $ map pureToPair argCons

475+ | otherwise = mconcatE (map pureToPair argCons)

475

476

476 argCons = zip3 (map varE args) argTys' fields

477 argCons = zip3 (map varE args) argTys' fields

477

478

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

479+ maybeFields = mconcatE (map maybeToPair maybes)

479

480

480− restFields = listE $ map pureToPair rest

481+ restFields = mconcatE (map pureToPair rest)

481

482

482 (maybes0, rest0) = partition isMaybe argCons

483 (maybes0, rest0) = partition isMaybe argCons

483 (options, rest) = partition isOption rest0

484 (options, rest) = partition isOption rest0

@@ -489,11 +490,11 @@ argsToValue target jc tvMap opts multiCons

489 toPairLifted lifted (arg, argTy, field) =

490 toPairLifted lifted (arg, argTy, field) =

490 let toValue = dispatchToJSON target jc conName tvMap argTy

491 let toValue = dispatchToJSON target jc conName tvMap argTy

491 fieldName = fieldLabel opts field

492 fieldName = fieldLabel opts field

492− e arg' = toPair target fieldName (toValue `appE` arg')

493+ e arg' = pairE fieldName (toValue `appE` arg')

493 in if lifted

494 in if lifted

494 then do

495 then do

495 x <- newName "x"

496 x <- newName "x"

496− infixApp (lam1E (varP x) (e (varE x))) [|(<$>)|] arg

497+ [|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg

497 else e arg

498 else e arg

498

499

499 match (conP conName $ map varP args)

500 match (conP conName $ map varP args)

@@ -534,10 +535,6 @@ optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)

534(<^>) a b = infixApp a [|(E.><)|] b

535(<^>) a b = infixApp a [|(E.><)|] b

535infixr 6 <^>

536infixr 6 <^>

536

537

537−(<:>) :: ExpQ -> ExpQ -> ExpQ

538−(<:>) a b = a <^> [|E.colon|] <^> b

539−infixr 5 <:>

540−

541(<%>) :: ExpQ -> ExpQ -> ExpQ

538(<%>) :: ExpQ -> ExpQ -> ExpQ

542(<%>) a b = a <^> [|E.comma|] <^> b

539(<%>) a b = a <^> [|E.comma|] <^> b

543infixr 4 <%>

540infixr 4 <%>

@@ -565,62 +562,25 @@ array Value es = do

565 doE (newMV:stmts++[ret]))

562 doE (newMV:stmts++[ret]))

566

563

567-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.

564-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.

568−object :: ToJSONFun -> [(String, ExpQ)] -> ExpQ

565+objectE :: [(String, ExpQ)] -> ExpQ

569−object target = wrapObject target . catPairs target . fmap (uncurry (toPair target))

566+objectE = fromPairsE . mconcatE . fmap (uncurry pairE)

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

600

567

601−-- | Create (an encoding of) a key-value pair.

568+-- | 'mconcat' a list of fixed length.

602--

569--

603−-- > toPair Value "k" [|v|] = [|("k",v)|] -- The quoted string is actually Text.

570+-- > mconcatE [ [|x|], [|y|], [|z|] ] = [| x <> (y <> z) |]

604−-- > toPair Encoding "k" [|"v"|] = [|"\"k\":v"|]

571+mconcatE :: [ExpQ] -> ExpQ

605−toPair :: ToJSONFun -> String -> ExpQ -> ExpQ

572+mconcatE [] = [|Monoid.mempty|]

606−toPair Value k v = infixApp [|T.pack k|] [|(.=)|] v

573+mconcatE [x] = x

607−toPair Encoding k v = [|E.string k|] <:> v

574+mconcatE (x : xs) = infixApp x [|(Monoid.<>)|] (mconcatE xs)

608

575

609−-- | Map an associative list in an 'Object'.

576+fromPairsE :: ExpQ -> ExpQ

610−--

577+fromPairsE = ([|fromPairs|] `appE`)

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

616

578

617−-- | Separate 'Encoding's by commas.

579+-- | Create (an encoding of) a key-value pair.

618--

580--

619−-- > commaSep ["a","b","c"] = "a,b,c"

581+-- > pairE "k" [|v|] = [|pair "k" v|]

620−commaSep :: [E.Encoding] -> E.Encoding

582+pairE :: String -> ExpQ -> ExpQ

621−commaSep [] = E.empty

583+pairE k v = [|pair k|] `appE` v

622−commaSep [x] = x

623−commaSep (x : xs) = x E.>< E.comma E.>< commaSep xs

624

584

625--------------------------------------------------------------------------------

585--------------------------------------------------------------------------------

626-- FromJSON

586-- FromJSON

Data/Aeson/Types/ToJSON.hs+24−18

@@ -50,6 +50,8 @@ module Data.Aeson.Types.ToJSON

50 , contramapToJSONKeyFunction

51 -- * Object key-value pairs

52 , KeyValue(..)

53+ , KeyValuePair(..)

54+ , FromPairs(..)

53 -- * Functions needed for documentation

55 -- * Functions needed for documentation

54 -- * Encoding functions

56 -- * Encoding functions

55 , listEncoding

57 , listEncoding

@@ -853,14 +855,14 @@ instance ( IsRecord a isRecord

853 , TaggedObject' enc pairs arity a isRecord

855 , TaggedObject' enc pairs arity a isRecord

854 , FromPairs enc pairs

856 , FromPairs enc pairs

855 , FromString enc

857 , FromString enc

856− , GKeyValue enc pairs

858+ , KeyValuePair enc pairs

857 , Constructor c

859 , Constructor c

858 ) => TaggedObject enc arity (C1 c a)

860 ) => TaggedObject enc arity (C1 c a)

859 where

861 where

860 taggedObject opts targs tagFieldName contentsFieldName =

862 taggedObject opts targs tagFieldName contentsFieldName =

861 fromPairs . (tag <>) . contents

863 fromPairs . (tag <>) . contents

862 where

864 where

863− tag = tagFieldName `gPair`

865+ tag = tagFieldName `pair`

864 (fromString (constructorTagModifier opts (conName (undefined :: t c a p)))

866 (fromString (constructorTagModifier opts (conName (undefined :: t c a p)))

865 :: enc)

867 :: enc)

866 contents =

868 contents =

@@ -872,11 +874,11 @@ class TaggedObject' enc pairs arity f isRecord where

872 -> String -> f a -> Tagged isRecord pairs

874 -> String -> f a -> Tagged isRecord pairs

873

875

874instance ( GToJSON enc arity f

876instance ( GToJSON enc arity f

875− , GKeyValue enc pairs

877+ , KeyValuePair enc pairs

876 ) => TaggedObject' enc pairs arity f False

878 ) => TaggedObject' enc pairs arity f False

877 where

879 where

878 taggedObject' opts targs contentsFieldName =

880 taggedObject' opts targs contentsFieldName =

879− Tagged . (contentsFieldName `gPair`) . gToJSON opts targs

881+ Tagged . (contentsFieldName `pair`) . gToJSON opts targs

880

882

881instance OVERLAPPING_ Monoid pairs => TaggedObject' enc pairs arity U1 False where

883instance OVERLAPPING_ Monoid pairs => TaggedObject' enc pairs arity U1 False where

882 taggedObject' _ _ _ _ = Tagged mempty

884 taggedObject' _ _ _ _ = Tagged mempty

@@ -1005,7 +1007,7 @@ instance ( Monoid pairs

1005

1007

1006instance ( Selector s

1008instance ( Selector s

1007 , GToJSON enc arity a

1009 , GToJSON enc arity a

1008− , GKeyValue enc pairs

1010+ , KeyValuePair enc pairs

1009 ) => RecordToPairs enc pairs arity (S1 s a)

1011 ) => RecordToPairs enc pairs arity (S1 s a)

1010 where

1012 where

1011 recordToPairs = fieldToPair

1013 recordToPairs = fieldToPair

@@ -1014,7 +1016,7 @@ instance ( Selector s

1014instance INCOHERENT_

1016instance INCOHERENT_

1015 ( Selector s

1017 ( Selector s

1016 , GToJSON enc arity (K1 i (Maybe a))

1018 , GToJSON enc arity (K1 i (Maybe a))

1017− , GKeyValue enc pairs

1019+ , KeyValuePair enc pairs

1018 , Monoid pairs

1020 , Monoid pairs

1019 ) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a)))

1021 ) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a)))

1020 where

1022 where

@@ -1026,7 +1028,7 @@ instance INCOHERENT_

1026instance INCOHERENT_

1028instance INCOHERENT_

1027 ( Selector s

1029 ( Selector s

1028 , GToJSON enc arity (K1 i (Maybe a))

1030 , GToJSON enc arity (K1 i (Maybe a))

1029− , GKeyValue enc pairs

1031+ , KeyValuePair enc pairs

1030 , Monoid pairs

1032 , Monoid pairs

1031 ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))

1033 ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))

1032 where

1034 where

@@ -1038,13 +1040,13 @@ instance INCOHERENT_

1038

1040

1039fieldToPair :: (Selector s

1041fieldToPair :: (Selector s

1040 , GToJSON enc arity a

1042 , GToJSON enc arity a

1041− , GKeyValue enc pairs)

1043+ , KeyValuePair enc pairs)

1042 => Options -> ToArgs enc arity p

1044 => Options -> ToArgs enc arity p

1043 -> S1 s a p -> pairs

1045 -> S1 s a p -> pairs

1044fieldToPair opts targs m1 =

1046fieldToPair opts targs m1 =

1045 let key = fieldLabelModifier opts (selName m1)

1047 let key = fieldLabelModifier opts (selName m1)

1046 value = gToJSON opts targs (unM1 m1)

1048 value = gToJSON opts targs (unM1 m1)

1047− in key `gPair` value

1049+ in key `pair` value

1048{-# INLINE fieldToPair #-}

1050{-# INLINE fieldToPair #-}

1049

1051

1050--------------------------------------------------------------------------------

1052--------------------------------------------------------------------------------

@@ -1098,12 +1100,12 @@ instance OVERLAPPABLE_ (GToJSON Encoding arity a) => EncodeProduct arity a where

1098instance ( GToJSON enc arity a

1100instance ( GToJSON enc arity a

1099 , ConsToJSON enc arity a

1101 , ConsToJSON enc arity a

1100 , FromPairs enc pairs

1102 , FromPairs enc pairs

1101− , GKeyValue enc pairs

1103+ , KeyValuePair enc pairs

1102 , Constructor c

1104 , Constructor c

1103 ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)

1105 ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)

1104 where

1106 where

1105 sumToJSON' opts targs =

1107 sumToJSON' opts targs =

1106− Tagged . fromPairs . (typ `gPair`) . gToJSON opts targs

1108+ Tagged . fromPairs . (typ `pair`) . gToJSON opts targs

1107 where

1109 where

1108 typ = constructorTagModifier opts $

1110 typ = constructorTagModifier opts $

1109 conName (undefined :: t c a p)

1111 conName (undefined :: t c a p)

@@ -2716,20 +2718,24 @@ packChunks lbs =

2716

2718

2717--------------------------------------------------------------------------------

2719--------------------------------------------------------------------------------

2718

2720

2721+-- | Wrap a list of pairs as an object.

2719class Monoid pairs => FromPairs enc pairs | enc -> pairs where

2722class Monoid pairs => FromPairs enc pairs | enc -> pairs where

2720 fromPairs :: pairs -> enc

2723 fromPairs :: pairs -> enc

2721

2724

2722−instance FromPairs Encoding Series where

2725+instance (a ~ Value) => FromPairs (Encoding' a) Series where

2723 fromPairs = E.pairs

2726 fromPairs = E.pairs

2724

2727

2725instance FromPairs Value (DList Pair) where

2728instance FromPairs Value (DList Pair) where

2726 fromPairs = object . toList

2729 fromPairs = object . toList

2727

2730

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.

2728−class Monoid kv => GKeyValue v kv where

2734+class Monoid kv => KeyValuePair v kv where

2729− gPair :: String -> v -> kv

2735+ pair :: String -> v -> kv

2730

2736

2731−instance ToJSON v => GKeyValue v (DList Pair) where

2737+instance (v ~ Value) => KeyValuePair v (DList Pair) where

2732− gPair k v = DList.singleton (pack k .= v)

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

2733

2739

2734−instance GKeyValue Encoding Series where

2740+instance (e ~ Encoding) => KeyValuePair e Series where

2735− gPair = E.pairStr

2741+ pair = E.pairStr