@@ -1,8 +1,9 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
32{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE EmptyDataDecls #-}
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
67{-# LANGUAGE GADTs #-}
78{-# LANGUAGE MultiParamTypeClasses #-}
89{-# LANGUAGE NamedFieldPuns #-}
@@ -36,7 +37,6 @@ module Data.Aeson.Types.ToJSON
3637 , toEncoding2
3738 -- * Generic JSON classes
3839 , GToJSON(..)
39− , GToEncoding(..)
4040 , ToArgs(..)
4141 , genericToJSON
4242 , genericToEncoding
@@ -61,7 +61,7 @@ import Prelude.Compat
6161import Control.Applicative (Const(..))
6262import Control.Monad.ST (ST)
6363import Data.Aeson.Encoding (Encoding, Encoding', Series, dict, emptyArray_)
64−import Data.Aeson.Encoding.Internal ((>*<), (><))
64+import Data.Aeson.Encoding.Internal ((>*<))
6565import Data.Aeson.Internal.Functions (mapHashKeyVal, mapKeyVal)
6666import Data.Aeson.Types.Generic (AllNullary, False, IsRecord(..), One, ProductSize, Tagged2(..), True, Zero, productSize)
6767import Data.Aeson.Types.Internal
@@ -93,7 +93,7 @@ import Foreign.Storable (Storable)
9393import GHC.Generics
9494import Numeric.Natural (Natural)
9595import 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)
9797import qualified Data.ByteString as S
9898import qualified Data.ByteString.Lazy as L
9999import qualified Data.DList as DList
@@ -149,19 +149,16 @@ realFloatToJSON d
149149
150150-- | Class of generic representation types that can be converted to
151151-- JSON.
152−class GToJSON arity f where
152+class GToJSON enc arity f where
153153 -- | This method (applied to 'defaultOptions') is used as the
154− -- default generic implementation of 'toJSON' (if the @arity@ is 'Zero')
155− -- or 'liftToJSON' (if the @arity@ is 'One').
156− gToJSON :: Options -> ToArgs Value arity a -> f a -> Value
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')
163− -- or 'liftToEncoding' (if the @arity@ is 'One').
164− gToEncoding :: Options -> ToArgs Encoding arity a -> f a -> Encoding
154+ -- default generic implementation of 'toJSON'
155+ -- (with @enc ~ 'Value'@ and @arity ~ 'Zero'@)
156+ -- and 'liftToJSON' (if the @arity@ is 'One').
157+ --
158+ -- It also provides a generic implementation of 'toEncoding'
159+ -- (with @enc ~ 'Encoding'@ and @arity ~ 'Zero'@)
160+ -- and 'liftToEncoding' (if the @arity@ is 'One').
161+ gToJSON :: Options -> ToArgs enc arity a -> f a -> enc
165162
166163-- | A 'ToArgs' value either stores nothing (for 'ToJSON') or it stores the two
167164-- function arguments that encode occurrences of the type parameter (for
@@ -173,14 +170,14 @@ data ToArgs res arity a where
173170-- | A configurable generic JSON creator. This function applied to
174171-- 'defaultOptions' is used as the default for 'toJSON' when the type
175172-- is an instance of 'Generic'.
176−genericToJSON :: (Generic a, GToJSON Zero (Rep a))
173+genericToJSON :: (Generic a, GToJSON Value Zero (Rep a))
177174 => Options -> a -> Value
178175genericToJSON opts = gToJSON opts NoToArgs . from
179176
180177-- | A configurable generic JSON creator. This function applied to
181178-- 'defaultOptions' is used as the default for 'liftToJSON' when the type
182179-- is an instance of 'Generic1'.
183−genericLiftToJSON :: (Generic1 f, GToJSON One (Rep1 f))
180+genericLiftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f))
184181 => Options -> (a -> Value) -> ([a] -> Value)
185182 -> f a -> Value
186183genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1
@@ -188,17 +185,17 @@ genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1
188185-- | A configurable generic JSON encoder. This function applied to
189186-- 'defaultOptions' is used as the default for 'toEncoding' when the type
190187-- is an instance of 'Generic'.
191−genericToEncoding :: (Generic a, GToEncoding Zero (Rep a))
188+genericToEncoding :: (Generic a, GToJSON Encoding Zero (Rep a))
192189 => Options -> a -> Encoding
193−genericToEncoding opts = gToEncoding opts NoToArgs . from
190+genericToEncoding opts = gToJSON opts NoToArgs . from
194191
195192-- | A configurable generic JSON encoder. This function applied to
196193-- 'defaultOptions' is used as the default for 'liftToEncoding' when the type
197194-- is an instance of 'Generic1'.
198−genericLiftToEncoding :: (Generic1 f, GToEncoding One (Rep1 f))
195+genericLiftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f))
199196 => Options -> (a -> Encoding) -> ([a] -> Encoding)
200197 -> 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
202199
203200-------------------------------------------------------------------------------
204201-- Class
@@ -284,7 +281,7 @@ class ToJSON a where
284281 -- | Convert a Haskell value to a JSON-friendly intermediate type.
285282 toJSON :: a -> Value
286283
287− default toJSON :: (Generic a, GToJSON Zero (Rep a)) => a -> Value
284+ default toJSON :: (Generic a, GToJSON Value Zero (Rep a)) => a -> Value
288285 toJSON = genericToJSON defaultOptions
289286
290287 -- | Encode a Haskell value as JSON.
@@ -544,7 +541,7 @@ contramapToJSONKeyFunction h x = case x of
544541class ToJSON1 f where
545542 liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value
546543
547− default liftToJSON :: (Generic1 f, GToJSON One (Rep1 f))
544+ default liftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f))
548545 => (a -> Value) -> ([a] -> Value) -> f a -> Value
549546 liftToJSON = genericLiftToJSON defaultOptions
550547
@@ -553,7 +550,7 @@ class ToJSON1 f where
553550
554551 liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
555552
556− default liftToEncoding :: (Generic1 f, GToEncoding One (Rep1 f))
553+ default liftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f))
557554 => (a -> Encoding) -> ([a] -> Encoding)
558555 -> f a -> Encoding
559556 liftToEncoding = genericLiftToEncoding defaultOptions
@@ -653,39 +650,54 @@ instance (ToJSON a) => ToJSON [a] where
653650-- Generic toJSON / toEncoding
654651-------------------------------------------------------------------------------
655652
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
660654 -- Meta-information, which is not handled elsewhere, is ignored:
661655 gToJSON opts targs = gToJSON opts targs . unM1
662656
663−instance (ToJSON a) => GToJSON arity (K1 i a) where
664− -- Constant values are encoded using their ToJSON instance:
665− gToJSON _opts _ = toJSON . unK1
666−
667−instance GToJSON One Par1 where
657+instance GToJSON enc One Par1 where
668658 -- Direct occurrences of the last type parameter are encoded with the
669659 -- function passed in as an argument:
670660 gToJSON _opts (To1Args tj _) = tj . unPar1
671661
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
673689 -- Recursive occurrences of the last type parameter are encoded using their
674690 -- ToJSON1 instance:
675691 gToJSON _opts (To1Args tj tjl) = liftToJSON tj tjl . unRec1
676692
677−instance GToJSON arity U1 where
693+instance GToJSON Value arity U1 where
678694 -- Empty constructors are encoded to an empty array:
679695 gToJSON _opts _ _ = emptyArray
680696
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−
686697instance ( WriteProduct arity a, WriteProduct arity b
687698 , ProductSize a, ProductSize b
688− ) => GToJSON arity (a :*: b) where
699+ ) => GToJSON Value arity (a :*: b)
700+ where
689701 -- Products are encoded to an array. Here we allocate a mutable vector of
690702 -- the same size as the product and write the product's elements to it using
691703 -- 'writeProduct':
@@ -698,16 +710,10 @@ instance ( WriteProduct arity a, WriteProduct arity b
698710 lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
699711 productSize
700712
701−instance ( AllNullary (a :+: b) allNullary
702− , SumToJSON arity (a :+: b) allNullary
703− ) => GToJSON arity (a :+: b) where
704− -- If all constructors of a sum datatype are nullary and the
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
713+instance ( ToJSON1 f
714+ , GToJSON Value One g
715+ ) => GToJSON Value One (f :.: g)
716+ where
711717 -- If an occurrence of the last type parameter is nested inside two
712718 -- composed types, it is encoded by using the outermost type's ToJSON1
713719 -- instance to generically encode the innermost type:
@@ -718,216 +724,153 @@ instance (ToJSON1 f, GToJSON One g) => GToJSON One (f :.: g) where
718724--------------------------------------------------------------------------------
719725-- Generic toEncoding
720726
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
726728 -- Constant values are encoded using their ToJSON instance:
727− gToEncoding _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
729+ gToJSON _opts _ = toEncoding . unK1
733730
734−instance (ToJSON1 f) => GToEncoding One (Rec1 f) where
731+instance ToJSON1 f => GToJSON Encoding One (Rec1 f) where
735732 -- Recursive occurrences of the last type parameter are encoded using their
736733 -- ToEncoding1 instance:
737− gToEncoding _opts (To1Args te tel) = liftToEncoding te tel . unRec1
734+ gToJSON _opts (To1Args te tel) = liftToEncoding te tel . unRec1
738735
739−instance GToEncoding arity U1 where
736+instance GToJSON Encoding arity U1 where
740737 -- Empty constructors are encoded to an empty array:
741− gToEncoding _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
738+ gToJSON _opts _ _ = E.emptyArray_
747739
748740instance ( EncodeProduct arity a
749741 , EncodeProduct arity b
750− ) => GToEncoding arity (a :*: b) where
742+ ) => GToJSON Encoding arity (a :*: b)
743+ where
751744 -- Products are encoded to an array. Here we allocate a mutable vector of
752745 -- the same size as the product and write the product's elements to it using
753746 -- '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]
755748
756−instance ( AllNullary (a :+: b) allNullary
757− , SumToEncoding arity (a :+: b) allNullary
758− ) => GToEncoding arity (a :+: b) where
759− -- If all constructors of a sum datatype are nullary and the
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
749+instance ( ToJSON1 f
750+ , GToJSON Encoding One g
751+ ) => GToJSON Encoding One (f :.: g)
752+ where
767753 -- If an occurrence of the last type parameter is nested inside two
768754 -- composed types, it is encoded by using the outermost type's ToJSON1
769755 -- instance to generically encode the innermost type:
770− gToEncoding opts targs =
771− let gte = gToEncoding opts targs in
756+ gToJSON opts targs =
757+ let gte = gToJSON opts targs in
772758 liftToEncoding gte (listEncoding gte) . unComp1
773759
774760--------------------------------------------------------------------------------
775761
776−class SumToJSON arity f allNullary where
777− sumToJSON :: Options -> ToArgs Value arity a
778− -> f a -> Tagged allNullary Value
779−
780−instance ( GetConName f
781− , TaggedObjectPairs arity f
782− , ObjectWithSingleFieldObj arity f
783− , TwoElemArrayObj arity f
784− , UntaggedValueObj arity f
785− ) => SumToJSON arity f True where
762+class SumToJSON enc arity f allNullary where
763+ sumToJSON :: Options -> ToArgs enc arity a
764+ -> f a -> Tagged allNullary enc
765+
766+instance ( GetConName f
767+ , FromString enc
768+ , TaggedObject enc arity f
769+ , SumToJSON' ObjectWithSingleField enc arity f
770+ , SumToJSON' TwoElemArray enc arity f
771+ , SumToJSON' UntaggedValue enc arity f
772+ ) => SumToJSON enc arity f True
773+ where
786774 sumToJSON opts targs
787− | allNullaryToStringTag opts = Tagged . String . pack
775+ | allNullaryToStringTag opts = Tagged . fromString
788776 . constructorTagModifier opts . getConName
789777 | otherwise = Tagged . nonAllNullarySumToJSON opts targs
790778
791−instance ( TwoElemArrayObj arity f
792− , TaggedObjectPairs arity f
793− , ObjectWithSingleFieldObj arity f
794− , UntaggedValueObj arity f
795− ) => SumToJSON arity f False where
779+instance ( TaggedObject enc arity f
780+ , SumToJSON' ObjectWithSingleField enc arity f
781+ , SumToJSON' TwoElemArray enc arity f
782+ , SumToJSON' UntaggedValue enc arity f
783+ ) => SumToJSON enc arity f False
784+ where
796785 sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs
797786
798−nonAllNullarySumToJSON :: ( TwoElemArrayObj arity f
799− , TaggedObjectPairs arity f
800− , ObjectWithSingleFieldObj arity f
801− , UntaggedValueObj arity f
802− ) => Options -> ToArgs Value arity a
803− -> f a -> Value
787+nonAllNullarySumToJSON :: ( TaggedObject enc arity f
788+ , SumToJSON' ObjectWithSingleField enc arity f
789+ , SumToJSON' TwoElemArray enc arity f
790+ , SumToJSON' UntaggedValue enc arity f
791+ ) => Options -> ToArgs enc arity a
792+ -> f a -> enc
804793nonAllNullarySumToJSON opts targs =
805794 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−--------------------------------------------------------------------------------
813795
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
844796 TaggedObject{..} ->
845− taggedObjectEnc opts targs tagFieldName contentsFieldName
846− ObjectWithSingleField -> objectWithSingleFieldEnc opts targs
847− TwoElemArray -> twoElemArrayEnc opts targs
848− UntaggedValue -> untaggedValueEnc opts targs
797+ taggedObject opts targs tagFieldName contentsFieldName
849798
850−--------------------------------------------------------------------------------
799+ ObjectWithSingleField ->
800+ (unTagged :: Tagged ObjectWithSingleField enc -> enc)
801+ . sumToJSON' opts targs
851802
852−class TaggedObjectPairs arity f where
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]) .
873− taggedObjectPairs' opts targs contentsFieldName . unM1
803+ TwoElemArray ->
804+ (unTagged :: Tagged TwoElemArray enc -> enc)
805+ . sumToJSON' opts targs
874806
875−class TaggedObjectPairs' arity f isRecord where
876− taggedObjectPairs' :: Options -> ToArgs Value arity a
877− -> String -> f a -> Tagged isRecord [Pair]
807+ UntaggedValue ->
808+ (unTagged :: Tagged UntaggedValue enc -> enc)
809+ . sumToJSON' opts targs
878810
879−instance OVERLAPPING_ TaggedObjectPairs' arity U1 False where
880− taggedObjectPairs' _ _ _ _ = Tagged []
811+--------------------------------------------------------------------------------
881812
882−instance (RecordToPairs arity f) => TaggedObjectPairs' arity f True where
883− taggedObjectPairs' opts targs _ =
884− Tagged . toList . recordToPairs opts targs
813+class FromString enc where
814+ fromString :: String -> enc
885815
886−instance (GToJSON arity f) => TaggedObjectPairs' arity f False where
887− taggedObjectPairs' opts targs contentsFieldName =
888− Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts targs
816+instance FromString Encoding where
817+ fromString = toEncoding
818+
819+instance FromString Value where
820+ fromString = String . pack
889821
890822--------------------------------------------------------------------------------
891823
892−class TaggedObjectEnc arity f where
893− taggedObjectEnc :: Options -> ToArgs Encoding arity a
894− -> String -> String
895− -> f a -> Encoding
896−
897−instance ( TaggedObjectEnc arity a
898− , TaggedObjectEnc arity b
899− ) => TaggedObjectEnc arity (a :+: b) where
900− taggedObjectEnc opts targs tagFieldName contentsFieldName (L1 x) =
901− taggedObjectEnc opts targs tagFieldName contentsFieldName x
902− taggedObjectEnc opts targs tagFieldName contentsFieldName (R1 x) =
903− taggedObjectEnc opts targs tagFieldName contentsFieldName x
904−
905−instance ( IsRecord a isRecord
906− , TaggedObjectEnc' arity a isRecord
824+class TaggedObject enc arity f where
825+ taggedObject :: Options -> ToArgs enc arity a
826+ -> String -> String
827+ -> f a -> enc
828+
829+instance ( TaggedObject enc arity a
830+ , TaggedObject enc arity b
831+ ) => TaggedObject enc arity (a :+: b)
832+ where
833+ taggedObject opts targs tagFieldName contentsFieldName (L1 x) =
834+ taggedObject opts targs tagFieldName contentsFieldName x
835+ taggedObject opts targs tagFieldName contentsFieldName (R1 x) =
836+ taggedObject opts targs tagFieldName contentsFieldName x
837+
838+instance ( IsRecord a isRecord
839+ , TaggedObject' enc pairs arity a isRecord
840+ , FromPairs enc pairs
841+ , FromString enc
842+ , GKeyValue enc pairs
907843 , Constructor c
908− ) => TaggedObjectEnc arity (C1 c a) where
909− taggedObjectEnc opts targs tagFieldName contentsFieldName v = E.pairs (E.pair key val)
844+ ) => TaggedObject enc arity (C1 c a)
845+ where
846+ taggedObject opts targs tagFieldName contentsFieldName =
847+ fromPairs . (tag <>) . contents
910848 where
911− key :: Text
912− key = pack tagFieldName
913− val = toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))
914− >< ((unTagged :: Tagged isRecord Encoding -> Encoding) . taggedObjectEnc' opts targs contentsFieldName . unM1 $ v)
915−
916−class TaggedObjectEnc' arity f isRecord where
917− taggedObjectEnc' :: Options -> ToArgs Encoding arity a
918− -> String -> f a -> Tagged isRecord Encoding
919−
920−instance OVERLAPPING_ TaggedObjectEnc' arity U1 False where
921− taggedObjectEnc' _ _ _ _ = Tagged E.empty
849+ tag = tagFieldName `gPair`
850+ (fromString (constructorTagModifier opts (conName (undefined :: t c a p)))
851+ :: enc)
852+ contents =
853+ (unTagged :: Tagged isRecord pairs -> pairs) .
854+ taggedObject' opts targs contentsFieldName . unM1
855+
856+class TaggedObject' enc pairs arity f isRecord where
857+ taggedObject' :: Options -> ToArgs enc arity a
858+ -> String -> f a -> Tagged isRecord pairs
859+
860+instance ( GToJSON enc arity f
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
922866
923−instance (RecordToEncoding arity f) => TaggedObjectEnc' arity f True where
924− taggedObjectEnc' opts targs _ = Tagged . (E.comma ><) . fst
925− . recordToEncoding opts targs
867+instance OVERLAPPING_ Monoid pairs => TaggedObject' enc pairs arity U1 False where
868+ taggedObject' _ _ _ _ = Tagged mempty
926869
927−instance (GToEncoding arity f) => TaggedObjectEnc' arity f False where
928− taggedObjectEnc' opts targs contentsFieldName =
929− Tagged . (\z -> E.comma >< toEncoding contentsFieldName >< E.colon >< z) .
930− gToEncoding opts targs
870+instance ( RecordToPairs enc pairs arity f
871+ ) => TaggedObject' enc pairs arity f True
872+ where
873+ taggedObject' opts targs _ = Tagged . recordToPairs opts targs
931874
932875--------------------------------------------------------------------------------
933876
@@ -942,23 +885,35 @@ instance (GetConName a, GetConName b) => GetConName (a :+: b) where
942885instance (Constructor c) => GetConName (C1 c a) where
943886 getConName = conName
944887
888+
945889--------------------------------------------------------------------------------
946890
947−class TwoElemArrayObj arity f where
948− twoElemArrayObj :: Options -> ToArgs Value arity a
949− -> f a -> V.Vector Value
891+-- Reflection of SumEncoding variants
892+
893+data ObjectWithSingleField
894+data TwoElemArray
895+data UntaggedValue
950896
951−instance ( TwoElemArrayObj arity a
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
897+--------------------------------------------------------------------------------
956898
957−instance ( GToJSON arity a
958− , ConsToJSON arity a
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+
912+instance ( GToJSON Value arity a
913+ , ConsToJSON Value arity a
959914 , Constructor c
960− ) => TwoElemArrayObj arity (C1 c a) where
961− twoElemArrayObj opts targs x = V.create $ do
915+ ) => SumToJSON' TwoElemArray Value arity (C1 c a) where
916+ sumToJSON' opts targs x = Tagged $ Array $ V.create $ do
962917 mv <- VM.unsafeNew 2
963918 VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts
964919 $ conName (undefined :: t c a p)
@@ -967,149 +922,103 @@ instance ( GToJSON arity a
967922
968923--------------------------------------------------------------------------------
969924
970−class TwoElemArrayEnc arity f where
971− twoElemArrayEnc :: Options -> ToArgs Encoding arity a
972− -> f a -> Encoding
973−
974−instance ( TwoElemArrayEnc arity a
975− , TwoElemArrayEnc arity b
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
925+instance ( GToJSON Encoding arity a
926+ , ConsToJSON Encoding arity a
982927 , Constructor c
983− ) => TwoElemArrayEnc arity (C1 c a) where
984− twoElemArrayEnc opts targs x = E.list id
928+ ) => SumToJSON' TwoElemArray Encoding arity (C1 c a)
929+ where
930+ sumToJSON' opts targs x = Tagged $ E.list id
985931 [ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))
986− , gToEncoding opts targs x
932+ , gToJSON opts targs x
987933 ]
988934
989935--------------------------------------------------------------------------------
990936
991−class ConsToJSON arity f where
992− consToJSON :: Options -> ToArgs Value arity a
993− -> f a -> Value
937+class ConsToJSON enc arity f where
938+ consToJSON :: Options -> ToArgs enc arity a
939+ -> f a -> enc
994940
995−class ConsToJSON' arity f isRecord where
996− consToJSON' :: Options -> ToArgs Value arity a
941+class ConsToJSON' enc arity f isRecord where
942+ consToJSON' :: Options -> ToArgs enc arity a
997943 -> Bool -- ^ Are we a record with one field?
998− -> f a -> Tagged isRecord Value
944+ -> f a -> Tagged isRecord enc
999945
1000−instance ( IsRecord f isRecord
1001− , ConsToJSON' arity f isRecord
1002− ) => ConsToJSON arity f where
946+instance ( IsRecord f isRecord
947+ , ConsToJSON' enc arity f isRecord
948+ ) => ConsToJSON enc arity f
949+ where
1003950 consToJSON opts targs =
1004− (unTagged :: Tagged isRecord Value -> Value)
951+ (unTagged :: Tagged isRecord enc -> enc)
1005952 . consToJSON' opts targs (isUnary (undefined :: f a))
953+ {-# INLINE consToJSON #-}
1006954
1007−instance (RecordToPairs arity f) => ConsToJSON' arity f True where
1008− consToJSON' opts targs isUn f = let
1009− vals = toList $ recordToPairs opts targs f
1010− in case (unwrapUnaryRecords opts,isUn,vals) of
1011− (True,True,[(_,val)]) -> Tagged val
1012− _ -> Tagged $ object vals
1013−
1014−instance GToJSON arity f => ConsToJSON' arity f False where
955+instance ( RecordToPairs enc pairs arity f
956+ , FromPairs enc pairs
957+ , GToJSON enc arity f
958+ ) => ConsToJSON' enc arity f True
959+ where
960+ consToJSON' opts targs isUn =
961+ Tagged .
962+ case (isUn, unwrapUnaryRecords opts) of
963+ (True, True) -> gToJSON opts targs
964+ _ -> fromPairs . recordToPairs opts targs
965+ {-# INLINE consToJSON' #-}
966+
967+instance GToJSON enc arity f => ConsToJSON' enc arity f False where
1015968 consToJSON' opts targs _ = Tagged . gToJSON opts targs
969+ {-# INLINE consToJSON' #-}
1016970
1017971--------------------------------------------------------------------------------
1018972
1019−class ConsToEncoding arity f where
1020− consToEncoding :: Options -> ToArgs Encoding arity a
1021− -> f a -> Encoding
1022−
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
1049− -> f a -> DList Pair
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
973+class RecordToPairs enc pairs arity f where
974+ -- 1st element: whole thing
975+ -- 2nd element: in case the record has only 1 field, just the value
976+ -- of the field (without the key); 'Nothing' otherwise
977+ recordToPairs :: Options -> ToArgs enc arity a
978+ -> f a -> pairs
1056979
1057−instance (Selector s, GToJSON arity a) => RecordToPairs arity (S1 s a) where
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
995+ ) => RecordToPairs enc pairs arity (S1 s a)
996+ where
1058997 recordToPairs = fieldToPair
998+ {-# INLINE recordToPairs #-}
1059999
1060−instance OVERLAPPING_ (Selector s, ToJSON a) =>
1061− RecordToPairs arity (S1 s (K1 i (Maybe a))) where
1000+instance OVERLAPPING_
1001+ ( Selector s
1002+ , GToJSON enc arity (K1 i (Maybe a))
1003+ , GKeyValue enc pairs
1004+ , Monoid pairs
1005+ ) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a)))
1006+ where
10621007 recordToPairs opts _ (M1 k1) | omitNothingFields opts
1063− , K1 Nothing <- k1 = DList.empty
1008+ , K1 Nothing <- k1 = mempty
10641009 recordToPairs opts targs m1 = fieldToPair opts targs m1
1065−
1066−fieldToPair :: (Selector s, GToJSON arity a)
1067− => Options -> ToArgs Value arity p
1068− -> S1 s a p -> DList Pair
1069−fieldToPair opts targs m1 = pure ( pack $ fieldLabelModifier opts $ selName m1
1070− , gToJSON opts targs (unM1 m1)
1071− )
1072−
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)
1010+ {-# INLINE recordToPairs #-}
1011+
1012+fieldToPair :: (Selector s
1013+ , GToJSON enc arity a
1014+ , GKeyValue enc pairs)
1015+ => Options -> ToArgs enc arity p
1016+ -> S1 s a p -> pairs
1017+fieldToPair opts targs m1 =
1018+ let key = fieldLabelModifier opts (selName m1)
1019+ value = gToJSON opts targs (unM1 m1)
1020+ in key `gPair` value
1021+{-# INLINE fieldToPair #-}
11131022
11141023--------------------------------------------------------------------------------
11151024
@@ -1133,7 +1042,7 @@ instance ( WriteProduct arity a
11331042 lenR = len - lenL
11341043 ixR = ix + lenL
11351044
1136−instance OVERLAPPABLE_ (GToJSON arity a) => WriteProduct arity a where
1045+instance OVERLAPPABLE_ (GToJSON Value arity a) => WriteProduct arity a where
11371046 writeProduct opts targs mv ix _ =
11381047 VM.unsafeWrite mv ix . gToJSON opts targs
11391048
@@ -1154,109 +1063,38 @@ instance ( EncodeProduct arity a
11541063 encodeProduct opts targs a >*<
11551064 encodeProduct opts targs b
11561065
1157−instance OVERLAPPABLE_ (GToEncoding arity a) => EncodeProduct arity a where
1158− encodeProduct opts targs a = E.retagEncoding $ gToEncoding opts targs a
1066+instance OVERLAPPABLE_ (GToJSON Encoding arity a) => EncodeProduct arity a where
1067+ encodeProduct opts targs a = E.retagEncoding $ gToJSON opts targs a
11591068
11601069--------------------------------------------------------------------------------
11611070
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
1175− , ConsToJSON arity a
1071+instance ( GToJSON enc arity a
1072+ , ConsToJSON enc arity a
1073+ , FromPairs enc pairs
1074+ , GKeyValue enc pairs
11761075 , Constructor c
1177− ) => ObjectWithSingleFieldObj arity (C1 c a) where
1178− objectWithSingleFieldObj opts targs = H.singleton typ . gToJSON opts targs
1076+ ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)
1077+ where
1078+ sumToJSON' opts targs =
1079+ Tagged . fromPairs . (typ `gPair`) . gToJSON opts targs
11791080 where
1180− typ = pack $ constructorTagModifier opts $
1081+ typ = constructorTagModifier opts $
11811082 conName (undefined :: t c a p)
11821083
11831084--------------------------------------------------------------------------------
11841085
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−
12221086instance OVERLAPPABLE_
1223− ( GToJSON arity a
1224− , ConsToJSON arity a
1225− ) => UntaggedValueObj arity (C1 c a) where
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)
1087+ ( ConsToJSON enc arity a
1088+ ) => SumToJSON' UntaggedValue enc arity (C1 c a)
12521089 where
1253− untaggedValueEnc = gToEncoding
1090+ sumToJSON' opts targs = Tagged . gToJSON opts targs
12541091
12551092instance OVERLAPPING_
1256− ( Constructor c )
1257− => UntaggedValueEnc arity (C1 c U1)
1093+ ( Constructor c
1094+ , FromString enc
1095+ ) => SumToJSON' UntaggedValue enc arity (C1 c U1)
12581096 where
1259− untaggedValueEnc opts _ _ = toEncoding $
1097+ sumToJSON' opts _ _ = Tagged . fromString $
12601098 constructorTagModifier opts $ conName (undefined :: t c U1 p)
12611099
12621100-------------------------------------------------------------------------------
@@ -2834,3 +2672,23 @@ packChunks lbs =
28342672 copyBytes pf (pbuf `plusPtr` o) l
28352673 copyChunks lbs' (pf `plusPtr` l)
28362674#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