@@ -1,27 +1,29 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE EmptyDataDecls #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE NoImplicitPrelude #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PatternGuards #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE RecordWildCards #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TypeOperators #-}
15−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DefaultSignatures #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE NamedFieldPuns #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PatternGuards #-}
11+{-# LANGUAGE RecordWildCards #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE TypeSynonymInstances #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+
17+#if __GLASGOW_HASKELL__ >= 706
18+{-# LANGUAGE PolyKinds #-}
19+#endif
1620
1721#include "overlapping-compat.h"
18−#include "incoherent-compat.h"
1922
2023-- TODO: Drop this when we remove support for Data.Attoparsec.Number
2124{-# OPTIONS_GHC -fno-warn-deprecations #-}
2225
23−module Data.Aeson.Types.ToJSON
24− (
26+module Data.Aeson.Types.ToJSON (
2527 -- * Core JSON classes
2628 ToJSON(..)
2729 -- * Liftings to unary and binary type constructors
@@ -33,115 +35,95 @@ module Data.Aeson.Types.ToJSON
3335 , toEncoding2
3436 -- * Generic JSON classes
3537 , GToJSON(..)
36− , ToArgs(..)
38+ , GToEncoding(..)
3739 , genericToJSON
3840 , genericToEncoding
39− , genericLiftToJSON
40− , genericLiftToEncoding
4141 -- * Classes and types for map keys
4242 , ToJSONKey(..)
4343 , ToJSONKeyFunction(..)
44− , toJSONKeyText
4544 , contramapToJSONKeyFunction
46−
47− , GToJSONKey()
48− , genericToJSONKey
49−
5045 -- * Object key-value pairs
5146 , KeyValue(..)
52− , KeyValuePair(..)
53− , FromPairs(..)
5447 -- * Functions needed for documentation
5548 -- * Encoding functions
5649 , listEncoding
5750 , listValue
5851 ) where
5952
53+import Prelude ()
6054import Prelude.Compat
6155
62−import Control.Applicative (Const(..))
63−import Control.Monad.ST (ST)
64−import Data.Aeson.Encoding (Encoding, Encoding', Series, dict, emptyArray_)
65−import Data.Aeson.Encoding.Internal ((>*<))
66−import Data.Aeson.Internal.Functions (mapHashKeyVal, mapKeyVal)
67−import Data.Aeson.Types.Generic (AllNullary, False, IsRecord, One, ProductSize, Tagged2(..), True, Zero, productSize)
56+import Data.Aeson.Encoding.Internal (Encoding (..), Series, dict, emptyArray_,
57+ tuple, (>*<))
58+import Data.Aeson.Functions (mapHashKeyVal, mapKeyVal)
59+import Data.Aeson.Types.Generic
6860import Data.Aeson.Types.Internal
69−import Data.Attoparsec.Number (Number(..))
70−import Data.Bits (unsafeShiftR)
71−import Data.DList (DList)
72−import Data.Fixed (Fixed, HasResolution, Nano)
73−import Data.Foldable (toList)
74−import Data.Functor.Compose (Compose(..))
75−import Data.Functor.Contravariant (Contravariant (..))
76−import Data.Functor.Identity (Identity(..))
77−import Data.Functor.Product (Product(..))
78−import Data.Functor.Sum (Sum(..))
79−import Data.Int (Int16, Int32, Int64, Int8)
80−import Data.List (intersperse)
81−import Data.List.NonEmpty (NonEmpty(..))
82−import Data.Semigroup ((<>))
83−import Data.Proxy (Proxy(..))
84−import Data.Ratio (Ratio, denominator, numerator)
85−import Data.Scientific (Scientific)
86−import Data.Tagged (Tagged(..))
87−import Data.Text (Text, pack)
88−import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
89−import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
90−import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
91−import Data.Time.Clock.System.Compat (SystemTime (..))
92−import Data.Time.Format.Compat (FormatTime, formatTime, defaultTimeLocale)
93−import Data.Vector (Vector)
94−import Data.Version (Version, showVersion)
95−import Data.Void (Void, absurd)
96−import Data.Word (Word16, Word32, Word64, Word8)
97−import Foreign.Storable (Storable)
98−import Foreign.C.Types (CTime (..))
61+
62+import qualified Data.Aeson.Encode.Builder as EB
63+import qualified Data.Aeson.Encoding.Internal as E
64+
65+import Control.Applicative (Const (..))
66+import Control.Monad.ST (ST)
67+import Data.Attoparsec.Number (Number (..))
68+import Data.Bits (unsafeShiftR)
69+import Data.DList (DList)
70+import Data.Fixed (Fixed, HasResolution)
71+import Data.Foldable (toList)
72+import Data.Functor.Identity (Identity (..))
73+import Data.Int (Int16, Int32, Int64, Int8)
74+import Data.List (intersperse)
75+import Data.List.NonEmpty (NonEmpty (..))
76+import Data.Monoid (Dual (..), First (..), Last (..), (<>))
77+import Data.Proxy (Proxy (..))
78+import Data.Ratio (Ratio, denominator, numerator)
79+import Data.Scientific (Scientific)
80+import Data.Tagged (Tagged (..))
81+import Data.Text (Text, pack)
82+import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay,
83+ UTCTime, ZonedTime)
84+import Data.Time.Format (FormatTime, formatTime)
85+import Data.Time.Locale.Compat (defaultTimeLocale)
86+import Data.Vector (Vector)
87+import Data.Version (Version, showVersion)
88+import Data.Word (Word16, Word32, Word64, Word8)
89+import Foreign.Storable (Storable)
9990import GHC.Generics
100−import Numeric.Natural (Natural)
101−import qualified Data.Aeson.Encoding as E
102−import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)
103−import qualified Data.ByteString.Lazy as L
104−import qualified Data.DList as DList
105−import qualified Data.HashMap.Strict as H
106−import qualified Data.HashSet as HashSet
107−import qualified Data.IntMap as IntMap
108−import qualified Data.IntSet as IntSet
109−import qualified Data.List.NonEmpty as NE
110−import qualified Data.Map as M
111−import qualified Data.Monoid as Monoid
112−import qualified Data.Scientific as Scientific
113−import qualified Data.Semigroup as Semigroup
114−import qualified Data.Sequence as Seq
115−import qualified Data.Set as Set
116−import qualified Data.Text as T
117−import qualified Data.Text.Encoding as T
118−import qualified Data.Text.Lazy as LT
119−import qualified Data.Tree as Tree
120−import qualified Data.UUID.Types as UUID
121−import qualified Data.Vector as V
122−import qualified Data.Vector.Generic as VG
123−import qualified Data.Vector.Mutable as VM
124−import qualified Data.Vector.Primitive as VP
125−import qualified Data.Vector.Storable as VS
126−import qualified Data.Vector.Unboxed as VU
127−
128−import qualified Data.Aeson.Encoding.Builder as EB
129−import qualified Data.ByteString.Builder as B
130−
131−import qualified GHC.Exts as Exts
132−import qualified Data.Primitive.Array as PM
133−import qualified Data.Primitive.SmallArray as PM
134−import qualified Data.Primitive.Types as PM
135−
136−#if MIN_VERSION_primitive(0,6,4)
137−#if !MIN_VERSION_primitive(0,7,0)
138−import qualified Data.Primitive.UnliftedArray as PM
139−#endif
140−import qualified Data.Primitive.PrimArray as PM
141−#endif
91+import Numeric.Natural (Natural)
92+
93+import qualified Data.ByteString.Builder as B
94+import qualified Data.ByteString.Lazy as L
95+import qualified Data.DList as DList
96+import qualified Data.HashMap.Strict as H
97+import qualified Data.HashSet as HashSet
98+import qualified Data.IntMap as IntMap
99+import qualified Data.IntSet as IntSet
100+import qualified Data.List.NonEmpty as NE
101+import qualified Data.Map as M
102+import qualified Data.Scientific as Scientific
103+import qualified Data.Sequence as Seq
104+import qualified Data.Set as Set
105+import qualified Data.Text as T
106+import qualified Data.Text.Encoding as T
107+import qualified Data.Text.Lazy as LT
108+import qualified Data.Text.Lazy.Builder as LTB
109+import qualified Data.Text.Lazy.Builder.Int as LTBI
110+import qualified Data.Tree as Tree
111+import qualified Data.Vector as V
112+import qualified Data.Vector.Generic as VG
113+import qualified Data.Vector.Mutable as VM
114+import qualified Data.Vector.Primitive as VP
115+import qualified Data.Vector.Storable as VS
116+import qualified Data.Vector.Unboxed as VU
117+
118+builder :: ToJSON a => a -> B.Builder
119+builder = fromEncoding . toEncoding
142120
143121toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value
144−toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)
122+toJSONPair keySerialiser valSerializer (a, b) = Array $ V.create $ do
123+ mv <- VM.unsafeNew 2
124+ VM.unsafeWrite mv 0 (keySerialiser a)
125+ VM.unsafeWrite mv 1 (valSerializer b)
126+ return mv
145127{-# INLINE toJSONPair #-}
146128
147129realFloatToJSON :: RealFloat a => a -> Value
@@ -150,59 +132,41 @@ realFloatToJSON d
150132 | otherwise = Number $ Scientific.fromFloatDigits d
151133{-# INLINE realFloatToJSON #-}
152134
135+realFloatToEncoding :: RealFloat a => a -> Encoding
136+realFloatToEncoding d
137+ | isNaN d || isInfinite d = Encoding EB.null_
138+ | otherwise = toEncoding (Scientific.fromFloatDigits d)
139+{-# INLINE realFloatToEncoding #-}
153140-------------------------------------------------------------------------------
154141-- Generics
155142-------------------------------------------------------------------------------
156143
157−-- | Class of generic representation types that can be converted to
144+-- | Class of generic representation types ('Rep') that can be converted to
158145-- JSON.
159−class GToJSON enc arity f where
146+class GToJSON f where
160147 -- | This method (applied to 'defaultOptions') is used as the
161− -- default generic implementation of 'toJSON'
162− -- (with @enc ~ 'Value'@ and @arity ~ 'Zero'@)
163− -- and 'liftToJSON' (if the @arity@ is 'One').
164− --
165− -- It also provides a generic implementation of 'toEncoding'
166− -- (with @enc ~ 'Encoding'@ and @arity ~ 'Zero'@)
167− -- and 'liftToEncoding' (if the @arity@ is 'One').
168− gToJSON :: Options -> ToArgs enc arity a -> f a -> enc
169−
170−-- | A 'ToArgs' value either stores nothing (for 'ToJSON') or it stores the two
171−-- function arguments that encode occurrences of the type parameter (for
172−-- 'ToJSON1').
173−data ToArgs res arity a where
174− NoToArgs :: ToArgs res Zero a
175− To1Args :: (a -> res) -> ([a] -> res) -> ToArgs res One a
148+ -- default generic implementation of 'toJSON'.
149+ gToJSON :: Options -> f a -> Value
150+
151+-- | Class of generic representation types ('Rep') that can be converted to
152+-- a JSON 'Encoding'.
153+class GToEncoding f where
154+ -- | This method (applied to 'defaultOptions') can be used as the
155+ -- default generic implementation of 'toEncoding'.
156+ gToEncoding :: Options -> f a -> Encoding
157+
176158
177159-- | A configurable generic JSON creator. This function applied to
178160-- 'defaultOptions' is used as the default for 'toJSON' when the type
179161-- is an instance of 'Generic'.
180−genericToJSON :: (Generic a, GToJSON Value Zero (Rep a))
181− => Options -> a -> Value
182−genericToJSON opts = gToJSON opts NoToArgs . from
183−
184−-- | A configurable generic JSON creator. This function applied to
185−-- 'defaultOptions' is used as the default for 'liftToJSON' when the type
186−-- is an instance of 'Generic1'.
187−genericLiftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f))
188− => Options -> (a -> Value) -> ([a] -> Value)
189− -> f a -> Value
190−genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1
162+genericToJSON :: (Generic a, GToJSON (Rep a)) => Options -> a -> Value
163+genericToJSON opts = gToJSON opts . from
191164
192165-- | A configurable generic JSON encoder. This function applied to
193166-- 'defaultOptions' is used as the default for 'toEncoding' when the type
194167-- is an instance of 'Generic'.
195−genericToEncoding :: (Generic a, GToJSON Encoding Zero (Rep a))
196− => Options -> a -> Encoding
197−genericToEncoding opts = gToJSON opts NoToArgs . from
198−
199−-- | A configurable generic JSON encoder. This function applied to
200−-- 'defaultOptions' is used as the default for 'liftToEncoding' when the type
201−-- is an instance of 'Generic1'.
202−genericLiftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f))
203− => Options -> (a -> Encoding) -> ([a] -> Encoding)
204− -> f a -> Encoding
205−genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1
168+genericToEncoding :: (Generic a, GToEncoding (Rep a)) => Options -> a -> Encoding
169+genericToEncoding opts = gToEncoding opts . from
206170
207171-------------------------------------------------------------------------------
208172-- Class
@@ -210,9 +174,6 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1
210174
211175-- | A type that can be converted to JSON.
212176--
213−-- Instances in general /must/ specify 'toJSON' and /should/ (but don't need
214−-- to) specify 'toEncoding'.
215−--
216177-- An example type and instance:
217178--
218179-- @
@@ -221,10 +182,10 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1
221182--
222183-- data Coord = Coord { x :: Double, y :: Double }
223184--
224−-- instance 'ToJSON' Coord where
225−-- 'toJSON' (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]
185+-- instance ToJSON Coord where
186+-- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]
226187--
227−-- 'toEncoding' (Coord x y) = 'pairs' (\"x\" '.=' x '<>' \"y\" '.=' y)
188+-- toEncoding (Coord x y) = 'pairs' (\"x\" '.=' x '<>' \"y\" '.=' y)
228189-- @
229190--
230191-- Instead of manually writing your 'ToJSON' instance, there are two options
@@ -232,15 +193,17 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1
232193--
233194-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
234195-- instance at compile time. The generated instance is optimized for your type
235−-- so it will probably be more efficient than the following option.
196+-- so will probably be more efficient than the following two options:
236197--
237198-- * The compiler can provide a default generic implementation for
238199-- 'toJSON'.
239200--
240201-- To use the second, simply add a @deriving 'Generic'@ clause to your
241−-- datatype and declare a 'ToJSON' instance. If you require nothing other than
242−-- 'defaultOptions', it is sufficient to write (and this is the only
243−-- alternative where the default 'toJSON' implementation is sufficient):
202+-- datatype and declare a 'ToJSON' instance for your datatype without giving
203+-- definitions for 'toJSON' or 'toEncoding'.
204+--
205+-- For example, the previous example can be simplified to a more
206+-- minimal instance:
244207--
245208-- @
246209-- {-\# LANGUAGE DeriveGeneric \#-}
@@ -249,46 +212,35 @@ genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1
249212--
250213-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'
251214--
252−-- instance 'ToJSON' Coord where
253−-- 'toEncoding' = 'genericToEncoding' 'defaultOptions'
215+-- instance ToJSON Coord where
216+-- toEncoding = 'genericToEncoding' 'defaultOptions'
254217-- @
255218--
256−-- If on the other hand you wish to customize the generic decoding, you have
257−-- to implement both methods:
219+-- Why do we provide an implementation for 'toEncoding' here? The
220+-- 'toEncoding' function is a relatively new addition to this class.
221+-- To allow users of older versions of this library to upgrade without
222+-- having to edit all of their instances or encounter surprising
223+-- incompatibilities, the default implementation of 'toEncoding' uses
224+-- 'toJSON'. This produces correct results, but since it performs an
225+-- intermediate conversion to a 'Value', it will be less efficient
226+-- than directly emitting an 'Encoding'. Our one-liner definition of
227+-- 'toEncoding' above bypasses the intermediate 'Value'.
228+--
229+-- If @DefaultSignatures@ doesn't give exactly the results you want,
230+-- you can customize the generic encoding with only a tiny amount of
231+-- effort, using 'genericToJSON' and 'genericToEncoding' with your
232+-- preferred 'Options':
258233--
259234-- @
260−-- customOptions = 'defaultOptions'
261−-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'
262−-- }
263−--
264−-- instance 'ToJSON' Coord where
265−-- 'toJSON' = 'genericToJSON' customOptions
266−-- 'toEncoding' = 'genericToEncoding' customOptions
235+-- instance ToJSON Coord where
236+-- toJSON = 'genericToJSON' 'defaultOptions'
237+-- toEncoding = 'genericToEncoding' 'defaultOptions'
267238-- @
268−--
269−-- Previous versions of this library only had the 'toJSON' method. Adding
270−-- 'toEncoding' had two reasons:
271−--
272−-- 1. toEncoding is more efficient for the common case that the output of
273−-- 'toJSON' is directly serialized to a @ByteString@.
274−-- Further, expressing either method in terms of the other would be
275−-- non-optimal.
276−--
277−-- 2. The choice of defaults allows a smooth transition for existing users:
278−-- Existing instances that do not define 'toEncoding' still
279−-- compile and have the correct semantics. This is ensured by making
280−-- the default implementation of 'toEncoding' use 'toJSON'. This produces
281−-- correct results, but since it performs an intermediate conversion to a
282−-- 'Value', it will be less efficient than directly emitting an 'Encoding'.
283−-- (this also means that specifying nothing more than
284−-- @instance ToJSON Coord@ would be sufficient as a generically decoding
285−-- instance, but there probably exists no good reason to not specify
286−-- 'toEncoding' in new instances.)
287239class ToJSON a where
288240 -- | Convert a Haskell value to a JSON-friendly intermediate type.
289241 toJSON :: a -> Value
290242
291− default toJSON :: (Generic a, GToJSON Value Zero (Rep a)) => a -> Value
243+ default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
292244 toJSON = genericToJSON defaultOptions
293245
294246 -- | Encode a Haskell value as JSON.
@@ -305,12 +257,12 @@ class ToJSON a where
305257 -- extension, and then have GHC generate a method body as follows.
306258 --
307259 -- @
308− -- instance 'ToJSON' Coord where
309− -- 'toEncoding' = 'genericToEncoding' 'defaultOptions'
260+ -- instance ToJSON Coord where
261+ -- toEncoding = 'genericToEncoding' 'defaultOptions'
310262 -- @
311263
312264 toEncoding :: a -> Encoding
313− toEncoding = E.value . toJSON
265+ toEncoding = E.Encoding . EB.encodeToBuilder . toJSON
314266 {-# INLINE toEncoding #-}
315267
316268 toJSONList :: [a] -> Value
@@ -331,280 +283,46 @@ class KeyValue kv where
331283 infixr 8 .=
332284
333285instance KeyValue Series where
334− name .= value = E.pair name (toEncoding value)
286+ name .= value = E.Value $ E.text name <> E.colon <> toEncoding value
335287 {-# INLINE (.=) #-}
336288
337289instance KeyValue Pair where
338290 name .= value = (name, toJSON value)
339291 {-# INLINE (.=) #-}
340292
341−-- | Constructs a singleton 'H.HashMap'. For calling functions that
342−-- demand an 'Object' for constructing objects. To be used in
343−-- conjunction with 'mconcat'. Prefer to use 'object' where possible.
344−instance KeyValue Object where
345− name .= value = H.singleton name (toJSON value)
346− {-# INLINE (.=) #-}
347−
348293-------------------------------------------------------------------------------
349294-- Classes and types for map keys
350295-------------------------------------------------------------------------------
351296
352−-- | Typeclass for types that can be used as the key of a map-like container
353−-- (like 'Map' or 'HashMap'). For example, since 'Text' has a 'ToJSONKey'
354−-- instance and 'Char' has a 'ToJSON' instance, we can encode a value of
355−-- type 'Map' 'Text' 'Char':
356−--
357−-- >>> LBC8.putStrLn $ encode $ Map.fromList [("foo" :: Text, 'a')]
358−-- {"foo":"a"}
359−--
360−-- Since 'Int' also has a 'ToJSONKey' instance, we can similarly write:
361−--
362−-- >>> LBC8.putStrLn $ encode $ Map.fromList [(5 :: Int, 'a')]
363−-- {"5":"a"}
364−--
365−-- JSON documents only accept strings as object keys. For any type
366−-- from @base@ that has a natural textual representation, it can be
367−-- expected that its 'ToJSONKey' instance will choose that representation.
368−--
369−-- For data types that lack a natural textual representation, an alternative
370−-- is provided. The map-like container is represented as a JSON array
371−-- instead of a JSON object. Each value in the array is an array with
372−-- exactly two values. The first is the key and the second is the value.
373−--
374−-- For example, values of type '[Text]' cannot be encoded to a
375−-- string, so a 'Map' with keys of type '[Text]' is encoded as follows:
376−--
377−-- >>> LBC8.putStrLn $ encode $ Map.fromList [(["foo","bar","baz" :: Text], 'a')]
378−-- [[["foo","bar","baz"],"a"]]
379−--
380−-- The default implementation of 'ToJSONKey' chooses this method of
381−-- encoding a key, using the 'ToJSON' instance of the type.
382−--
383−-- To use your own data type as the key in a map, all that is needed
384−-- is to write a 'ToJSONKey' (and possibly a 'FromJSONKey') instance
385−-- for it. If the type cannot be trivially converted to and from 'Text',
386−-- it is recommended that 'ToJSONKeyValue' is used. Since the default
387−-- implementations of the typeclass methods can build this from a
388−-- 'ToJSON' instance, there is nothing that needs to be written:
389−--
390−-- > data Foo = Foo { fooAge :: Int, fooName :: Text }
391−-- > deriving (Eq,Ord,Generic)
392−-- > instance ToJSON Foo
393−-- > instance ToJSONKey Foo
394−--
395−-- That's it. We can now write:
396−--
397−-- >>> let m = Map.fromList [(Foo 4 "bar",'a'),(Foo 6 "arg",'b')]
398−-- >>> LBC8.putStrLn $ encode m
399−-- [[{"fooName":"bar","fooAge":4},"a"],[{"fooName":"arg","fooAge":6},"b"]]
400−--
401−-- The next case to consider is if we have a type that is a
402−-- newtype wrapper around 'Text'. The recommended approach is to use
403−-- generalized newtype deriving:
404−--
405−-- > newtype RecordId = RecordId { getRecordId :: Text }
406−-- > deriving (Eq,Ord,ToJSONKey)
407−--
408−-- Then we may write:
409−--
410−-- >>> LBC8.putStrLn $ encode $ Map.fromList [(RecordId "abc",'a')]
411−-- {"abc":"a"}
412−--
413−-- Simple sum types are a final case worth considering. Suppose we have:
414−--
415−-- > data Color = Red | Green | Blue
416−-- > deriving (Show,Read,Eq,Ord)
417−--
418−-- It is possible to get the 'ToJSONKey' instance for free as we did
419−-- with 'Foo'. However, in this case, we have a natural way to go to
420−-- and from 'Text' that does not require any escape sequences. So
421−-- 'ToJSONKeyText' can be used instead of 'ToJSONKeyValue' to encode maps
422−-- as objects instead of arrays of pairs. This instance may be
423−-- implemented using generics as follows:
424−--
425−-- @
426−-- instance 'ToJSONKey' Color where
427−-- 'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'
428−-- @
429−--
430−-- === __Low-level implementations__
431−--
432−-- The 'Show' instance can be used to help write 'ToJSONKey':
433−--
434−-- > instance ToJSONKey Color where
435−-- > toJSONKey = ToJSONKeyText f g
436−-- > where f = Text.pack . show
437−-- > g = text . Text.pack . show
438−-- > -- text function is from Data.Aeson.Encoding
439−--
440−-- The situation of needing to turning function @a -> Text@ into
441−-- a 'ToJSONKeyFunction' is common enough that a special combinator
442−-- is provided for it. The above instance can be rewritten as:
443−--
444−-- > instance ToJSONKey Color where
445−-- > toJSONKey = toJSONKeyText (Text.pack . show)
446−--
447−-- The performance of the above instance can be improved by
448−-- not using 'String' as an intermediate step when converting to
449−-- 'Text'. One option for improving performance would be to use
450−-- template haskell machinery from the @text-show@ package. However,
451−-- even with the approach, the 'Encoding' (a wrapper around a bytestring
452−-- builder) is generated by encoding the 'Text' to a 'ByteString',
453−-- an intermediate step that could be avoided. The fastest possible
454−-- implementation would be:
455−--
456−-- > -- Assuming that OverloadedStrings is enabled
457−-- > instance ToJSONKey Color where
458−-- > toJSONKey = ToJSONKeyText f g
459−-- > where f x = case x of {Red -> "Red";Green ->"Green";Blue -> "Blue"}
460−-- > g x = case x of {Red -> text "Red";Green -> text "Green";Blue -> text "Blue"}
461−-- > -- text function is from Data.Aeson.Encoding
462−--
463−-- This works because GHC can lift the encoded values out of the case
464−-- statements, which means that they are only evaluated once. This
465−-- approach should only be used when there is a serious need to
466−-- maximize performance.
467−
468297class ToJSONKey a where
469− -- | Strategy for rendering the key for a map-like container.
470298 toJSONKey :: ToJSONKeyFunction a
471299 default toJSONKey :: ToJSON a => ToJSONKeyFunction a
472− toJSONKey = ToJSONKeyValue toJSON toEncoding
473−
474− -- | This is similar in spirit to the 'showsList' method of 'Show'.
475− -- It makes it possible to give 'String' keys special treatment
476− -- without using @OverlappingInstances@. End users should always
477− -- be able to use the default implementation of this method.
300+ toJSONKey = ToJSONKeyValue (toJSON, toEncoding)
478301 toJSONKeyList :: ToJSONKeyFunction [a]
479302 default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]
480− toJSONKeyList = ToJSONKeyValue toJSON toEncoding
303+ toJSONKeyList = ToJSONKeyValue (toJSON, toEncoding)
481304
482305data ToJSONKeyFunction a
483− = ToJSONKeyText !(a -> Text) !(a -> Encoding' Text)
484− -- ^ key is encoded to string, produces object
485− | ToJSONKeyValue !(a -> Value) !(a -> Encoding)
486− -- ^ key is encoded to value, produces array
306+ = ToJSONKeyText (a -> Text, a -> Encoding)
307+ | ToJSONKeyValue (a -> Value, a -> Encoding)
487308
488−-- | Helper for creating textual keys.
489−--
490−-- @
491−-- instance 'ToJSONKey' MyKey where
492−-- 'toJSONKey' = 'toJSONKeyText' myKeyToText
493−-- where
494−-- myKeyToText = Text.pack . show -- or showt from text-show
495−-- @
496−toJSONKeyText :: (a -> Text) -> ToJSONKeyFunction a
497−toJSONKeyText f = ToJSONKeyText f (E.text . f)
498−
499−-- | TODO: should this be exported?
500−toJSONKeyTextEnc :: (a -> Encoding' Text) -> ToJSONKeyFunction a
501−toJSONKeyTextEnc e = ToJSONKeyText tot e
502− where
503− -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm
504− tot = T.dropAround (== '"')
505− . T.decodeLatin1
506− . L.toStrict
507− . E.encodingToLazyByteString
508− . e
509−
510−instance Contravariant ToJSONKeyFunction where
511− contramap = contramapToJSONKeyFunction
512−
513−-- | Contravariant map, as 'ToJSONKeyFunction' is a contravariant functor.
514309contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b
515310contramapToJSONKeyFunction h x = case x of
516− ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)
517− ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)
518−
519−-- 'toJSONKey' for 'Generic' types.
520−-- Deriving is supported for enumeration types, i.e. the sums of nullary
521−-- constructors. The names of constructors will be used as keys for JSON
522−-- objects.
523−--
524−-- See also 'genericFromJSONKey'.
525−--
526−-- === __Example__
527−--
528−-- @
529−-- data Color = Red | Green | Blue
530−-- deriving 'Generic'
531−--
532−-- instance 'ToJSONKey' Color where
533−-- 'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'
534−-- @
535−genericToJSONKey :: (Generic a, GToJSONKey (Rep a))
536− => JSONKeyOptions -> ToJSONKeyFunction a
537−genericToJSONKey opts = toJSONKeyText (pack . keyModifier opts . getConName . from)
538−
539−class GetConName f => GToJSONKey f
540−instance GetConName f => GToJSONKey f
311+ ToJSONKeyText (f,g) -> ToJSONKeyText (f . h, g . h)
312+ ToJSONKeyValue (f,g) -> ToJSONKeyValue (f . h, g . h)
541313
542314-------------------------------------------------------------------------------
543315-- Lifings of FromJSON and ToJSON to unary and binary type constructors
544316-------------------------------------------------------------------------------
545317
546−
547318-- | Lifting of the 'ToJSON' class to unary type constructors.
548−--
549−-- Instead of manually writing your 'ToJSON1' instance, there are two options
550−-- to do it automatically:
551−--
552−-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
553−-- instance at compile time. The generated instance is optimized for your type
554−-- so it will probably be more efficient than the following option.
555−--
556−-- * The compiler can provide a default generic implementation for
557−-- 'toJSON1'.
558−--
559−-- To use the second, simply add a @deriving 'Generic1'@ clause to your
560−-- datatype and declare a 'ToJSON1' instance for your datatype without giving
561−-- definitions for 'liftToJSON' or 'liftToEncoding'.
562−--
563−-- For example:
564−--
565−-- @
566−-- {-\# LANGUAGE DeriveGeneric \#-}
567−--
568−-- import "GHC.Generics"
569−--
570−-- data Pair = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'
571−--
572−-- instance 'ToJSON' a => 'ToJSON1' (Pair a)
573−-- @
574−--
575−-- If the default implementation doesn't give exactly the results you want,
576−-- you can customize the generic encoding with only a tiny amount of
577−-- effort, using 'genericLiftToJSON' and 'genericLiftToEncoding' with
578−-- your preferred 'Options':
579−--
580−-- @
581−-- customOptions = 'defaultOptions'
582−-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'
583−-- }
584−--
585−-- instance 'ToJSON' a => 'ToJSON1' (Pair a) where
586−-- 'liftToJSON' = 'genericLiftToJSON' customOptions
587−-- 'liftToEncoding' = 'genericLiftToEncoding' customOptions
588−-- @
589−--
590−-- See also 'ToJSON'.
591319class ToJSON1 f where
592320 liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value
593−
594− default liftToJSON :: (Generic1 f, GToJSON Value One (Rep1 f))
595− => (a -> Value) -> ([a] -> Value) -> f a -> Value
596− liftToJSON = genericLiftToJSON defaultOptions
597−
598321 liftToJSONList :: (a -> Value) -> ([a] -> Value) -> [f a] -> Value
599322 liftToJSONList f g = listValue (liftToJSON f g)
600323
324+ -- | Unfortunately there cannot be a default implementation of 'liftToEncoding'.
601325 liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding
602−
603− default liftToEncoding :: (Generic1 f, GToJSON Encoding One (Rep1 f))
604− => (a -> Encoding) -> ([a] -> Encoding)
605− -> f a -> Encoding
606− liftToEncoding = genericLiftToEncoding defaultOptions
607−
608326 liftToEncodingList :: (a -> Encoding) -> ([a] -> Encoding) -> [f a] -> Encoding
609327 liftToEncodingList f g = listEncoding (liftToEncoding f g)
610328
@@ -618,13 +336,8 @@ toEncoding1 :: (ToJSON1 f, ToJSON a) => f a -> Encoding
618336toEncoding1 = liftToEncoding toEncoding toEncodingList
619337{-# INLINE toEncoding1 #-}
620338
339+
621340-- | Lifting of the 'ToJSON' class to binary type constructors.
622−--
623−-- Instead of manually writing your 'ToJSON2' instance, "Data.Aeson.TH"
624−-- provides Template Haskell functions which will derive an instance at compile time.
625−--
626−-- The compiler cannot provide a default generic implementation for 'liftToJSON2',
627−-- unlike 'toJSON' and 'liftToJSON'.
628341class ToJSON2 f where
629342 liftToJSON2 :: (a -> Value) -> ([a] -> Value) -> (b -> Value) -> ([b] -> Value) -> f a b -> Value
630343 liftToJSONList2 :: (a -> Value) -> ([a] -> Value) -> (b -> Value) -> ([b] -> Value) -> [f a b] -> Value
@@ -648,25 +361,9 @@ toEncoding2 = liftToEncoding2 toEncoding toEncodingList toEncoding toEncodingLis
648361-- Encoding functions
649362-------------------------------------------------------------------------------
650363
651−-- | Helper function to use with 'liftToEncoding'.
652−-- Useful when writing own 'ToJSON1' instances.
653−--
654−-- @
655−-- newtype F a = F [a]
656−--
657−-- -- This instance encodes 'String' as an array of chars
658−-- instance 'ToJSON1' F where
659−-- 'liftToJSON' tj _ (F xs) = 'liftToJSON' tj ('listValue' tj) xs
660−-- 'liftToEncoding' te _ (F xs) = 'liftToEncoding' te ('listEncoding' te) xs
661−--
662−-- instance 'Data.Aeson.FromJSON.FromJSON1' F where
663−-- 'Data.Aeson.FromJSON.liftParseJSON' p _ v = F \<$\> 'Data.Aeson.FromJSON.liftParseJSON' p ('Data.Aeson.FromJSON.listParser' p) v
664−-- @
665364listEncoding :: (a -> Encoding) -> [a] -> Encoding
666365listEncoding = E.list
667−{-# INLINE listEncoding #-}
668366
669−-- | Helper function to use with 'liftToJSON', see 'listEncoding'.
670367listValue :: (a -> Value) -> [a] -> Value
671368listValue f = Array . V.fromList . map f
672369{-# INLINE listValue #-}
@@ -685,11 +382,6 @@ instance ToJSON1 [] where
685382 {-# INLINE liftToEncoding #-}
686383
687384instance (ToJSON a) => ToJSON [a] where
688− {-# SPECIALIZE instance ToJSON String #-}
689− {-# SPECIALIZE instance ToJSON [String] #-}
690− {-# SPECIALIZE instance ToJSON [Array] #-}
691− {-# SPECIALIZE instance ToJSON [Object] #-}
692−
693385 toJSON = toJSON1
694386 {-# INLINE toJSON #-}
695387
@@ -700,260 +392,214 @@ instance (ToJSON a) => ToJSON [a] where
700392-- Generic toJSON / toEncoding
701393-------------------------------------------------------------------------------
702394
703−instance OVERLAPPABLE_ (GToJSON enc arity a) => GToJSON enc arity (M1 i c a) where
704− -- Meta-information, which is not handled elsewhere, is ignored:
705− gToJSON opts targs = gToJSON opts targs . unM1
706− {-# INLINE gToJSON #-}
707−
708−instance GToJSON enc One Par1 where
709− -- Direct occurrences of the last type parameter are encoded with the
710− -- function passed in as an argument:
711− gToJSON _opts (To1Args tj _) = tj . unPar1
712− {-# INLINE gToJSON #-}
713−
714−instance ( ConsToJSON enc arity a
715− , AllNullary (C1 c a) allNullary
716− , SumToJSON enc arity (C1 c a) allNullary
717− ) => GToJSON enc arity (D1 d (C1 c a)) where
718− -- The option 'tagSingleConstructors' determines whether to wrap
719− -- a single-constructor type.
720− gToJSON opts targs
721− | tagSingleConstructors opts = (unTagged :: Tagged allNullary enc -> enc)
722− . sumToJSON opts targs
723− . unM1
724− | otherwise = consToJSON opts targs . unM1 . unM1
725− {-# INLINE gToJSON #-}
726−
727−instance (ConsToJSON enc arity a) => GToJSON enc arity (C1 c a) where
728− -- Constructors need to be encoded differently depending on whether they're
729− -- a record or not. This distinction is made by 'consToJSON':
730− gToJSON opts targs = consToJSON opts targs . unM1
731− {-# INLINE gToJSON #-}
732−
733−instance ( AllNullary (a :+: b) allNullary
734− , SumToJSON enc arity (a :+: b) allNullary
735− ) => GToJSON enc arity (a :+: b)
736− where
737− -- If all constructors of a sum datatype are nullary and the
738− -- 'allNullaryToStringTag' option is set they are encoded to
739− -- strings. This distinction is made by 'sumToJSON':
740− gToJSON opts targs = (unTagged :: Tagged allNullary enc -> enc)
741− . sumToJSON opts targs
742− {-# INLINE gToJSON #-}
743−
744395--------------------------------------------------------------------------------
745396-- Generic toJSON
746397
747−-- Note: Refactoring 'ToJSON a' to 'ToJSON enc a' (and 'ToJSON1' similarly) is
748−-- possible but makes error messages a bit harder to understand for missing
749−-- instances.
750−
751−instance GToJSON Value arity V1 where
752− -- Empty values do not exist, which makes the job of formatting them
753− -- rather easy:
754− gToJSON _ _ x = x `seq` error "case: V1"
755− {-# INLINE gToJSON #-}
398+instance OVERLAPPABLE_ (GToJSON a) => GToJSON (M1 i c a) where
399+ -- Meta-information, which is not handled elsewhere, is ignored:
400+ gToJSON opts = gToJSON opts . unM1
756401
757−instance ToJSON a => GToJSON Value arity (K1 i a) where
402+instance (ToJSON a) => GToJSON (K1 i a) where
758403 -- Constant values are encoded using their ToJSON instance:
759− gToJSON _opts _ = toJSON . unK1
760− {-# INLINE gToJSON #-}
404+ gToJSON _opts = toJSON . unK1
761405
762−instance ToJSON1 f => GToJSON Value One (Rec1 f) where
763− -- Recursive occurrences of the last type parameter are encoded using their
764− -- ToJSON1 instance:
765− gToJSON _opts (To1Args tj tjl) = liftToJSON tj tjl . unRec1
766− {-# INLINE gToJSON #-}
767−
768−instance GToJSON Value arity U1 where
406+instance GToJSON U1 where
769407 -- Empty constructors are encoded to an empty array:
770− gToJSON _opts _ _ = emptyArray
771− {-# INLINE gToJSON #-}
408+ gToJSON _opts _ = emptyArray
409+
410+instance (ConsToJSON a) => GToJSON (C1 c a) where
411+ -- Constructors need to be encoded differently depending on whether they're
412+ -- a record or not. This distinction is made by 'consToJSON':
413+ gToJSON opts = consToJSON opts . unM1
772414
773−instance ( WriteProduct arity a, WriteProduct arity b
774− , ProductSize a, ProductSize b
775− ) => GToJSON Value arity (a :*: b)
776− where
415+instance ( WriteProduct a, WriteProduct b
416+ , ProductSize a, ProductSize b ) => GToJSON (a :*: b) where
777417 -- Products are encoded to an array. Here we allocate a mutable vector of
778418 -- the same size as the product and write the product's elements to it using
779419 -- 'writeProduct':
780− gToJSON opts targs p =
420+ gToJSON opts p =
781421 Array $ V.create $ do
782422 mv <- VM.unsafeNew lenProduct
783− writeProduct opts targs mv 0 lenProduct p
423+ writeProduct opts mv 0 lenProduct p
784424 return mv
785425 where
786426 lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
787427 productSize
788− {-# INLINE gToJSON #-}
789−
790−instance ( ToJSON1 f
791− , GToJSON Value One g
792− ) => GToJSON Value One (f :.: g)
793− where
794− -- If an occurrence of the last type parameter is nested inside two
795− -- composed types, it is encoded by using the outermost type's ToJSON1
796− -- instance to generically encode the innermost type:
797− gToJSON opts targs =
798− let gtj = gToJSON opts targs in
799− liftToJSON gtj (listValue gtj) . unComp1
800− {-# INLINE gToJSON #-}
428+
429+instance ( AllNullary (a :+: b) allNullary
430+ , SumToJSON (a :+: b) allNullary ) => GToJSON (a :+: b) where
431+ -- If all constructors of a sum datatype are nullary and the
432+ -- 'allNullaryToStringTag' option is set they are encoded to
433+ -- strings. This distinction is made by 'sumToJSON':
434+ gToJSON opts = (unTagged :: Tagged allNullary Value -> Value)
435+ . sumToJSON opts
801436
802437--------------------------------------------------------------------------------
803438-- Generic toEncoding
804439
805−instance ToJSON a => GToJSON Encoding arity (K1 i a) where
806− -- Constant values are encoded using their ToJSON instance:
807− gToJSON _opts _ = toEncoding . unK1
808− {-# INLINE gToJSON #-}
440+instance OVERLAPPABLE_ (GToEncoding a) => GToEncoding (M1 i c a) where
441+ -- Meta-information, which is not handled elsewhere, is ignored:
442+ gToEncoding opts = gToEncoding opts . unM1
809443
810−instance ToJSON1 f => GToJSON Encoding One (Rec1 f) where
811− -- Recursive occurrences of the last type parameter are encoded using their
812− -- ToEncoding1 instance:
813− gToJSON _opts (To1Args te tel) = liftToEncoding te tel . unRec1
814− {-# INLINE gToJSON #-}
444+instance (ToJSON a) => GToEncoding (K1 i a) where
445+ -- Constant values are encoded using their ToJSON instance:
446+ gToEncoding _opts = toEncoding . unK1
815447
816−instance GToJSON Encoding arity U1 where
448+instance GToEncoding U1 where
817449 -- Empty constructors are encoded to an empty array:
818− gToJSON _opts _ _ = E.emptyArray_
819− {-# INLINE gToJSON #-}
450+ gToEncoding _opts _ = E.emptyArray_
820451
821−instance ( EncodeProduct arity a
822− , EncodeProduct arity b
823− ) => GToJSON Encoding arity (a :*: b)
824− where
452+instance (ConsToEncoding a) => GToEncoding (C1 c a) where
453+ -- Constructors need to be encoded differently depending on whether they're
454+ -- a record or not. This distinction is made by 'consToEncoding':
455+ gToEncoding opts = consToEncoding opts . unM1
456+
457+instance ( EncodeProduct a, EncodeProduct b ) => GToEncoding (a :*: b) where
825458 -- Products are encoded to an array. Here we allocate a mutable vector of
826459 -- the same size as the product and write the product's elements to it using
827460 -- 'encodeProduct':
828− gToJSON opts targs p = E.list E.retagEncoding [encodeProduct opts targs p]
829− {-# INLINE gToJSON #-}
830−
831−instance ( ToJSON1 f
832− , GToJSON Encoding One g
833− ) => GToJSON Encoding One (f :.: g)
834− where
835− -- If an occurrence of the last type parameter is nested inside two
836− -- composed types, it is encoded by using the outermost type's ToJSON1
837− -- instance to generically encode the innermost type:
838− gToJSON opts targs =
839− let gte = gToJSON opts targs in
840− liftToEncoding gte (listEncoding gte) . unComp1
841− {-# INLINE gToJSON #-}
461+ gToEncoding opts p = E.tuple $ encodeProduct opts p
462+
463+instance ( AllNullary (a :+: b) allNullary
464+ , SumToEncoding (a :+: b) allNullary ) => GToEncoding (a :+: b) where
465+ -- If all constructors of a sum datatype are nullary and the
466+ -- 'allNullaryToStringTag' option is set they are encoded to
467+ -- strings. This distinction is made by 'sumToEncoding':
468+ gToEncoding opts
469+ = (unTagged :: Tagged allNullary Encoding -> Encoding)
470+ . sumToEncoding opts
842471
843472--------------------------------------------------------------------------------
844473
845−class SumToJSON enc arity f allNullary where
846− sumToJSON :: Options -> ToArgs enc arity a
847− -> f a -> Tagged allNullary enc
848−
849−instance ( GetConName f
850− , FromString enc
851− , TaggedObject enc arity f
852− , SumToJSON' ObjectWithSingleField enc arity f
853− , SumToJSON' TwoElemArray enc arity f
854− , SumToJSON' UntaggedValue enc arity f
855− ) => SumToJSON enc arity f True
856− where
857− sumToJSON opts targs
858− | allNullaryToStringTag opts = Tagged . fromString
474+class SumToJSON f allNullary where
475+ sumToJSON :: Options -> f a -> Tagged allNullary Value
476+
477+instance ( GetConName f
478+ , TaggedObjectPairs f
479+ , ObjectWithSingleFieldObj f
480+ , TwoElemArrayObj f ) => SumToJSON f True where
481+ sumToJSON opts
482+ | allNullaryToStringTag opts = Tagged . String . pack
859483 . constructorTagModifier opts . getConName
860− | otherwise = Tagged . nonAllNullarySumToJSON opts targs
861−
862−instance ( TaggedObject enc arity f
863− , SumToJSON' ObjectWithSingleField enc arity f
864− , SumToJSON' TwoElemArray enc arity f
865− , SumToJSON' UntaggedValue enc arity f
866− ) => SumToJSON enc arity f False
867− where
868− sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs
869−
870−nonAllNullarySumToJSON :: ( TaggedObject enc arity f
871− , SumToJSON' ObjectWithSingleField enc arity f
872− , SumToJSON' TwoElemArray enc arity f
873− , SumToJSON' UntaggedValue enc arity f
874− ) => Options -> ToArgs enc arity a
875− -> f a -> enc
876−nonAllNullarySumToJSON opts targs =
484+ | otherwise = Tagged . nonAllNullarySumToJSON opts
485+
486+instance ( TwoElemArrayObj f
487+ , TaggedObjectPairs f
488+ , ObjectWithSingleFieldObj f ) => SumToJSON f False where
489+ sumToJSON opts = Tagged . nonAllNullarySumToJSON opts
490+
491+nonAllNullarySumToJSON :: ( TwoElemArrayObj f
492+ , TaggedObjectPairs f
493+ , ObjectWithSingleFieldObj f
494+ ) => Options -> f a -> Value
495+nonAllNullarySumToJSON opts =
877496 case sumEncoding opts of
497+ TaggedObject{..} ->
498+ object . taggedObjectPairs opts tagFieldName contentsFieldName
499+ ObjectWithSingleField -> Object . objectWithSingleFieldObj opts
500+ TwoElemArray -> Array . twoElemArrayObj opts
501+
502+--------------------------------------------------------------------------------
878503
504+class SumToEncoding f allNullary where
505+ sumToEncoding :: Options -> f a -> Tagged allNullary Encoding
506+
507+instance ( GetConName f
508+ , TaggedObjectEnc f
509+ , ObjectWithSingleFieldEnc f
510+ , TwoElemArrayEnc f ) => SumToEncoding f True where
511+ sumToEncoding opts
512+ | allNullaryToStringTag opts = Tagged . toEncoding .
513+ constructorTagModifier opts . getConName
514+ | otherwise = Tagged . nonAllNullarySumToEncoding opts
515+
516+instance ( TwoElemArrayEnc f
517+ , TaggedObjectEnc f
518+ , ObjectWithSingleFieldEnc f ) => SumToEncoding f False where
519+ sumToEncoding opts = Tagged . nonAllNullarySumToEncoding opts
520+
521+nonAllNullarySumToEncoding :: ( TwoElemArrayEnc f
522+ , TaggedObjectEnc f
523+ , ObjectWithSingleFieldEnc f
524+ ) => Options -> f a -> Encoding
525+nonAllNullarySumToEncoding opts =
526+ case sumEncoding opts of
879527 TaggedObject{..} ->
880− taggedObject opts targs tagFieldName contentsFieldName
528+ taggedObjectEnc opts tagFieldName contentsFieldName
529+ ObjectWithSingleField -> objectWithSingleFieldEnc opts
530+ TwoElemArray -> twoElemArrayEnc opts
531+
532+--------------------------------------------------------------------------------
881533
882− ObjectWithSingleField ->
883− (unTagged :: Tagged ObjectWithSingleField enc -> enc)
884− . sumToJSON' opts targs
534+class TaggedObjectPairs f where
535+ taggedObjectPairs :: Options -> String -> String -> f a -> [Pair]
885536
886− TwoElemArray ->
887− (unTagged :: Tagged TwoElemArray enc -> enc)
888− . sumToJSON' opts targs
537+instance ( TaggedObjectPairs a
538+ , TaggedObjectPairs b ) => TaggedObjectPairs (a :+: b) where
539+ taggedObjectPairs opts tagFieldName contentsFieldName (L1 x) =
540+ taggedObjectPairs opts tagFieldName contentsFieldName x
541+ taggedObjectPairs opts tagFieldName contentsFieldName (R1 x) =
542+ taggedObjectPairs opts tagFieldName contentsFieldName x
889543
890− UntaggedValue ->
891− (unTagged :: Tagged UntaggedValue enc -> enc)
892− . sumToJSON' opts targs
544+instance ( IsRecord a isRecord
545+ , TaggedObjectPairs' a isRecord
546+ , Constructor c ) => TaggedObjectPairs (C1 c a) where
547+ taggedObjectPairs opts tagFieldName contentsFieldName =
548+ (pack tagFieldName .= constructorTagModifier opts
549+ (conName (undefined :: t c a p)) :) .
550+ (unTagged :: Tagged isRecord [Pair] -> [Pair]) .
551+ taggedObjectPairs' opts contentsFieldName . unM1
893552
894−--------------------------------------------------------------------------------
553+class TaggedObjectPairs' f isRecord where
554+ taggedObjectPairs' :: Options -> String -> f a -> Tagged isRecord [Pair]
895555
896−class FromString enc where
897− fromString :: String -> enc
556+instance OVERLAPPING_ TaggedObjectPairs' U1 False where
557+ taggedObjectPairs' _ _ _ = Tagged []
898558
899−instance FromString Encoding where
900− fromString = toEncoding
559+instance (RecordToPairs f) => TaggedObjectPairs' f True where
560+ taggedObjectPairs' opts _ = Tagged . toList . recordToPairs opts
901561
902−instance FromString Value where
903− fromString = String . pack
562+instance (GToJSON f) => TaggedObjectPairs' f False where
563+ taggedObjectPairs' opts contentsFieldName =
564+ Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts
904565
905566--------------------------------------------------------------------------------
906567
907−class TaggedObject enc arity f where
908− taggedObject :: Options -> ToArgs enc arity a
909− -> String -> String
910− -> f a -> enc
911−
912−instance ( TaggedObject enc arity a
913− , TaggedObject enc arity b
914− ) => TaggedObject enc arity (a :+: b)
915− where
916− taggedObject opts targs tagFieldName contentsFieldName (L1 x) =
917− taggedObject opts targs tagFieldName contentsFieldName x
918− taggedObject opts targs tagFieldName contentsFieldName (R1 x) =
919− taggedObject opts targs tagFieldName contentsFieldName x
920−
921−instance ( IsRecord a isRecord
922− , TaggedObject' enc pairs arity a isRecord
923− , FromPairs enc pairs
924− , FromString enc
925− , KeyValuePair enc pairs
926− , Constructor c
927− ) => TaggedObject enc arity (C1 c a)
928− where
929− taggedObject opts targs tagFieldName contentsFieldName =
930− fromPairs . mappend tag . contents
931− where
932− tag = tagFieldName `pair`
933− (fromString (constructorTagModifier opts (conName (undefined :: t c a p)))
934− :: enc)
935− contents =
936− (unTagged :: Tagged isRecord pairs -> pairs) .
937− taggedObject' opts targs contentsFieldName . unM1
938−
939−class TaggedObject' enc pairs arity f isRecord where
940− taggedObject' :: Options -> ToArgs enc arity a
941− -> String -> f a -> Tagged isRecord pairs
942−
943−instance ( GToJSON enc arity f
944− , KeyValuePair enc pairs
945− ) => TaggedObject' enc pairs arity f False
946− where
947− taggedObject' opts targs contentsFieldName =
948− Tagged . (contentsFieldName `pair`) . gToJSON opts targs
949−
950−instance OVERLAPPING_ Monoid pairs => TaggedObject' enc pairs arity U1 False where
951− taggedObject' _ _ _ _ = Tagged mempty
952−
953−instance ( RecordToPairs enc pairs arity f
954− ) => TaggedObject' enc pairs arity f True
955− where
956− taggedObject' opts targs _ = Tagged . recordToPairs opts targs
568+class TaggedObjectEnc f where
569+ taggedObjectEnc :: Options -> String -> String -> f a -> Encoding
570+
571+instance ( TaggedObjectEnc a
572+ , TaggedObjectEnc b ) => TaggedObjectEnc (a :+: b) where
573+ taggedObjectEnc opts tagFieldName contentsFieldName (L1 x) =
574+ taggedObjectEnc opts tagFieldName contentsFieldName x
575+ taggedObjectEnc opts tagFieldName contentsFieldName (R1 x) =
576+ taggedObjectEnc opts tagFieldName contentsFieldName x
577+
578+instance ( IsRecord a isRecord
579+ , TaggedObjectEnc' a isRecord
580+ , Constructor c ) => TaggedObjectEnc (C1 c a) where
581+ taggedObjectEnc opts tagFieldName contentsFieldName v =
582+ E.openCurly <>
583+ (toEncoding tagFieldName <>
584+ E.colon <>
585+ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))) <>
586+ ((unTagged :: Tagged isRecord Encoding -> Encoding) .
587+ taggedObjectEnc' opts contentsFieldName . unM1 $ v) <>
588+ E.closeCurly
589+
590+class TaggedObjectEnc' f isRecord where
591+ taggedObjectEnc' :: Options -> String -> f a -> Tagged isRecord Encoding
592+
593+instance OVERLAPPING_ TaggedObjectEnc' U1 False where
594+ taggedObjectEnc' _ _ _ = Tagged mempty
595+
596+instance (RecordToEncoding f) => TaggedObjectEnc' f True where
597+ taggedObjectEnc' opts _ = Tagged . (E.comma <>) . fst . recordToEncoding opts
598+
599+instance (GToEncoding f) => TaggedObjectEnc' f False where
600+ taggedObjectEnc' opts contentsFieldName =
601+ Tagged . (\z -> E.comma <> toEncoding contentsFieldName <> E.colon <> z) .
602+ gToEncoding opts
957603
958604--------------------------------------------------------------------------------
959605
@@ -968,251 +614,248 @@ instance (GetConName a, GetConName b) => GetConName (a :+: b) where
968614instance (Constructor c) => GetConName (C1 c a) where
969615 getConName = conName
970616
971−-- For genericToJSONKey
972−instance GetConName a => GetConName (D1 d a) where
973− getConName (M1 x) = getConName x
974−
975617--------------------------------------------------------------------------------
976618
977−-- Reflection of SumEncoding variants
619+class TwoElemArrayObj f where
620+ twoElemArrayObj :: Options -> f a -> V.Vector Value
978621
979−data ObjectWithSingleField
980−data TwoElemArray
981−data UntaggedValue
622+instance (TwoElemArrayObj a, TwoElemArrayObj b) => TwoElemArrayObj (a :+: b) where
623+ twoElemArrayObj opts (L1 x) = twoElemArrayObj opts x
624+ twoElemArrayObj opts (R1 x) = twoElemArrayObj opts x
625+
626+instance ( GToJSON a, ConsToJSON a
627+ , Constructor c ) => TwoElemArrayObj (C1 c a) where
628+ twoElemArrayObj opts x = V.create $ do
629+ mv <- VM.unsafeNew 2
630+ VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts
631+ $ conName (undefined :: t c a p)
632+ VM.unsafeWrite mv 1 $ gToJSON opts x
633+ return mv
982634
983635--------------------------------------------------------------------------------
984636
985−class SumToJSON' s enc arity f where
986− sumToJSON' :: Options -> ToArgs enc arity a
987− -> f a -> Tagged s enc
637+class TwoElemArrayEnc f where
638+ twoElemArrayEnc :: Options -> f a -> Encoding
639+
640+instance (TwoElemArrayEnc a, TwoElemArrayEnc b) => TwoElemArrayEnc (a :+: b) where
641+ twoElemArrayEnc opts (L1 x) = twoElemArrayEnc opts x
642+ twoElemArrayEnc opts (R1 x) = twoElemArrayEnc opts x
988643
989−instance ( SumToJSON' s enc arity a
990− , SumToJSON' s enc arity b
991− ) => SumToJSON' s enc arity (a :+: b)
992− where
993− sumToJSON' opts targs (L1 x) = sumToJSON' opts targs x
994− sumToJSON' opts targs (R1 x) = sumToJSON' opts targs x
644+instance ( GToEncoding a, ConsToEncoding a
645+ , Constructor c ) => TwoElemArrayEnc (C1 c a) where
646+ twoElemArrayEnc opts x = E.tuple $
647+ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p))) >*<
648+ gToEncoding opts x
995649
996650--------------------------------------------------------------------------------
997651
998−instance ( GToJSON Value arity a
999− , ConsToJSON Value arity a
1000− , Constructor c
1001− ) => SumToJSON' TwoElemArray Value arity (C1 c a) where
1002− sumToJSON' opts targs x = Tagged $ Array $ V.create $ do
1003− mv <- VM.unsafeNew 2
1004− VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts
1005− $ conName (undefined :: t c a p)
1006− VM.unsafeWrite mv 1 $ gToJSON opts targs x
1007− return mv
652+class ConsToJSON f where
653+ consToJSON :: Options -> f a -> Value
654+
655+class ConsToJSON' f isRecord where
656+ consToJSON' :: Options -> Bool -- ^ Are we a record with one field?
657+ -> f a -> Tagged isRecord Value
658+
659+instance ( IsRecord f isRecord
660+ , ConsToJSON' f isRecord ) => ConsToJSON f where
661+ consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)
662+ . consToJSON' opts (isUnary (undefined :: f a))
663+
664+instance (RecordToPairs f) => ConsToJSON' f True where
665+ consToJSON' opts isUn f = let
666+ vals = toList $ recordToPairs opts f
667+ in case (unwrapUnaryRecords opts,isUn,vals) of
668+ (True,True,[(_,val)]) -> Tagged val
669+ _ -> Tagged $ object vals
670+
671+instance GToJSON f => ConsToJSON' f False where
672+ consToJSON' opts _ = Tagged . gToJSON opts
1008673
1009674--------------------------------------------------------------------------------
1010675
1011−instance ( GToJSON Encoding arity a
1012− , ConsToJSON Encoding arity a
1013− , Constructor c
1014− ) => SumToJSON' TwoElemArray Encoding arity (C1 c a)
1015− where
1016− sumToJSON' opts targs x = Tagged $ E.list id
1017− [ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))
1018− , gToJSON opts targs x
1019− ]
676+class ConsToEncoding f where
677+ consToEncoding :: Options -> f a -> Encoding
678+
679+class ConsToEncoding' f isRecord where
680+ consToEncoding' :: Options -> Bool -- ^ Are we a record with one field?
681+ -> f a -> Tagged isRecord Encoding
682+
683+instance ( IsRecord f isRecord
684+ , ConsToEncoding' f isRecord ) => ConsToEncoding f where
685+ consToEncoding opts = (unTagged :: Tagged isRecord Encoding -> Encoding)
686+ . consToEncoding' opts (isUnary (undefined :: f a))
687+
688+instance (RecordToEncoding f) => ConsToEncoding' f True where
689+ consToEncoding' opts isUn x =
690+ let (enc, mbVal) = recordToEncoding opts x
691+ in case (unwrapUnaryRecords opts, isUn, mbVal) of
692+ (True, True, Just val) -> Tagged val
693+ _ -> Tagged $ E.wrapObject enc
694+
695+instance GToEncoding f => ConsToEncoding' f False where
696+ consToEncoding' opts _ = Tagged . gToEncoding opts
1020697
1021698--------------------------------------------------------------------------------
1022699
1023−class ConsToJSON enc arity f where
1024− consToJSON :: Options -> ToArgs enc arity a
1025− -> f a -> enc
1026−
1027−class ConsToJSON' enc arity f isRecord where
1028− consToJSON' :: Options -> ToArgs enc arity a
1029− -> f a -> Tagged isRecord enc
1030−
1031−instance ( IsRecord f isRecord
1032− , ConsToJSON' enc arity f isRecord
1033− ) => ConsToJSON enc arity f
1034− where
1035− consToJSON opts targs =
1036− (unTagged :: Tagged isRecord enc -> enc)
1037− . consToJSON' opts targs
1038− {-# INLINE consToJSON #-}
1039−
1040−instance OVERLAPPING_
1041− ( RecordToPairs enc pairs arity (S1 s f)
1042− , FromPairs enc pairs
1043− , GToJSON enc arity f
1044− ) => ConsToJSON' enc arity (S1 s f) True
1045− where
1046− consToJSON' opts targs
1047− | unwrapUnaryRecords opts = Tagged . gToJSON opts targs
1048− | otherwise = Tagged . fromPairs . recordToPairs opts targs
1049− {-# INLINE consToJSON' #-}
1050−
1051−instance ( RecordToPairs enc pairs arity f
1052− , FromPairs enc pairs
1053− ) => ConsToJSON' enc arity f True
1054− where
1055− consToJSON' opts targs = Tagged . fromPairs . recordToPairs opts targs
1056− {-# INLINE consToJSON' #-}
1057−
1058−instance GToJSON enc arity f => ConsToJSON' enc arity f False where
1059− consToJSON' opts targs = Tagged . gToJSON opts targs
1060− {-# INLINE consToJSON' #-}
700+class RecordToPairs f where
701+ recordToPairs :: Options -> f a -> DList Pair
702+
703+instance (RecordToPairs a, RecordToPairs b) => RecordToPairs (a :*: b) where
704+ recordToPairs opts (a :*: b) = recordToPairs opts a <>
705+ recordToPairs opts b
706+
707+instance (Selector s, GToJSON a) => RecordToPairs (S1 s a) where
708+ recordToPairs = fieldToPair
709+
710+instance OVERLAPPING_ (Selector s, ToJSON a) =>
711+ RecordToPairs (S1 s (K1 i (Maybe a))) where
712+ recordToPairs opts (M1 k1) | omitNothingFields opts
713+ , K1 Nothing <- k1 = DList.empty
714+ recordToPairs opts m1 = fieldToPair opts m1
715+
716+fieldToPair :: (Selector s, GToJSON a) => Options -> S1 s a p -> DList Pair
717+fieldToPair opts m1 = pure ( pack $ fieldLabelModifier opts $ selName m1
718+ , gToJSON opts (unM1 m1)
719+ )
1061720
1062721--------------------------------------------------------------------------------
1063722
1064−class RecordToPairs enc pairs arity f where
723+class RecordToEncoding f where
1065724 -- 1st element: whole thing
1066725 -- 2nd element: in case the record has only 1 field, just the value
1067726 -- of the field (without the key); 'Nothing' otherwise
1068− recordToPairs :: Options -> ToArgs enc arity a
1069− -> f a -> pairs
1070−
1071−instance ( Monoid pairs
1072− , RecordToPairs enc pairs arity a
1073− , RecordToPairs enc pairs arity b
1074− ) => RecordToPairs enc pairs arity (a :*: b)
1075− where
1076− recordToPairs opts (targs :: ToArgs enc arity p) (a :*: b) =
1077− pairsOf a `mappend` pairsOf b
1078− where
1079− pairsOf :: (RecordToPairs enc pairs arity f) => f p -> pairs
1080− pairsOf = recordToPairs opts targs
1081− {-# INLINE recordToPairs #-}
1082−
1083−instance ( Selector s
1084− , GToJSON enc arity a
1085− , KeyValuePair enc pairs
1086− ) => RecordToPairs enc pairs arity (S1 s a)
1087− where
1088− recordToPairs = fieldToPair
1089− {-# INLINE recordToPairs #-}
1090−
1091−instance INCOHERENT_
1092− ( Selector s
1093− , GToJSON enc arity (K1 i (Maybe a))
1094− , KeyValuePair enc pairs
1095− , Monoid pairs
1096− ) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a)))
1097− where
1098− recordToPairs opts _ (M1 k1) | omitNothingFields opts
1099− , K1 Nothing <- k1 = mempty
1100− recordToPairs opts targs m1 = fieldToPair opts targs m1
1101− {-# INLINE recordToPairs #-}
1102−
1103−instance INCOHERENT_
1104− ( Selector s
1105− , GToJSON enc arity (K1 i (Maybe a))
1106− , KeyValuePair enc pairs
1107− , Monoid pairs
1108− ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))
1109− where
1110− recordToPairs opts targs = recordToPairs opts targs . unwrap
1111− where
1112− unwrap :: S1 s (K1 i (Semigroup.Option a)) p -> S1 s (K1 i (Maybe a)) p
1113− unwrap (M1 (K1 (Semigroup.Option a))) = M1 (K1 a)
1114− {-# INLINE recordToPairs #-}
1115−
1116−fieldToPair :: (Selector s
1117− , GToJSON enc arity a
1118− , KeyValuePair enc pairs)
1119− => Options -> ToArgs enc arity p
1120− -> S1 s a p -> pairs
1121−fieldToPair opts targs m1 =
1122− let key = fieldLabelModifier opts (selName m1)
1123− value = gToJSON opts targs (unM1 m1)
1124− in key `pair` value
1125−{-# INLINE fieldToPair #-}
727+ recordToEncoding :: Options -> f a -> (Encoding, Maybe Encoding)
728+
729+instance (RecordToEncoding a, RecordToEncoding b) => RecordToEncoding (a :*: b) where
730+ recordToEncoding opts (a :*: b) | omitNothingFields opts =
731+ (mconcat $ intersperse E.comma $
732+ filter (not . E.nullEncoding)
733+ [fst (recordToEncoding opts a), fst (recordToEncoding opts b)]
734+ , Nothing)
735+ recordToEncoding opts (a :*: b) =
736+ (fst (recordToEncoding opts a) <> E.comma <>
737+ fst (recordToEncoding opts b),
738+ Nothing)
739+
740+instance (Selector s, GToEncoding a) => RecordToEncoding (S1 s a) where
741+ recordToEncoding = fieldToEncoding
742+
743+instance OVERLAPPING_ (Selector s, ToJSON a) =>
744+ RecordToEncoding (S1 s (K1 i (Maybe a))) where
745+ recordToEncoding opts (M1 k1) | omitNothingFields opts
746+ , K1 Nothing <- k1 = (mempty, Nothing)
747+ recordToEncoding opts m1 = fieldToEncoding opts m1
748+
749+fieldToEncoding :: (Selector s, GToEncoding a) => Options -> S1 s a p -> (Encoding, Maybe Encoding)
750+fieldToEncoding opts m1 =
751+ let keyBuilder = toEncoding (fieldLabelModifier opts $ selName m1)
752+ valueBuilder = gToEncoding opts (unM1 m1)
753+ in (keyBuilder <> E.colon <> valueBuilder, Just valueBuilder)
1126754
1127755--------------------------------------------------------------------------------
1128756
1129−class WriteProduct arity f where
757+class WriteProduct f where
1130758 writeProduct :: Options
1131− -> ToArgs Value arity a
1132759 -> VM.MVector s Value
1133760 -> Int -- ^ index
1134761 -> Int -- ^ length
1135762 -> f a
1136763 -> ST s ()
1137764
1138−instance ( WriteProduct arity a
1139− , WriteProduct arity b
1140− ) => WriteProduct arity (a :*: b) where
1141− writeProduct opts targs mv ix len (a :*: b) = do
1142− writeProduct opts targs mv ix lenL a
1143− writeProduct opts targs mv ixR lenR b
765+instance ( WriteProduct a
766+ , WriteProduct b ) => WriteProduct (a :*: b) where
767+ writeProduct opts mv ix len (a :*: b) = do
768+ writeProduct opts mv ix lenL a
769+ writeProduct opts mv ixR lenR b
1144770 where
1145771 lenL = len `unsafeShiftR` 1
1146772 lenR = len - lenL
1147773 ixR = ix + lenL
1148− {-# INLINE writeProduct #-}
1149774
1150−instance OVERLAPPABLE_ (GToJSON Value arity a) => WriteProduct arity a where
1151− writeProduct opts targs mv ix _ =
1152− VM.unsafeWrite mv ix . gToJSON opts targs
1153− {-# INLINE writeProduct #-}
775+instance OVERLAPPABLE_ (GToJSON a) => WriteProduct a where
776+ writeProduct opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts
1154777
1155778--------------------------------------------------------------------------------
1156779
1157−class EncodeProduct arity f where
1158− encodeProduct :: Options -> ToArgs Encoding arity a
1159− -> f a -> Encoding' E.InArray
780+class EncodeProduct f where
781+ encodeProduct :: Options -> f a -> Encoding
1160782
1161−instance ( EncodeProduct arity a
1162− , EncodeProduct arity b
1163− ) => EncodeProduct arity (a :*: b) where
1164− encodeProduct opts targs (a :*: b) | omitNothingFields opts =
1165− E.econcat $ intersperse E.comma $
783+instance ( EncodeProduct a
784+ , EncodeProduct b ) => EncodeProduct (a :*: b) where
785+ encodeProduct opts (a :*: b) | omitNothingFields opts =
786+ mconcat $ intersperse E.comma $
1166787 filter (not . E.nullEncoding)
1167− [encodeProduct opts targs a, encodeProduct opts targs b]
1168− encodeProduct opts targs (a :*: b) =
1169− encodeProduct opts targs a >*<
1170− encodeProduct opts targs b
1171− {-# INLINE encodeProduct #-}
788+ [encodeProduct opts a, encodeProduct opts b]
789+ encodeProduct opts (a :*: b) = encodeProduct opts a <>
790+ E.comma <>
791+ encodeProduct opts b
1172792
1173−instance OVERLAPPABLE_ (GToJSON Encoding arity a) => EncodeProduct arity a where
1174− encodeProduct opts targs a = E.retagEncoding $ gToJSON opts targs a
1175− {-# INLINE encodeProduct #-}
793+instance OVERLAPPABLE_ (GToEncoding a) => EncodeProduct a where
794+ encodeProduct opts = gToEncoding opts
1176795
1177796--------------------------------------------------------------------------------
1178797
1179−instance ( GToJSON enc arity a
1180− , ConsToJSON enc arity a
1181− , FromPairs enc pairs
1182− , KeyValuePair enc pairs
1183− , Constructor c
1184− ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)
1185− where
1186− sumToJSON' opts targs =
1187− Tagged . fromPairs . (typ `pair`) . gToJSON opts targs
798+class ObjectWithSingleFieldObj f where
799+ objectWithSingleFieldObj :: Options -> f a -> Object
800+
801+instance ( ObjectWithSingleFieldObj a
802+ , ObjectWithSingleFieldObj b ) => ObjectWithSingleFieldObj (a :+: b) where
803+ objectWithSingleFieldObj opts (L1 x) = objectWithSingleFieldObj opts x
804+ objectWithSingleFieldObj opts (R1 x) = objectWithSingleFieldObj opts x
805+
806+instance ( GToJSON a, ConsToJSON a
807+ , Constructor c ) => ObjectWithSingleFieldObj (C1 c a) where
808+ objectWithSingleFieldObj opts = H.singleton typ . gToJSON opts
1188809 where
1189− typ = constructorTagModifier opts $
810+ typ = pack $ constructorTagModifier opts $
1190811 conName (undefined :: t c a p)
1191812
1192813--------------------------------------------------------------------------------
1193814
1194−instance OVERLAPPABLE_
1195− ( ConsToJSON enc arity a
1196− ) => SumToJSON' UntaggedValue enc arity (C1 c a)
1197− where
1198− sumToJSON' opts targs = Tagged . gToJSON opts targs
1199−
1200−instance OVERLAPPING_
1201− ( Constructor c
1202− , FromString enc
1203− ) => SumToJSON' UntaggedValue enc arity (C1 c U1)
1204− where
1205− sumToJSON' opts _ _ = Tagged . fromString $
1206− constructorTagModifier opts $ conName (undefined :: t c U1 p)
815+class ObjectWithSingleFieldEnc f where
816+ objectWithSingleFieldEnc :: Options -> f a -> Encoding
817+
818+instance ( ObjectWithSingleFieldEnc a
819+ , ObjectWithSingleFieldEnc b ) => ObjectWithSingleFieldEnc (a :+: b) where
820+ objectWithSingleFieldEnc opts (L1 x) = objectWithSingleFieldEnc opts x
821+ objectWithSingleFieldEnc opts (R1 x) = objectWithSingleFieldEnc opts x
822+
823+instance ( GToEncoding a, ConsToEncoding a
824+ , Constructor c ) => ObjectWithSingleFieldEnc (C1 c a) where
825+ objectWithSingleFieldEnc opts v =
826+ E.openCurly <>
827+ toEncoding
828+ (constructorTagModifier opts
829+ (conName (undefined :: t c a p))) <>
830+ E.colon <>
831+ gToEncoding opts v <>
832+ E.closeCurly
1207833
1208834-------------------------------------------------------------------------------
1209835-- Instances
1210836-------------------------------------------------------------------------------
1211837
838+
839+
1212840-------------------------------------------------------------------------------
1213841-- base
1214842-------------------------------------------------------------------------------
1215843
844+instance ToJSON1 Identity where
845+ liftToJSON t _ (Identity a) = t a
846+ {-# INLINE liftToJSON #-}
847+
848+ liftToEncoding t _ (Identity a) = t a
849+ {-# INLINE liftToEncoding #-}
850+
851+instance (ToJSON a) => ToJSON (Identity a) where
852+ toJSON = toJSON1
853+ {-# INLINE toJSON #-}
854+
855+ toEncoding = toEncoding1
856+ {-# INLINE toEncoding #-}
857+
858+
1216859instance ToJSON2 Const where
1217860 liftToJSON2 t _ _ _ (Const x) = t x
1218861 {-# INLINE liftToJSON2 #-}
@@ -1241,7 +884,7 @@ instance ToJSON1 Maybe where
1241884 {-# INLINE liftToJSON #-}
1242885
1243886 liftToEncoding t _ (Just a) = t a
1244− liftToEncoding _ _ Nothing = E.null_
887+ liftToEncoding _ _ Nothing = Encoding EB.null_
1245888 {-# INLINE liftToEncoding #-}
1246889
1247890instance (ToJSON a) => ToJSON (Maybe a) where
@@ -1253,13 +896,19 @@ instance (ToJSON a) => ToJSON (Maybe a) where
1253896
1254897
1255898instance ToJSON2 Either where
1256− liftToJSON2 toA _ _toB _ (Left a) = Object $ H.singleton "Left" (toA a)
1257− liftToJSON2 _toA _ toB _ (Right b) = Object $ H.singleton "Right" (toB b)
899+ liftToJSON2 toA _ _toB _ (Left a) = Object $ H.singleton left (toA a)
900+ liftToJSON2 _toA _ toB _ (Right b) = Object $ H.singleton right (toB b)
1258901 {-# INLINE liftToJSON2 #-}
1259902
1260− liftToEncoding2 toA _ _toB _ (Left a) = E.pairs $ E.pair "Left" $ toA a
903+ liftToEncoding2 toA _ _toB _ (Left a) =
904+ Encoding (B.shortByteString "{\"Left\":")
905+ <> toA a
906+ <> Encoding (B.char7 '}')
1261907
1262− liftToEncoding2 _toA _ toB _ (Right b) = E.pairs $ E.pair "Right" $ toB b
908+ liftToEncoding2 _toA _ toB _ (Right b) =
909+ Encoding (B.shortByteString "{\"Right\":")
910+ <> toB b
911+ <> Encoding (B.char7 '}')
1263912 {-# INLINE liftToEncoding2 #-}
1264913
1265914instance (ToJSON a) => ToJSON1 (Either a) where
@@ -1276,24 +925,18 @@ instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
1276925 toEncoding = toEncoding2
1277926 {-# INLINE toEncoding #-}
1278927
1279−instance ToJSON Void where
1280− toJSON = absurd
1281− {-# INLINE toJSON #-}
1282−
1283− toEncoding = absurd
1284− {-# INLINE toEncoding #-}
928+left, right :: Text
929+left = "Left"
930+right = "Right"
1285931
1286932
1287933instance ToJSON Bool where
1288934 toJSON = Bool
1289935 {-# INLINE toJSON #-}
1290936
1291− toEncoding = E.bool
937+ toEncoding = Encoding . EB.bool
1292938 {-# INLINE toEncoding #-}
1293939
1294−instance ToJSONKey Bool where
1295− toJSONKey = toJSONKeyText $ \x -> if x then "true" else "false"
1296−
1297940
1298941instance ToJSON Ordering where
1299942 toJSON = toJSON . orderingToText
@@ -1320,10 +963,10 @@ instance ToJSON Char where
1320963 toJSONList = String . T.pack
1321964 {-# INLINE toJSONList #-}
1322965
1323− toEncoding = E.string . (:[])
966+ toEncoding = Encoding . EB.string . (:[])
1324967 {-# INLINE toEncoding #-}
1325968
1326− toEncodingList = E.string
969+ toEncodingList = Encoding . EB.string
1327970 {-# INLINE toEncodingList #-}
1328971
1329972
@@ -1331,13 +974,9 @@ instance ToJSON Double where
1331974 toJSON = realFloatToJSON
1332975 {-# INLINE toJSON #-}
1333976
1334− toEncoding = E.double
977+ toEncoding = realFloatToEncoding
1335978 {-# INLINE toEncoding #-}
1336979
1337−instance ToJSONKey Double where
1338− toJSONKey = toJSONKeyTextEnc E.doubleText
1339− {-# INLINE toJSONKey #-}
1340−
1341980
1342981instance ToJSON Number where
1343982 toJSON (D d) = toJSON d
@@ -1353,23 +992,20 @@ instance ToJSON Float where
1353992 toJSON = realFloatToJSON
1354993 {-# INLINE toJSON #-}
1355994
1356− toEncoding = E.float
995+ toEncoding = realFloatToEncoding
1357996 {-# INLINE toEncoding #-}
1358997
1359−instance ToJSONKey Float where
1360− toJSONKey = toJSONKeyTextEnc E.floatText
1361− {-# INLINE toJSONKey #-}
1362−
1363998
1364−instance (ToJSON a, Integral a) => ToJSON (Ratio a) where
999+instance ToJSON (Ratio Integer) where
13651000 toJSON r = object [ "numerator" .= numerator r
13661001 , "denominator" .= denominator r
13671002 ]
13681003 {-# INLINE toJSON #-}
13691004
1370− toEncoding r = E.pairs $
1371− "numerator" .= numerator r <>
1372− "denominator" .= denominator r
1005+ toEncoding r = Encoding $
1006+ B.shortByteString "{\"numerator\":" <> builder (numerator r) <>
1007+ B.shortByteString ",\"denominator\":" <> builder (denominator r) <>
1008+ B.char7 '}'
13731009 {-# INLINE toEncoding #-}
13741010
13751011
@@ -1377,37 +1013,24 @@ instance HasResolution a => ToJSON (Fixed a) where
13771013 toJSON = Number . realToFrac
13781014 {-# INLINE toJSON #-}
13791015
1380− toEncoding = E.scientific . realToFrac
1016+ toEncoding = Encoding . EB.number . realToFrac
13811017 {-# INLINE toEncoding #-}
13821018
1383−instance HasResolution a => ToJSONKey (Fixed a) where
1384− toJSONKey = toJSONKeyTextEnc (E.scientificText . realToFrac)
1385− {-# INLINE toJSONKey #-}
1386−
13871019
13881020instance ToJSON Int where
13891021 toJSON = Number . fromIntegral
13901022 {-# INLINE toJSON #-}
13911023
1392− toEncoding = E.int
1024+ toEncoding = Encoding . B.intDec
13931025 {-# INLINE toEncoding #-}
13941026
1395−instance ToJSONKey Int where
1396− toJSONKey = toJSONKeyTextEnc E.intText
1397− {-# INLINE toJSONKey #-}
1398−
1399−
14001027instance ToJSON Integer where
14011028 toJSON = Number . fromInteger
14021029 {-# INLINE toJSON #-}
14031030
1404− toEncoding = E.integer
1031+ toEncoding = Encoding . B.integerDec
14051032 {-# INLINE toEncoding #-}
14061033
1407−instance ToJSONKey Integer where
1408− toJSONKey = toJSONKeyTextEnc E.integerText
1409− {-# INLINE toJSONKey #-}
1410−
14111034
14121035instance ToJSON Natural where
14131036 toJSON = toJSON . toInteger
@@ -1416,147 +1039,93 @@ instance ToJSON Natural where
14161039 toEncoding = toEncoding . toInteger
14171040 {-# INLINE toEncoding #-}
14181041
1419−instance ToJSONKey Natural where
1420− toJSONKey = toJSONKeyTextEnc (E.integerText . toInteger)
1421− {-# INLINE toJSONKey #-}
1422−
14231042
14241043instance ToJSON Int8 where
14251044 toJSON = Number . fromIntegral
14261045 {-# INLINE toJSON #-}
14271046
1428− toEncoding = E.int8
1047+ toEncoding = Encoding . B.int8Dec
14291048 {-# INLINE toEncoding #-}
14301049
1431−instance ToJSONKey Int8 where
1432− toJSONKey = toJSONKeyTextEnc E.int8Text
1433− {-# INLINE toJSONKey #-}
1434−
14351050
14361051instance ToJSON Int16 where
14371052 toJSON = Number . fromIntegral
14381053 {-# INLINE toJSON #-}
14391054
1440− toEncoding = E.int16
1055+ toEncoding = Encoding . B.int16Dec
14411056 {-# INLINE toEncoding #-}
14421057
1443−instance ToJSONKey Int16 where
1444− toJSONKey = toJSONKeyTextEnc E.int16Text
1445− {-# INLINE toJSONKey #-}
1446−
14471058
14481059instance ToJSON Int32 where
14491060 toJSON = Number . fromIntegral
14501061 {-# INLINE toJSON #-}
14511062
1452− toEncoding = E.int32
1063+ toEncoding = Encoding . B.int32Dec
14531064 {-# INLINE toEncoding #-}
14541065
1455−instance ToJSONKey Int32 where
1456− toJSONKey = toJSONKeyTextEnc E.int32Text
1457− {-# INLINE toJSONKey #-}
1458−
14591066
14601067instance ToJSON Int64 where
14611068 toJSON = Number . fromIntegral
14621069 {-# INLINE toJSON #-}
14631070
1464− toEncoding = E.int64
1071+ toEncoding = Encoding . B.int64Dec
14651072 {-# INLINE toEncoding #-}
14661073
1467−instance ToJSONKey Int64 where
1468− toJSONKey = toJSONKeyTextEnc E.int64Text
1469− {-# INLINE toJSONKey #-}
14701074
14711075instance ToJSON Word where
14721076 toJSON = Number . fromIntegral
14731077 {-# INLINE toJSON #-}
14741078
1475− toEncoding = E.word
1079+ toEncoding = Encoding . B.wordDec
14761080 {-# INLINE toEncoding #-}
14771081
1478−instance ToJSONKey Word where
1479− toJSONKey = toJSONKeyTextEnc E.wordText
1480− {-# INLINE toJSONKey #-}
1481−
14821082
14831083instance ToJSON Word8 where
14841084 toJSON = Number . fromIntegral
14851085 {-# INLINE toJSON #-}
14861086
1487− toEncoding = E.word8
1087+ toEncoding = Encoding . B.word8Dec
14881088 {-# INLINE toEncoding #-}
14891089
1490−instance ToJSONKey Word8 where
1491− toJSONKey = toJSONKeyTextEnc E.word8Text
1492− {-# INLINE toJSONKey #-}
1493−
14941090
14951091instance ToJSON Word16 where
14961092 toJSON = Number . fromIntegral
14971093 {-# INLINE toJSON #-}
14981094
1499− toEncoding = E.word16
1095+ toEncoding = Encoding . B.word16Dec
15001096 {-# INLINE toEncoding #-}
15011097
1502−instance ToJSONKey Word16 where
1503− toJSONKey = toJSONKeyTextEnc E.word16Text
1504− {-# INLINE toJSONKey #-}
1505−
15061098
15071099instance ToJSON Word32 where
15081100 toJSON = Number . fromIntegral
15091101 {-# INLINE toJSON #-}
15101102
1511− toEncoding = E.word32
1103+ toEncoding = Encoding . B.word32Dec
15121104 {-# INLINE toEncoding #-}
15131105
1514−instance ToJSONKey Word32 where
1515− toJSONKey = toJSONKeyTextEnc E.word32Text
1516− {-# INLINE toJSONKey #-}
1517−
1518−
15191106instance ToJSON Word64 where
15201107 toJSON = Number . fromIntegral
15211108 {-# INLINE toJSON #-}
15221109
1523− toEncoding = E.word64
1524− {-# INLINE toEncoding #-}
1525−
1526−instance ToJSONKey Word64 where
1527− toJSONKey = toJSONKeyTextEnc E.word64Text
1528− {-# INLINE toJSONKey #-}
1529−
1530−instance ToJSON CTime where
1531− toJSON (CTime i) = toJSON i
1532− {-# INLINE toJSON #-}
1533−
1534− toEncoding (CTime i) = toEncoding i
1110+ toEncoding = Encoding . B.word64Dec
15351111 {-# INLINE toEncoding #-}
15361112
15371113instance ToJSON Text where
15381114 toJSON = String
15391115 {-# INLINE toJSON #-}
15401116
1541− toEncoding = E.text
1117+ toEncoding = Encoding . EB.text
15421118 {-# INLINE toEncoding #-}
15431119
1544−instance ToJSONKey Text where
1545− toJSONKey = toJSONKeyText id
1546− {-# INLINE toJSONKey #-}
1547−
1548−
15491120instance ToJSON LT.Text where
15501121 toJSON = String . LT.toStrict
15511122 {-# INLINE toJSON #-}
15521123
1553− toEncoding = E.lazyText
1124+ toEncoding t = Encoding $
1125+ B.char7 '"' <>
1126+ LT.foldrChunks (\x xs -> EB.unquoted x <> xs) (B.char7 '"') t
15541127 {-# INLINE toEncoding #-}
15551128
1556−instance ToJSONKey LT.Text where
1557− toJSONKey = toJSONKeyText LT.toStrict
1558−
1559−
15601129instance ToJSON Version where
15611130 toJSON = toJSON . showVersion
15621131 {-# INLINE toJSON #-}
@@ -1564,8 +1133,6 @@ instance ToJSON Version where
15641133 toEncoding = toEncoding . showVersion
15651134 {-# INLINE toEncoding #-}
15661135
1567−instance ToJSONKey Version where
1568− toJSONKey = toJSONKeyText (T.pack . showVersion)
15691136
15701137-------------------------------------------------------------------------------
15711138-- semigroups NonEmpty
@@ -1593,138 +1160,7 @@ instance ToJSON Scientific where
15931160 toJSON = Number
15941161 {-# INLINE toJSON #-}
15951162
1596− toEncoding = E.scientific
1597− {-# INLINE toEncoding #-}
1598−
1599−instance ToJSONKey Scientific where
1600− toJSONKey = toJSONKeyTextEnc E.scientificText
1601−
1602−-------------------------------------------------------------------------------
1603−-- DList
1604−-------------------------------------------------------------------------------
1605−
1606−instance ToJSON1 DList.DList where
1607− liftToJSON t _ = listValue t . toList
1608− {-# INLINE liftToJSON #-}
1609−
1610− liftToEncoding t _ = listEncoding t . toList
1611− {-# INLINE liftToEncoding #-}
1612−
1613−instance (ToJSON a) => ToJSON (DList.DList a) where
1614− toJSON = toJSON1
1615− {-# INLINE toJSON #-}
1616−
1617− toEncoding = toEncoding1
1618− {-# INLINE toEncoding #-}
1619−
1620−-------------------------------------------------------------------------------
1621−-- transformers - Functors
1622−-------------------------------------------------------------------------------
1623−
1624−instance ToJSON1 Identity where
1625− liftToJSON t _ (Identity a) = t a
1626− {-# INLINE liftToJSON #-}
1627−
1628− liftToJSONList _ tl xs = tl (map runIdentity xs)
1629− {-# INLINE liftToJSONList #-}
1630−
1631− liftToEncoding t _ (Identity a) = t a
1632− {-# INLINE liftToEncoding #-}
1633−
1634− liftToEncodingList _ tl xs = tl (map runIdentity xs)
1635− {-# INLINE liftToEncodingList #-}
1636−
1637−instance (ToJSON a) => ToJSON (Identity a) where
1638− toJSON = toJSON1
1639− {-# INLINE toJSON #-}
1640−
1641− toJSONList = liftToJSONList toJSON toJSONList
1642− {-# INLINE toJSONList #-}
1643−
1644− toEncoding = toEncoding1
1645− {-# INLINE toEncoding #-}
1646−
1647− toEncodingList = liftToEncodingList toEncoding toEncodingList
1648− {-# INLINE toEncodingList #-}
1649−
1650−instance (ToJSONKey a) => ToJSONKey (Identity a) where
1651− toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey
1652− toJSONKeyList = contramapToJSONKeyFunction (map runIdentity) toJSONKeyList
1653−
1654−
1655−instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where
1656− liftToJSON tv tvl (Compose x) = liftToJSON g gl x
1657− where
1658− g = liftToJSON tv tvl
1659− gl = liftToJSONList tv tvl
1660− {-# INLINE liftToJSON #-}
1661−
1662− liftToJSONList te tel xs = liftToJSONList g gl (map getCompose xs)
1663− where
1664− g = liftToJSON te tel
1665− gl = liftToJSONList te tel
1666− {-# INLINE liftToJSONList #-}
1667−
1668− liftToEncoding te tel (Compose x) = liftToEncoding g gl x
1669− where
1670− g = liftToEncoding te tel
1671− gl = liftToEncodingList te tel
1672− {-# INLINE liftToEncoding #-}
1673−
1674− liftToEncodingList te tel xs = liftToEncodingList g gl (map getCompose xs)
1675− where
1676− g = liftToEncoding te tel
1677− gl = liftToEncodingList te tel
1678− {-# INLINE liftToEncodingList #-}
1679−
1680−instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Compose f g a) where
1681− toJSON = toJSON1
1682− {-# INLINE toJSON #-}
1683−
1684− toJSONList = liftToJSONList toJSON toJSONList
1685− {-# INLINE toJSONList #-}
1686−
1687− toEncoding = toEncoding1
1688− {-# INLINE toEncoding #-}
1689−
1690− toEncodingList = liftToEncodingList toEncoding toEncodingList
1691− {-# INLINE toEncodingList #-}
1692−
1693−
1694−instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Product f g) where
1695− liftToJSON tv tvl (Pair x y) = liftToJSON2 tx txl ty tyl (x, y)
1696− where
1697− tx = liftToJSON tv tvl
1698− txl = liftToJSONList tv tvl
1699− ty = liftToJSON tv tvl
1700− tyl = liftToJSONList tv tvl
1701−
1702− liftToEncoding te tel (Pair x y) = liftToEncoding2 tx txl ty tyl (x, y)
1703− where
1704− tx = liftToEncoding te tel
1705− txl = liftToEncodingList te tel
1706− ty = liftToEncoding te tel
1707− tyl = liftToEncodingList te tel
1708−
1709−instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Product f g a) where
1710− toJSON = toJSON1
1711− {-# INLINE toJSON #-}
1712−
1713− toEncoding = toEncoding1
1714− {-# INLINE toEncoding #-}
1715−
1716−instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Sum f g) where
1717− liftToJSON tv tvl (InL x) = Object $ H.singleton "InL" (liftToJSON tv tvl x)
1718− liftToJSON tv tvl (InR y) = Object $ H.singleton "InR" (liftToJSON tv tvl y)
1719−
1720− liftToEncoding te tel (InL x) = E.pairs $ E.pair "InL" $ liftToEncoding te tel x
1721− liftToEncoding te tel (InR y) = E.pairs $ E.pair "InR" $ liftToEncoding te tel y
1722−
1723−instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Sum f g a) where
1724− toJSON = toJSON1
1725− {-# INLINE toJSON #-}
1726−
1727− toEncoding = toEncoding1
1163+ toEncoding = Encoding . EB.number
17281164 {-# INLINE toEncoding #-}
17291165
17301166-------------------------------------------------------------------------------
@@ -1792,15 +1228,17 @@ instance ToJSON a => ToJSON (IntMap.IntMap a) where
17921228
17931229instance ToJSONKey k => ToJSON1 (M.Map k) where
17941230 liftToJSON g _ = case toJSONKey of
1795− ToJSONKeyText f _ -> Object . mapHashKeyVal f g
1796− ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . M.toList
1231+ ToJSONKeyText (f,_) -> Object . mapHashKeyVal f g
1232+ ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . M.toList
17971233 {-# INLINE liftToJSON #-}
17981234
1235+ -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding
17991236 liftToEncoding g _ = case toJSONKey of
1800− ToJSONKeyText _ f -> dict f g M.foldrWithKey
1801− ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . M.toList
1237+ ToJSONKeyText (_,f) -> dict f g M.foldrWithKey
1238+ ToJSONKeyValue (_,f) -> listEncoding (pairEncoding f) . M.toList
18021239 where
1803− pairEncoding f (a, b) = E.list id [f a, g b]
1240+ -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
1241+ pairEncoding f (a, b) = tuple $ f a >*< g b
18041242 {-# INLINE liftToEncoding #-}
18051243
18061244
@@ -1838,17 +1276,6 @@ instance (ToJSON v) => ToJSON (Tree.Tree v) where
18381276 toEncoding = toEncoding1
18391277 {-# INLINE toEncoding #-}
18401278
1841−-------------------------------------------------------------------------------
1842−-- uuid
1843−-------------------------------------------------------------------------------
1844−
1845−instance ToJSON UUID.UUID where
1846− toJSON = toJSON . UUID.toText
1847− toEncoding = E.unsafeToEncoding . EB.quote . B.byteString . UUID.toASCIIBytes
1848−
1849−instance ToJSONKey UUID.UUID where
1850− toJSONKey = ToJSONKeyText UUID.toText $
1851− E.unsafeToEncoding . EB.quote . B.byteString . UUID.toASCIIBytes
18521279
18531280-------------------------------------------------------------------------------
18541281-- vector
@@ -1858,20 +1285,29 @@ instance ToJSON1 Vector where
18581285 liftToJSON t _ = Array . V.map t
18591286 {-# INLINE liftToJSON #-}
18601287
1861− liftToEncoding t _ = listEncoding t . V.toList
1288+ liftToEncoding t _ xs
1289+ | V.null xs = emptyArray_
1290+ | otherwise = Encoding $
1291+ B.char7 '[' <> fromEncoding (t (V.unsafeHead xs)) <>
1292+ V.foldr go (B.char7 ']') (V.unsafeTail xs)
1293+ where
1294+ go v b = B.char7 ',' <> fromEncoding (t v) <> b
18621295 {-# INLINE liftToEncoding #-}
18631296
18641297instance (ToJSON a) => ToJSON (Vector a) where
1865− {-# SPECIALIZE instance ToJSON Array #-}
1866−
1867− toJSON = toJSON1
1298+ toJSON = Array . V.map toJSON
18681299 {-# INLINE toJSON #-}
18691300
1870− toEncoding = toEncoding1
1301+ toEncoding = encodeVector
18711302 {-# INLINE toEncoding #-}
18721303
18731304encodeVector :: (ToJSON a, VG.Vector v a) => v a -> Encoding
1874−encodeVector = listEncoding toEncoding . VG.toList
1305+encodeVector xs
1306+ | VG.null xs = emptyArray_
1307+ | otherwise = Encoding $
1308+ B.char7 '[' <> builder (VG.unsafeHead xs) <>
1309+ VG.foldr go (B.char7 ']') (VG.unsafeTail xs)
1310+ where go v b = B.char7 ',' <> builder v <> b
18751311{-# INLINE encodeVector #-}
18761312
18771313vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
@@ -1922,21 +1358,20 @@ instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
19221358
19231359instance ToJSONKey k => ToJSON1 (H.HashMap k) where
19241360 liftToJSON g _ = case toJSONKey of
1925− ToJSONKeyText f _ -> Object . mapKeyVal f g
1926− ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . H.toList
1361+ ToJSONKeyText (f,_) -> Object . mapKeyVal f g
1362+ ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . H.toList
19271363 {-# INLINE liftToJSON #-}
19281364
19291365 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding
19301366 liftToEncoding g _ = case toJSONKey of
1931− ToJSONKeyText _ f -> dict f g H.foldrWithKey
1932− ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . H.toList
1367+ ToJSONKeyText (_,f) -> dict f g H.foldrWithKey
1368+ ToJSONKeyValue (_,f) -> listEncoding (pairEncoding f) . H.toList
19331369 where
1934− pairEncoding f (a, b) = E.list id [f a, g b]
1370+ -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
1371+ pairEncoding f (a, b) = tuple $ f a >*< g b
19351372 {-# INLINE liftToEncoding #-}
19361373
19371374instance (ToJSON v, ToJSONKey k) => ToJSON (H.HashMap k v) where
1938− {-# SPECIALIZE instance ToJSON Object #-}
1939−
19401375 toJSON = toJSON1
19411376 {-# INLINE toJSON #-}
19421377
@@ -1951,7 +1386,7 @@ instance ToJSON Value where
19511386 toJSON a = a
19521387 {-# INLINE toJSON #-}
19531388
1954− toEncoding = E.value
1389+ toEncoding = Encoding . EB.encodeToBuilder
19551390 {-# INLINE toEncoding #-}
19561391
19571392instance ToJSON DotNetTime where
@@ -1963,159 +1398,69 @@ dotNetTime :: DotNetTime -> String
19631398dotNetTime (DotNetTime t) = secs ++ formatMillis t ++ ")/"
19641399 where secs = formatTime defaultTimeLocale "/Date(%s" t
19651400
1966−formatMillis :: (FormatTime t) => t -> String
1967−formatMillis = take 3 . formatTime defaultTimeLocale "%q"
1968−
1969−-------------------------------------------------------------------------------
1970−-- primitive
1971−-------------------------------------------------------------------------------
1972−
1973−instance ToJSON a => ToJSON (PM.Array a) where
1974− -- note: we could do better than this if vector exposed the data
1975− -- constructor in Data.Vector.
1976− toJSON = toJSON . Exts.toList
1977− toEncoding = toEncoding . Exts.toList
1978−
1979−instance ToJSON a => ToJSON (PM.SmallArray a) where
1980− toJSON = toJSON . Exts.toList
1981− toEncoding = toEncoding . Exts.toList
1982−
1983−#if (MIN_VERSION_primitive(0,6,4))
1984−instance (PM.Prim a,ToJSON a) => ToJSON (PM.PrimArray a) where
1985− toJSON = toJSON . Exts.toList
1986− toEncoding = toEncoding . Exts.toList
1987−
1988−#if !MIN_VERSION_primitive(0,7,0)
1989−instance (PM.PrimUnlifted a,ToJSON a) => ToJSON (PM.UnliftedArray a) where
1990− toJSON = toJSON . Exts.toList
1991− toEncoding = toEncoding . Exts.toList
1992−#endif
1993−#endif
1994−
19951401-------------------------------------------------------------------------------
19961402-- time
19971403-------------------------------------------------------------------------------
19981404
19991405instance ToJSON Day where
2000− toJSON = stringEncoding . E.day
2001− toEncoding = E.day
2002−
2003−instance ToJSONKey Day where
2004− toJSONKey = toJSONKeyTextEnc E.day
1406+ toJSON = stringEncoding
1407+ toEncoding z = Encoding (EB.quote $ EB.day z)
20051408
20061409
20071410instance ToJSON TimeOfDay where
2008− toJSON = stringEncoding . E.timeOfDay
2009− toEncoding = E.timeOfDay
2010−
2011−instance ToJSONKey TimeOfDay where
2012− toJSONKey = toJSONKeyTextEnc E.timeOfDay
1411+ toJSON = stringEncoding
1412+ toEncoding z = Encoding (EB.quote $ EB.timeOfDay z)
20131413
20141414
20151415instance ToJSON LocalTime where
2016− toJSON = stringEncoding . E.localTime
2017− toEncoding = E.localTime
2018−
2019−instance ToJSONKey LocalTime where
2020− toJSONKey = toJSONKeyTextEnc E.localTime
2021−
1416+ toJSON = stringEncoding
1417+ toEncoding z = Encoding (EB.quote $ EB.localTime z)
20221418
20231419instance ToJSON ZonedTime where
2024− toJSON = stringEncoding . E.zonedTime
2025− toEncoding = E.zonedTime
1420+ toJSON = stringEncoding
20261421
2027−instance ToJSONKey ZonedTime where
2028− toJSONKey = toJSONKeyTextEnc E.zonedTime
1422+ toEncoding z = Encoding (EB.quote $ EB.zonedTime z)
20291423
1424+formatMillis :: (FormatTime t) => t -> String
1425+formatMillis = take 3 . formatTime defaultTimeLocale "%q"
20301426
20311427instance ToJSON UTCTime where
2032− toJSON = stringEncoding . E.utcTime
2033− toEncoding = E.utcTime
1428+ toJSON = stringEncoding
20341429
2035−instance ToJSONKey UTCTime where
2036− toJSONKey = toJSONKeyTextEnc E.utcTime
1430+ toEncoding t = Encoding (EB.quote $ EB.utcTime t)
20371431
20381432-- | Encode something t a JSON string.
2039−stringEncoding :: Encoding' Text -> Value
1433+--
1434+-- TODO: remove me, this is a hack
1435+stringEncoding :: (ToJSON a) => a -> Value
20401436stringEncoding = String
20411437 . T.dropAround (== '"')
20421438 . T.decodeLatin1
20431439 . L.toStrict
2044− . E.encodingToLazyByteString
1440+ . B.toLazyByteString
1441+ . fromEncoding
1442+ . toEncoding
20451443{-# INLINE stringEncoding #-}
20461444
2047−
20481445instance ToJSON NominalDiffTime where
20491446 toJSON = Number . realToFrac
20501447 {-# INLINE toJSON #-}
20511448
2052− toEncoding = E.scientific . realToFrac
1449+ toEncoding = Encoding . EB.number . realToFrac
20531450 {-# INLINE toEncoding #-}
20541451
2055−
2056−instance ToJSON DiffTime where
2057− toJSON = Number . realToFrac
2058− {-# INLINE toJSON #-}
2059−
2060− toEncoding = E.scientific . realToFrac
2061− {-# INLINE toEncoding #-}
2062−
2063−-- | Encoded as number
2064−instance ToJSON SystemTime where
2065− toJSON (MkSystemTime secs nsecs) =
2066− toJSON (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)
2067− toEncoding (MkSystemTime secs nsecs) =
2068− toEncoding (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)
2069−
2070−instance ToJSON CalendarDiffTime where
2071− toJSON (CalendarDiffTime m nt) = object
2072− [ "months" .= m
2073− , "time" .= nt
2074− ]
2075− toEncoding (CalendarDiffTime m nt) = E.pairs
2076− ("months" .= m <> "time" .= nt)
2077−
2078−instance ToJSON CalendarDiffDays where
2079− toJSON (CalendarDiffDays m d) = object
2080− [ "months" .= m
2081− , "days" .= d
2082− ]
2083− toEncoding (CalendarDiffDays m d) = E.pairs
2084− ("months" .= m <> "days" .= d)
2085−
2086−instance ToJSON DayOfWeek where
2087− toJSON Monday = "monday"
2088− toJSON Tuesday = "tuesday"
2089− toJSON Wednesday = "wednesday"
2090− toJSON Thursday = "thursday"
2091− toJSON Friday = "friday"
2092− toJSON Saturday = "saturday"
2093− toJSON Sunday = "sunday"
2094−
2095−toEncodingDayOfWeek :: DayOfWeek -> E.Encoding' Text
2096−toEncodingDayOfWeek Monday = E.unsafeToEncoding "\"monday\""
2097−toEncodingDayOfWeek Tuesday = E.unsafeToEncoding "\"tuesday\""
2098−toEncodingDayOfWeek Wednesday = E.unsafeToEncoding "\"wednesday\""
2099−toEncodingDayOfWeek Thursday = E.unsafeToEncoding "\"thursday\""
2100−toEncodingDayOfWeek Friday = E.unsafeToEncoding "\"friday\""
2101−toEncodingDayOfWeek Saturday = E.unsafeToEncoding "\"saturday\""
2102−toEncodingDayOfWeek Sunday = E.unsafeToEncoding "\"sunday\""
2103−
2104−instance ToJSONKey DayOfWeek where
2105− toJSONKey = toJSONKeyTextEnc toEncodingDayOfWeek
2106−
21071452-------------------------------------------------------------------------------
21081453-- base Monoid/Semigroup
21091454-------------------------------------------------------------------------------
21101455
2111−instance ToJSON1 Monoid.Dual where
2112− liftToJSON t _ = t . Monoid.getDual
1456+instance ToJSON1 Dual where
1457+ liftToJSON t _ = t . getDual
21131458 {-# INLINE liftToJSON #-}
21141459
2115− liftToEncoding t _ = t . Monoid.getDual
1460+ liftToEncoding t _ = t . getDual
21161461 {-# INLINE liftToEncoding #-}
21171462
2118−instance ToJSON a => ToJSON (Monoid.Dual a) where
1463+instance ToJSON a => ToJSON (Dual a) where
21191464 toJSON = toJSON1
21201465 {-# INLINE toJSON #-}
21211466
@@ -2123,14 +1468,14 @@ instance ToJSON a => ToJSON (Monoid.Dual a) where
21231468 {-# INLINE toEncoding #-}
21241469
21251470
2126−instance ToJSON1 Monoid.First where
2127− liftToJSON t to' = liftToJSON t to' . Monoid.getFirst
1471+instance ToJSON1 First where
1472+ liftToJSON t to' = liftToJSON t to' . getFirst
21281473 {-# INLINE liftToJSON #-}
21291474
2130− liftToEncoding t to' = liftToEncoding t to' . Monoid.getFirst
1475+ liftToEncoding t to' = liftToEncoding t to' . getFirst
21311476 {-# INLINE liftToEncoding #-}
21321477
2133−instance ToJSON a => ToJSON (Monoid.First a) where
1478+instance ToJSON a => ToJSON (First a) where
21341479 toJSON = toJSON1
21351480 {-# INLINE toJSON #-}
21361481
@@ -2138,103 +1483,14 @@ instance ToJSON a => ToJSON (Monoid.First a) where
21381483 {-# INLINE toEncoding #-}
21391484
21401485
2141−instance ToJSON1 Monoid.Last where
2142− liftToJSON t to' = liftToJSON t to' . Monoid.getLast
1486+instance ToJSON1 Last where
1487+ liftToJSON t to' = liftToJSON t to' . getLast
21431488 {-# INLINE liftToJSON #-}
21441489
2145− liftToEncoding t to' = liftToEncoding t to' . Monoid.getLast
1490+ liftToEncoding t to' = liftToEncoding t to' . getLast
21461491 {-# INLINE liftToEncoding #-}
21471492
2148−instance ToJSON a => ToJSON (Monoid.Last a) where
2149− toJSON = toJSON1
2150− {-# INLINE toJSON #-}
2151−
2152− toEncoding = toEncoding1
2153− {-# INLINE toEncoding #-}
2154−
2155−
2156−instance ToJSON1 Semigroup.Min where
2157− liftToJSON t _ (Semigroup.Min x) = t x
2158− {-# INLINE liftToJSON #-}
2159−
2160− liftToEncoding t _ (Semigroup.Min x) = t x
2161− {-# INLINE liftToEncoding #-}
2162−
2163−instance ToJSON a => ToJSON (Semigroup.Min a) where
2164− toJSON = toJSON1
2165− {-# INLINE toJSON #-}
2166−
2167− toEncoding = toEncoding1
2168− {-# INLINE toEncoding #-}
2169−
2170−
2171−instance ToJSON1 Semigroup.Max where
2172− liftToJSON t _ (Semigroup.Max x) = t x
2173− {-# INLINE liftToJSON #-}
2174−
2175− liftToEncoding t _ (Semigroup.Max x) = t x
2176− {-# INLINE liftToEncoding #-}
2177−
2178−instance ToJSON a => ToJSON (Semigroup.Max a) where
2179− toJSON = toJSON1
2180− {-# INLINE toJSON #-}
2181−
2182− toEncoding = toEncoding1
2183− {-# INLINE toEncoding #-}
2184−
2185−instance ToJSON1 Semigroup.First where
2186− liftToJSON t _ (Semigroup.First x) = t x
2187− {-# INLINE liftToJSON #-}
2188−
2189− liftToEncoding t _ (Semigroup.First x) = t x
2190− {-# INLINE liftToEncoding #-}
2191−
2192−instance ToJSON a => ToJSON (Semigroup.First a) where
2193− toJSON = toJSON1
2194− {-# INLINE toJSON #-}
2195−
2196− toEncoding = toEncoding1
2197− {-# INLINE toEncoding #-}
2198−
2199−
2200−instance ToJSON1 Semigroup.Last where
2201− liftToJSON t _ (Semigroup.Last x) = t x
2202− {-# INLINE liftToJSON #-}
2203−
2204− liftToEncoding t _ (Semigroup.Last x) = t x
2205− {-# INLINE liftToEncoding #-}
2206−
2207−instance ToJSON a => ToJSON (Semigroup.Last a) where
2208− toJSON = toJSON1
2209− {-# INLINE toJSON #-}
2210−
2211− toEncoding = toEncoding1
2212− {-# INLINE toEncoding #-}
2213−
2214−
2215−instance ToJSON1 Semigroup.WrappedMonoid where
2216− liftToJSON t _ (Semigroup.WrapMonoid x) = t x
2217− {-# INLINE liftToJSON #-}
2218−
2219− liftToEncoding t _ (Semigroup.WrapMonoid x) = t x
2220− {-# INLINE liftToEncoding #-}
2221−
2222−instance ToJSON a => ToJSON (Semigroup.WrappedMonoid a) where
2223− toJSON = toJSON1
2224− {-# INLINE toJSON #-}
2225−
2226− toEncoding = toEncoding1
2227− {-# INLINE toEncoding #-}
2228−
2229−
2230−instance ToJSON1 Semigroup.Option where
2231− liftToJSON t to' = liftToJSON t to' . Semigroup.getOption
2232− {-# INLINE liftToJSON #-}
2233−
2234− liftToEncoding t to' = liftToEncoding t to' . Semigroup.getOption
2235− {-# INLINE liftToEncoding #-}
2236−
2237−instance ToJSON a => ToJSON (Semigroup.Option a) where
1493+instance ToJSON a => ToJSON (Last a) where
22381494 toJSON = toJSON1
22391495 {-# INLINE toJSON #-}
22401496
@@ -2245,28 +1501,14 @@ instance ToJSON a => ToJSON (Semigroup.Option a) where
22451501-- tagged
22461502-------------------------------------------------------------------------------
22471503
2248−instance ToJSON1 Proxy where
2249− liftToJSON _ _ _ = Null
2250− {-# INLINE liftToJSON #-}
2251−
2252− liftToEncoding _ _ _ = E.null_
2253− {-# INLINE liftToEncoding #-}
2254−
22551504instance ToJSON (Proxy a) where
22561505 toJSON _ = Null
22571506 {-# INLINE toJSON #-}
22581507
2259− toEncoding _ = E.null_
1508+ toEncoding _ = Encoding EB.null_
22601509 {-# INLINE toEncoding #-}
22611510
22621511
2263−instance ToJSON2 Tagged where
2264− liftToJSON2 _ _ t _ (Tagged x) = t x
2265− {-# INLINE liftToJSON2 #-}
2266−
2267− liftToEncoding2 _ _ t _ (Tagged x) = t x
2268− {-# INLINE liftToEncoding2 #-}
2269−
22701512instance ToJSON1 (Tagged a) where
22711513 liftToJSON t _ (Tagged x) = t x
22721514 {-# INLINE liftToJSON #-}
@@ -2281,6 +1523,7 @@ instance ToJSON b => ToJSON (Tagged a b) where
22811523 toEncoding = toEncoding1
22821524 {-# INLINE toEncoding #-}
22831525
1526+
22841527instance ToJSONKey b => ToJSONKey (Tagged a b) where
22851528 toJSONKey = contramapToJSONKeyFunction unTagged toJSONKey
22861529 toJSONKeyList = contramapToJSONKeyFunction (fmap unTagged) toJSONKeyList
@@ -2289,22 +1532,41 @@ instance ToJSONKey b => ToJSONKey (Tagged a b) where
22891532-- Instances for converting t map keys
22901533-------------------------------------------------------------------------------
22911534
1535+instance ToJSONKey Text where
1536+ toJSONKey = ToJSONKeyText (id,toEncoding)
1537+
1538+
1539+instance ToJSONKey Bool where
1540+ toJSONKey = ToJSONKeyText
1541+ ( (\x -> if x then "true" else "false")
1542+ , (\x -> Encoding $ if x then "\"true\"" else "\"false\"")
1543+ )
1544+
1545+instance ToJSONKey Int where
1546+ toJSONKey = ToJSONKeyText
1547+ ( LT.toStrict . LTB.toLazyText . LTBI.decimal
1548+ , \x -> Encoding $ B.char7 '"' <> fromEncoding (toEncoding x) <> B.char7 '"'
1549+ )
1550+
22921551instance (ToJSON a, ToJSON b) => ToJSONKey (a,b)
22931552instance (ToJSON a, ToJSON b, ToJSON c) => ToJSONKey (a,b,c)
22941553instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSONKey (a,b,c,d)
22951554
22961555instance ToJSONKey Char where
2297− toJSONKey = ToJSONKeyText T.singleton (E.string . (:[]))
2298− toJSONKeyList = toJSONKeyText T.pack
1556+ toJSONKey = ToJSONKeyText (T.singleton, toEncoding)
1557+ toJSONKeyList = ToJSONKeyText (T.pack, toEncoding . T.pack)
22991558
23001559instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where
23011560 toJSONKey = toJSONKeyList
23021561
1562+instance (ToJSONKey a, ToJSON a) => ToJSONKey (Identity a) where
1563+ toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey
1564+
23031565-------------------------------------------------------------------------------
2304−-- Tuple instances
1566+-- Tuple instances, see tuple-instances-to.hs
23051567-------------------------------------------------------------------------------
23061568
2307−instance ToJSON2 (,) where
1569+instance ToJSON2 ((,) ) where
23081570 liftToJSON2 toA _ toB _ (a, b) = Array $ V.create $ do
23091571 mv <- VM.unsafeNew 2
23101572 VM.unsafeWrite mv 0 (toA a)
@@ -2312,7 +1574,9 @@ instance ToJSON2 (,) where
23121574 return mv
23131575 {-# INLINE liftToJSON2 #-}
23141576
2315− liftToEncoding2 toA _ toB _ (a, b) = E.list id [toA a, toB b]
1577+ liftToEncoding2 toA _ toB _ (a, b) = tuple $
1578+ toA a >*<
1579+ toB b
23161580 {-# INLINE liftToEncoding2 #-}
23171581
23181582instance (ToJSON a) => ToJSON1 ((,) a) where
@@ -2336,11 +1600,10 @@ instance (ToJSON a) => ToJSON2 ((,,) a) where
23361600 return mv
23371601 {-# INLINE liftToJSON2 #-}
23381602
2339− liftToEncoding2 toB _ toC _ (a, b, c) = E.list id
2340− [ toEncoding a
2341− , toB b
2342− , toC c
2343− ]
1603+ liftToEncoding2 toB _ toC _ (a, b, c) = tuple $
1604+ toEncoding a >*<
1605+ toB b >*<
1606+ toC c
23441607 {-# INLINE liftToEncoding2 #-}
23451608
23461609instance (ToJSON a, ToJSON b) => ToJSON1 ((,,) a b) where
@@ -2365,12 +1628,11 @@ instance (ToJSON a, ToJSON b) => ToJSON2 ((,,,) a b) where
23651628 return mv
23661629 {-# INLINE liftToJSON2 #-}
23671630
2368− liftToEncoding2 toC _ toD _ (a, b, c, d) = E.list id
2369− [ toEncoding a
2370− , toEncoding b
2371− , toC c
2372− , toD d
2373− ]
1631+ liftToEncoding2 toC _ toD _ (a, b, c, d) = tuple $
1632+ toEncoding a >*<
1633+ toEncoding b >*<
1634+ toC c >*<
1635+ toD d
23741636 {-# INLINE liftToEncoding2 #-}
23751637
23761638instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON1 ((,,,) a b c) where
@@ -2396,13 +1658,12 @@ instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON2 ((,,,,) a b c) where
23961658 return mv
23971659 {-# INLINE liftToJSON2 #-}
23981660
2399− liftToEncoding2 toD _ toE _ (a, b, c, d, e) = E.list id
2400− [ toEncoding a
2401− , toEncoding b
2402− , toEncoding c
2403− , toD d
2404− , toE e
2405− ]
1661+ liftToEncoding2 toD _ toE _ (a, b, c, d, e) = tuple $
1662+ toEncoding a >*<
1663+ toEncoding b >*<
1664+ toEncoding c >*<
1665+ toD d >*<
1666+ toE e
24061667 {-# INLINE liftToEncoding2 #-}
24071668
24081669instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON1 ((,,,,) a b c d) where
@@ -2429,14 +1690,13 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON2 ((,,,,,) a b c d) w
24291690 return mv
24301691 {-# INLINE liftToJSON2 #-}
24311692
2432− liftToEncoding2 toE _ toF _ (a, b, c, d, e, f) = E.list id
2433− [ toEncoding a
2434− , toEncoding b
2435− , toEncoding c
2436− , toEncoding d
2437− , toE e
2438− , toF f
2439− ]
1693+ liftToEncoding2 toE _ toF _ (a, b, c, d, e, f) = tuple $
1694+ toEncoding a >*<
1695+ toEncoding b >*<
1696+ toEncoding c >*<
1697+ toEncoding d >*<
1698+ toE e >*<
1699+ toF f
24401700 {-# INLINE liftToEncoding2 #-}
24411701
24421702instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON1 ((,,,,,) a b c d e) where
@@ -2464,15 +1724,14 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON2 ((,,,,,,)
24641724 return mv
24651725 {-# INLINE liftToJSON2 #-}
24661726
2467− liftToEncoding2 toF _ toG _ (a, b, c, d, e, f, g) = E.list id
2468− [ toEncoding a
2469− , toEncoding b
2470− , toEncoding c
2471− , toEncoding d
2472− , toEncoding e
2473− , toF f
2474− , toG g
2475− ]
1727+ liftToEncoding2 toF _ toG _ (a, b, c, d, e, f, g) = tuple $
1728+ toEncoding a >*<
1729+ toEncoding b >*<
1730+ toEncoding c >*<
1731+ toEncoding d >*<
1732+ toEncoding e >*<
1733+ toF f >*<
1734+ toG g
24761735 {-# INLINE liftToEncoding2 #-}
24771736
24781737instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON1 ((,,,,,,) a b c d e f) where
@@ -2501,16 +1760,15 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON2
25011760 return mv
25021761 {-# INLINE liftToJSON2 #-}
25031762
2504− liftToEncoding2 toG _ toH _ (a, b, c, d, e, f, g, h) = E.list id
2505− [ toEncoding a
2506− , toEncoding b
2507− , toEncoding c
2508− , toEncoding d
2509− , toEncoding e
2510− , toEncoding f
2511− , toG g
2512− , toH h
2513− ]
1763+ liftToEncoding2 toG _ toH _ (a, b, c, d, e, f, g, h) = tuple $
1764+ toEncoding a >*<
1765+ toEncoding b >*<
1766+ toEncoding c >*<
1767+ toEncoding d >*<
1768+ toEncoding e >*<
1769+ toEncoding f >*<
1770+ toG g >*<
1771+ toH h
25141772 {-# INLINE liftToEncoding2 #-}
25151773
25161774instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON1 ((,,,,,,,) a b c d e f g) where
@@ -2540,17 +1798,16 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g)
25401798 return mv
25411799 {-# INLINE liftToJSON2 #-}
25421800
2543− liftToEncoding2 toH _ toI _ (a, b, c, d, e, f, g, h, i) = E.list id
2544− [ toEncoding a
2545− , toEncoding b
2546− , toEncoding c
2547− , toEncoding d
2548− , toEncoding e
2549− , toEncoding f
2550− , toEncoding g
2551− , toH h
2552− , toI i
2553− ]
1801+ liftToEncoding2 toH _ toI _ (a, b, c, d, e, f, g, h, i) = tuple $
1802+ toEncoding a >*<
1803+ toEncoding b >*<
1804+ toEncoding c >*<
1805+ toEncoding d >*<
1806+ toEncoding e >*<
1807+ toEncoding f >*<
1808+ toEncoding g >*<
1809+ toH h >*<
1810+ toI i
25541811 {-# INLINE liftToEncoding2 #-}
25551812
25561813instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h) => ToJSON1 ((,,,,,,,,) a b c d e f g h) where
@@ -2581,18 +1838,17 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,
25811838 return mv
25821839 {-# INLINE liftToJSON2 #-}
25831840
2584− liftToEncoding2 toI _ toJ _ (a, b, c, d, e, f, g, h, i, j) = E.list id
2585− [ toEncoding a
2586− , toEncoding b
2587− , toEncoding c
2588− , toEncoding d
2589− , toEncoding e
2590− , toEncoding f
2591− , toEncoding g
2592− , toEncoding h
2593− , toI i
2594− , toJ j
2595− ]
1841+ liftToEncoding2 toI _ toJ _ (a, b, c, d, e, f, g, h, i, j) = tuple $
1842+ toEncoding a >*<
1843+ toEncoding b >*<
1844+ toEncoding c >*<
1845+ toEncoding d >*<
1846+ toEncoding e >*<
1847+ toEncoding f >*<
1848+ toEncoding g >*<
1849+ toEncoding h >*<
1850+ toI i >*<
1851+ toJ j
25961852 {-# INLINE liftToEncoding2 #-}
25971853
25981854instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i) => ToJSON1 ((,,,,,,,,,) a b c d e f g h i) where
@@ -2624,19 +1880,18 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,
26241880 return mv
26251881 {-# INLINE liftToJSON2 #-}
26261882
2627− liftToEncoding2 toJ _ toK _ (a, b, c, d, e, f, g, h, i, j, k) = E.list id
2628− [ toEncoding a
2629− , toEncoding b
2630− , toEncoding c
2631− , toEncoding d
2632− , toEncoding e
2633− , toEncoding f
2634− , toEncoding g
2635− , toEncoding h
2636− , toEncoding i
2637− , toJ j
2638− , toK k
2639− ]
1883+ liftToEncoding2 toJ _ toK _ (a, b, c, d, e, f, g, h, i, j, k) = tuple $
1884+ toEncoding a >*<
1885+ toEncoding b >*<
1886+ toEncoding c >*<
1887+ toEncoding d >*<
1888+ toEncoding e >*<
1889+ toEncoding f >*<
1890+ toEncoding g >*<
1891+ toEncoding h >*<
1892+ toEncoding i >*<
1893+ toJ j >*<
1894+ toK k
26401895 {-# INLINE liftToEncoding2 #-}
26411896
26421897instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j) => ToJSON1 ((,,,,,,,,,,) a b c d e f g h i j) where
@@ -2669,20 +1924,19 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,
26691924 return mv
26701925 {-# INLINE liftToJSON2 #-}
26711926
2672− liftToEncoding2 toK _ toL _ (a, b, c, d, e, f, g, h, i, j, k, l) = E.list id
2673− [ toEncoding a
2674− , toEncoding b
2675− , toEncoding c
2676− , toEncoding d
2677− , toEncoding e
2678− , toEncoding f
2679− , toEncoding g
2680− , toEncoding h
2681− , toEncoding i
2682− , toEncoding j
2683− , toK k
2684− , toL l
2685− ]
1927+ liftToEncoding2 toK _ toL _ (a, b, c, d, e, f, g, h, i, j, k, l) = tuple $
1928+ toEncoding a >*<
1929+ toEncoding b >*<
1930+ toEncoding c >*<
1931+ toEncoding d >*<
1932+ toEncoding e >*<
1933+ toEncoding f >*<
1934+ toEncoding g >*<
1935+ toEncoding h >*<
1936+ toEncoding i >*<
1937+ toEncoding j >*<
1938+ toK k >*<
1939+ toL l
26861940 {-# INLINE liftToEncoding2 #-}
26871941
26881942instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k) => ToJSON1 ((,,,,,,,,,,,) a b c d e f g h i j k) where
@@ -2716,21 +1970,20 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,
27161970 return mv
27171971 {-# INLINE liftToJSON2 #-}
27181972
2719− liftToEncoding2 toL _ toM _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = E.list id
2720− [ toEncoding a
2721− , toEncoding b
2722− , toEncoding c
2723− , toEncoding d
2724− , toEncoding e
2725− , toEncoding f
2726− , toEncoding g
2727− , toEncoding h
2728− , toEncoding i
2729− , toEncoding j
2730− , toEncoding k
2731− , toL l
2732− , toM m
2733− ]
1973+ liftToEncoding2 toL _ toM _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = tuple $
1974+ toEncoding a >*<
1975+ toEncoding b >*<
1976+ toEncoding c >*<
1977+ toEncoding d >*<
1978+ toEncoding e >*<
1979+ toEncoding f >*<
1980+ toEncoding g >*<
1981+ toEncoding h >*<
1982+ toEncoding i >*<
1983+ toEncoding j >*<
1984+ toEncoding k >*<
1985+ toL l >*<
1986+ toM m
27341987 {-# INLINE liftToEncoding2 #-}
27351988
27361989instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l) => ToJSON1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) where
@@ -2765,22 +2018,21 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,
27652018 return mv
27662019 {-# INLINE liftToJSON2 #-}
27672020
2768− liftToEncoding2 toM _ toN _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = E.list id
2769− [ toEncoding a
2770− , toEncoding b
2771− , toEncoding c
2772− , toEncoding d
2773− , toEncoding e
2774− , toEncoding f
2775− , toEncoding g
2776− , toEncoding h
2777− , toEncoding i
2778− , toEncoding j
2779− , toEncoding k
2780− , toEncoding l
2781− , toM m
2782− , toN n
2783− ]
2021+ liftToEncoding2 toM _ toN _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = tuple $
2022+ toEncoding a >*<
2023+ toEncoding b >*<
2024+ toEncoding c >*<
2025+ toEncoding d >*<
2026+ toEncoding e >*<
2027+ toEncoding f >*<
2028+ toEncoding g >*<
2029+ toEncoding h >*<
2030+ toEncoding i >*<
2031+ toEncoding j >*<
2032+ toEncoding k >*<
2033+ toEncoding l >*<
2034+ toM m >*<
2035+ toN n
27842036 {-# INLINE liftToEncoding2 #-}
27852037
27862038instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l, ToJSON m) => ToJSON1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) where
@@ -2816,23 +2068,22 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,
28162068 return mv
28172069 {-# INLINE liftToJSON2 #-}
28182070
2819− liftToEncoding2 toN _ toO _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = E.list id
2820− [ toEncoding a
2821− , toEncoding b
2822− , toEncoding c
2823− , toEncoding d
2824− , toEncoding e
2825− , toEncoding f
2826− , toEncoding g
2827− , toEncoding h
2828− , toEncoding i
2829− , toEncoding j
2830− , toEncoding k
2831− , toEncoding l
2832− , toEncoding m
2833− , toN n
2834− , toO o
2835− ]
2071+ liftToEncoding2 toN _ toO _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = tuple $
2072+ toEncoding a >*<
2073+ toEncoding b >*<
2074+ toEncoding c >*<
2075+ toEncoding d >*<
2076+ toEncoding e >*<
2077+ toEncoding f >*<
2078+ toEncoding g >*<
2079+ toEncoding h >*<
2080+ toEncoding i >*<
2081+ toEncoding j >*<
2082+ toEncoding k >*<
2083+ toEncoding l >*<
2084+ toEncoding m >*<
2085+ toN n >*<
2086+ toO o
28362087 {-# INLINE liftToEncoding2 #-}
28372088
28382089instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l, ToJSON m, ToJSON n) => ToJSON1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) where
@@ -2846,27 +2097,3 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,
28462097 {-# INLINE toJSON #-}
28472098 toEncoding = toEncoding2
28482099 {-# INLINE toEncoding #-}
2849−
2850−--------------------------------------------------------------------------------
2851−
2852−-- | Wrap a list of pairs as an object.
2853−class Monoid pairs => FromPairs enc pairs | enc -> pairs where
2854− fromPairs :: pairs -> enc
2855−
2856−instance (a ~ Value) => FromPairs (Encoding' a) Series where
2857− fromPairs = E.pairs
2858−
2859−instance FromPairs Value (DList Pair) where
2860− fromPairs = object . toList
2861−
2862−-- | Like 'KeyValue' but the value is already converted to JSON
2863−-- ('Value' or 'Encoding'), and the result actually represents lists of pairs
2864−-- so it can be readily concatenated.
2865−class Monoid kv => KeyValuePair v kv where
2866− pair :: String -> v -> kv
2867−
2868−instance (v ~ Value) => KeyValuePair v (DList Pair) where
2869− pair k v = DList.singleton (pack k .= v)
2870−
2871−instance (e ~ Encoding) => KeyValuePair e Series where
2872− pair = E.pairStr