dcb4a7e · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Merge pull request #524 from Lysxia/refactor-generic

dcb4a7eAdam Bergmark10 years ago

Data/Aeson.hs+2−2

compare with master

unifiedsplit

@@ -76,8 +76,8 @@ module Data.Aeson

76 -- ** Generic JSON classes and options

77 , GFromJSON(..)

78 , FromArgs(..)

79− , GToJSON(..)

79+ , GToJSON

80− , GToEncoding(..)

80+ , GToEncoding

81 , ToArgs(..)

82 , Zero

83 , One

Data/Aeson/Encoding.hs+1

@@ -14,6 +14,7 @@ module Data.Aeson.Encoding

14 , Series

15 , pairs

16 , pair

17+ , pairStr

17 , pair'

18 , pair'

18 -- * Predicates

19 -- * Predicates

19 , nullEncoding

20 , nullEncoding

Data/Aeson/Encoding/Internal.hs+6

@@ -13,6 +13,7 @@ module Data.Aeson.Encoding.Internal

13 , Series (..)

14 , pairs

15 , pair

16+ , pairStr

16 , pair'

17 , pair'

17 -- * Predicates

18 -- * Predicates

18 , nullEncoding

19 , nullEncoding

@@ -124,6 +125,11 @@ data Series = Empty

124

125

125pair :: Text -> Encoding -> Series

126pair :: Text -> Encoding -> Series

126pair name val = pair' (text name) val

127pair name val = pair' (text name) val

128+{-# INLINE pair #-}

129+

130+pairStr :: String -> Encoding -> Series

131+pairStr name val = pair' (string name) val

132+{-# INLINE pairStr #-}

127

133

128pair' :: Encoding' Text -> Encoding -> Series

134pair' :: Encoding' Text -> Encoding -> Series

129pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val

135pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val

Data/Aeson/Types.hs+2−2

@@ -63,8 +63,8 @@ module Data.Aeson.Types

63 -- ** Generic JSON classes

64 , GFromJSON(..)

65 , FromArgs(..)

66− , GToJSON(..)

66+ , GToJSON

67− , GToEncoding(..)

67+ , GToEncoding

68 , ToArgs(..)

69 , Zero

70 , One

Data/Aeson/Types/Class.hs+10−3

@@ -1,4 +1,5 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

@@ -36,8 +37,8 @@ module Data.Aeson.Types.Class

36 -- * Generic JSON classes

37 -- * Generic JSON classes

37 , GFromJSON(..)

38 , GFromJSON(..)

38 , FromArgs(..)

39 , FromArgs(..)

39− , GToJSON(..)

40+ , GToJSON

40− , GToEncoding(..)

41+ , GToEncoding

41 , ToArgs(..)

42 , ToArgs(..)

42 , Zero

43 , Zero

43 , One

44 , One

@@ -94,4 +95,10 @@ import Prelude ()

95import Data.Aeson.Types.FromJSON

96import Data.Aeson.Types.FromJSON

96import Data.Aeson.Types.Generic (One, Zero)

97import Data.Aeson.Types.Generic (One, Zero)

97−import Data.Aeson.Types.ToJSON

98+import Data.Aeson.Types.ToJSON hiding (GToJSON)

99+import qualified Data.Aeson.Types.ToJSON as ToJSON

100+import Data.Aeson.Types.Internal (Value)

101+import Data.Aeson.Encoding (Encoding)

102+

103+type GToJSON = ToJSON.GToJSON Value

104+type GToEncoding = ToJSON.GToJSON Encoding

Data/Aeson/Types/ToJSON.hs+301−443

@@ -1,8 +1,9 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DefaultSignatures #-}

2{-# LANGUAGE DefaultSignatures #-}

3+{-# LANGUAGE EmptyDataDecls #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE GADTs #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE NamedFieldPuns #-}

9{-# LANGUAGE NamedFieldPuns #-}

@@ -36,7 +37,6 @@ module Data.Aeson.Types.ToJSON

36 , toEncoding2

37 , toEncoding2

37 -- * Generic JSON classes

38 -- * Generic JSON classes

38 , GToJSON(..)

39 , GToJSON(..)

39− , GToEncoding(..)

40 , ToArgs(..)

41 , genericToJSON

42 , genericToEncoding

@@ -61,7 +61,7 @@ import Prelude.Compat

61import Control.Applicative (Const(..))

62import Control.Monad.ST (ST)

63import Data.Aeson.Encoding (Encoding, Encoding', Series, dict, emptyArray_)

64−import Data.Aeson.Encoding.Internal ((>*<), (><))

64+import Data.Aeson.Encoding.Internal ((>*<))

65import Data.Aeson.Internal.Functions (mapHashKeyVal, mapKeyVal)

66import Data.Aeson.Types.Generic (AllNullary, False, IsRecord(..), One, ProductSize, Tagged2(..), True, Zero, productSize)

67import Data.Aeson.Types.Internal

@@ -93,7 +93,7 @@ import Foreign.Storable (Storable)

93import GHC.Generics

94import Numeric.Natural (Natural)

95import qualified Data.Aeson.Encoding as E

96−import qualified Data.Aeson.Encoding.Internal as E (InArray, colon, comma, econcat, empty, retagEncoding, wrapObject)

96+import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)

97import qualified Data.ByteString as S

98import qualified Data.ByteString.Lazy as L

99import qualified Data.DList as DList

@@ -149,19 +149,16 @@ realFloatToJSON d

149

150-- | Class of generic representation types that can be converted to

151-- JSON.

152−class GToJSON arity f where

152+class GToJSON enc arity f where

153 -- | This method (applied to 'defaultOptions') is used as the

154− -- default generic implementation of 'toJSON' (if the @arity@ is 'Zero')

154+ -- default generic implementation of 'toJSON'

155+ -- (with @enc ~ 'Value'@ and @arity ~ 'Zero'@)

155− -- or 'liftToJSON' (if the @arity@ is 'One').

156+ -- and 'liftToJSON' (if the @arity@ is 'One').

156− gToJSON :: Options -> ToArgs Value arity a -> f a -> Value

157+ --

157−

158−-- | Class of generic representation types that can be converted to

159−-- a JSON 'Encoding'.

160−class GToEncoding arity f where

161− -- | This method (applied to 'defaultOptions') can be used as the

162− -- default generic implementation of 'toEncoding' (if the @arity@ is 'Zero')

158+ -- It also provides a generic implementation of 'toEncoding'

159+ -- (with @enc ~ 'Encoding'@ and @arity ~ 'Zero'@)

163− -- or 'liftToEncoding' (if the @arity@ is 'One').

160+ -- and 'liftToEncoding' (if the @arity@ is 'One').

164− gToEncoding :: Options -> ToArgs Encoding arity a -> f a -> Encoding

161+ gToJSON :: Options -> ToArgs enc arity a -> f a -> enc

165

162

166-- | A 'ToArgs' value either stores nothing (for 'ToJSON') or it stores the two

163-- | A 'ToArgs' value either stores nothing (for 'ToJSON') or it stores the two

167-- function arguments that encode occurrences of the type parameter (for

164-- function arguments that encode occurrences of the type parameter (for

@@ -173,14 +170,14 @@ data ToArgs res arity a where

173-- | A configurable generic JSON creator. This function applied to

170-- | A configurable generic JSON creator. This function applied to

174-- 'defaultOptions' is used as the default for 'toJSON' when the type

171-- 'defaultOptions' is used as the default for 'toJSON' when the type

175-- is an instance of 'Generic'.

172-- is an instance of 'Generic'.

176−genericToJSON :: (Generic a, GToJSON Zero (Rep a))

173+genericToJSON :: (Generic a, GToJSON Value Zero (Rep a))

177 => Options -> a -> Value

174 => Options -> a -> Value

178genericToJSON opts = gToJSON opts NoToArgs . from

175genericToJSON opts = gToJSON opts NoToArgs . from

179

176

180-- | A configurable generic JSON creator. This function applied to

177-- | A configurable generic JSON creator. This function applied to

181-- 'defaultOptions' is used as the default for 'liftToJSON' when the type

178-- 'defaultOptions' is used as the default for 'liftToJSON' when the type

182-- is an instance of 'Generic1'.

179-- is an instance of 'Generic1'.

183−genericLiftToJSON :: (Generic1 f, GToJSON One (Rep1 f))

180+genericLiftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f))

184 => Options -> (a -> Value) -> ([a] -> Value)

181 => Options -> (a -> Value) -> ([a] -> Value)

185 -> f a -> Value

182 -> f a -> Value

186genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1

183genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1

@@ -188,17 +185,17 @@ genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1

188-- | A configurable generic JSON encoder. This function applied to

185-- | A configurable generic JSON encoder. This function applied to

189-- 'defaultOptions' is used as the default for 'toEncoding' when the type

186-- 'defaultOptions' is used as the default for 'toEncoding' when the type

190-- is an instance of 'Generic'.

187-- is an instance of 'Generic'.

191−genericToEncoding :: (Generic a, GToEncoding Zero (Rep a))

188+genericToEncoding :: (Generic a, GToJSON Encoding Zero (Rep a))

192 => Options -> a -> Encoding

189 => Options -> a -> Encoding

193−genericToEncoding opts = gToEncoding opts NoToArgs . from

190+genericToEncoding opts = gToJSON opts NoToArgs . from

194

191

195-- | A configurable generic JSON encoder. This function applied to

192-- | A configurable generic JSON encoder. This function applied to

196-- 'defaultOptions' is used as the default for 'liftToEncoding' when the type

193-- 'defaultOptions' is used as the default for 'liftToEncoding' when the type

197-- is an instance of 'Generic1'.

194-- is an instance of 'Generic1'.

198−genericLiftToEncoding :: (Generic1 f, GToEncoding One (Rep1 f))

195+genericLiftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f))

199 => Options -> (a -> Encoding) -> ([a] -> Encoding)

196 => Options -> (a -> Encoding) -> ([a] -> Encoding)

200 -> f a -> Encoding

197 -> f a -> Encoding

201−genericLiftToEncoding opts te tel = gToEncoding opts (To1Args te tel) . from1

198+genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1

202

199

203-------------------------------------------------------------------------------

200-------------------------------------------------------------------------------

204-- Class

201-- Class

@@ -284,7 +281,7 @@ class ToJSON a where

284 -- | Convert a Haskell value to a JSON-friendly intermediate type.

281 -- | Convert a Haskell value to a JSON-friendly intermediate type.

285 toJSON :: a -> Value

282 toJSON :: a -> Value

286

283

287− default toJSON :: (Generic a, GToJSON Zero (Rep a)) => a -> Value

284+ default toJSON :: (Generic a, GToJSON Value Zero (Rep a)) => a -> Value

288 toJSON = genericToJSON defaultOptions

285 toJSON = genericToJSON defaultOptions

289

286

290 -- | Encode a Haskell value as JSON.

287 -- | Encode a Haskell value as JSON.

@@ -544,7 +541,7 @@ contramapToJSONKeyFunction h x = case x of

544class ToJSON1 f where

541class ToJSON1 f where

545 liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value

542 liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value

546

543

547− default liftToJSON :: (Generic1 f, GToJSON One (Rep1 f))

544+ default liftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f))

548 => (a -> Value) -> ([a] -> Value) -> f a -> Value

545 => (a -> Value) -> ([a] -> Value) -> f a -> Value

549 liftToJSON = genericLiftToJSON defaultOptions

546 liftToJSON = genericLiftToJSON defaultOptions

550

547

@@ -553,7 +550,7 @@ class ToJSON1 f where

553

550

554 liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding

551 liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding

555

552

556− default liftToEncoding :: (Generic1 f, GToEncoding One (Rep1 f))

553+ default liftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f))

557 => (a -> Encoding) -> ([a] -> Encoding)

554 => (a -> Encoding) -> ([a] -> Encoding)

558 -> f a -> Encoding

555 -> f a -> Encoding

559 liftToEncoding = genericLiftToEncoding defaultOptions

556 liftToEncoding = genericLiftToEncoding defaultOptions

@@ -653,39 +650,54 @@ instance (ToJSON a) => ToJSON [a] where

653-- Generic toJSON / toEncoding

650-- Generic toJSON / toEncoding

654-------------------------------------------------------------------------------

651-------------------------------------------------------------------------------

655

652

656−--------------------------------------------------------------------------------

657−-- Generic toJSON

658−

659−instance OVERLAPPABLE_ (GToJSON arity a) => GToJSON arity (M1 i c a) where

653+instance OVERLAPPABLE_ (GToJSON enc arity a) => GToJSON enc arity (M1 i c a) where

660 -- Meta-information, which is not handled elsewhere, is ignored:

654 -- Meta-information, which is not handled elsewhere, is ignored:

661 gToJSON opts targs = gToJSON opts targs . unM1

655 gToJSON opts targs = gToJSON opts targs . unM1

662

656

663−instance (ToJSON a) => GToJSON arity (K1 i a) where

657+instance GToJSON enc One Par1 where

664− -- Constant values are encoded using their ToJSON instance:

665− gToJSON _opts _ = toJSON . unK1

666−

667−instance GToJSON One Par1 where

668 -- Direct occurrences of the last type parameter are encoded with the

658 -- Direct occurrences of the last type parameter are encoded with the

669 -- function passed in as an argument:

659 -- function passed in as an argument:

670 gToJSON _opts (To1Args tj _) = tj . unPar1

660 gToJSON _opts (To1Args tj _) = tj . unPar1

671

661

672−instance (ToJSON1 f) => GToJSON One (Rec1 f) where

662+instance (ConsToJSON enc arity a) => GToJSON enc arity (C1 c a) where

663+ -- Constructors need to be encoded differently depending on whether they're

664+ -- a record or not. This distinction is made by 'consToJSON':

665+ gToJSON opts targs = consToJSON opts targs . unM1

666+

667+instance ( AllNullary (a :+: b) allNullary

668+ , SumToJSON enc arity (a :+: b) allNullary

669+ ) => GToJSON enc arity (a :+: b)

670+ where

671+ -- If all constructors of a sum datatype are nullary and the

672+ -- 'allNullaryToStringTag' option is set they are encoded to

673+ -- strings. This distinction is made by 'sumToJSON':

674+ gToJSON opts targs = (unTagged :: Tagged allNullary enc -> enc)

675+ . sumToJSON opts targs

676+

677+--------------------------------------------------------------------------------

678+-- Generic toJSON

679+

680+-- Note: Refactoring 'ToJSON a' to 'ToJSON enc a' (and 'ToJSON1' similarly) is

681+-- possible but makes error messages a bit harder to understand for missing

682+-- instances.

683+

684+instance ToJSON a => GToJSON Value arity (K1 i a) where

685+ -- Constant values are encoded using their ToJSON instance:

686+ gToJSON _opts _ = toJSON . unK1

687+

688+instance ToJSON1 f => GToJSON Value One (Rec1 f) where

673 -- Recursive occurrences of the last type parameter are encoded using their

689 -- Recursive occurrences of the last type parameter are encoded using their

674 -- ToJSON1 instance:

690 -- ToJSON1 instance:

675 gToJSON _opts (To1Args tj tjl) = liftToJSON tj tjl . unRec1

691 gToJSON _opts (To1Args tj tjl) = liftToJSON tj tjl . unRec1

676

692

677−instance GToJSON arity U1 where

693+instance GToJSON Value arity U1 where

678 -- Empty constructors are encoded to an empty array:

694 -- Empty constructors are encoded to an empty array:

679 gToJSON _opts _ _ = emptyArray

695 gToJSON _opts _ _ = emptyArray

680

696

681−instance (ConsToJSON arity a) => GToJSON arity (C1 c a) where

682− -- Constructors need to be encoded differently depending on whether they're

683− -- a record or not. This distinction is made by 'consToJSON':

684− gToJSON opts targs = consToJSON opts targs . unM1

685−

686instance ( WriteProduct arity a, WriteProduct arity b

697instance ( WriteProduct arity a, WriteProduct arity b

687 , ProductSize a, ProductSize b

698 , ProductSize a, ProductSize b

688− ) => GToJSON arity (a :*: b) where

699+ ) => GToJSON Value arity (a :*: b)

700+ where

689 -- Products are encoded to an array. Here we allocate a mutable vector of

701 -- Products are encoded to an array. Here we allocate a mutable vector of

690 -- the same size as the product and write the product's elements to it using

702 -- the same size as the product and write the product's elements to it using

691 -- 'writeProduct':

703 -- 'writeProduct':

@@ -698,16 +710,10 @@ instance ( WriteProduct arity a, WriteProduct arity b

698 lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)

710 lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)

699 productSize

711 productSize

700

712

701−instance ( AllNullary (a :+: b) allNullary

713+instance ( ToJSON1 f

702− , SumToJSON arity (a :+: b) allNullary

714+ , GToJSON Value One g

703− ) => GToJSON arity (a :+: b) where

715+ ) => GToJSON Value One (f :.: g)

704− -- If all constructors of a sum datatype are nullary and the

716+ where

705− -- 'allNullaryToStringTag' option is set they are encoded to

706− -- strings. This distinction is made by 'sumToJSON':

707− gToJSON opts targs = (unTagged :: Tagged allNullary Value -> Value)

708− . sumToJSON opts targs

709−

710−instance (ToJSON1 f, GToJSON One g) => GToJSON One (f :.: g) where

711 -- If an occurrence of the last type parameter is nested inside two

717 -- If an occurrence of the last type parameter is nested inside two

712 -- composed types, it is encoded by using the outermost type's ToJSON1

718 -- composed types, it is encoded by using the outermost type's ToJSON1

713 -- instance to generically encode the innermost type:

719 -- instance to generically encode the innermost type:

@@ -718,216 +724,153 @@ instance (ToJSON1 f, GToJSON One g) => GToJSON One (f :.: g) where

718--------------------------------------------------------------------------------

724--------------------------------------------------------------------------------

719-- Generic toEncoding

725-- Generic toEncoding

720

726

721−instance OVERLAPPABLE_ (GToEncoding arity a) => GToEncoding arity (M1 i c a) where

722− -- Meta-information, which is not handled elsewhere, is ignored:

723− gToEncoding opts targs = gToEncoding opts targs . unM1

724−

725−instance (ToJSON a) => GToEncoding arity (K1 i a) where

727+instance ToJSON a => GToJSON Encoding arity (K1 i a) where

726 -- Constant values are encoded using their ToJSON instance:

728 -- Constant values are encoded using their ToJSON instance:

727− gToEncoding _opts _ = toEncoding . unK1

729+ gToJSON _opts _ = toEncoding . unK1

728−

729−instance GToEncoding One Par1 where

730− -- Direct occurrences of the last type parameter are encoded with the

731− -- function passed in as an argument:

732− gToEncoding _opts (To1Args te _) = te . unPar1

733

730

734−instance (ToJSON1 f) => GToEncoding One (Rec1 f) where

731+instance ToJSON1 f => GToJSON Encoding One (Rec1 f) where

735 -- Recursive occurrences of the last type parameter are encoded using their

732 -- Recursive occurrences of the last type parameter are encoded using their

736 -- ToEncoding1 instance:

733 -- ToEncoding1 instance:

737− gToEncoding _opts (To1Args te tel) = liftToEncoding te tel . unRec1

734+ gToJSON _opts (To1Args te tel) = liftToEncoding te tel . unRec1

738

735

739−instance GToEncoding arity U1 where

736+instance GToJSON Encoding arity U1 where

740 -- Empty constructors are encoded to an empty array:

737 -- Empty constructors are encoded to an empty array:

741− gToEncoding _opts _ _ = E.emptyArray_

738+ gToJSON _opts _ _ = E.emptyArray_

742−

743−instance (ConsToEncoding arity a) => GToEncoding arity (C1 c a) where

744− -- Constructors need to be encoded differently depending on whether they're

745− -- a record or not. This distinction is made by 'consToEncoding':

746− gToEncoding opts targs = consToEncoding opts targs . unM1

747

739

748instance ( EncodeProduct arity a

740instance ( EncodeProduct arity a

749 , EncodeProduct arity b

741 , EncodeProduct arity b

750− ) => GToEncoding arity (a :*: b) where

742+ ) => GToJSON Encoding arity (a :*: b)

743+ where

751 -- Products are encoded to an array. Here we allocate a mutable vector of

744 -- Products are encoded to an array. Here we allocate a mutable vector of

752 -- the same size as the product and write the product's elements to it using

745 -- the same size as the product and write the product's elements to it using

753 -- 'encodeProduct':

746 -- 'encodeProduct':

754− gToEncoding opts targs p = E.list E.retagEncoding [encodeProduct opts targs p]

747+ gToJSON opts targs p = E.list E.retagEncoding [encodeProduct opts targs p]

755

748

756−instance ( AllNullary (a :+: b) allNullary

749+instance ( ToJSON1 f

757− , SumToEncoding arity (a :+: b) allNullary

750+ , GToJSON Encoding One g

758− ) => GToEncoding arity (a :+: b) where

751+ ) => GToJSON Encoding One (f :.: g)

759− -- If all constructors of a sum datatype are nullary and the

752+ where

760− -- 'allNullaryToStringTag' option is set they are encoded to

761− -- strings. This distinction is made by 'sumToEncoding':

762− gToEncoding opts targs

763− = (unTagged :: Tagged allNullary Encoding -> Encoding)

764− . sumToEncoding opts targs

765−

766−instance (ToJSON1 f, GToEncoding One g) => GToEncoding One (f :.: g) where

767 -- If an occurrence of the last type parameter is nested inside two

753 -- If an occurrence of the last type parameter is nested inside two

768 -- composed types, it is encoded by using the outermost type's ToJSON1

754 -- composed types, it is encoded by using the outermost type's ToJSON1

769 -- instance to generically encode the innermost type:

755 -- instance to generically encode the innermost type:

770− gToEncoding opts targs =

756+ gToJSON opts targs =

771− let gte = gToEncoding opts targs in

757+ let gte = gToJSON opts targs in

772 liftToEncoding gte (listEncoding gte) . unComp1

758 liftToEncoding gte (listEncoding gte) . unComp1

773

759

774--------------------------------------------------------------------------------

760--------------------------------------------------------------------------------

775

761

776−class SumToJSON arity f allNullary where

762+class SumToJSON enc arity f allNullary where

777− sumToJSON :: Options -> ToArgs Value arity a

763+ sumToJSON :: Options -> ToArgs enc arity a

778− -> f a -> Tagged allNullary Value

764+ -> f a -> Tagged allNullary enc

779−

765+

780−instance ( GetConName f

766+instance ( GetConName f

781− , TaggedObjectPairs arity f

767+ , FromString enc

782− , ObjectWithSingleFieldObj arity f

768+ , TaggedObject enc arity f

783− , TwoElemArrayObj arity f

769+ , SumToJSON' ObjectWithSingleField enc arity f

784− , UntaggedValueObj arity f

770+ , SumToJSON' TwoElemArray enc arity f

771+ , SumToJSON' UntaggedValue enc arity f

785− ) => SumToJSON arity f True where

772+ ) => SumToJSON enc arity f True

773+ where

786 sumToJSON opts targs

774 sumToJSON opts targs

787− | allNullaryToStringTag opts = Tagged . String . pack

775+ | allNullaryToStringTag opts = Tagged . fromString

788 . constructorTagModifier opts . getConName

776 . constructorTagModifier opts . getConName

789 | otherwise = Tagged . nonAllNullarySumToJSON opts targs

777 | otherwise = Tagged . nonAllNullarySumToJSON opts targs

790

778

791−instance ( TwoElemArrayObj arity f

779+instance ( TaggedObject enc arity f

792− , TaggedObjectPairs arity f

780+ , SumToJSON' ObjectWithSingleField enc arity f

793− , ObjectWithSingleFieldObj arity f

781+ , SumToJSON' TwoElemArray enc arity f

794− , UntaggedValueObj arity f

782+ , SumToJSON' UntaggedValue enc arity f

795− ) => SumToJSON arity f False where

783+ ) => SumToJSON enc arity f False

784+ where

796 sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs

785 sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs

797

786

798−nonAllNullarySumToJSON :: ( TwoElemArrayObj arity f

787+nonAllNullarySumToJSON :: ( TaggedObject enc arity f

799− , TaggedObjectPairs arity f

788+ , SumToJSON' ObjectWithSingleField enc arity f

800− , ObjectWithSingleFieldObj arity f

789+ , SumToJSON' TwoElemArray enc arity f

801− , UntaggedValueObj arity f

790+ , SumToJSON' UntaggedValue enc arity f

802− ) => Options -> ToArgs Value arity a

791+ ) => Options -> ToArgs enc arity a

803− -> f a -> Value

792+ -> f a -> enc

804nonAllNullarySumToJSON opts targs =

793nonAllNullarySumToJSON opts targs =

805 case sumEncoding opts of

794 case sumEncoding opts of

806− TaggedObject{..} ->

807− object . taggedObjectPairs opts targs tagFieldName contentsFieldName

808− ObjectWithSingleField -> Object . objectWithSingleFieldObj opts targs

809− TwoElemArray -> Array . twoElemArrayObj opts targs

810− UntaggedValue -> untaggedValueObj opts targs

811−

812−--------------------------------------------------------------------------------

813

795

814−class SumToEncoding arity f allNullary where

815− sumToEncoding :: Options -> ToArgs Encoding arity a

816− -> f a -> Tagged allNullary Encoding

817−

818−instance ( GetConName f

819− , TaggedObjectEnc arity f

820− , ObjectWithSingleFieldEnc arity f

821− , TwoElemArrayEnc arity f

822− , UntaggedValueEnc arity f

823− ) => SumToEncoding arity f True where

824− sumToEncoding opts targs

825− | allNullaryToStringTag opts = Tagged . toEncoding .

826− constructorTagModifier opts . getConName

827− | otherwise = Tagged . nonAllNullarySumToEncoding opts targs

828−

829−instance ( TwoElemArrayEnc arity f

830− , TaggedObjectEnc arity f

831− , ObjectWithSingleFieldEnc arity f

832− , UntaggedValueEnc arity f

833− ) => SumToEncoding arity f False where

834− sumToEncoding opts targs = Tagged . nonAllNullarySumToEncoding opts targs

835−

836−nonAllNullarySumToEncoding :: ( TwoElemArrayEnc arity f

837− , TaggedObjectEnc arity f

838− , ObjectWithSingleFieldEnc arity f

839− , UntaggedValueEnc arity f

840− ) => Options -> ToArgs Encoding arity a

841− -> f a -> Encoding

842−nonAllNullarySumToEncoding opts targs =

843− case sumEncoding opts of

844 TaggedObject{..} ->

796 TaggedObject{..} ->

845− taggedObjectEnc opts targs tagFieldName contentsFieldName

797+ taggedObject opts targs tagFieldName contentsFieldName

846− ObjectWithSingleField -> objectWithSingleFieldEnc opts targs

847− TwoElemArray -> twoElemArrayEnc opts targs

848− UntaggedValue -> untaggedValueEnc opts targs

849

798

850−--------------------------------------------------------------------------------

799+ ObjectWithSingleField ->

800+ (unTagged :: Tagged ObjectWithSingleField enc -> enc)

801+ . sumToJSON' opts targs

851

802

852−class TaggedObjectPairs arity f where

803+ TwoElemArray ->

853− taggedObjectPairs :: Options -> ToArgs Value arity a

854− -> String -> String

855− -> f a -> [Pair]

856−

857−instance ( TaggedObjectPairs arity a

858− , TaggedObjectPairs arity b

859− ) => TaggedObjectPairs arity (a :+: b) where

860− taggedObjectPairs opts targs tagFieldName contentsFieldName (L1 x) =

861− taggedObjectPairs opts targs tagFieldName contentsFieldName x

862− taggedObjectPairs opts targs tagFieldName contentsFieldName (R1 x) =

863− taggedObjectPairs opts targs tagFieldName contentsFieldName x

864−

865−instance ( IsRecord a isRecord

866− , TaggedObjectPairs' arity a isRecord

867− , Constructor c

868− ) => TaggedObjectPairs arity (C1 c a) where

869− taggedObjectPairs opts targs tagFieldName contentsFieldName =

870− (pack tagFieldName .= constructorTagModifier opts

871− (conName (undefined :: t c a p)) :) .

872− (unTagged :: Tagged isRecord [Pair] -> [Pair]) .

804+ (unTagged :: Tagged TwoElemArray enc -> enc)

873− taggedObjectPairs' opts targs contentsFieldName . unM1

805+ . sumToJSON' opts targs

874

806

875−class TaggedObjectPairs' arity f isRecord where

807+ UntaggedValue ->

876− taggedObjectPairs' :: Options -> ToArgs Value arity a

808+ (unTagged :: Tagged UntaggedValue enc -> enc)

877− -> String -> f a -> Tagged isRecord [Pair]

809+ . sumToJSON' opts targs

878

810

879−instance OVERLAPPING_ TaggedObjectPairs' arity U1 False where

811+--------------------------------------------------------------------------------

880− taggedObjectPairs' _ _ _ _ = Tagged []

881

812

882−instance (RecordToPairs arity f) => TaggedObjectPairs' arity f True where

813+class FromString enc where

883− taggedObjectPairs' opts targs _ =

814+ fromString :: String -> enc

884− Tagged . toList . recordToPairs opts targs

885

815

886−instance (GToJSON arity f) => TaggedObjectPairs' arity f False where

816+instance FromString Encoding where

887− taggedObjectPairs' opts targs contentsFieldName =

817+ fromString = toEncoding

888− Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts targs

818+

819+instance FromString Value where

820+ fromString = String . pack

889

821

890--------------------------------------------------------------------------------

822--------------------------------------------------------------------------------

891

823

892−class TaggedObjectEnc arity f where

824+class TaggedObject enc arity f where

893− taggedObjectEnc :: Options -> ToArgs Encoding arity a

825+ taggedObject :: Options -> ToArgs enc arity a

894− -> String -> String

826+ -> String -> String

895− -> f a -> Encoding

827+ -> f a -> enc

896−

828+

897−instance ( TaggedObjectEnc arity a

829+instance ( TaggedObject enc arity a

898− , TaggedObjectEnc arity b

830+ , TaggedObject enc arity b

899− ) => TaggedObjectEnc arity (a :+: b) where

831+ ) => TaggedObject enc arity (a :+: b)

832+ where

900− taggedObjectEnc opts targs tagFieldName contentsFieldName (L1 x) =

833+ taggedObject opts targs tagFieldName contentsFieldName (L1 x) =

901− taggedObjectEnc opts targs tagFieldName contentsFieldName x

834+ taggedObject opts targs tagFieldName contentsFieldName x

902− taggedObjectEnc opts targs tagFieldName contentsFieldName (R1 x) =

835+ taggedObject opts targs tagFieldName contentsFieldName (R1 x) =

903− taggedObjectEnc opts targs tagFieldName contentsFieldName x

836+ taggedObject opts targs tagFieldName contentsFieldName x

904−

837+

905−instance ( IsRecord a isRecord

838+instance ( IsRecord a isRecord

906− , TaggedObjectEnc' arity a isRecord

839+ , TaggedObject' enc pairs arity a isRecord

840+ , FromPairs enc pairs

841+ , FromString enc

842+ , GKeyValue enc pairs

907 , Constructor c

843 , Constructor c

908− ) => TaggedObjectEnc arity (C1 c a) where

844+ ) => TaggedObject enc arity (C1 c a)

845+ where

909− taggedObjectEnc opts targs tagFieldName contentsFieldName v = E.pairs (E.pair key val)

846+ taggedObject opts targs tagFieldName contentsFieldName =

847+ fromPairs . (tag <>) . contents

910 where

848 where

911− key :: Text

912− key = pack tagFieldName

849+ tag = tagFieldName `gPair`

913− val = toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))

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

851+ :: enc)

852+ contents =

853+ (unTagged :: Tagged isRecord pairs -> pairs) .

914− >< ((unTagged :: Tagged isRecord Encoding -> Encoding) . taggedObjectEnc' opts targs contentsFieldName . unM1 $ v)

854+ taggedObject' opts targs contentsFieldName . unM1

915−

855+

916−class TaggedObjectEnc' arity f isRecord where

856+class TaggedObject' enc pairs arity f isRecord where

917− taggedObjectEnc' :: Options -> ToArgs Encoding arity a

857+ taggedObject' :: Options -> ToArgs enc arity a

918− -> String -> f a -> Tagged isRecord Encoding

858+ -> String -> f a -> Tagged isRecord pairs

919−

859+

920−instance OVERLAPPING_ TaggedObjectEnc' arity U1 False where

860+instance ( GToJSON enc arity f

921− taggedObjectEnc' _ _ _ _ = Tagged E.empty

861+ , GKeyValue enc pairs

862+ ) => TaggedObject' enc pairs arity f False

863+ where

864+ taggedObject' opts targs contentsFieldName =

865+ Tagged . (contentsFieldName `gPair`) . gToJSON opts targs

922

866

923−instance (RecordToEncoding arity f) => TaggedObjectEnc' arity f True where

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

924− taggedObjectEnc' opts targs _ = Tagged . (E.comma ><) . fst

868+ taggedObject' _ _ _ _ = Tagged mempty

925− . recordToEncoding opts targs

926

869

927−instance (GToEncoding arity f) => TaggedObjectEnc' arity f False where

870+instance ( RecordToPairs enc pairs arity f

928− taggedObjectEnc' opts targs contentsFieldName =

871+ ) => TaggedObject' enc pairs arity f True

929− Tagged . (\z -> E.comma >< toEncoding contentsFieldName >< E.colon >< z) .

872+ where

930− gToEncoding opts targs

873+ taggedObject' opts targs _ = Tagged . recordToPairs opts targs

931

874

932--------------------------------------------------------------------------------

875--------------------------------------------------------------------------------

933

876

@@ -942,23 +885,35 @@ instance (GetConName a, GetConName b) => GetConName (a :+: b) where

942instance (Constructor c) => GetConName (C1 c a) where

885instance (Constructor c) => GetConName (C1 c a) where

943 getConName = conName

886 getConName = conName

944

887

888+

945--------------------------------------------------------------------------------

889--------------------------------------------------------------------------------

946

890

947−class TwoElemArrayObj arity f where

891+-- Reflection of SumEncoding variants

948− twoElemArrayObj :: Options -> ToArgs Value arity a

892+

949− -> f a -> V.Vector Value

893+data ObjectWithSingleField

894+data TwoElemArray

895+data UntaggedValue

950

896

951−instance ( TwoElemArrayObj arity a

897+--------------------------------------------------------------------------------

952− , TwoElemArrayObj arity b

953− ) => TwoElemArrayObj arity (a :+: b) where

954− twoElemArrayObj opts targs (L1 x) = twoElemArrayObj opts targs x

955− twoElemArrayObj opts targs (R1 x) = twoElemArrayObj opts targs x

956

898

899+class SumToJSON' s enc arity f where

900+ sumToJSON' :: Options -> ToArgs enc arity a

901+ -> f a -> Tagged s enc

902+

903+instance ( SumToJSON' s enc arity a

904+ , SumToJSON' s enc arity b

905+ ) => SumToJSON' s enc arity (a :+: b)

906+ where

907+ sumToJSON' opts targs (L1 x) = sumToJSON' opts targs x

908+ sumToJSON' opts targs (R1 x) = sumToJSON' opts targs x

909+

910+--------------------------------------------------------------------------------

911+

957−instance ( GToJSON arity a

912+instance ( GToJSON Value arity a

958− , ConsToJSON arity a

913+ , ConsToJSON Value arity a

959 , Constructor c

914 , Constructor c

960− ) => TwoElemArrayObj arity (C1 c a) where

915+ ) => SumToJSON' TwoElemArray Value arity (C1 c a) where

961− twoElemArrayObj opts targs x = V.create $ do

916+ sumToJSON' opts targs x = Tagged $ Array $ V.create $ do

962 mv <- VM.unsafeNew 2

917 mv <- VM.unsafeNew 2

963 VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts

918 VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts

964 $ conName (undefined :: t c a p)

919 $ conName (undefined :: t c a p)

@@ -967,149 +922,103 @@ instance ( GToJSON arity a

967

922

968--------------------------------------------------------------------------------

923--------------------------------------------------------------------------------

969

924

970−class TwoElemArrayEnc arity f where

971− twoElemArrayEnc :: Options -> ToArgs Encoding arity a

972− -> f a -> Encoding

973−

974−instance ( TwoElemArrayEnc arity a

925+instance ( GToJSON Encoding arity a

975− , TwoElemArrayEnc arity b

926+ , ConsToJSON Encoding arity a

976− ) => TwoElemArrayEnc arity (a :+: b) where

977− twoElemArrayEnc opts targs (L1 x) = twoElemArrayEnc opts targs x

978− twoElemArrayEnc opts targs (R1 x) = twoElemArrayEnc opts targs x

979−

980−instance ( GToEncoding arity a

981− , ConsToEncoding arity a

982 , Constructor c

927 , Constructor c

983− ) => TwoElemArrayEnc arity (C1 c a) where

928+ ) => SumToJSON' TwoElemArray Encoding arity (C1 c a)

929+ where

984− twoElemArrayEnc opts targs x = E.list id

930+ sumToJSON' opts targs x = Tagged $ E.list id

985 [ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))

931 [ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))

986− , gToEncoding opts targs x

932+ , gToJSON opts targs x

987 ]

933 ]

988

934

989--------------------------------------------------------------------------------

935--------------------------------------------------------------------------------

990

936

991−class ConsToJSON arity f where

937+class ConsToJSON enc arity f where

992− consToJSON :: Options -> ToArgs Value arity a

938+ consToJSON :: Options -> ToArgs enc arity a

993− -> f a -> Value

939+ -> f a -> enc

994

940

995−class ConsToJSON' arity f isRecord where

941+class ConsToJSON' enc arity f isRecord where

996− consToJSON' :: Options -> ToArgs Value arity a

942+ consToJSON' :: Options -> ToArgs enc arity a

997 -> Bool -- ^ Are we a record with one field?

943 -> Bool -- ^ Are we a record with one field?

998− -> f a -> Tagged isRecord Value

944+ -> f a -> Tagged isRecord enc

999

945

1000−instance ( IsRecord f isRecord

946+instance ( IsRecord f isRecord

1001− , ConsToJSON' arity f isRecord

947+ , ConsToJSON' enc arity f isRecord

1002− ) => ConsToJSON arity f where

948+ ) => ConsToJSON enc arity f

949+ where

1003 consToJSON opts targs =

950 consToJSON opts targs =

1004− (unTagged :: Tagged isRecord Value -> Value)

951+ (unTagged :: Tagged isRecord enc -> enc)

1005 . consToJSON' opts targs (isUnary (undefined :: f a))

952 . consToJSON' opts targs (isUnary (undefined :: f a))

953+ {-# INLINE consToJSON #-}

1006

954

955+instance ( RecordToPairs enc pairs arity f

956+ , FromPairs enc pairs

957+ , GToJSON enc arity f

1007−instance (RecordToPairs arity f) => ConsToJSON' arity f True where

958+ ) => ConsToJSON' enc arity f True

959+ where

1008− consToJSON' opts targs isUn f = let

960+ consToJSON' opts targs isUn =

1009− vals = toList $ recordToPairs opts targs f

961+ Tagged .

1010− in case (unwrapUnaryRecords opts,isUn,vals) of

962+ case (isUn, unwrapUnaryRecords opts) of

1011− (True,True,[(_,val)]) -> Tagged val

963+ (True, True) -> gToJSON opts targs

1012− _ -> Tagged $ object vals

964+ _ -> fromPairs . recordToPairs opts targs

1013−

965+ {-# INLINE consToJSON' #-}

966+

1014−instance GToJSON arity f => ConsToJSON' arity f False where

967+instance GToJSON enc arity f => ConsToJSON' enc arity f False where

1015 consToJSON' opts targs _ = Tagged . gToJSON opts targs

968 consToJSON' opts targs _ = Tagged . gToJSON opts targs

969+ {-# INLINE consToJSON' #-}

1016

970

1017--------------------------------------------------------------------------------

971--------------------------------------------------------------------------------

1018

972

1019−class ConsToEncoding arity f where

973+class RecordToPairs enc pairs arity f where

1020− consToEncoding :: Options -> ToArgs Encoding arity a

974+ -- 1st element: whole thing

1021− -> f a -> Encoding

975+ -- 2nd element: in case the record has only 1 field, just the value

1022−

976+ -- of the field (without the key); 'Nothing' otherwise

1023−class ConsToEncoding' arity f isRecord where

1024− consToEncoding' :: Options -> ToArgs Encoding arity a

1025− -> Bool -- ^ Are we a record with one field?

1026− -> f a -> Tagged isRecord Encoding

1027−

1028−instance ( IsRecord f isRecord

1029− , ConsToEncoding' arity f isRecord

1030− ) => ConsToEncoding arity f where

1031− consToEncoding opts targs =

1032− (unTagged :: Tagged isRecord Encoding -> Encoding)

1033− . consToEncoding' opts targs (isUnary (undefined :: f a))

1034−

1035−instance (RecordToEncoding arity f) => ConsToEncoding' arity f True where

1036− consToEncoding' opts targs isUn x =

1037− let (enc, mbVal) = recordToEncoding opts targs x

1038− in case (unwrapUnaryRecords opts, isUn, mbVal) of

1039− (True, True, Just val) -> Tagged val

1040− _ -> Tagged $ E.wrapObject enc

1041−

1042−instance GToEncoding arity f => ConsToEncoding' arity f False where

1043− consToEncoding' opts targs _ = Tagged . gToEncoding opts targs

1044−

1045−--------------------------------------------------------------------------------

1046−

1047−class RecordToPairs arity f where

1048− recordToPairs :: Options -> ToArgs Value arity a

977+ recordToPairs :: Options -> ToArgs enc arity a

1049− -> f a -> DList Pair

978+ -> f a -> pairs

1050−

1051−instance ( RecordToPairs arity a

1052− , RecordToPairs arity b

1053− ) => RecordToPairs arity (a :*: b) where

1054− recordToPairs opts targs (a :*: b) = recordToPairs opts targs a <>

1055− recordToPairs opts targs b

1056

979

980+instance ( Monoid pairs

981+ , RecordToPairs enc pairs arity a

982+ , RecordToPairs enc pairs arity b

983+ ) => RecordToPairs enc pairs arity (a :*: b)

984+ where

985+ recordToPairs opts (targs :: ToArgs enc arity p) (a :*: b) =

986+ pairsOf a <> pairsOf b

987+ where

988+ pairsOf :: (RecordToPairs enc pairs arity f) => f p -> pairs

989+ pairsOf = recordToPairs opts targs

990+ {-# INLINE recordToPairs #-}

991+

992+instance ( Selector s

993+ , GToJSON enc arity a

994+ , GKeyValue enc pairs

1057−instance (Selector s, GToJSON arity a) => RecordToPairs arity (S1 s a) where

995+ ) => RecordToPairs enc pairs arity (S1 s a)

996+ where

1058 recordToPairs = fieldToPair

997 recordToPairs = fieldToPair

998+ {-# INLINE recordToPairs #-}

1059

999

1060−instance OVERLAPPING_ (Selector s, ToJSON a) =>

1000+instance OVERLAPPING_

1001+ ( Selector s

1002+ , GToJSON enc arity (K1 i (Maybe a))

1003+ , GKeyValue enc pairs

1004+ , Monoid pairs

1061− RecordToPairs arity (S1 s (K1 i (Maybe a))) where

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

1006+ where

1062 recordToPairs opts _ (M1 k1) | omitNothingFields opts

1007 recordToPairs opts _ (M1 k1) | omitNothingFields opts

1063− , K1 Nothing <- k1 = DList.empty

1008+ , K1 Nothing <- k1 = mempty

1064 recordToPairs opts targs m1 = fieldToPair opts targs m1

1009 recordToPairs opts targs m1 = fieldToPair opts targs m1

1065−

1010+ {-# INLINE recordToPairs #-}

1011+

1066−fieldToPair :: (Selector s, GToJSON arity a)

1012+fieldToPair :: (Selector s

1013+ , GToJSON enc arity a

1014+ , GKeyValue enc pairs)

1067− => Options -> ToArgs Value arity p

1015+ => Options -> ToArgs enc arity p

1068− -> S1 s a p -> DList Pair

1016+ -> S1 s a p -> pairs

1017+fieldToPair opts targs m1 =

1069−fieldToPair opts targs m1 = pure ( pack $ fieldLabelModifier opts $ selName m1

1018+ let key = fieldLabelModifier opts (selName m1)

1070− , gToJSON opts targs (unM1 m1)

1019+ value = gToJSON opts targs (unM1 m1)

1071− )

1020+ in key `gPair` value

1072−

1021+{-# INLINE fieldToPair #-}

1073−--------------------------------------------------------------------------------

1074−

1075−class RecordToEncoding arity f where

1076− -- 1st element: whole thing

1077− -- 2nd element: in case the record has only 1 field, just the value

1078− -- of the field (without the key); 'Nothing' otherwise

1079− recordToEncoding :: Options -> ToArgs Encoding arity a

1080− -> f a -> (Encoding, Maybe Encoding)

1081−

1082−instance ( RecordToEncoding arity a

1083− , RecordToEncoding arity b

1084− ) => RecordToEncoding arity (a :*: b) where

1085− recordToEncoding opts targs (a :*: b) | omitNothingFields opts =

1086− (E.econcat $ intersperse E.comma $

1087− filter (not . E.nullEncoding)

1088− [ fst (recordToEncoding opts targs a)

1089− , fst (recordToEncoding opts targs b) ]

1090− , Nothing)

1091− recordToEncoding opts targs (a :*: b) =

1092− (fst (recordToEncoding opts targs a) >< E.comma ><

1093− fst (recordToEncoding opts targs b),

1094− Nothing)

1095−

1096−

1097−instance (Selector s, GToEncoding arity a) => RecordToEncoding arity (S1 s a) where

1098− recordToEncoding = fieldToEncoding

1099−

1100−instance OVERLAPPING_ (Selector s, ToJSON a) =>

1101− RecordToEncoding arity (S1 s (K1 i (Maybe a))) where

1102− recordToEncoding opts _ (M1 k1) | omitNothingFields opts

1103− , K1 Nothing <- k1 = (E.empty, Nothing)

1104− recordToEncoding opts targs m1 = fieldToEncoding opts targs m1

1105−

1106−fieldToEncoding :: (Selector s, GToEncoding arity a)

1107− => Options -> ToArgs Encoding arity p

1108− -> S1 s a p -> (Encoding, Maybe Encoding)

1109−fieldToEncoding opts targs m1 =

1110− let keyBuilder = toEncoding (fieldLabelModifier opts $ selName m1)

1111− valueBuilder = gToEncoding opts targs (unM1 m1)

1112− in (keyBuilder >< E.colon >< valueBuilder, Just valueBuilder)

1113

1022

1114--------------------------------------------------------------------------------

1023--------------------------------------------------------------------------------

1115

1024

@@ -1133,7 +1042,7 @@ instance ( WriteProduct arity a

1133 lenR = len - lenL

1042 lenR = len - lenL

1134 ixR = ix + lenL

1043 ixR = ix + lenL

1135

1044

1136−instance OVERLAPPABLE_ (GToJSON arity a) => WriteProduct arity a where

1045+instance OVERLAPPABLE_ (GToJSON Value arity a) => WriteProduct arity a where

1137 writeProduct opts targs mv ix _ =

1046 writeProduct opts targs mv ix _ =

1138 VM.unsafeWrite mv ix . gToJSON opts targs

1047 VM.unsafeWrite mv ix . gToJSON opts targs

1139

1048

@@ -1154,109 +1063,38 @@ instance ( EncodeProduct arity a

1154 encodeProduct opts targs a >*<

1063 encodeProduct opts targs a >*<

1155 encodeProduct opts targs b

1064 encodeProduct opts targs b

1156

1065

1157−instance OVERLAPPABLE_ (GToEncoding arity a) => EncodeProduct arity a where

1066+instance OVERLAPPABLE_ (GToJSON Encoding arity a) => EncodeProduct arity a where

1158− encodeProduct opts targs a = E.retagEncoding $ gToEncoding opts targs a

1067+ encodeProduct opts targs a = E.retagEncoding $ gToJSON opts targs a

1159

1068

1160--------------------------------------------------------------------------------

1069--------------------------------------------------------------------------------

1161

1070

1162−class ObjectWithSingleFieldObj arity f where

1163− objectWithSingleFieldObj :: Options -> ToArgs Value arity a

1164− -> f a -> Object

1165−

1166−instance ( ObjectWithSingleFieldObj arity a

1167− , ObjectWithSingleFieldObj arity b

1168− ) => ObjectWithSingleFieldObj arity (a :+: b) where

1169− objectWithSingleFieldObj opts targs (L1 x) =

1170− objectWithSingleFieldObj opts targs x

1171− objectWithSingleFieldObj opts targs (R1 x) =

1172− objectWithSingleFieldObj opts targs x

1173−

1174−instance ( GToJSON arity a

1071+instance ( GToJSON enc arity a

1175− , ConsToJSON arity a

1072+ , ConsToJSON enc arity a

1073+ , FromPairs enc pairs

1074+ , GKeyValue enc pairs

1176 , Constructor c

1075 , Constructor c

1177− ) => ObjectWithSingleFieldObj arity (C1 c a) where

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

1178− objectWithSingleFieldObj opts targs = H.singleton typ . gToJSON opts targs

1077+ where

1078+ sumToJSON' opts targs =

1079+ Tagged . fromPairs . (typ `gPair`) . gToJSON opts targs

1179 where

1080 where

1180− typ = pack $ constructorTagModifier opts $

1081+ typ = constructorTagModifier opts $

1181 conName (undefined :: t c a p)

1082 conName (undefined :: t c a p)

1182

1083

1183--------------------------------------------------------------------------------

1084--------------------------------------------------------------------------------

1184

1085

1185−class ObjectWithSingleFieldEnc arity f where

1186− objectWithSingleFieldEnc :: Options -> ToArgs Encoding arity a

1187− -> f a -> Encoding

1188−

1189−instance ( ObjectWithSingleFieldEnc arity a

1190− , ObjectWithSingleFieldEnc arity b

1191− ) => ObjectWithSingleFieldEnc arity (a :+: b) where

1192− objectWithSingleFieldEnc opts targs (L1 x) =

1193− objectWithSingleFieldEnc opts targs x

1194− objectWithSingleFieldEnc opts targs (R1 x) =

1195− objectWithSingleFieldEnc opts targs x

1196−

1197−instance ( GToEncoding arity a

1198− , ConsToEncoding arity a

1199− , Constructor c

1200− ) => ObjectWithSingleFieldEnc arity (C1 c a) where

1201− objectWithSingleFieldEnc opts targs v = E.pairs (E.pair key val)

1202− where

1203− key :: Text

1204− key = pack (constructorTagModifier opts (conName (undefined :: t c a p)))

1205− val :: Encoding' Value

1206− val = gToEncoding opts targs v

1207−

1208−--------------------------------------------------------------------------------

1209−

1210−class UntaggedValueObj arity f where

1211− untaggedValueObj :: Options -> ToArgs Value arity a

1212− -> f a -> Value

1213−

1214−instance

1215− ( UntaggedValueObj arity a

1216− , UntaggedValueObj arity b

1217− ) => UntaggedValueObj arity (a :+: b)

1218− where

1219− untaggedValueObj opts targs (L1 x) = untaggedValueObj opts targs x

1220− untaggedValueObj opts targs (R1 x) = untaggedValueObj opts targs x

1221−

1222instance OVERLAPPABLE_

1086instance OVERLAPPABLE_

1223− ( GToJSON arity a

1224− , ConsToJSON arity a

1087+ ( ConsToJSON enc arity a

1225− ) => UntaggedValueObj arity (C1 c a) where

1088+ ) => SumToJSON' UntaggedValue enc arity (C1 c a)

1226− untaggedValueObj = gToJSON

1227−

1228−instance OVERLAPPING_

1229− ( Constructor c )

1230− => UntaggedValueObj arity (C1 c U1)

1231− where

1232− untaggedValueObj opts _ _ = toJSON $

1233− constructorTagModifier opts $ conName (undefined :: t c U1 p)

1234−

1235−--------------------------------------------------------------------------------

1236−

1237−class UntaggedValueEnc arity f where

1238− untaggedValueEnc :: Options -> ToArgs Encoding arity a

1239− -> f a -> Encoding

1240−instance

1241− ( UntaggedValueEnc arity a

1242− , UntaggedValueEnc arity b

1243− ) => UntaggedValueEnc arity (a :+: b)

1244− where

1245− untaggedValueEnc opts targs (L1 x) = untaggedValueEnc opts targs x

1246− untaggedValueEnc opts targs (R1 x) = untaggedValueEnc opts targs x

1247−

1248−instance OVERLAPPABLE_

1249− ( GToEncoding arity a

1250− , ConsToEncoding arity a

1251− ) => UntaggedValueEnc arity (C1 c a)

1252 where

1089 where

1253− untaggedValueEnc = gToEncoding

1090+ sumToJSON' opts targs = Tagged . gToJSON opts targs

1254

1091

1255instance OVERLAPPING_

1092instance OVERLAPPING_

1256− ( Constructor c )

1093+ ( Constructor c

1257− => UntaggedValueEnc arity (C1 c U1)

1094+ , FromString enc

1095+ ) => SumToJSON' UntaggedValue enc arity (C1 c U1)

1258 where

1096 where

1259− untaggedValueEnc opts _ _ = toEncoding $

1097+ sumToJSON' opts _ _ = Tagged . fromString $

1260 constructorTagModifier opts $ conName (undefined :: t c U1 p)

1098 constructorTagModifier opts $ conName (undefined :: t c U1 p)

1261

1099

1262-------------------------------------------------------------------------------

1100-------------------------------------------------------------------------------

@@ -2834,3 +2672,23 @@ packChunks lbs =

2834 copyBytes pf (pbuf `plusPtr` o) l

2672 copyBytes pf (pbuf `plusPtr` o) l

2835 copyChunks lbs' (pf `plusPtr` l)

2673 copyChunks lbs' (pf `plusPtr` l)

2836#endif

2674#endif

2675+

2676+--------------------------------------------------------------------------------

2677+

2678+class Monoid pairs => FromPairs enc pairs | enc -> pairs where

2679+ fromPairs :: pairs -> enc

2680+

2681+instance FromPairs Encoding Series where

2682+ fromPairs = E.pairs

2683+

2684+instance FromPairs Value (DList Pair) where

2685+ fromPairs = object . toList

2686+

2687+class Monoid kv => GKeyValue v kv where

2688+ gPair :: String -> v -> kv

2689+

2690+instance ToJSON v => GKeyValue v (DList Pair) where

2691+ gPair k v = DList.singleton (pack k .= v)

2692+

2693+instance GKeyValue Encoding Series where

2694+ gPair = E.pairStr

benchmarks/AesonCompareAutoInstances.hs+80−27

@@ -1,5 +1,5 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveGeneric #-}

1{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE TemplateHaskell #-}

5module Main (main) where

@@ -7,16 +7,24 @@ module Main (main) where

7import Prelude ()

8import Prelude.Compat

10+import Control.Monad

10import Control.DeepSeq (NFData, rnf, deepseq)

11import Control.DeepSeq (NFData, rnf, deepseq)

11import Criterion.Main hiding (defaultOptions)

12import Criterion.Main hiding (defaultOptions)

12−import Data.Aeson.Encode

13+import Data.Aeson

14+import Data.Aeson.Encoding

13import Data.Aeson.TH

15import Data.Aeson.TH

14import Data.Aeson.Types

16import Data.Aeson.Types

17+import Data.ByteString.Lazy (ByteString)

15import Data.Data (Data)

18import Data.Data (Data)

16import Data.Typeable (Typeable)

19import Data.Typeable (Typeable)

17−import GHC.Generics (Generic)

20+import GHC.Generics (Generic, Rep)

18import Options

21import Options

19−import qualified Data.Aeson.Generic as G (fromJSON, toJSON)

22+

23+toBS :: Encoding -> ByteString

24+toBS = encodingToLazyByteString

25+

26+gEncode :: (Generic a, GToEncoding Zero (Rep a)) => a -> ByteString

27+gEncode = toBS . genericToEncoding opts

21--------------------------------------------------------------------------------

29--------------------------------------------------------------------------------

@@ -27,7 +35,7 @@ data D a = Nullary

27 , testTwo :: Bool

35 , testTwo :: Bool

28 , testThree :: D a

36 , testThree :: D a

29 }

37 }

30− deriving (Show, Eq, Data, Typeable)

38+ deriving (Show, Eq)

32deriveJSON opts ''D

40deriveJSON opts ''D

@@ -60,7 +68,7 @@ data D' a = Nullary'

60 , testTwo' :: Bool

68 , testTwo' :: Bool

61 , testThree' :: D' a

69 , testThree' :: D' a

62 }

70 }

63− deriving (Show, Eq, Generic, Data, Typeable)

71+ deriving (Show, Eq, Generic)

65instance ToJSON a => ToJSON (D' a) where

73instance ToJSON a => ToJSON (D' a) where

66 toJSON = genericToJSON opts

74 toJSON = genericToJSON opts

@@ -96,7 +104,7 @@ data BigRecord = BigRecord

96 , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int

104 , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int

97 , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int

105 , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int

98 , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int

106 , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int

99− } deriving (Show, Eq, Generic, Data, Typeable)

107+ } deriving (Show, Eq, Generic)

100

108

101instance NFData BigRecord

109instance NFData BigRecord

102

110

@@ -106,15 +114,23 @@ bigRecord = BigRecord 1 2 3 4 5

106 16 17 18 19 20

114 16 17 18 19 20

107 21 22 23 24 25

115 21 22 23 24 25

108

116

117+return []

118+

109gBigRecordToJSON :: BigRecord -> Value

119gBigRecordToJSON :: BigRecord -> Value

110gBigRecordToJSON = genericToJSON opts

120gBigRecordToJSON = genericToJSON opts

111

121

122+gBigRecordEncode :: BigRecord -> ByteString

123+gBigRecordEncode = gEncode

124+

112gBigRecordFromJSON :: Value -> Result BigRecord

125gBigRecordFromJSON :: Value -> Result BigRecord

113gBigRecordFromJSON = parse $ genericParseJSON opts

126gBigRecordFromJSON = parse $ genericParseJSON opts

114

127

115thBigRecordToJSON :: BigRecord -> Value

128thBigRecordToJSON :: BigRecord -> Value

116thBigRecordToJSON = $(mkToJSON opts ''BigRecord)

129thBigRecordToJSON = $(mkToJSON opts ''BigRecord)

117

130

131+thBigRecordEncode :: BigRecord -> ByteString

132+thBigRecordEncode = toBS . $(mkToEncoding opts ''BigRecord)

133+

118thBigRecordFromJSON :: Value -> Result BigRecord

134thBigRecordFromJSON :: Value -> Result BigRecord

119thBigRecordFromJSON = parse $(mkParseJSON opts ''BigRecord)

135thBigRecordFromJSON = parse $(mkParseJSON opts ''BigRecord)

120

136

@@ -126,7 +142,7 @@ data BigProduct = BigProduct

126 !Int !Int !Int !Int !Int

142 !Int !Int !Int !Int !Int

127 !Int !Int !Int !Int !Int

143 !Int !Int !Int !Int !Int

128 !Int !Int !Int !Int !Int

144 !Int !Int !Int !Int !Int

129− deriving (Show, Eq, Generic, Data, Typeable)

145+ deriving (Show, Eq, Generic)

130

146

131instance NFData BigProduct

147instance NFData BigProduct

132

148

@@ -136,15 +152,23 @@ bigProduct = BigProduct 1 2 3 4 5

136 16 17 18 19 20

152 16 17 18 19 20

137 21 22 23 24 25

153 21 22 23 24 25

138

154

155+return []

156+

139gBigProductToJSON :: BigProduct -> Value

157gBigProductToJSON :: BigProduct -> Value

140gBigProductToJSON = genericToJSON opts

158gBigProductToJSON = genericToJSON opts

141

159

160+gBigProductEncode :: BigProduct -> ByteString

161+gBigProductEncode = gEncode

162+

142gBigProductFromJSON :: Value -> Result BigProduct

163gBigProductFromJSON :: Value -> Result BigProduct

143gBigProductFromJSON = parse $ genericParseJSON opts

164gBigProductFromJSON = parse $ genericParseJSON opts

144

165

145thBigProductToJSON :: BigProduct -> Value

166thBigProductToJSON :: BigProduct -> Value

146thBigProductToJSON = $(mkToJSON opts ''BigProduct)

167thBigProductToJSON = $(mkToJSON opts ''BigProduct)

147

168

169+thBigProductEncode :: BigProduct -> ByteString

170+thBigProductEncode = toBS . $(mkToEncoding opts ''BigProduct)

171+

148thBigProductFromJSON :: Value -> Result BigProduct

172thBigProductFromJSON :: Value -> Result BigProduct

149thBigProductFromJSON = parse $(mkParseJSON opts ''BigProduct)

173thBigProductFromJSON = parse $(mkParseJSON opts ''BigProduct)

150

174

@@ -155,21 +179,29 @@ data BigSum = F01 | F02 | F03 | F04 | F05

155 | F11 | F12 | F13 | F14 | F15

179 | F11 | F12 | F13 | F14 | F15

156 | F16 | F17 | F18 | F19 | F20

180 | F16 | F17 | F18 | F19 | F20

157 | F21 | F22 | F23 | F24 | F25

181 | F21 | F22 | F23 | F24 | F25

158− deriving (Show, Eq, Generic, Data, Typeable)

182+ deriving (Show, Eq, Generic)

159

183

160instance NFData BigSum

184instance NFData BigSum

161

185

162bigSum = F25

186bigSum = F25

163

187

188+return []

189+

164gBigSumToJSON :: BigSum -> Value

190gBigSumToJSON :: BigSum -> Value

165gBigSumToJSON = genericToJSON opts

191gBigSumToJSON = genericToJSON opts

166

192

193+gBigSumEncode :: BigSum -> ByteString

194+gBigSumEncode = gEncode

195+

167gBigSumFromJSON :: Value -> Result BigSum

196gBigSumFromJSON :: Value -> Result BigSum

168gBigSumFromJSON = parse $ genericParseJSON opts

197gBigSumFromJSON = parse $ genericParseJSON opts

169

198

170thBigSumToJSON :: BigSum -> Value

199thBigSumToJSON :: BigSum -> Value

171thBigSumToJSON = $(mkToJSON opts ''BigSum)

200thBigSumToJSON = $(mkToJSON opts ''BigSum)

172

201

202+thBigSumEncode :: BigSum -> ByteString

203+thBigSumEncode = toBS . $(mkToEncoding opts ''BigSum)

204+

173thBigSumFromJSON :: Value -> Result BigSum

205thBigSumFromJSON :: Value -> Result BigSum

174thBigSumFromJSON = parse $(mkParseJSON opts ''BigSum)

206thBigSumFromJSON = parse $(mkParseJSON opts ''BigSum)

175

207

@@ -177,53 +209,74 @@ thBigSumFromJSON = parse $(mkParseJSON opts ''BigSum)

177

209

178type FJ a = Value -> Result a

210type FJ a = Value -> Result a

179

211

180−main :: IO ()

212+runBench :: IO ()

181−main = defaultMain

213+runBench = defaultMain

182 [ let v = toJSON d

214 [ let v = toJSON d

183 in (d, d', v) `deepseq`

215 in (d, d', v) `deepseq`

184 bgroup "D"

216 bgroup "D"

185 [ group "toJSON" (nf toJSON d)

217 [ group "toJSON" (nf toJSON d)

186− (nf G.toJSON d)

187 (nf toJSON d')

218 (nf toJSON d')

219+ , group "encode" (nf encode d)

220+ (nf encode d')

188 , group "fromJSON" (nf ( fromJSON :: FJ T ) v)

221 , group "fromJSON" (nf ( fromJSON :: FJ T ) v)

189− (nf (G.fromJSON :: FJ T ) v)

190 (nf ( fromJSON :: FJ T') v)

222 (nf ( fromJSON :: FJ T') v)

191 ]

223 ]

192 , let v = thBigRecordToJSON bigRecord

224 , let v = thBigRecordToJSON bigRecord

193 in bigRecord `deepseq` v `deepseq`

225 in bigRecord `deepseq` v `deepseq`

194 bgroup "BigRecord"

226 bgroup "BigRecord"

195 [ group "toJSON" (nf thBigRecordToJSON bigRecord)

227 [ group "toJSON" (nf thBigRecordToJSON bigRecord)

196− (nf G.toJSON bigRecord)

197− (nf gBigRecordToJSON bigRecord)

228+ (nf gBigRecordToJSON bigRecord)

229+ , group "encode" (nf thBigRecordEncode bigRecord)

230+ (nf gBigRecordEncode bigRecord)

198 , group "fromJSON" (nf (thBigRecordFromJSON :: FJ BigRecord) v)

231 , group "fromJSON" (nf (thBigRecordFromJSON :: FJ BigRecord) v)

199− (nf (G.fromJSON :: FJ BigRecord) v)

200− (nf (gBigRecordFromJSON :: FJ BigRecord) v)

232+ (nf ( gBigRecordFromJSON :: FJ BigRecord) v)

201 ]

233 ]

202 , let v = thBigProductToJSON bigProduct

234 , let v = thBigProductToJSON bigProduct

203 in bigProduct `deepseq` v `deepseq`

235 in bigProduct `deepseq` v `deepseq`

204 bgroup "BigProduct"

236 bgroup "BigProduct"

205 [ group "toJSON" (nf thBigProductToJSON bigProduct)

237 [ group "toJSON" (nf thBigProductToJSON bigProduct)

206− (nf G.toJSON bigProduct)

207 (nf gBigProductToJSON bigProduct)

238 (nf gBigProductToJSON bigProduct)

239+ , group "encode" (nf thBigProductEncode bigProduct)

240+ (nf gBigProductEncode bigProduct)

208 , group "fromJSON" (nf (thBigProductFromJSON :: FJ BigProduct) v)

241 , group "fromJSON" (nf (thBigProductFromJSON :: FJ BigProduct) v)

209− (nf (G.fromJSON :: FJ BigProduct) v)

210 (nf (gBigProductFromJSON :: FJ BigProduct) v)

242 (nf (gBigProductFromJSON :: FJ BigProduct) v)

211 ]

243 ]

212 , let v = thBigSumToJSON bigSum

244 , let v = thBigSumToJSON bigSum

213 in bigSum `deepseq` v `deepseq`

245 in bigSum `deepseq` v `deepseq`

214 bgroup "BigSum"

246 bgroup "BigSum"

215 [ group "toJSON" (nf thBigSumToJSON bigSum)

247 [ group "toJSON" (nf thBigSumToJSON bigSum)

216− (nf G.toJSON bigSum)

217 (nf gBigSumToJSON bigSum)

248 (nf gBigSumToJSON bigSum)

249+ , group "encode" (nf thBigSumEncode bigSum)

250+ (nf gBigSumEncode bigSum)

218 , group "fromJSON" (nf (thBigSumFromJSON :: FJ BigSum) v)

251 , group "fromJSON" (nf (thBigSumFromJSON :: FJ BigSum) v)

219− (nf (G.fromJSON :: FJ BigSum) v)

220 (nf (gBigSumFromJSON :: FJ BigSum) v)

252 (nf (gBigSumFromJSON :: FJ BigSum) v)

221 ]

253 ]

222 ]

254 ]

223

255

224−group n th syb gen = bcompare

225− [ bgroup n [ bench "th" th

256+group n th gen = bgroup n [ bench "th" th

226− , bench "syb" syb

227− , bench "generic" gen

257+ , bench "generic" gen

228− ]

258+ ]

229− ]

259+

260+sanityCheck = do

261+ check d toJSON fromJSON encode

262+ check d' toJSON fromJSON encode

263+ check bigRecord thBigRecordToJSON thBigRecordFromJSON thBigRecordEncode

264+ check bigRecord gBigRecordToJSON gBigRecordFromJSON gBigRecordEncode

265+ check bigProduct thBigProductToJSON thBigProductFromJSON thBigProductEncode

266+ check bigProduct gBigProductToJSON gBigProductFromJSON gBigProductEncode

267+ check bigSum thBigSumToJSON thBigSumFromJSON thBigSumEncode

268+ check bigSum gBigSumToJSON gBigSumFromJSON gBigSumEncode

269+

270+check :: (Show a, Eq a)

271+ => a -> (a -> Value) -> (Value -> Result a) -> (a -> ByteString) -> IO ()

272+check x toJSON fromJSON encode = do

273+ unless (Success x == (fromJSON . toJSON) x) $ fail $ "toJSON: " ++ show x

274+ unless (Success x == (decode' . encode) x) $ fail $ "encode: " ++ show x

275+ where

276+ decode' s = case decode s of

277+ Just v -> fromJSON v

278+ Nothing -> fail ""

279+

280+main = do

281+ sanityCheck

282+ runBench

benchmarks/Options.hs+1−1

@@ -1,4 +1,4 @@

1−module Options () where

1+module Options where

3import Prelude ()

4import Prelude.Compat