packages feed

aeson 1.5.5.1 → 1.5.6.0

raw patch · 88 files changed

+11913/−14032 lines, 88 filesdep ~QuickCheckdep ~attoparsecdep ~base-compat-batteriesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, attoparsec, base-compat-batteries, base-orphans, hashable, hashable-time, semigroups, strict, these, time, transformers, transformers-compat

API changes (from Hackage documentation)

Files

− Data/Aeson.hs 
@@ -1,529 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--- |--- Module:      Data.Aeson--- Copyright:   (c) 2011-2016 Bryan O'Sullivan---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Types and functions for working efficiently with JSON data.------ (A note on naming: in Greek mythology, Aeson was the father of Jason.)--module Data.Aeson-    (-    -- * How to use this library-    -- $use--    -- ** Writing instances by hand-    -- $manual--    -- ** Working with the AST-    -- $ast--    -- ** Decoding to a Haskell value-    -- $haskell--    -- ** Decoding a mixed-type object-    -- $mixed--    -- * Encoding and decoding-    -- $encoding_and_decoding--    -- ** Direct encoding-    -- $encoding-      decode-    , decode'-    , eitherDecode-    , eitherDecode'-    , encode-    , encodeFile-    -- ** Variants for strict bytestrings-    , decodeStrict-    , decodeFileStrict-    , decodeStrict'-    , decodeFileStrict'-    , eitherDecodeStrict-    , eitherDecodeFileStrict-    , eitherDecodeStrict'-    , eitherDecodeFileStrict'-    -- * Core JSON types-    , Value(..)-    , Encoding-    , fromEncoding-    , Array-    , Object-    -- * Convenience types-    , DotNetTime(..)-    -- * Type conversion-    , FromJSON(..)-    , Result(..)-    , fromJSON-    , ToJSON(..)-    , KeyValue(..)-    , (<?>)-    , JSONPath-    -- ** Keys for maps-    , ToJSONKey(..)-    , ToJSONKeyFunction(..)-    , FromJSONKey(..)-    , FromJSONKeyFunction(..)-    -- *** Generic keys-    , GToJSONKey()-    , genericToJSONKey-    , GFromJSONKey()-    , genericFromJSONKey-    -- ** Liftings to unary and binary type constructors-    , FromJSON1(..)-    , parseJSON1-    , FromJSON2(..)-    , parseJSON2-    , ToJSON1(..)-    , toJSON1-    , toEncoding1-    , ToJSON2(..)-    , toJSON2-    , toEncoding2-    -- ** Generic JSON classes and options-    , GFromJSON-    , FromArgs-    , GToJSON-    , GToEncoding-    , GToJSON'-    , ToArgs-    , Zero-    , One-    , genericToJSON-    , genericLiftToJSON-    , genericToEncoding-    , genericLiftToEncoding-    , genericParseJSON-    , genericLiftParseJSON-    -- ** Generic and TH encoding configuration-    , Options-    , defaultOptions-    -- *** Options fields-    -- $optionsFields-    , fieldLabelModifier-    , constructorTagModifier-    , allNullaryToStringTag-    , omitNothingFields-    , sumEncoding-    , unwrapUnaryRecords-    , tagSingleConstructors-    , rejectUnknownFields-    -- *** Options utilities-    , SumEncoding(..)-    , camelTo2-    , defaultTaggedObject-    -- ** Options for object keys-    , JSONKeyOptions-    , keyModifier-    , defaultJSONKeyOptions--    -- * Inspecting @'Value's@-    , withObject-    , withText-    , withArray-    , withScientific-    , withBool-    , withEmbeddedJSON-    -- * Constructors and accessors-    , Series-    , pairs-    , foldable-    , (.:)-    , (.:?)-    , (.:!)-    , (.!=)-    , object-    -- * Parsing-    , json-    , json'-    , parseIndexedJSON-    ) where--import Prelude.Compat--import Data.Aeson.Types.FromJSON (ifromJSON, parseIndexedJSON)-import Data.Aeson.Encoding (encodingToLazyByteString)-import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json')-import Data.Aeson.Types-import Data.Aeson.Types.Internal (formatError)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L---- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.------ This is implemented in terms of the 'ToJSON' class's 'toEncoding' method.-encode :: (ToJSON a) => a -> L.ByteString-encode = encodingToLazyByteString . toEncoding---- | Efficiently serialize a JSON value as a lazy 'L.ByteString' and write it to a file.-encodeFile :: (ToJSON a) => FilePath -> a -> IO ()-encodeFile fp = L.writeFile fp . encode---- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.--- If this fails due to incomplete or invalid input, 'Nothing' is--- returned.------ The input must consist solely of a JSON document, with no trailing--- data except for whitespace.------ This function parses immediately, but defers conversion.  See--- 'json' for details.-decode :: (FromJSON a) => L.ByteString -> Maybe a-decode = decodeWith jsonEOF fromJSON-{-# INLINE decode #-}---- | Efficiently deserialize a JSON value from a strict 'B.ByteString'.--- If this fails due to incomplete or invalid input, 'Nothing' is--- returned.------ The input must consist solely of a JSON document, with no trailing--- data except for whitespace.------ This function parses immediately, but defers conversion.  See--- 'json' for details.-decodeStrict :: (FromJSON a) => B.ByteString -> Maybe a-decodeStrict = decodeStrictWith jsonEOF fromJSON-{-# INLINE decodeStrict #-}---- | Efficiently deserialize a JSON value from a file.--- If this fails due to incomplete or invalid input, 'Nothing' is--- returned.------ The input file's content must consist solely of a JSON document,--- with no trailing data except for whitespace.------ This function parses immediately, but defers conversion.  See--- 'json' for details.-decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a)-decodeFileStrict = fmap decodeStrict . B.readFile---- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.--- If this fails due to incomplete or invalid input, 'Nothing' is--- returned.------ The input must consist solely of a JSON document, with no trailing--- data except for whitespace.------ This function parses and performs conversion immediately.  See--- 'json'' for details.-decode' :: (FromJSON a) => L.ByteString -> Maybe a-decode' = decodeWith jsonEOF' fromJSON-{-# INLINE decode' #-}---- | Efficiently deserialize a JSON value from a strict 'B.ByteString'.--- If this fails due to incomplete or invalid input, 'Nothing' is--- returned.------ The input must consist solely of a JSON document, with no trailing--- data except for whitespace.------ This function parses and performs conversion immediately.  See--- 'json'' for details.-decodeStrict' :: (FromJSON a) => B.ByteString -> Maybe a-decodeStrict' = decodeStrictWith jsonEOF' fromJSON-{-# INLINE decodeStrict' #-}---- | Efficiently deserialize a JSON value from a file.--- If this fails due to incomplete or invalid input, 'Nothing' is--- returned.------ The input file's content must consist solely of a JSON document,--- with no trailing data except for whitespace.------ This function parses and performs conversion immediately.  See--- 'json'' for details.-decodeFileStrict' :: (FromJSON a) => FilePath -> IO (Maybe a)-decodeFileStrict' = fmap decodeStrict' . B.readFile--eitherFormatError :: Either (JSONPath, String) a -> Either String a-eitherFormatError = either (Left . uncurry formatError) Right-{-# INLINE eitherFormatError #-}---- | Like 'decode' but returns an error message when decoding fails.-eitherDecode :: (FromJSON a) => L.ByteString -> Either String a-eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON-{-# INLINE eitherDecode #-}---- | Like 'decodeStrict' but returns an error message when decoding fails.-eitherDecodeStrict :: (FromJSON a) => B.ByteString -> Either String a-eitherDecodeStrict =-  eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON-{-# INLINE eitherDecodeStrict #-}---- | Like 'decodeFileStrict' but returns an error message when decoding fails.-eitherDecodeFileStrict :: (FromJSON a) => FilePath -> IO (Either String a)-eitherDecodeFileStrict =-  fmap eitherDecodeStrict . B.readFile-{-# INLINE eitherDecodeFileStrict #-}---- | Like 'decode'' but returns an error message when decoding fails.-eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a-eitherDecode' = eitherFormatError . eitherDecodeWith jsonEOF' ifromJSON-{-# INLINE eitherDecode' #-}---- | Like 'decodeStrict'' but returns an error message when decoding fails.-eitherDecodeStrict' :: (FromJSON a) => B.ByteString -> Either String a-eitherDecodeStrict' =-  eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON-{-# INLINE eitherDecodeStrict' #-}---- | Like 'decodeFileStrict'' but returns an error message when decoding fails.-eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a)-eitherDecodeFileStrict' =-  fmap eitherDecodeStrict' . B.readFile-{-# INLINE eitherDecodeFileStrict' #-}---- $use------ This section contains basic information on the different ways to--- work with data using this library. These range from simple but--- inflexible, to complex but flexible.------ The most common way to use the library is to define a data type,--- corresponding to some JSON data you want to work with, and then--- write either a 'FromJSON' instance, a to 'ToJSON' instance, or both--- for that type.------ For example, given this JSON data:------ > { "name": "Joe", "age": 12 }------ we create a matching data type:------ > {-# LANGUAGE DeriveGeneric #-}--- >--- > import GHC.Generics--- >--- > data Person = Person {--- >       name :: Text--- >     , age  :: Int--- >     } deriving (Generic, Show)------ The @LANGUAGE@ pragma and 'Generic' instance let us write empty--- 'FromJSON' and 'ToJSON' instances for which the compiler will--- generate sensible default implementations.------ @--- instance 'ToJSON' Person where---     \-- No need to provide a 'toJSON' implementation.------     \-- For efficiency, we write a simple 'toEncoding' implementation, as---     \-- the default version uses 'toJSON'.---     'toEncoding' = 'genericToEncoding' 'defaultOptions'------ instance 'FromJSON' Person---     \-- No need to provide a 'parseJSON' implementation.--- @------ We can now encode a value like so:------ > >>> encode (Person {name = "Joe", age = 12})--- > "{\"name\":\"Joe\",\"age\":12}"---- $manual------ When necessary, we can write 'ToJSON' and 'FromJSON' instances by--- hand.  This is valuable when the JSON-on-the-wire and Haskell data--- are different or otherwise need some more carefully managed--- translation.  Let's revisit our JSON data:------ > { "name": "Joe", "age": 12 }------ We once again create a matching data type, without bothering to add--- a 'Generic' instance this time:------ > data Person = Person {--- >       name :: Text--- >     , age  :: Int--- >     } deriving Show------ To decode data, we need to define a 'FromJSON' instance:------ > {-# LANGUAGE OverloadedStrings #-}--- >--- > instance FromJSON Person where--- >     parseJSON = withObject "Person" $ \v -> Person--- >         <$> v .: "name"--- >         <*> v .: "age"------ We can now parse the JSON data like so:------ > >>> decode "{\"name\":\"Joe\",\"age\":12}" :: Maybe Person--- > Just (Person {name = "Joe", age = 12})------ To encode data, we need to define a 'ToJSON' instance. Let's begin--- with an instance written entirely by hand.------ @--- instance ToJSON Person where---     \-- this generates a 'Value'---     'toJSON' (Person name age) =---         'object' [\"name\" '.=' name, \"age\" '.=' age]------     \-- this encodes directly to a bytestring Builder---     'toEncoding' (Person name age) =---         'pairs' (\"name\" '.=' 'name' '<>' \"age\" '.=' age)--- @------ We can now encode a value like so:------ > >>> encode (Person {name = "Joe", age = 12})--- > "{\"name\":\"Joe\",\"age\":12}"------ There are predefined 'FromJSON' and 'ToJSON' instances for many--- types. Here's an example using lists and 'Int's:------ > >>> decode "[1,2,3]" :: Maybe [Int]--- > Just [1,2,3]------ And here's an example using the 'Data.Map.Map' type to get a map of--- 'Int's.------ > >>> decode "{\"foo\":1,\"bar\":2}" :: Maybe (Map String Int)--- > Just (fromList [("bar",2),("foo",1)])---- While the notes below focus on decoding, you can apply almost the--- same techniques to /encoding/ data. (The main difference is that--- encoding always succeeds, but decoding has to handle the--- possibility of failure, where an input doesn't match our--- expectations.)------ See the documentation of 'FromJSON' and 'ToJSON' for some examples--- of how you can automatically derive instances in many common--- circumstances.---- $ast------ Sometimes you want to work with JSON data directly, without first--- converting it to a custom data type. This can be useful if you want--- to e.g. convert JSON data to YAML data, without knowing what the--- contents of the original JSON data was. The 'Value' type, which is--- an instance of 'FromJSON', is used to represent an arbitrary JSON--- AST (abstract syntax tree). Example usage:------ > >>> decode "{\"foo\": 123}" :: Maybe Value--- > Just (Object (fromList [("foo",Number 123)]))------ > >>> decode "{\"foo\": [\"abc\",\"def\"]}" :: Maybe Value--- > Just (Object (fromList [("foo",Array (fromList [String "abc",String "def"]))]))------ Once you have a 'Value' you can write functions to traverse it and--- make arbitrary transformations.---- $haskell------ We can decode to any instance of 'FromJSON':------ > λ> decode "[1,2,3]" :: Maybe [Int]--- > Just [1,2,3]------ Alternatively, there are instances for standard data types, so you--- can use them directly. For example, use the 'Data.Map.Map' type to--- get a map of 'Int's.------ > λ> import Data.Map--- > λ> decode "{\"foo\":1,\"bar\":2}" :: Maybe (Map String Int)--- > Just (fromList [("bar",2),("foo",1)])---- $mixed------ The above approach with maps of course will not work for mixed-type--- objects that don't follow a strict schema, but there are a couple--- of approaches available for these.------ The 'Object' type contains JSON objects:------ > λ> decode "{\"name\":\"Dave\",\"age\":2}" :: Maybe Object--- > Just (fromList [("name",String "Dave"),("age",Number 2)])------ You can extract values from it with a parser using 'parse',--- 'parseEither' or, in this example, 'parseMaybe':------ > λ> do result <- decode "{\"name\":\"Dave\",\"age\":2}"--- >       flip parseMaybe result $ \obj -> do--- >         age <- obj .: "age"--- >         name <- obj .: "name"--- >         return (name ++ ": " ++ show (age*2))--- >--- > Just "Dave: 4"------ Considering that any type that implements 'FromJSON' can be used--- here, this is quite a powerful way to parse JSON. See the--- documentation in 'FromJSON' for how to implement this class for--- your own data types.------ The downside is that you have to write the parser yourself; the--- upside is that you have complete control over the way the JSON is--- parsed.---- $encoding_and_decoding------ Decoding is a two-step process.------ * When decoding a value, the process is reversed: the bytes are---   converted to a 'Value', then the 'FromJSON' class is used to---   convert to the desired type.------ There are two ways to encode a value.------ * Convert to a 'Value' using 'toJSON', then possibly further---   encode.  This was the only method available in aeson 0.9 and---   earlier.------ * Directly encode (to what will become a 'L.ByteString') using---   'toEncoding'.  This is much more efficient (about 3x faster, and---   less memory intensive besides), but is only available in aeson---   0.10 and newer.------ For convenience, the 'encode' and 'decode' functions combine both--- steps.---- $encoding------ In older versions of this library, encoding a Haskell value--- involved converting to an intermediate 'Value', then encoding that.------ A \"direct\" encoder converts straight from a source Haskell value--- to a 'BL.ByteString' without constructing an intermediate 'Value'.--- This approach is faster than 'toJSON', and allocates less memory.--- The 'toEncoding' method makes it possible to implement direct--- encoding with low memory overhead.------ To complicate matters, the default implementation of 'toEncoding'--- uses 'toJSON'.  Why?  The 'toEncoding' method was added to this--- library much more recently than 'toJSON'.  Using 'toJSON' ensures--- that packages written against older versions of this library will--- compile and produce correct output, but they will not see any--- speedup from direct encoding.------ To write a minimal implementation of direct encoding, your type--- must implement GHC's 'Generic' class, and your code should look--- like this:------ @---     'toEncoding' = 'genericToEncoding' 'defaultOptions'--- @------ What if you have more elaborate encoding needs?  For example,--- perhaps you need to change the names of object keys, omit parts of--- a value.------ To encode to a JSON \"object\", use the 'pairs' function.------ @---     'toEncoding' (Person name age) =---         'pairs' (\"name\" '.=' 'name' '<>' \"age\" '.=' age)--- @------ Any container type that implements 'Foldable' can be encoded to a--- JSON \"array\" using 'foldable'.------ > > import Data.Sequence as Seq--- > > encode (Seq.fromList [1,2,3])--- > "[1,2,3]"
− Data/Aeson/Encode.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--- |--- Module:      Data.Aeson.Encode--- Copyright:   (c) 2012-2016 Bryan O'Sullivan---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ This module is left to supply limited backwards-compatibility.--module Data.Aeson.Encode {-# DEPRECATED "Use Data.Aeson or Data.Aeson.Text instead" #-}-    (-      encode-    , encodeToTextBuilder-    ) where---import Data.ByteString.Lazy (ByteString)-import Data.Text.Lazy.Builder (Builder)-import qualified Data.Aeson as A-import qualified Data.Aeson.Text as A--encode :: A.ToJSON a => a -> ByteString-encode = A.encode-{-# DEPRECATED encode "Use encode from Data.Aeson" #-}--encodeToTextBuilder :: A.Value -> Builder-encodeToTextBuilder = A.encodeToTextBuilder-{-# DEPRECATED encodeToTextBuilder "Use encodeTotextBuilder from Data.Aeson.Text" #-}
− Data/Aeson/Encoding.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--- |------ Functions in this module return well-formed 'Encoding''.--- Polymorphic variants, which return @'Encoding' a@, return a textual JSON--- value, so it can be used as both @'Encoding'' 'Text'@ and @'Encoding' = 'Encoding'' 'Value'@.--module Data.Aeson.Encoding-    (-    -- * Encoding-      Encoding-    , Encoding'-    , encodingToLazyByteString-    , fromEncoding-    , unsafeToEncoding-    , Series-    , pairs-    , pair-    , pairStr-    , pair'-    -- * Predicates-    , nullEncoding-    -- * Encoding constructors-    , emptyArray_-    , emptyObject_-    , text-    , lazyText-    , string-    , list-    , dict-    , null_-    , bool-    -- ** Decimal numbers-    , int8, int16, int32, int64, int-    , word8, word16, word32, word64, word-    , integer, float, double, scientific--    -- ** Decimal numbers as Text-    , int8Text, int16Text, int32Text, int64Text, intText-    , word8Text, word16Text, word32Text, word64Text, wordText-    , integerText, floatText, doubleText, scientificText--    -- ** Time-    , day-    , month-    , quarter-    , localTime-    , utcTime-    , timeOfDay-    , zonedTime--    -- ** value-    , value-    ) where---import Data.Aeson.Encoding.Internal
− Data/Aeson/Encoding/Builder.hs 
@@ -1,287 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TupleSections #-}--- |--- Module:      Data.Aeson.Encoding.Builder--- Copyright:   (c) 2011 MailRank, Inc.---              (c) 2013 Simon Meier <iridcode@gmail.com>--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Efficiently serialize a JSON value using the UTF-8 encoding.--module Data.Aeson.Encoding.Builder-    (-      encodeToBuilder-    , null_-    , bool-    , array-    , emptyArray_-    , emptyObject_-    , object-    , text-    , string-    , unquoted-    , quote-    , scientific-    , day-    , month-    , quarter-    , localTime-    , utcTime-    , timeOfDay-    , zonedTime-    , ascii2-    , ascii4-    , ascii5-    ) where--import Prelude.Compat--import Data.Aeson.Internal.Time-import Data.Aeson.Types.Internal (Value (..))-import Data.ByteString.Builder as B-import Data.ByteString.Builder.Prim as BP-import Data.ByteString.Builder.Scientific (scientificBuilder)-import Data.Char (chr, ord)-import Data.Scientific (Scientific, base10Exponent, coefficient)-import Data.Text.Encoding (encodeUtf8BuilderEscaped)-import Data.Time (UTCTime(..))-import Data.Time.Calendar (Day(..), toGregorian)-import Data.Time.Calendar.Month.Compat (Month, toYearMonth)-import Data.Time.Calendar.Quarter.Compat (Quarter, toYearQuarter, QuarterOfYear (..))-import Data.Time.LocalTime-import Data.Word (Word8)-import qualified Data.HashMap.Strict as HMS-import qualified Data.Text as T-import qualified Data.Vector as V---- | Encode a JSON value to a "Data.ByteString" 'B.Builder'.------ Use this function if you are encoding over the wire, or need to--- prepend or append further bytes to the encoded JSON value.-encodeToBuilder :: Value -> Builder-encodeToBuilder Null       = null_-encodeToBuilder (Bool b)   = bool b-encodeToBuilder (Number n) = scientific n-encodeToBuilder (String s) = text s-encodeToBuilder (Array v)  = array v-encodeToBuilder (Object m) = object m---- | Encode a JSON null.-null_ :: Builder-null_ = BP.primBounded (ascii4 ('n',('u',('l','l')))) ()---- | Encode a JSON boolean.-bool :: Bool -> Builder-bool = BP.primBounded (BP.condB id (ascii4 ('t',('r',('u','e'))))-                                   (ascii5 ('f',('a',('l',('s','e'))))))---- | Encode a JSON array.-array :: V.Vector Value -> Builder-array v-  | V.null v  = emptyArray_-  | otherwise = B.char8 '[' <>-                encodeToBuilder (V.unsafeHead v) <>-                V.foldr withComma (B.char8 ']') (V.unsafeTail v)-  where-    withComma a z = B.char8 ',' <> encodeToBuilder a <> z---- Encode a JSON object.-object :: HMS.HashMap T.Text Value -> Builder-object m = case HMS.toList m of-    (x:xs) -> B.char8 '{' <> one x <> foldr withComma (B.char8 '}') xs-    _      -> emptyObject_-  where-    withComma a z = B.char8 ',' <> one a <> z-    one (k,v)     = text k <> B.char8 ':' <> encodeToBuilder v---- | Encode a JSON string.-text :: T.Text -> Builder-text t = B.char8 '"' <> unquoted t <> B.char8 '"'---- | Encode a JSON string, without enclosing quotes.-unquoted :: T.Text -> Builder-unquoted = encodeUtf8BuilderEscaped escapeAscii---- | Add quotes surrounding a builder-quote :: Builder -> Builder-quote b = B.char8 '"' <> b <> B.char8 '"'---- | Encode a JSON string.-string :: String -> Builder-string t = B.char8 '"' <> BP.primMapListBounded go t <> B.char8 '"'-  where go = BP.condB (> '\x7f') BP.charUtf8 (c2w >$< escapeAscii)--escapeAscii :: BP.BoundedPrim Word8-escapeAscii =-    BP.condB (== c2w '\\'  ) (ascii2 ('\\','\\')) $-    BP.condB (== c2w '\"'  ) (ascii2 ('\\','"' )) $-    BP.condB (>= c2w '\x20') (BP.liftFixedToBounded BP.word8) $-    BP.condB (== c2w '\n'  ) (ascii2 ('\\','n' )) $-    BP.condB (== c2w '\r'  ) (ascii2 ('\\','r' )) $-    BP.condB (== c2w '\t'  ) (ascii2 ('\\','t' )) $-    BP.liftFixedToBounded hexEscape -- fallback for chars < 0x20-  where-    hexEscape :: BP.FixedPrim Word8-    hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$<-        BP.char8 >*< BP.char8 >*< BP.word16HexFixed-{-# INLINE escapeAscii #-}--c2w :: Char -> Word8-c2w c = fromIntegral (ord c)---- | Encode a JSON number.-scientific :: Scientific -> Builder-scientific s-    | e < 0 || e > 1024 = scientificBuilder s-    | otherwise = B.integerDec (coefficient s * 10 ^ e)-  where-    e = base10Exponent s--emptyArray_ :: Builder-emptyArray_ = BP.primBounded (ascii2 ('[',']')) ()--emptyObject_ :: Builder-emptyObject_ = BP.primBounded (ascii2 ('{','}')) ()--ascii2 :: (Char, Char) -> BP.BoundedPrim a-ascii2 cs = BP.liftFixedToBounded $ const cs BP.>$< BP.char7 >*< BP.char7-{-# INLINE ascii2 #-}--ascii3 :: (Char, (Char, Char)) -> BP.BoundedPrim a-ascii3 cs = BP.liftFixedToBounded $ const cs >$<-    BP.char7 >*< BP.char7 >*< BP.char7-{-# INLINE ascii3 #-}--ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a-ascii4 cs = BP.liftFixedToBounded $ const cs >$<-    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7-{-# INLINE ascii4 #-}--ascii5 :: (Char, (Char, (Char, (Char, Char)))) -> BP.BoundedPrim a-ascii5 cs = BP.liftFixedToBounded $ const cs >$<-    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7-{-# INLINE ascii5 #-}--ascii6 :: (Char, (Char, (Char, (Char, (Char, Char))))) -> BP.BoundedPrim a-ascii6 cs = BP.liftFixedToBounded $ const cs >$<-    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7-{-# INLINE ascii6 #-}--ascii8 :: (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))-       -> BP.BoundedPrim a-ascii8 cs = BP.liftFixedToBounded $ const cs >$<-    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*<-    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7-{-# INLINE ascii8 #-}--day :: Day -> Builder-day dd = encodeYear yr <>-         BP.primBounded (ascii6 ('-',(mh,(ml,('-',(dh,dl)))))) ()-  where (yr,m,d)    = toGregorian dd-        !(T mh ml)  = twoDigits m-        !(T dh dl)  = twoDigits d-{-# INLINE day #-}--month :: Month -> Builder-month mm = encodeYear yr <>-           BP.primBounded (ascii3 ('-',(mh,ml))) ()-  where (yr,m) = toYearMonth mm-        !(T mh ml) = twoDigits m-{-# INLINE month #-}--quarter :: Quarter -> Builder-quarter qq = encodeYear yr <>-             BP.primBounded (ascii3 ('-',('q',qd))) ()-  where (yr,q) = toYearQuarter qq-        qd = case q of-            Q1 -> '1'-            Q2 -> '2'-            Q3 -> '3'-            Q4 -> '4'-{-# INLINE quarter #-}---- | Used in encoding day, month, quarter-encodeYear :: Integer -> Builder-encodeYear y-    | y >= 1000 = B.integerDec y-    | y >= 0    = BP.primBounded (ascii4 (padYear y)) ()-    | y >= -999 = BP.primBounded (ascii5 ('-',padYear (- y))) ()-    | otherwise = B.integerDec y-  where-    padYear y' =-        let (ab,c) = fromIntegral y' `quotRem` 10-            (a,b)  = ab `quotRem` 10-        in ('0',(digit a,(digit b,digit c)))-{-# INLINE encodeYear #-}--timeOfDay :: TimeOfDay -> Builder-timeOfDay t = timeOfDay64 (toTimeOfDay64 t)-{-# INLINE timeOfDay #-}--timeOfDay64 :: TimeOfDay64 -> Builder-timeOfDay64 (TOD h m s)-  | frac == 0 = hhmmss -- omit subseconds if 0-  | otherwise = hhmmss <> BP.primBounded showFrac frac-  where-    hhmmss  = BP.primBounded (ascii8 (hh,(hl,(':',(mh,(ml,(':',(sh,sl)))))))) ()-    !(T hh hl)  = twoDigits h-    !(T mh ml)  = twoDigits m-    !(T sh sl)  = twoDigits (fromIntegral real)-    (real,frac) = s `quotRem` pico-    showFrac = ('.',) >$< (BP.liftFixedToBounded BP.char7 >*< trunc12)-    trunc12 = (`quotRem` micro) >$<-              BP.condB (\(_,y) -> y == 0) (fst >$< trunc6) (digits6 >*< trunc6)-    digits6 = ((`quotRem` milli) . fromIntegral) >$< (digits3 >*< digits3)-    trunc6  = ((`quotRem` milli) . fromIntegral) >$<-              BP.condB (\(_,y) -> y == 0) (fst >$< trunc3) (digits3 >*< trunc3)-    digits3 = (`quotRem` 10) >$< (digits2 >*< digits1)-    digits2 = (`quotRem` 10) >$< (digits1 >*< digits1)-    digits1 = BP.liftFixedToBounded (digit >$< BP.char7)-    trunc3  = BP.condB (== 0) BP.emptyB $-              (`quotRem` 100) >$< (digits1 >*< trunc2)-    trunc2  = BP.condB (== 0) BP.emptyB $-              (`quotRem` 10)  >$< (digits1 >*< trunc1)-    trunc1  = BP.condB (== 0) BP.emptyB digits1--    pico       = 1000000000000 -- number of picoseconds  in 1 second-    micro      =       1000000 -- number of microseconds in 1 second-    milli      =          1000 -- number of milliseconds in 1 second--timeZone :: TimeZone -> Builder-timeZone (TimeZone off _ _)-  | off == 0  = B.char7 'Z'-  | otherwise = BP.primBounded (ascii6 (s,(hh,(hl,(':',(mh,ml)))))) ()-  where !s         = if off < 0 then '-' else '+'-        !(T hh hl) = twoDigits h-        !(T mh ml) = twoDigits m-        (h,m)      = abs off `quotRem` 60-{-# INLINE timeZone #-}--dayTime :: Day -> TimeOfDay64 -> Builder-dayTime d t = day d <> B.char7 'T' <> timeOfDay64 t-{-# INLINE dayTime #-}--utcTime :: UTCTime -> B.Builder-utcTime (UTCTime d s) = dayTime d (diffTimeOfDay64 s) <> B.char7 'Z'-{-# INLINE utcTime #-}--localTime :: LocalTime -> Builder-localTime (LocalTime d t) = dayTime d (toTimeOfDay64 t)-{-# INLINE localTime #-}--zonedTime :: ZonedTime -> Builder-zonedTime (ZonedTime t z) = localTime t <> timeZone z-{-# INLINE zonedTime #-}--data T = T {-# UNPACK #-} !Char {-# UNPACK #-} !Char--twoDigits :: Int -> T-twoDigits a     = T (digit hi) (digit lo)-  where (hi,lo) = a `quotRem` 10--digit :: Int -> Char-digit x = chr (x + 48)
− Data/Aeson/Encoding/Internal.hs 
@@ -1,380 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--module Data.Aeson.Encoding.Internal-    (-    -- * Encoding-      Encoding' (..)-    , Encoding-    , encodingToLazyByteString-    , unsafeToEncoding-    , retagEncoding-    , Series (..)-    , pairs-    , pair-    , pairStr-    , pair'-    -- * Predicates-    , nullEncoding-    -- * Encoding constructors-    , emptyArray_-    , emptyObject_-    , wrapObject-    , wrapArray-    , null_-    , bool-    , text-    , lazyText-    , string-    , list-    , dict-    , tuple-    , (>*<)-    , InArray-    , empty-    , (><)-    , econcat-    -- ** Decimal numbers-    , int8, int16, int32, int64, int-    , word8, word16, word32, word64, word-    , integer, float, double, scientific-    -- ** Decimal numbers as Text-    , int8Text, int16Text, int32Text, int64Text, intText-    , word8Text, word16Text, word32Text, word64Text, wordText-    , integerText, floatText, doubleText, scientificText-    -- ** Time-    , day-    , month-    , quarter-    , localTime-    , utcTime-    , timeOfDay-    , zonedTime-    -- ** value-    , value-    -- ** JSON tokens-    , comma, colon, openBracket, closeBracket, openCurly, closeCurly-    ) where--import Prelude.Compat--import Data.Aeson.Types.Internal (Value)-import Data.ByteString.Builder (Builder, char7, toLazyByteString)-import Data.Int-import Data.Scientific (Scientific)-import Data.Text (Text)-import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime)-import Data.Time.Calendar.Month.Compat (Month)-import Data.Time.Calendar.Quarter.Compat (Quarter)-import Data.Typeable (Typeable)-import Data.Word-import qualified Data.Aeson.Encoding.Builder as EB-import qualified Data.ByteString.Builder as B-import qualified Data.ByteString.Lazy as BSL-import qualified Data.Text.Lazy as LT---- | An encoding of a JSON value.------ @tag@ represents which kind of JSON the Encoding is encoding to,--- we reuse 'Text' and 'Value' as tags here.-newtype Encoding' tag = Encoding {-      fromEncoding :: Builder-      -- ^ Acquire the underlying bytestring builder.-    } deriving (Typeable)---- | Often used synonym for 'Encoding''.-type Encoding = Encoding' Value---- | Make Encoding from Builder.------ Use with care! You have to make sure that the passed Builder--- is a valid JSON Encoding!-unsafeToEncoding :: Builder -> Encoding' a-unsafeToEncoding = Encoding--encodingToLazyByteString :: Encoding' a -> BSL.ByteString-encodingToLazyByteString = toLazyByteString . fromEncoding-{-# INLINE encodingToLazyByteString #-}--retagEncoding :: Encoding' a -> Encoding' b-retagEncoding = Encoding . fromEncoding------------------------------------------------------------------------------------ Encoding instances----------------------------------------------------------------------------------instance Show (Encoding' a) where-    show (Encoding e) = show (toLazyByteString e)--instance Eq (Encoding' a) where-    Encoding a == Encoding b = toLazyByteString a == toLazyByteString b--instance Ord (Encoding' a) where-    compare (Encoding a) (Encoding b) =-      compare (toLazyByteString a) (toLazyByteString b)---- | A series of values that, when encoded, should be separated by--- commas. Since 0.11.0.0, the '.=' operator is overloaded to create--- either @(Text, Value)@ or 'Series'. You can use Series when--- encoding directly to a bytestring builder as in the following--- example:------ > toEncoding (Person name age) = pairs ("name" .= name <> "age" .= age)-data Series = Empty-            | Value (Encoding' Series)-            deriving (Typeable)--pair :: Text -> Encoding -> Series-pair name val = pair' (text name) val-{-# INLINE pair #-}--pairStr :: String -> Encoding -> Series-pairStr name val = pair' (string name) val-{-# INLINE pairStr #-}--pair' :: Encoding' Text -> Encoding -> Series-pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val--instance Semigroup Series where-    Empty   <> a       = a-    a       <> Empty   = a-    Value a <> Value b = Value (a >< comma >< b)--instance Monoid Series where-    mempty  = Empty-    mappend = (<>)--nullEncoding :: Encoding' a -> Bool-nullEncoding = BSL.null . toLazyByteString . fromEncoding--emptyArray_ :: Encoding-emptyArray_ = Encoding EB.emptyArray_--emptyObject_ :: Encoding-emptyObject_ = Encoding EB.emptyObject_--wrapArray :: Encoding' a -> Encoding-wrapArray e = retagEncoding $ openBracket >< e >< closeBracket--wrapObject :: Encoding' a -> Encoding-wrapObject e = retagEncoding $ openCurly >< e >< closeCurly--null_ :: Encoding-null_ = Encoding EB.null_--bool :: Bool -> Encoding-bool True = Encoding "true"-bool False = Encoding "false"---- | Encode a series of key/value pairs, separated by commas.-pairs :: Series -> Encoding-pairs (Value v) = openCurly >< retagEncoding v >< closeCurly-pairs Empty     = emptyObject_-{-# INLINE pairs #-}--list :: (a -> Encoding) -> [a] -> Encoding-list _  []     = emptyArray_-list to' (x:xs) = openBracket >< to' x >< commas xs >< closeBracket-  where-    commas = foldr (\v vs -> comma >< to' v >< vs) empty-{-# INLINE list #-}---- | Encode as JSON object-dict-    :: (k -> Encoding' Text)                     -- ^ key encoding-    -> (v -> Encoding)                                -- ^ value encoding-    -> (forall a. (k -> v -> a -> a) -> a -> m -> a)  -- ^ @foldrWithKey@ - indexed fold-    -> m                                              -- ^ container-    -> Encoding-dict encodeKey encodeVal foldrWithKey = pairs . foldrWithKey go mempty-  where-    go k v c = Value (encodeKV k v) <> c-    encodeKV k v = retagEncoding (encodeKey k) >< colon >< retagEncoding (encodeVal v)-{-# INLINE dict #-}---- | Type tag for tuples contents, see 'tuple'.-data InArray--infixr 6 >*<--- | See 'tuple'.-(>*<) :: Encoding' a -> Encoding' b -> Encoding' InArray-a >*< b = retagEncoding a >< comma >< retagEncoding b-{-# INLINE (>*<) #-}--empty :: Encoding' a-empty = Encoding mempty--econcat :: [Encoding' a] -> Encoding' a-econcat = foldr (><) empty--infixr 6 ><-(><) :: Encoding' a -> Encoding' a -> Encoding' a-Encoding a >< Encoding b = Encoding (a <> b)-{-# INLINE (><) #-}---- | Encode as a tuple.------ @--- toEncoding (X a b c) = tuple $---     toEncoding a >*<---     toEncoding b >*<---     toEncoding c-tuple :: Encoding' InArray -> Encoding-tuple b = retagEncoding $ openBracket >< b >< closeBracket-{-# INLINE tuple #-}--text :: Text -> Encoding' a-text = Encoding . EB.text--lazyText :: LT.Text -> Encoding' a-lazyText t = Encoding $-    B.char7 '"' <>-    LT.foldrChunks (\x xs -> EB.unquoted x <> xs) (B.char7 '"') t--string :: String -> Encoding' a-string = Encoding . EB.string------------------------------------------------------------------------------------ chars----------------------------------------------------------------------------------comma, colon, openBracket, closeBracket, openCurly, closeCurly :: Encoding' a-comma        = Encoding $ char7 ','-colon        = Encoding $ char7 ':'-openBracket  = Encoding $ char7 '['-closeBracket = Encoding $ char7 ']'-openCurly    = Encoding $ char7 '{'-closeCurly   = Encoding $ char7 '}'------------------------------------------------------------------------------------ Decimal numbers----------------------------------------------------------------------------------int8 :: Int8 -> Encoding-int8 = Encoding . B.int8Dec--int16 :: Int16 -> Encoding-int16 = Encoding . B.int16Dec--int32 :: Int32 -> Encoding-int32 = Encoding . B.int32Dec--int64 :: Int64 -> Encoding-int64 = Encoding . B.int64Dec--int :: Int -> Encoding-int = Encoding . B.intDec--word8 :: Word8 -> Encoding-word8 = Encoding . B.word8Dec--word16 :: Word16 -> Encoding-word16 = Encoding . B.word16Dec--word32 :: Word32 -> Encoding-word32 = Encoding . B.word32Dec--word64 :: Word64 -> Encoding-word64 = Encoding . B.word64Dec--word :: Word -> Encoding-word = Encoding . B.wordDec--integer :: Integer -> Encoding-integer = Encoding . B.integerDec--float :: Float -> Encoding-float = realFloatToEncoding $ Encoding . B.floatDec--double :: Double -> Encoding-double = realFloatToEncoding $ Encoding . B.doubleDec--scientific :: Scientific -> Encoding-scientific = Encoding . EB.scientific--realFloatToEncoding :: RealFloat a => (a -> Encoding) -> a -> Encoding-realFloatToEncoding e d-    | isNaN d || isInfinite d = null_-    | otherwise               = e d-{-# INLINE realFloatToEncoding #-}------------------------------------------------------------------------------------ Decimal numbers as Text----------------------------------------------------------------------------------int8Text :: Int8 -> Encoding' a-int8Text = Encoding . EB.quote . B.int8Dec--int16Text :: Int16 -> Encoding' a-int16Text = Encoding . EB.quote . B.int16Dec--int32Text :: Int32 -> Encoding' a-int32Text = Encoding . EB.quote . B.int32Dec--int64Text :: Int64 -> Encoding' a-int64Text = Encoding . EB.quote . B.int64Dec--intText :: Int -> Encoding' a-intText = Encoding . EB.quote . B.intDec--word8Text :: Word8 -> Encoding' a-word8Text = Encoding . EB.quote . B.word8Dec--word16Text :: Word16 -> Encoding' a-word16Text = Encoding . EB.quote . B.word16Dec--word32Text :: Word32 -> Encoding' a-word32Text = Encoding . EB.quote . B.word32Dec--word64Text :: Word64 -> Encoding' a-word64Text = Encoding . EB.quote . B.word64Dec--wordText :: Word -> Encoding' a-wordText = Encoding . EB.quote . B.wordDec--integerText :: Integer -> Encoding' a-integerText = Encoding . EB.quote . B.integerDec--floatText :: Float -> Encoding' a-floatText = Encoding . EB.quote . B.floatDec--doubleText :: Double -> Encoding' a-doubleText = Encoding . EB.quote . B.doubleDec--scientificText :: Scientific -> Encoding' a-scientificText = Encoding . EB.quote . EB.scientific------------------------------------------------------------------------------------ time----------------------------------------------------------------------------------day :: Day -> Encoding' a-day = Encoding . EB.quote . EB.day--month :: Month -> Encoding' a-month = Encoding . EB.quote . EB.month--quarter :: Quarter -> Encoding' a-quarter = Encoding . EB.quote . EB.quarter--localTime :: LocalTime -> Encoding' a-localTime = Encoding . EB.quote . EB.localTime--utcTime :: UTCTime -> Encoding' a-utcTime = Encoding . EB.quote . EB.utcTime--timeOfDay :: TimeOfDay -> Encoding' a-timeOfDay = Encoding . EB.quote . EB.timeOfDay--zonedTime :: ZonedTime -> Encoding' a-zonedTime = Encoding . EB.quote . EB.zonedTime------------------------------------------------------------------------------------ Value----------------------------------------------------------------------------------value :: Value -> Encoding-value = Encoding . EB.encodeToBuilder
− Data/Aeson/Internal.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--- |--- Module:      Data.Aeson.Internal--- Copyright:   (c) 2015-2016 Bryan O'Sullivan--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Internal types and functions.------ __Note__: all declarations in this module are unstable, and prone--- to being changed at any time.--module Data.Aeson.Internal-    (-      IResult(..)-    , JSONPathElement(..)-    , JSONPath-    , (<?>)-    , formatError-    , ifromJSON-    , iparse-    ) where---import Data.Aeson.Types.Internal-import Data.Aeson.Types.FromJSON (ifromJSON)
− Data/Aeson/Internal/Functions.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--- |--- Module:      Data.Aeson.Functions--- Copyright:   (c) 2011-2016 Bryan O'Sullivan---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable--module Data.Aeson.Internal.Functions-    (-      mapHashKeyVal-    , mapKeyVal-    , mapKey-    ) where--import Prelude.Compat--import Data.Hashable (Hashable)-import qualified Data.HashMap.Strict as H-import qualified Data.Map as M---- | Transform a 'M.Map' into a 'H.HashMap' while transforming the keys.-mapHashKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)-              -> M.Map k1 v1 -> H.HashMap k2 v2-mapHashKeyVal fk kv = M.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty-{-# INLINE mapHashKeyVal #-}---- | Transform the keys and values of a 'H.HashMap'.-mapKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)-          -> H.HashMap k1 v1 -> H.HashMap k2 v2-mapKeyVal fk kv = H.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty-{-# INLINE mapKeyVal #-}---- | Transform the keys of a 'H.HashMap'.-mapKey :: (Eq k2, Hashable k2) => (k1 -> k2) -> H.HashMap k1 v -> H.HashMap k2 v-mapKey fk = mapKeyVal fk id-{-# INLINE mapKey #-}
− Data/Aeson/Internal/Time.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE CPP #-}---- |--- Module:      Data.Aeson.Internal.Time--- Copyright:   (c) 2015-2016 Bryan O'Sullivan--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable--module Data.Aeson.Internal.Time-    (-      TimeOfDay64(..)-    , fromPico-    , toPico-    , diffTimeOfDay64-    , toTimeOfDay64-    ) where--import Data.Attoparsec.Time.Internal
− Data/Aeson/Parser.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--- |--- Module:      Data.Aeson.Parser--- Copyright:   (c) 2012-2016 Bryan O'Sullivan---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Efficiently and correctly parse a JSON string.  The string must be--- encoded as UTF-8.------ It can be useful to think of parsing as occurring in two phases:------ * Identification of the textual boundaries of a JSON value.  This---   is always strict, so that an invalid JSON document can be---   rejected as soon as possible.------ * Conversion of a JSON value to a Haskell value.  This may be---   either immediate (strict) or deferred (lazy); see below for---   details.------ The question of whether to choose a lazy or strict parser is--- subtle, but it can have significant performance implications,--- resulting in changes in CPU use and memory footprint of 30% to 50%,--- or occasionally more.  Measure the performance of your application--- with each!--module Data.Aeson.Parser-    (-    -- * Lazy parsers-    -- $lazy-      json-    , value-    , jstring-    , scientific-    -- ** Handling objects with duplicate keys-    , jsonWith-    , jsonLast-    , jsonAccum-    , jsonNoDup-    -- * Strict parsers-    -- $strict-    , json'-    , value'-    -- ** Handling objects with duplicate keys-    , jsonWith'-    , jsonLast'-    , jsonAccum'-    , jsonNoDup'-    -- * Decoding without FromJSON instances-    , decodeWith-    , decodeStrictWith-    , eitherDecodeWith-    , eitherDecodeStrictWith-    ) where---import Data.Aeson.Parser.Internal---- $lazy------ The 'json' and 'value' parsers decouple identification from--- conversion.  Identification occurs immediately (so that an invalid--- JSON document can be rejected as early as possible), but conversion--- to a Haskell value is deferred until that value is needed.------ This decoupling can be time-efficient if only a smallish subset of--- elements in a JSON value need to be inspected, since the cost of--- conversion is zero for uninspected elements.  The trade off is an--- increase in memory usage, due to allocation of thunks for values--- that have not yet been converted.---- $strict------ The 'json'' and 'value'' parsers combine identification with--- conversion.  They consume more CPU cycles up front, but have a--- smaller memory footprint.
− Data/Aeson/Parser/Internal.hs 
@@ -1,544 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-#if __GLASGOW_HASKELL__ <= 710 && __GLASGOW_HASKELL__ >= 706--- Work around a compiler bug-{-# OPTIONS_GHC -fsimpl-tick-factor=300 #-}-#endif--- |--- Module:      Data.Aeson.Parser.Internal--- Copyright:   (c) 2011-2016 Bryan O'Sullivan---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Efficiently and correctly parse a JSON string.  The string must be--- encoded as UTF-8.--module Data.Aeson.Parser.Internal-    (-    -- * Lazy parsers-      json, jsonEOF-    , jsonWith-    , jsonLast-    , jsonAccum-    , jsonNoDup-    , value-    , jstring-    , jstring_-    , scientific-    -- * Strict parsers-    , json', jsonEOF'-    , jsonWith'-    , jsonLast'-    , jsonAccum'-    , jsonNoDup'-    , value'-    -- * Helpers-    , decodeWith-    , decodeStrictWith-    , eitherDecodeWith-    , eitherDecodeStrictWith-    -- ** Handling objects with duplicate keys-    , fromListAccum-    , parseListNoDup-    ) where--import Prelude.Compat--import Control.Applicative ((<|>))-import Control.Monad (void, when)-import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..))-import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)-import Data.Function (fix)-import Data.Functor.Compat (($>))-import Data.Scientific (Scientific)-import Data.Text (Text)-import qualified Data.Text.Encoding as TE-import Data.Vector (Vector)-import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)-import qualified Data.Attoparsec.ByteString as A-import qualified Data.Attoparsec.Lazy as L-import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as C-import qualified Data.ByteString.Builder as B-import qualified Data.HashMap.Strict as H-import qualified Data.Scientific as Sci-import Data.Aeson.Parser.Unescape (unescapeText)--#define BACKSLASH 92-#define CLOSE_CURLY 125-#define CLOSE_SQUARE 93-#define COMMA 44-#define DOUBLE_QUOTE 34-#define OPEN_CURLY 123-#define OPEN_SQUARE 91-#define C_0 48-#define C_9 57-#define C_A 65-#define C_F 70-#define C_a 97-#define C_f 102-#define C_n 110-#define C_t 116---- | Parse any JSON value.------ The conversion of a parsed value to a Haskell value is deferred--- until the Haskell value is needed.  This may improve performance if--- only a subset of the results of conversions are needed, but at a--- cost in thunk allocation.------ This function is an alias for 'value'. In aeson 0.8 and earlier, it--- parsed only object or array types, in conformance with the--- now-obsolete RFC 4627.------ ==== Warning------ If an object contains duplicate keys, only the first one will be kept.--- For a more flexible alternative, see 'jsonWith'.-json :: Parser Value-json = value---- | Parse any JSON value.------ This is a strict version of 'json' which avoids building up thunks--- during parsing; it performs all conversions immediately.  Prefer--- this version if most of the JSON data needs to be accessed.------ This function is an alias for 'value''. In aeson 0.8 and earlier, it--- parsed only object or array types, in conformance with the--- now-obsolete RFC 4627.------ ==== Warning------ If an object contains duplicate keys, only the first one will be kept.--- For a more flexible alternative, see 'jsonWith''.-json' :: Parser Value-json' = value'---- Open recursion: object_, object_', array_, array_' are parameterized by the--- toplevel Value parser to be called recursively, to keep the parameter--- mkObject outside of the recursive loop for proper inlining.--object_ :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value-object_ mkObject val = {-# SCC "object_" #-} Object <$> objectValues mkObject jstring val-{-# INLINE object_ #-}--object_' :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value-object_' mkObject val' = {-# SCC "object_'" #-} do-  !vals <- objectValues mkObject jstring' val'-  return (Object vals)- where-  jstring' = do-    !s <- jstring-    return s-{-# INLINE object_' #-}--objectValues :: ([(Text, Value)] -> Either String Object)-             -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)-objectValues mkObject str val = do-  skipSpace-  w <- A.peekWord8'-  if w == CLOSE_CURLY-    then A.anyWord8 >> return H.empty-    else loop []- where-  -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'-  -- and it's much faster because it's doing in place update to the 'HashMap'!-  loop acc = do-    k <- (str A.<?> "object key") <* skipSpace <* (char ':' A.<?> "':'")-    v <- (val A.<?> "object value") <* skipSpace-    ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_CURLY) A.<?> "',' or '}'"-    let acc' = (k, v) : acc-    if ch == COMMA-      then skipSpace >> loop acc'-      else case mkObject acc' of-        Left err -> fail err-        Right obj -> pure obj-{-# INLINE objectValues #-}--array_ :: Parser Value -> Parser Value-array_ val = {-# SCC "array_" #-} Array <$> arrayValues val-{-# INLINE array_ #-}--array_' :: Parser Value -> Parser Value-array_' val = {-# SCC "array_'" #-} do-  !vals <- arrayValues val-  return (Array vals)-{-# INLINE array_' #-}--arrayValues :: Parser Value -> Parser (Vector Value)-arrayValues val = do-  skipSpace-  w <- A.peekWord8'-  if w == CLOSE_SQUARE-    then A.anyWord8 >> return Vector.empty-    else loop [] 1-  where-    loop acc !len = do-      v <- (val A.<?> "json list value") <* skipSpace-      ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_SQUARE) A.<?> "',' or ']'"-      if ch == COMMA-        then skipSpace >> loop (v:acc) (len+1)-        else return (Vector.reverse (Vector.fromListN len (v:acc)))-{-# INLINE arrayValues #-}---- | Parse any JSON value. Synonym of 'json'.-value :: Parser Value-value = jsonWith (pure . H.fromList)---- | Parse any JSON value.------ This parser is parameterized by a function to construct an 'Object'--- from a raw list of key-value pairs, where duplicates are preserved.--- The pairs appear in __reverse order__ from the source.------ ==== __Examples__------ 'json' keeps only the first occurence of each key, using 'HashMap.Lazy.fromList'.------ @--- 'json' = 'jsonWith' ('Right' '.' 'H.fromList')--- @------ 'jsonLast' keeps the last occurence of each key, using--- @'HashMap.Lazy.fromListWith' ('const' 'id')@.------ @--- 'jsonLast' = 'jsonWith' ('Right' '.' 'HashMap.Lazy.fromListWith' ('const' 'id'))--- @------ 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using--- 'fromListAccum'.------ @--- 'jsonAccum' = 'jsonWith' ('Right' . 'fromListAccum')--- @------ 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'.------ @--- 'jsonNoDup' = 'jsonWith' 'parseListNoDup'--- @-jsonWith :: ([(Text, Value)] -> Either String Object) -> Parser Value-jsonWith mkObject = fix $ \value_ -> do-  skipSpace-  w <- A.peekWord8'-  case w of-    DOUBLE_QUOTE  -> A.anyWord8 *> (String <$> jstring_)-    OPEN_CURLY    -> A.anyWord8 *> object_ mkObject value_-    OPEN_SQUARE   -> A.anyWord8 *> array_ value_-    C_f           -> string "false" $> Bool False-    C_t           -> string "true" $> Bool True-    C_n           -> string "null" $> Null-    _              | w >= 48 && w <= 57 || w == 45-                  -> Number <$> scientific-      | otherwise -> fail "not a valid json value"-{-# INLINE jsonWith #-}---- | Variant of 'json' which keeps only the last occurence of every key.-jsonLast :: Parser Value-jsonLast = jsonWith (Right . H.fromListWith (const id))---- | Variant of 'json' wrapping all object mappings in 'Array' to preserve--- key-value pairs with the same keys.-jsonAccum :: Parser Value-jsonAccum = jsonWith (Right . fromListAccum)---- | Variant of 'json' which fails if any object contains duplicate keys.-jsonNoDup :: Parser Value-jsonNoDup = jsonWith parseListNoDup---- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all--- associated values from the original list @kvs@.------ >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)]--- fromList [("apple", [Bool False, Bool True]), ("orange", [Bool False])]-fromListAccum :: [(Text, Value)] -> Object-fromListAccum =-  fmap (Array . Vector.fromList . ($ [])) . H.fromListWith (.) . (fmap . fmap) (:)---- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.-parseListNoDup :: [(Text, Value)] -> Either String Object-parseListNoDup =-  H.traverseWithKey unwrap . H.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just-  where-    unwrap k Nothing = Left $ "found duplicate key: " ++ show k-    unwrap _ (Just v) = Right v---- | Strict version of 'value'. Synonym of 'json''.-value' :: Parser Value-value' = jsonWith' (pure . H.fromList)---- | Strict version of 'jsonWith'.-jsonWith' :: ([(Text, Value)] -> Either String Object) -> Parser Value-jsonWith' mkObject = fix $ \value_ -> do-  skipSpace-  w <- A.peekWord8'-  case w of-    DOUBLE_QUOTE  -> do-                     !s <- A.anyWord8 *> jstring_-                     return (String s)-    OPEN_CURLY    -> A.anyWord8 *> object_' mkObject value_-    OPEN_SQUARE   -> A.anyWord8 *> array_' value_-    C_f           -> string "false" $> Bool False-    C_t           -> string "true" $> Bool True-    C_n           -> string "null" $> Null-    _              | w >= 48 && w <= 57 || w == 45-                  -> do-                     !n <- scientific-                     return (Number n)-      | otherwise -> fail "not a valid json value"-{-# INLINE jsonWith' #-}---- | Variant of 'json'' which keeps only the last occurence of every key.-jsonLast' :: Parser Value-jsonLast' = jsonWith' (pure . H.fromListWith (const id))---- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve--- key-value pairs with the same keys.-jsonAccum' :: Parser Value-jsonAccum' = jsonWith' (pure . fromListAccum)---- | Variant of 'json'' which fails if any object contains duplicate keys.-jsonNoDup' :: Parser Value-jsonNoDup' = jsonWith' parseListNoDup---- | Parse a quoted JSON string.-jstring :: Parser Text-jstring = A.word8 DOUBLE_QUOTE *> jstring_---- | Parse a string without a leading quote.-jstring_ :: Parser Text-{-# INLINE jstring_ #-}-jstring_ = do-  -- not sure whether >= or bit hackery is faster-  -- perfectly, we shouldn't care, it's compiler job.-  s <- A.takeWhile (\w -> w /= DOUBLE_QUOTE && w /= BACKSLASH && w >= 0x20 && w < 0x80)-  let txt = unsafeDecodeASCII s-  mw <- A.peekWord8-  case mw of-    Nothing           -> fail "string without end"-    Just DOUBLE_QUOTE -> A.anyWord8 $> txt-    Just w | w < 0x20 -> fail "unescaped control character"-    _                 -> jstringSlow s---- | The input is assumed to contain only 7bit ASCII characters (i.e. @< 0x80@).---   We use TE.decodeLatin1 here because TE.decodeASCII is currently (text-1.2.4.0)---   deprecated and equal to TE.decodeUtf8, which is slower than TE.decodeLatin1.-unsafeDecodeASCII :: B.ByteString -> Text-unsafeDecodeASCII = TE.decodeLatin1--jstringSlow :: B.ByteString -> Parser Text-{-# INLINE jstringSlow #-}-jstringSlow s' = {-# SCC "jstringSlow" #-} do-  s <- A.scan startState go <* A.anyWord8-  case unescapeText (B.append s' s) of-    Right r  -> return r-    Left err -> fail $ show err- where-    startState              = False-    go a c-      | a                  = Just False-      | c == DOUBLE_QUOTE  = Nothing-      | otherwise = let a' = c == backslash-                    in Just a'-      where backslash = BACKSLASH--decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a-decodeWith p to s =-    case L.parse p s of-      L.Done _ v -> case to v of-                      Success a -> Just a-                      _         -> Nothing-      _          -> Nothing-{-# INLINE decodeWith #-}--decodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString-                 -> Maybe a-decodeStrictWith p to s =-    case either Error to (A.parseOnly p s) of-      Success a -> Just a-      _         -> Nothing-{-# INLINE decodeStrictWith #-}--eitherDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString-                 -> Either (JSONPath, String) a-eitherDecodeWith p to s =-    case L.parse p s of-      L.Done _ v     -> case to v of-                          ISuccess a      -> Right a-                          IError path msg -> Left (path, msg)-      L.Fail notparsed ctx msg -> Left ([], buildMsg notparsed ctx msg)-  where-    buildMsg :: L.ByteString -> [String] -> String -> String-    buildMsg notYetParsed [] msg = msg ++ formatErrorLine notYetParsed-    buildMsg notYetParsed (expectation:_) msg =-      msg ++ ". Expecting " ++ expectation ++ formatErrorLine notYetParsed-{-# INLINE eitherDecodeWith #-}---- | Grab the first 100 bytes from the non parsed portion and--- format to get nicer error messages-formatErrorLine :: L.ByteString -> String-formatErrorLine bs =-  C.unpack .-  -- if formatting results in empty ByteString just return that-  -- otherwise construct the error message with the bytestring builder-  (\bs' ->-     if BSL.null bs'-       then BSL.empty-       else-         B.toLazyByteString $-         B.stringUtf8 " at '" <> B.lazyByteString bs' <> B.stringUtf8 "'"-  ) .-  -- if newline is present cut at that position-  BSL.takeWhile (10 /=) .-  -- remove spaces, CR's, tabs, backslashes and quotes characters-  BSL.filter (`notElem` [9, 13, 32, 34, 47, 92]) .-  -- take 100 bytes-  BSL.take 100 $ bs--eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString-                       -> Either (JSONPath, String) a-eitherDecodeStrictWith p to s =-    case either (IError []) to (A.parseOnly p s) of-      ISuccess a      -> Right a-      IError path msg -> Left (path, msg)-{-# INLINE eitherDecodeStrictWith #-}---- $lazy------ The 'json' and 'value' parsers decouple identification from--- conversion.  Identification occurs immediately (so that an invalid--- JSON document can be rejected as early as possible), but conversion--- to a Haskell value is deferred until that value is needed.------ This decoupling can be time-efficient if only a smallish subset of--- elements in a JSON value need to be inspected, since the cost of--- conversion is zero for uninspected elements.  The trade off is an--- increase in memory usage, due to allocation of thunks for values--- that have not yet been converted.---- $strict------ The 'json'' and 'value'' parsers combine identification with--- conversion.  They consume more CPU cycles up front, but have a--- smaller memory footprint.---- | Parse a top-level JSON value followed by optional whitespace and--- end-of-input.  See also: 'json'.-jsonEOF :: Parser Value-jsonEOF = json <* skipSpace <* endOfInput---- | Parse a top-level JSON value followed by optional whitespace and--- end-of-input.  See also: 'json''.-jsonEOF' :: Parser Value-jsonEOF' = json' <* skipSpace <* endOfInput---- | The only valid whitespace in a JSON document is space, newline,--- carriage return, and tab.-skipSpace :: Parser ()-skipSpace = A.skipWhile $ \w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09-{-# INLINE skipSpace #-}-------------------- Copy-pasted and adapted from attoparsec ---------------------- A strict pair-data SP = SP !Integer {-# UNPACK #-}!Int--decimal0 :: Parser Integer-decimal0 = do-  let zero = 48-  digits <- A.takeWhile1 isDigit_w8-  if B.length digits > 1 && B.unsafeHead digits == zero-    then fail "leading zero"-    else return (bsToInteger digits)---- | Parse a JSON number.-scientific :: Parser Scientific-scientific = do-  let minus = 45-      plus  = 43-  sign <- A.peekWord8'-  let !positive = sign == plus || sign /= minus-  when (sign == plus || sign == minus) $-    void A.anyWord8--  n <- decimal0--  let f fracDigits = SP (B.foldl' step n fracDigits)-                        (negate $ B.length fracDigits)-      step a w = a * 10 + fromIntegral (w - 48)--  dotty <- A.peekWord8-  -- '.' -> ascii 46-  SP c e <- case dotty of-              Just 46 -> A.anyWord8 *> (f <$> A.takeWhile1 isDigit_w8)-              _       -> pure (SP n 0)--  let !signedCoeff | positive  =  c-                   | otherwise = -c--  let littleE = 101-      bigE    = 69-  (A.satisfy (\ex -> ex == littleE || ex == bigE) *>-      fmap (Sci.scientific signedCoeff . (e +)) (signed decimal)) <|>-    return (Sci.scientific signedCoeff    e)-{-# INLINE scientific #-}-------------------- Copy-pasted and adapted from base --------------------------bsToInteger :: B.ByteString -> Integer-bsToInteger bs-    | l > 40    = valInteger 10 l [ fromIntegral (w - 48) | w <- B.unpack bs ]-    | otherwise = bsToIntegerSimple bs-  where-    l = B.length bs--bsToIntegerSimple :: B.ByteString -> Integer-bsToIntegerSimple = B.foldl' step 0 where-  step a b = a * 10 + fromIntegral (b - 48) -- 48 = '0'---- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b--- digits are combined into a single radix b^2 digit. This process is--- repeated until we are left with a single digit. This algorithm--- performs well only on large inputs, so we use the simple algorithm--- for smaller inputs.-valInteger :: Integer -> Int -> [Integer] -> Integer-valInteger = go-  where-    go :: Integer -> Int -> [Integer] -> Integer-    go _ _ []  = 0-    go _ _ [d] = d-    go b l ds-        | l > 40 = b' `seq` go b' l' (combine b ds')-        | otherwise = valSimple b ds-      where-        -- ensure that we have an even number of digits-        -- before we call combine:-        ds' = if even l then ds else 0 : ds-        b' = b * b-        l' = (l + 1) `quot` 2--    combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)-      where-        d = d1 * b + d2-    combine _ []  = []-    combine _ [_] = errorWithoutStackTrace "this should not happen"---- The following algorithm is only linear for types whose Num operations--- are in constant time.-valSimple :: Integer -> [Integer] -> Integer-valSimple base = go 0-  where-    go r [] = r-    go r (d : ds) = r' `seq` go r' ds-      where-        r' = r * base + fromIntegral d
− Data/Aeson/Parser/Time.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Aeson.Parser.Time-    (-      run-    , day-    , month-    , quarter-    , localTime-    , timeOfDay-    , timeZone-    , utcTime-    , zonedTime-    ) where--import Prelude.Compat--import Data.Attoparsec.Text (Parser)-import Data.Text (Text)-import Data.Time.Calendar (Day)-import Data.Time.Calendar.Quarter.Compat (Quarter)-import Data.Time.Calendar.Month.Compat (Month)-import Data.Time.Clock (UTCTime(..))-import qualified Data.Aeson.Types.Internal as Aeson-import qualified Data.Attoparsec.Text as A-import qualified Data.Attoparsec.Time as T-import qualified Data.Time.LocalTime as Local---- | Run an attoparsec parser as an aeson parser.-run :: Parser a -> Text -> Aeson.Parser a-run p t = case A.parseOnly (p <* A.endOfInput) t of-            Left err -> fail $ "could not parse date: " ++ err-            Right r  -> return r---- | Parse a date of the form @[+,-]YYYY-MM-DD@.-day :: Parser Day-day = T.day-{-# INLINE day #-}---- | Parse a date of the form @[+,-]YYYY-MM@.-month :: Parser Month-month = T.month-{-# INLINE month #-}---- | Parse a date of the form @[+,-]YYYY-QN@.-quarter :: Parser Quarter-quarter = T.quarter-{-# INLINE quarter #-}---- | Parse a time of the form @HH:MM[:SS[.SSS]]@.-timeOfDay :: Parser Local.TimeOfDay-timeOfDay = T.timeOfDay-{-# INLINE timeOfDay #-}---- | Parse a quarter of the form @[+,-]YYYY-QN@.---- | Parse a time zone, and return 'Nothing' if the offset from UTC is--- zero. (This makes some speedups possible.)-timeZone :: Parser (Maybe Local.TimeZone)-timeZone = T.timeZone-{-# INLINE timeZone #-}---- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@.--- The space may be replaced with a @T@.  The number of seconds is optional--- and may be followed by a fractional component.-localTime :: Parser Local.LocalTime-localTime = T.localTime-{-# INLINE localTime #-}---- | Behaves as 'zonedTime', but converts any time zone offset into a--- UTC time.-utcTime :: Parser UTCTime-utcTime = T.utcTime-{-# INLINE utcTime #-}---- | Parse a date with time zone info. Acceptable formats:------ @YYYY-MM-DD HH:MM Z@--- @YYYY-MM-DD HH:MM:SS Z@--- @YYYY-MM-DD HH:MM:SS.SSS Z@------ The first space may instead be a @T@, and the second space is--- optional.  The @Z@ represents UTC.  The @Z@ may be replaced with a--- time zone offset of the form @+0000@ or @-08:00@, where the first--- two digits are hours, the @:@ is optional and the second two digits--- (also optional) are minutes.-zonedTime :: Parser Local.ZonedTime-zonedTime = T.zonedTime-{-# INLINE zonedTime #-}
− Data/Aeson/Parser/Unescape.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE CPP #-}-module Data.Aeson.Parser.Unescape-  (-    unescapeText-  ) where--#ifdef CFFI-import Data.Aeson.Parser.UnescapeFFI (unescapeText)-#else-import Data.Aeson.Parser.UnescapePure (unescapeText)-#endif
− Data/Aeson/QQ/Simple.hs 
@@ -1,25 +0,0 @@--- | Like "Data.Aeson.QQ" but without interpolation.-module Data.Aeson.QQ.Simple (aesonQQ) where--import           Data.Aeson-import qualified Data.Text                  as T-import qualified Data.Text.Encoding         as TE-import           Language.Haskell.TH-import           Language.Haskell.TH.Quote-import           Language.Haskell.TH.Syntax (Lift (..))-import           Prelude                    ()-import           Prelude.Compat--aesonQQ :: QuasiQuoter-aesonQQ = QuasiQuoter-    { quoteExp  = aesonExp-    , quotePat  = const $ error "No quotePat defined for jsonQQ"-    , quoteType = const $ error "No quoteType defined for jsonQQ"-    , quoteDec  = const $ error "No quoteDec defined for jsonQQ"-    }--aesonExp :: String -> ExpQ-aesonExp txt =-  case eitherDecodeStrict $ TE.encodeUtf8 $ T.pack txt of-    Left err  -> error $ "Error in aesonExp: " ++ show err-    Right val -> lift (val :: Value)
− Data/Aeson/TH.hs 
@@ -1,2018 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 800--- a) THQ works on cross-compilers and unregisterised GHCs--- b) may make compilation faster as no dynamic loading is ever needed (not sure about this)--- c) removes one hindrance to have code inferred as SafeHaskell safe-{-# LANGUAGE TemplateHaskellQuotes #-}-#else-{-# LANGUAGE TemplateHaskell #-}-#endif--#include "incoherent-compat.h"-#include "overlapping-compat.h"--{-|-Module:      Data.Aeson.TH-Copyright:   (c) 2011-2016 Bryan O'Sullivan-             (c) 2011 MailRank, Inc.-License:     BSD3-Stability:   experimental-Portability: portable--Functions to mechanically derive 'ToJSON' and 'FromJSON' instances. Note that-you need to enable the @TemplateHaskell@ language extension in order to use this-module.--An example shows how instances are generated for arbitrary data types. First we-define a data type:--@-data D a = Nullary-         | Unary Int-         | Product String Char a-         | Record { testOne   :: Double-                  , testTwo   :: Bool-                  , testThree :: D a-                  } deriving Eq-@--Next we derive the necessary instances. Note that we make use of the-feature to change record field names. In this case we drop the first 4-characters of every field name. We also modify constructor names by-lower-casing them:--@-$('deriveJSON' 'defaultOptions'{'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower} ''D)-@--Now we can use the newly created instances.--@-d :: D 'Int'-d = Record { testOne = 3.14159-           , testTwo = 'True'-           , testThree = Product \"test\" \'A\' 123-           }-@-->>> fromJSON (toJSON d) == Success d-> True--This also works for data family instances, but instead of passing in the data-family name (with double quotes), we pass in a data family instance-constructor (with a single quote):--@-data family DF a-data instance DF Int = DF1 Int-                     | DF2 Int Int-                     deriving Eq--$('deriveJSON' 'defaultOptions' 'DF1)--- Alternatively, one could pass 'DF2 instead-@--Please note that you can derive instances for tuples using the following syntax:--@--- FromJSON and ToJSON instances for 4-tuples.-$('deriveJSON' 'defaultOptions' ''(,,,))-@---}-module Data.Aeson.TH-    (-      -- * Encoding configuration-      Options(..)-    , SumEncoding(..)-    , defaultOptions-    , defaultTaggedObject--     -- * FromJSON and ToJSON derivation-    , deriveJSON-    , deriveJSON1-    , deriveJSON2--    , deriveToJSON-    , deriveToJSON1-    , deriveToJSON2-    , deriveFromJSON-    , deriveFromJSON1-    , deriveFromJSON2--    , mkToJSON-    , mkLiftToJSON-    , mkLiftToJSON2-    , mkToEncoding-    , mkLiftToEncoding-    , mkLiftToEncoding2-    , mkParseJSON-    , mkLiftParseJSON-    , mkLiftParseJSON2-    ) where--import Prelude.Compat hiding (fail)---- We don't have MonadFail Q, so we should use `fail` from real `Prelude`-import Prelude (fail)--import Control.Applicative ((<|>))-import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))-import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)-import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))-import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)-import Data.Aeson.Types.ToJSON (fromPairs, pair)-import Control.Monad (liftM2, unless, when)-import Data.Foldable (foldr')-#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)-import Data.List (nub)-#endif-import Data.List (foldl', genericLength, intercalate, partition, union)-import Data.List.NonEmpty ((<|), NonEmpty((:|)))-import Data.Map (Map)-import Data.Maybe (catMaybes, fromMaybe, mapMaybe)-import qualified Data.Monoid as Monoid-import Data.Set (Set)-import Language.Haskell.TH hiding (Arity)-import Language.Haskell.TH.Datatype-#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))-import Language.Haskell.TH.Syntax (mkNameG_tc)-#endif-import Text.Printf (printf)-import qualified Data.Aeson.Encoding.Internal as E-import qualified Data.Foldable as F (all)-import qualified Data.HashMap.Strict as H (difference, fromList, keys, lookup, toList)-import qualified Data.List.NonEmpty as NE (length, reverse)-import qualified Data.Map as M (fromList, keys, lookup , singleton, size)-import qualified Data.Semigroup as Semigroup (Option(..))-import qualified Data.Set as Set (empty, insert, member)-import qualified Data.Text as T (Text, pack, unpack)-import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)-import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)------------------------------------------------------------------------------------- Convenience------------------------------------------------------------------------------------- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given--- data type or data family instance constructor.------ This is a convienience function which is equivalent to calling both--- 'deriveToJSON' and 'deriveFromJSON'.-deriveJSON :: Options-           -- ^ Encoding options.-           -> Name-           -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'-           -- instances.-           -> Q [Dec]-deriveJSON = deriveJSONBoth deriveToJSON deriveFromJSON---- | Generates both 'ToJSON1' and 'FromJSON1' instance declarations for the given--- data type or data family instance constructor.------ This is a convienience function which is equivalent to calling both--- 'deriveToJSON1' and 'deriveFromJSON1'.-deriveJSON1 :: Options-            -- ^ Encoding options.-            -> Name-            -- ^ Name of the type for which to generate 'ToJSON1' and 'FromJSON1'-            -- instances.-            -> Q [Dec]-deriveJSON1 = deriveJSONBoth deriveToJSON1 deriveFromJSON1---- | Generates both 'ToJSON2' and 'FromJSON2' instance declarations for the given--- data type or data family instance constructor.------ This is a convienience function which is equivalent to calling both--- 'deriveToJSON2' and 'deriveFromJSON2'.-deriveJSON2 :: Options-            -- ^ Encoding options.-            -> Name-            -- ^ Name of the type for which to generate 'ToJSON2' and 'FromJSON2'-            -- instances.-            -> Q [Dec]-deriveJSON2 = deriveJSONBoth deriveToJSON2 deriveFromJSON2------------------------------------------------------------------------------------- ToJSON-----------------------------------------------------------------------------------{--TODO: Don't constrain phantom type variables.--data Foo a = Foo Int-instance (ToJSON a) ⇒ ToJSON Foo where ...--The above (ToJSON a) constraint is not necessary and perhaps undesirable.--}---- | Generates a 'ToJSON' instance declaration for the given data type or--- data family instance constructor.-deriveToJSON :: Options-             -- ^ Encoding options.-             -> Name-             -- ^ Name of the type for which to generate a 'ToJSON' instance-             -- declaration.-             -> Q [Dec]-deriveToJSON = deriveToJSONCommon toJSONClass---- | Generates a 'ToJSON1' instance declaration for the given data type or--- data family instance constructor.-deriveToJSON1 :: Options-              -- ^ Encoding options.-              -> Name-              -- ^ Name of the type for which to generate a 'ToJSON1' instance-              -- declaration.-              -> Q [Dec]-deriveToJSON1 = deriveToJSONCommon toJSON1Class---- | Generates a 'ToJSON2' instance declaration for the given data type or--- data family instance constructor.-deriveToJSON2 :: Options-              -- ^ Encoding options.-              -> Name-              -- ^ Name of the type for which to generate a 'ToJSON2' instance-              -- declaration.-              -> Q [Dec]-deriveToJSON2 = deriveToJSONCommon toJSON2Class--deriveToJSONCommon :: JSONClass-                   -- ^ The ToJSON variant being derived.-                   -> Options-                   -- ^ Encoding options.-                   -> Name-                   -- ^ Name of the type for which to generate an instance.-                   -> Q [Dec]-deriveToJSONCommon = deriveJSONClass [ (ToJSON,     \jc _ -> consToValue Value jc)-                                     , (ToEncoding, \jc _ -> consToValue Encoding jc)-                                     ]---- | Generates a lambda expression which encodes the given data type or--- data family instance constructor as a 'Value'.-mkToJSON :: Options -- ^ Encoding options.-         -> Name -- ^ Name of the type to encode.-         -> Q Exp-mkToJSON = mkToJSONCommon toJSONClass---- | Generates a lambda expression which encodes the given data type or--- data family instance constructor as a 'Value' by using the given encoding--- function on occurrences of the last type parameter.-mkLiftToJSON :: Options -- ^ Encoding options.-             -> Name -- ^ Name of the type to encode.-             -> Q Exp-mkLiftToJSON = mkToJSONCommon toJSON1Class---- | Generates a lambda expression which encodes the given data type or--- data family instance constructor as a 'Value' by using the given encoding--- functions on occurrences of the last two type parameters.-mkLiftToJSON2 :: Options -- ^ Encoding options.-              -> Name -- ^ Name of the type to encode.-              -> Q Exp-mkLiftToJSON2 = mkToJSONCommon toJSON2Class--mkToJSONCommon :: JSONClass -- ^ Which class's method is being derived.-               -> Options -- ^ Encoding options.-               -> Name -- ^ Name of the encoded type.-               -> Q Exp-mkToJSONCommon = mkFunCommon (\jc _ -> consToValue Value jc)---- | Generates a lambda expression which encodes the given data type or--- data family instance constructor as a JSON string.-mkToEncoding :: Options -- ^ Encoding options.-             -> Name -- ^ Name of the type to encode.-             -> Q Exp-mkToEncoding = mkToEncodingCommon toJSONClass---- | Generates a lambda expression which encodes the given data type or--- data family instance constructor as a JSON string by using the given encoding--- function on occurrences of the last type parameter.-mkLiftToEncoding :: Options -- ^ Encoding options.-                 -> Name -- ^ Name of the type to encode.-                 -> Q Exp-mkLiftToEncoding = mkToEncodingCommon toJSON1Class---- | Generates a lambda expression which encodes the given data type or--- data family instance constructor as a JSON string by using the given encoding--- functions on occurrences of the last two type parameters.-mkLiftToEncoding2 :: Options -- ^ Encoding options.-                  -> Name -- ^ Name of the type to encode.-                  -> Q Exp-mkLiftToEncoding2 = mkToEncodingCommon toJSON2Class--mkToEncodingCommon :: JSONClass -- ^ Which class's method is being derived.-                   -> Options -- ^ Encoding options.-                   -> Name -- ^ Name of the encoded type.-                   -> Q Exp-mkToEncodingCommon = mkFunCommon (\jc _ -> consToValue Encoding jc)---- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates--- code to generate a 'Value' or 'Encoding' of a number of constructors. All--- constructors must be from the same type.-consToValue :: ToJSONFun-            -- ^ The method ('toJSON' or 'toEncoding') being derived.-            -> JSONClass-            -- ^ The ToJSON variant being derived.-            -> Options-            -- ^ Encoding options.-            -> [Type]-            -- ^ The types from the data type/data family instance declaration-            -> [ConstructorInfo]-            -- ^ Constructors for which to generate JSON generating code.-            -> Q Exp--consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "-                             ++ "Not a single constructor given!"--consToValue target jc opts instTys cons = do-    value <- newName "value"-    tjs   <- newNameList "_tj"  $ arityInt jc-    tjls  <- newNameList "_tjl" $ arityInt jc-    let zippedTJs      = zip tjs tjls-        interleavedTJs = interleave tjs tjls-        lastTyVars     = map varTToName $ drop (length instTys - arityInt jc) instTys-        tvMap          = M.fromList $ zip lastTyVars zippedTJs-    lamE (map varP $ interleavedTJs ++ [value]) $-        caseE (varE value) (matches tvMap)-  where-    matches tvMap = case cons of-      -- A single constructor is directly encoded. The constructor itself may be-      -- forgotten.-      [con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con]-      _ | allNullaryToStringTag opts && all isNullary cons ->-              [ match (conP conName []) (normalB $ conStr target opts conName) []-              | con <- cons-              , let conName = constructorName con-              ]-        | otherwise -> [argsToValue target jc tvMap opts True con | con <- cons]---- | Name of the constructor as a quoted 'Value' or 'Encoding'.-conStr :: ToJSONFun -> Options -> Name -> Q Exp-conStr Value opts = appE [|String|] . conTxt opts-conStr Encoding opts = appE [|E.text|] . conTxt opts---- | Name of the constructor as a quoted 'Text'.-conTxt :: Options -> Name -> Q Exp-conTxt opts = appE [|T.pack|] . stringE . conString opts---- | Name of the constructor.-conString :: Options -> Name -> String-conString opts = constructorTagModifier opts . nameBase---- | If constructor is nullary.-isNullary :: ConstructorInfo -> Bool-isNullary ConstructorInfo { constructorVariant = NormalConstructor-                          , constructorFields  = tys } = null tys-isNullary _ = False---- | Wrap fields of a non-record constructor. See 'sumToValue'.-opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ-opaqueSumToValue target opts multiCons nullary conName value =-  sumToValue target opts multiCons nullary conName-    value-    pairs-  where-    pairs contentsFieldName = pairE contentsFieldName value---- | Wrap fields of a record constructor. See 'sumToValue'.-recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ-recordSumToValue target opts multiCons nullary conName pairs =-  sumToValue target opts multiCons nullary conName-    (fromPairsE pairs)-    (const pairs)---- | Wrap fields of a constructor.-sumToValue-  :: ToJSONFun-  -- ^ The method being derived.-  -> Options-  -- ^ Deriving options.-  -> Bool-  -- ^ Does this type have multiple constructors.-  -> Bool-  -- ^ Is this constructor nullary.-  -> Name-  -- ^ Constructor name.-  -> ExpQ-  -- ^ Fields of the constructor as a 'Value' or 'Encoding'.-  -> (String -> ExpQ)-  -- ^ Representation of an 'Object' fragment used for the 'TaggedObject'-  -- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method-  -- being derived.-  ---  -- - For non-records, produces a pair @"contentsFieldName":value@,-  --   given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'.-  -- - For records, produces the list of pairs corresponding to fields of the-  --   encoded value (ignores the argument). See 'recordSumToValue'.-  -> ExpQ-sumToValue target opts multiCons nullary conName value pairs-    | multiCons =-        case sumEncoding opts of-          TwoElemArray ->-            array target [conStr target opts conName, value]-          TaggedObject{tagFieldName, contentsFieldName} ->-            -- TODO: Maybe throw an error in case-            -- tagFieldName overwrites a field in pairs.-            let tag = pairE tagFieldName (conStr target opts conName)-                content = pairs contentsFieldName-            in fromPairsE $-              if nullary then tag else infixApp tag [|(Monoid.<>)|] content-          ObjectWithSingleField ->-            objectE [(conString opts conName, value)]-          UntaggedValue | nullary -> conStr target opts conName-          UntaggedValue -> value-    | otherwise = value---- | Generates code to generate the JSON encoding of a single constructor.-argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match---- Polyadic constructors with special case for unary constructors.-argsToValue target jc tvMap opts multiCons-  ConstructorInfo { constructorName    = conName-                  , constructorVariant = NormalConstructor-                  , constructorFields  = argTys } = do-    argTys' <- mapM resolveTypeSynonyms argTys-    let len = length argTys'-    args <- newNameList "arg" len-    let js = case [ dispatchToJSON target jc conName tvMap argTy-                      `appE` varE arg-                  | (arg, argTy) <- zip args argTys'-                  ] of-               -- Single argument is directly converted.-               [e] -> e-               -- Zero and multiple arguments are converted to a JSON array.-               es -> array target es--    match (conP conName $ map varP args)-          (normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js)-          []---- Records.-argsToValue target jc tvMap opts multiCons-  info@ConstructorInfo { constructorName    = conName-                       , constructorVariant = RecordConstructor fields-                       , constructorFields  = argTys } =-    case (unwrapUnaryRecords opts, not multiCons, argTys) of-      (True,True,[_]) -> argsToValue target jc tvMap opts multiCons-                                     (info{constructorVariant = NormalConstructor})-      _ -> do-        argTys' <- mapM resolveTypeSynonyms argTys-        args <- newNameList "arg" $ length argTys'-        let pairs | omitNothingFields opts = infixApp maybeFields-                                                      [|(Monoid.<>)|]-                                                      restFields-                  | otherwise = mconcatE (map pureToPair argCons)--            argCons = zip3 (map varE args) argTys' fields--            maybeFields = mconcatE (map maybeToPair maybes)--            restFields = mconcatE (map pureToPair rest)--            (maybes0, rest0) = partition isMaybe argCons-            (options, rest) = partition isOption rest0-            maybes = maybes0 ++ map optionToMaybe options--            maybeToPair = toPairLifted True-            pureToPair = toPairLifted False--            toPairLifted lifted (arg, argTy, field) =-              let toValue = dispatchToJSON target jc conName tvMap argTy-                  fieldName = fieldLabel opts field-                  e arg' = pairE fieldName (toValue `appE` arg')-              in if lifted-                then do-                  x <- newName "x"-                  [|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg-                else e arg--        match (conP conName $ map varP args)-              (normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs)-              []---- Infix constructors.-argsToValue target jc tvMap opts multiCons-  ConstructorInfo { constructorName    = conName-                  , constructorVariant = InfixConstructor-                  , constructorFields  = argTys } = do-    [alTy, arTy] <- mapM resolveTypeSynonyms argTys-    al <- newName "argL"-    ar <- newName "argR"-    match (infixP (varP al) conName (varP ar))-          ( normalB-          $ opaqueSumToValue target opts multiCons False conName-          $ array target-              [ dispatchToJSON target jc conName tvMap aTy-                  `appE` varE a-              | (a, aTy) <- [(al,alTy), (ar,arTy)]-              ]-          )-          []--isMaybe :: (a, Type, b) -> Bool-isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe-isMaybe _                       = False--isOption :: (a, Type, b) -> Bool-isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option-isOption _                       = False--optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)-optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)--(<^>) :: ExpQ -> ExpQ -> ExpQ-(<^>) a b = infixApp a [|(E.><)|] b-infixr 6 <^>--(<%>) :: ExpQ -> ExpQ -> ExpQ-(<%>) a b = a <^> [|E.comma|] <^> b-infixr 4 <%>---- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').-array :: ToJSONFun -> [ExpQ] -> ExpQ-array Encoding [] = [|E.emptyArray_|]-array Value [] = [|Array V.empty|]-array Encoding es = [|E.wrapArray|] `appE` foldr1 (<%>) es-array Value es = do-  mv <- newName "mv"-  let newMV = bindS (varP mv)-                    ([|VM.unsafeNew|] `appE`-                      litE (integerL $ fromIntegral (length es)))-      stmts = [ noBindS $-                  [|VM.unsafeWrite|] `appE`-                    varE mv `appE`-                      litE (integerL ix) `appE`-                        e-              | (ix, e) <- zip [(0::Integer)..] es-              ]-      ret = noBindS $ [|return|] `appE` varE mv-  [|Array|] `appE`-             (varE 'V.create `appE`-               doE (newMV:stmts++[ret]))---- | Wrap an associative list of keys and quoted values in a quoted 'Object'.-objectE :: [(String, ExpQ)] -> ExpQ-objectE = fromPairsE . mconcatE . fmap (uncurry pairE)---- | 'mconcat' a list of fixed length.------ > mconcatE [ [|x|], [|y|], [|z|] ] = [| x <> (y <> z) |]-mconcatE :: [ExpQ] -> ExpQ-mconcatE [] = [|Monoid.mempty|]-mconcatE [x] = x-mconcatE (x : xs) = infixApp x [|(Monoid.<>)|] (mconcatE xs)--fromPairsE :: ExpQ -> ExpQ-fromPairsE = ([|fromPairs|] `appE`)---- | Create (an encoding of) a key-value pair.------ > pairE "k" [|v|] = [|pair "k" v|]-pairE :: String -> ExpQ -> ExpQ-pairE k v = [|pair k|] `appE` v------------------------------------------------------------------------------------- FromJSON------------------------------------------------------------------------------------- | Generates a 'FromJSON' instance declaration for the given data type or--- data family instance constructor.-deriveFromJSON :: Options-               -- ^ Encoding options.-               -> Name-               -- ^ Name of the type for which to generate a 'FromJSON' instance-               -- declaration.-               -> Q [Dec]-deriveFromJSON = deriveFromJSONCommon fromJSONClass---- | Generates a 'FromJSON1' instance declaration for the given data type or--- data family instance constructor.-deriveFromJSON1 :: Options-                -- ^ Encoding options.-                -> Name-                -- ^ Name of the type for which to generate a 'FromJSON1' instance-                -- declaration.-                -> Q [Dec]-deriveFromJSON1 = deriveFromJSONCommon fromJSON1Class---- | Generates a 'FromJSON2' instance declaration for the given data type or--- data family instance constructor.-deriveFromJSON2 :: Options-                -- ^ Encoding options.-                -> Name-                -- ^ Name of the type for which to generate a 'FromJSON3' instance-                -- declaration.-                -> Q [Dec]-deriveFromJSON2 = deriveFromJSONCommon fromJSON2Class--deriveFromJSONCommon :: JSONClass-                     -- ^ The FromJSON variant being derived.-                     -> Options-                     -- ^ Encoding options.-                     -> Name-                     -- ^ Name of the type for which to generate an instance.-                     -- declaration.-                     -> Q [Dec]-deriveFromJSONCommon = deriveJSONClass [(ParseJSON, consFromJSON)]---- | Generates a lambda expression which parses the JSON encoding of the given--- data type or data family instance constructor.-mkParseJSON :: Options -- ^ Encoding options.-            -> Name -- ^ Name of the encoded type.-            -> Q Exp-mkParseJSON = mkParseJSONCommon fromJSONClass---- | Generates a lambda expression which parses the JSON encoding of the given--- data type or data family instance constructor by using the given parsing--- function on occurrences of the last type parameter.-mkLiftParseJSON :: Options -- ^ Encoding options.-                -> Name -- ^ Name of the encoded type.-                -> Q Exp-mkLiftParseJSON = mkParseJSONCommon fromJSON1Class---- | Generates a lambda expression which parses the JSON encoding of the given--- data type or data family instance constructor by using the given parsing--- functions on occurrences of the last two type parameters.-mkLiftParseJSON2 :: Options -- ^ Encoding options.-                 -> Name -- ^ Name of the encoded type.-                 -> Q Exp-mkLiftParseJSON2 = mkParseJSONCommon fromJSON2Class--mkParseJSONCommon :: JSONClass -- ^ Which class's method is being derived.-                  -> Options -- ^ Encoding options.-                  -> Name -- ^ Name of the encoded type.-                  -> Q Exp-mkParseJSONCommon = mkFunCommon consFromJSON---- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates--- code to parse the JSON encoding of a number of constructors. All constructors--- must be from the same type.-consFromJSON :: JSONClass-             -- ^ The FromJSON variant being derived.-             -> Name-             -- ^ Name of the type to which the constructors belong.-             -> Options-             -- ^ Encoding options-             -> [Type]-             -- ^ The types from the data type/data family instance declaration-             -> [ConstructorInfo]-             -- ^ Constructors for which to generate JSON parsing code.-             -> Q Exp--consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "-                                ++ "Not a single constructor given!"--consFromJSON jc tName opts instTys cons = do-  value <- newName "value"-  pjs   <- newNameList "_pj"  $ arityInt jc-  pjls  <- newNameList "_pjl" $ arityInt jc-  let zippedPJs      = zip pjs pjls-      interleavedPJs = interleave pjs pjls-      lastTyVars     = map varTToName $ drop (length instTys - arityInt jc) instTys-      tvMap          = M.fromList $ zip lastTyVars zippedPJs-  lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap--  where-    checkExi tvMap con = checkExistentialContext jc tvMap-                                                 (constructorContext con)-                                                 (constructorName con)--    lamExpr value tvMap = case cons of-      [con]-        | not (tagSingleConstructors opts)-            -> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value)-      _ | sumEncoding opts == UntaggedValue-            -> parseUntaggedValue tvMap cons value-        | otherwise-            -> caseE (varE value) $-                   if allNullaryToStringTag opts && all isNullary cons-                   then allNullaryMatches-                   else mixedMatches tvMap--    allNullaryMatches =-      [ do txt <- newName "txt"-           match (conP 'String [varP txt])-                 (guardedB $-                  [ liftM2 (,) (normalG $-                                  infixApp (varE txt)-                                           [|(==)|]-                                           (conTxt opts conName)-                               )-                               ([|pure|] `appE` conE conName)-                  | con <- cons-                  , let conName = constructorName con-                  ]-                  ++-                  [ liftM2 (,)-                      (normalG [|otherwise|])-                      ( [|noMatchFail|]-                        `appE` litE (stringL $ show tName)-                        `appE` ([|T.unpack|] `appE` varE txt)-                      )-                  ]-                 )-                 []-      , do other <- newName "other"-           match (varP other)-                 (normalB $ [|noStringFail|]-                    `appE` litE (stringL $ show tName)-                    `appE` ([|valueConName|] `appE` varE other)-                 )-                 []-      ]--    mixedMatches tvMap =-        case sumEncoding opts of-          TaggedObject {tagFieldName, contentsFieldName} ->-            parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName-          UntaggedValue -> error "UntaggedValue: Should be handled already"-          ObjectWithSingleField ->-            parseObject $ parseObjectWithSingleField tvMap-          TwoElemArray ->-            [ do arr <- newName "array"-                 match (conP 'Array [varP arr])-                       (guardedB-                        [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)-                                                         [|(==)|]-                                                         (litE $ integerL 2))-                                     (parse2ElemArray tvMap arr)-                        , liftM2 (,) (normalG [|otherwise|])-                                     ([|not2ElemArray|]-                                       `appE` litE (stringL $ show tName)-                                       `appE` ([|V.length|] `appE` varE arr))-                        ]-                       )-                       []-            , do other <- newName "other"-                 match (varP other)-                       ( normalB-                         $ [|noArrayFail|]-                             `appE` litE (stringL $ show tName)-                             `appE` ([|valueConName|] `appE` varE other)-                       )-                       []-            ]--    parseObject f =-        [ do obj <- newName "obj"-             match (conP 'Object [varP obj]) (normalB $ f obj) []-        , do other <- newName "other"-             match (varP other)-                   ( normalB-                     $ [|noObjectFail|]-                         `appE` litE (stringL $ show tName)-                         `appE` ([|valueConName|] `appE` varE other)-                   )-                   []-        ]--    parseTaggedObject tvMap typFieldName valFieldName obj = do-      conKey <- newName "conKey"-      doE [ bindS (varP conKey)-                  (infixApp (varE obj)-                            [|(.:)|]-                            ([|T.pack|] `appE` stringE typFieldName))-          , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject-          ]--    parseUntaggedValue tvMap cons' conVal =-        foldr1 (\e e' -> infixApp e [|(<|>)|] e')-               (map (\x -> parseValue tvMap x conVal) cons')--    parseValue _tvMap-        ConstructorInfo { constructorName    = conName-                        , constructorVariant = NormalConstructor-                        , constructorFields  = [] }-        conVal = do-      str <- newName "str"-      caseE (varE conVal)-        [ match (conP 'String [varP str])-                (guardedB-                  [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName)-                               )-                               ([|pure|] `appE` conE conName)-                  ]-                )-                []-        , matchFailed tName conName "String"-        ]-    parseValue tvMap con conVal =-      checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal)---    parse2ElemArray tvMap arr = do-      conKey <- newName "conKey"-      conVal <- newName "conVal"-      let letIx n ix =-              valD (varP n)-                   (normalB ([|V.unsafeIndex|] `appE`-                               varE arr `appE`-                               litE (integerL ix)))-                   []-      letE [ letIx conKey 0-           , letIx conVal 1-           ]-           (caseE (varE conKey)-                  [ do txt <- newName "txt"-                       match (conP 'String [varP txt])-                             (normalB $ parseContents tvMap-                                                      txt-                                                      (Right conVal)-                                                      'conNotFoundFail2ElemArray-                             )-                             []-                  , do other <- newName "other"-                       match (varP other)-                             ( normalB-                               $ [|firstElemNoStringFail|]-                                     `appE` litE (stringL $ show tName)-                                     `appE` ([|valueConName|] `appE` varE other)-                             )-                             []-                  ]-           )--    parseObjectWithSingleField tvMap obj = do-      conKey <- newName "conKey"-      conVal <- newName "conVal"-      caseE ([e|H.toList|] `appE` varE obj)-            [ match (listP [tupP [varP conKey, varP conVal]])-                    (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField)-                    []-            , do other <- newName "other"-                 match (varP other)-                       (normalB $ [|wrongPairCountFail|]-                                  `appE` litE (stringL $ show tName)-                                  `appE` ([|show . length|] `appE` varE other)-                       )-                       []-            ]--    parseContents tvMap conKey contents errorFun =-        caseE (varE conKey)-              [ match wildP-                      ( guardedB $-                        [ do g <- normalG $ infixApp (varE conKey)-                                                     [|(==)|]-                                                     ([|T.pack|] `appE`-                                                        conNameExp opts con)-                             e <- checkExi tvMap con $-                                  parseArgs jc tvMap tName opts con contents-                             return (g, e)-                        | con <- cons-                        ]-                        ++-                        [ liftM2 (,)-                                 (normalG [e|otherwise|])-                                 ( varE errorFun-                                   `appE` litE (stringL $ show tName)-                                   `appE` listE (map ( litE-                                                     . stringL-                                                     . constructorTagModifier opts-                                                     . nameBase-                                                     . constructorName-                                                     ) cons-                                                )-                                   `appE` ([|T.unpack|] `appE` varE conKey)-                                 )-                        ]-                      )-                      []-              ]--parseNullaryMatches :: Name -> Name -> [Q Match]-parseNullaryMatches tName conName =-    [ do arr <- newName "arr"-         match (conP 'Array [varP arr])-               (guardedB-                [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)-                             ([|pure|] `appE` conE conName)-                , liftM2 (,) (normalG [|otherwise|])-                             (parseTypeMismatch tName conName-                                (litE $ stringL "an empty Array")-                                (infixApp (litE $ stringL "Array of length ")-                                          [|(++)|]-                                          ([|show . V.length|] `appE` varE arr)-                                )-                             )-                ]-               )-               []-    , matchFailed tName conName "Array"-    ]--parseUnaryMatches :: JSONClass -> TyVarMap -> Type -> Name -> [Q Match]-parseUnaryMatches jc tvMap argTy conName =-    [ do arg <- newName "arg"-         match (varP arg)-               ( normalB $ infixApp (conE conName)-                                    [|(<$>)|]-                                    (dispatchParseJSON jc conName tvMap argTy-                                      `appE` varE arg)-               )-               []-    ]--parseRecord :: JSONClass-            -> TyVarMap-            -> [Type]-            -> Options-            -> Name-            -> Name-            -> [Name]-            -> Name-            -> Bool-            -> ExpQ-parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =-    (if rejectUnknownFields opts-     then infixApp checkUnknownRecords [|(>>)|]-     else id) $-    foldl' (\a b -> infixApp a [|(<*>)|] b)-           (infixApp (conE conName) [|(<$>)|] x)-           xs-    where-      tagFieldNameAppender =-          if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id-      knownFields = appE [|H.fromList|] $ listE $-          map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $-              tagFieldNameAppender $ map (fieldLabel opts) fields-      checkUnknownRecords =-          caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields)-              [ match (listP []) (normalB [|return ()|]) []-              , newName "unknownFields" >>=-                  \unknownFields -> match (varP unknownFields)-                      (normalB $ appE [|fail|] $ infixApp-                          (litE (stringL "Unknown fields: "))-                          [|(++)|]-                          (appE [|show|] (varE unknownFields)))-                      []-              ]-      x:xs = [ [|lookupField|]-               `appE` dispatchParseJSON jc conName tvMap argTy-               `appE` litE (stringL $ show tName)-               `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)-               `appE` varE obj-               `appE` ( [|T.pack|] `appE` stringE (fieldLabel opts field)-                      )-             | (field, argTy) <- zip fields argTys-             ]--getValField :: Name -> String -> [MatchQ] -> Q Exp-getValField obj valFieldName matches = do-  val <- newName "val"-  doE [ bindS (varP val) $ infixApp (varE obj)-                                    [|(.:)|]-                                    ([|T.pack|] `appE`-                                       litE (stringL valFieldName))-      , noBindS $ caseE (varE val) matches-      ]--matchCases :: Either (String, Name) Name -> [MatchQ] -> Q Exp-matchCases (Left (valFieldName, obj)) = getValField obj valFieldName-matchCases (Right valName)            = caseE (varE valName)---- | Generates code to parse the JSON encoding of a single constructor.-parseArgs :: JSONClass -- ^ The FromJSON variant being derived.-          -> TyVarMap -- ^ Maps the last type variables to their decoding-                      --   function arguments.-          -> Name -- ^ Name of the type to which the constructor belongs.-          -> Options -- ^ Encoding options.-          -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.-          -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or-                                        --   Right valName-          -> Q Exp--- Nullary constructors.-parseArgs _ _ _ _-  ConstructorInfo { constructorName    = conName-                  , constructorVariant = NormalConstructor-                  , constructorFields  = [] }-  (Left _) =-    [|pure|] `appE` conE conName-parseArgs _ _ tName _-  ConstructorInfo { constructorName    = conName-                  , constructorVariant = NormalConstructor-                  , constructorFields  = [] }-  (Right valName) =-    caseE (varE valName) $ parseNullaryMatches tName conName---- Unary constructors.-parseArgs jc tvMap _ _-  ConstructorInfo { constructorName    = conName-                  , constructorVariant = NormalConstructor-                  , constructorFields  = [argTy] }-  contents = do-    argTy' <- resolveTypeSynonyms argTy-    matchCases contents $ parseUnaryMatches jc tvMap argTy' conName---- Polyadic constructors.-parseArgs jc tvMap tName _-  ConstructorInfo { constructorName    = conName-                  , constructorVariant = NormalConstructor-                  , constructorFields  = argTys }-  contents = do-    argTys' <- mapM resolveTypeSynonyms argTys-    let len = genericLength argTys'-    matchCases contents $ parseProduct jc tvMap argTys' tName conName len---- Records.-parseArgs jc tvMap tName opts-  ConstructorInfo { constructorName    = conName-                  , constructorVariant = RecordConstructor fields-                  , constructorFields  = argTys }-  (Left (_, obj)) = do-    argTys' <- mapM resolveTypeSynonyms argTys-    parseRecord jc tvMap argTys' opts tName conName fields obj True-parseArgs jc tvMap tName opts-  info@ConstructorInfo { constructorName    = conName-                       , constructorVariant = RecordConstructor fields-                       , constructorFields  = argTys }-  (Right valName) =-    case (unwrapUnaryRecords opts,argTys) of-      (True,[_])-> parseArgs jc tvMap tName opts-                             (info{constructorVariant = NormalConstructor})-                             (Right valName)-      _ -> do-        obj <- newName "recObj"-        argTys' <- mapM resolveTypeSynonyms argTys-        caseE (varE valName)-          [ match (conP 'Object [varP obj]) (normalB $-              parseRecord jc tvMap argTys' opts tName conName fields obj False) []-          , matchFailed tName conName "Object"-          ]---- Infix constructors. Apart from syntax these are the same as--- polyadic constructors.-parseArgs jc tvMap tName _-  ConstructorInfo { constructorName    = conName-                  , constructorVariant = InfixConstructor-                  , constructorFields  = argTys }-  contents = do-    argTys' <- mapM resolveTypeSynonyms argTys-    matchCases contents $ parseProduct jc tvMap argTys' tName conName 2---- | Generates code to parse the JSON encoding of an n-ary--- constructor.-parseProduct :: JSONClass -- ^ The FromJSON variant being derived.-             -> TyVarMap -- ^ Maps the last type variables to their decoding-                         --   function arguments.-             -> [Type] -- ^ The argument types of the constructor.-             -> Name -- ^ Name of the type to which the constructor belongs.-             -> Name -- ^ 'Con'structor name.-             -> Integer -- ^ 'Con'structor arity.-             -> [Q Match]-parseProduct jc tvMap argTys tName conName numArgs =-    [ do arr <- newName "arr"-         -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"-         let x:xs = [ dispatchParseJSON jc conName tvMap argTy-                      `appE`-                      infixApp (varE arr)-                               [|V.unsafeIndex|]-                               (litE $ integerL ix)-                    | (argTy, ix) <- zip argTys [0 .. numArgs - 1]-                    ]-         match (conP 'Array [varP arr])-               (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr)-                                           [|(==)|]-                                           (litE $ integerL numArgs)-                                )-                                ( foldl' (\a b -> infixApp a [|(<*>)|] b)-                                         (infixApp (conE conName) [|(<$>)|] x)-                                         xs-                                )-                                ( parseTypeMismatch tName conName-                                    (litE $ stringL $ "Array of length " ++ show numArgs)-                                    ( infixApp (litE $ stringL "Array of length ")-                                               [|(++)|]-                                               ([|show . V.length|] `appE` varE arr)-                                    )-                                )-               )-               []-    , matchFailed tName conName "Array"-    ]------------------------------------------------------------------------------------- Parsing errors-----------------------------------------------------------------------------------matchFailed :: Name -> Name -> String -> MatchQ-matchFailed tName conName expected = do-  other <- newName "other"-  match (varP other)-        ( normalB $ parseTypeMismatch tName conName-                      (litE $ stringL expected)-                      ([|valueConName|] `appE` varE other)-        )-        []--parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ-parseTypeMismatch tName conName expected actual =-    foldl appE-          [|parseTypeMismatch'|]-          [ litE $ stringL $ nameBase conName-          , litE $ stringL $ show tName-          , expected-          , actual-          ]--class LookupField a where-    lookupField :: (Value -> Parser a) -> String -> String-                -> Object -> T.Text -> Parser a--instance OVERLAPPABLE_ LookupField a where-    lookupField = lookupFieldWith--instance INCOHERENT_ LookupField (Maybe a) where-    lookupField pj _ _ = parseOptionalFieldWith pj--instance INCOHERENT_ LookupField (Semigroup.Option a) where-    lookupField pj tName rec obj key =-        fmap Semigroup.Option-             (lookupField (fmap Semigroup.getOption . pj) tName rec obj key)--lookupFieldWith :: (Value -> Parser a) -> String -> String-                -> Object -> T.Text -> Parser a-lookupFieldWith pj tName rec obj key =-    case H.lookup key obj of-      Nothing -> unknownFieldFail tName rec (T.unpack key)-      Just v  -> pj v <?> Key key--unknownFieldFail :: String -> String -> String -> Parser fail-unknownFieldFail tName rec key =-    fail $ printf "When parsing the record %s of type %s the key %s was not present."-                  rec tName key--noArrayFail :: String -> String -> Parser fail-noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o--noObjectFail :: String -> String -> Parser fail-noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o--firstElemNoStringFail :: String -> String -> Parser fail-firstElemNoStringFail t o = fail $ printf "When parsing %s expected an Array of 2 elements where the first element is a String but got %s at the first element." t o--wrongPairCountFail :: String -> String -> Parser fail-wrongPairCountFail t n =-    fail $ printf "When parsing %s expected an Object with a single tag/contents pair but got %s pairs."-                  t n--noStringFail :: String -> String -> Parser fail-noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o--noMatchFail :: String -> String -> Parser fail-noMatchFail t o =-    fail $ printf "When parsing %s expected a String with the tag of a constructor but got %s." t o--not2ElemArray :: String -> Int -> Parser fail-not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2 elements but got %i elements" t i--conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser fail-conNotFoundFail2ElemArray t cs o =-    fail $ printf "When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s."-                  t (intercalate ", " cs) o--conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser fail-conNotFoundFailObjectSingleField t cs o =-    fail $ printf "When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s."-                  t (intercalate ", " cs) o--conNotFoundFailTaggedObject :: String -> [String] -> String -> Parser fail-conNotFoundFailTaggedObject t cs o =-    fail $ printf "When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s."-                  t (intercalate ", " cs) o--parseTypeMismatch' :: String -> String -> String -> String -> Parser fail-parseTypeMismatch' conName tName expected actual =-    fail $ printf "When parsing the constructor %s of type %s expected %s but got %s."-                  conName tName expected actual------------------------------------------------------------------------------------- Shared ToJSON and FromJSON code------------------------------------------------------------------------------------- | Functionality common to 'deriveJSON', 'deriveJSON1', and 'deriveJSON2'.-deriveJSONBoth :: (Options -> Name -> Q [Dec])-               -- ^ Function which derives a flavor of 'ToJSON'.-               -> (Options -> Name -> Q [Dec])-               -- ^ Function which derives a flavor of 'FromJSON'.-               -> Options-               -- ^ Encoding options.-               -> Name-               -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'-               -- instances.-               -> Q [Dec]-deriveJSONBoth dtj dfj opts name =-    liftM2 (++) (dtj opts name) (dfj opts name)---- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.-deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]-                                        -> [ConstructorInfo] -> Q Exp)]-                -- ^ The class methods and the functions which derive them.-                -> JSONClass-                -- ^ The class for which to generate an instance.-                -> Options-                -- ^ Encoding options.-                -> Name-                -- ^ Name of the type for which to generate a class instance-                -- declaration.-                -> Q [Dec]-deriveJSONClass consFuns jc opts name = do-  info <- reifyDatatype name-  case info of-    DatatypeInfo { datatypeContext   = ctxt-                 , datatypeName      = parentName-#if MIN_VERSION_th_abstraction(0,3,0)-                 , datatypeInstTypes = instTys-#else-                 , datatypeVars      = instTys-#endif-                 , datatypeVariant   = variant-                 , datatypeCons      = cons-                 } -> do-      (instanceCxt, instanceType)-        <- buildTypeInstance parentName jc ctxt instTys variant-      (:[]) <$> instanceD (return instanceCxt)-                          (return instanceType)-                          (methodDecs parentName instTys cons)-  where-    methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]-    methodDecs parentName instTys cons = flip map consFuns $ \(jf, jfMaker) ->-      funD (jsonFunValName jf (arity jc))-           [ clause []-                    (normalB $ jfMaker jc parentName opts instTys cons)-                    []-           ]--mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)-            -- ^ The function which derives the expression.-            -> JSONClass-            -- ^ Which class's method is being derived.-            -> Options-            -- ^ Encoding options.-            -> Name-            -- ^ Name of the encoded type.-            -> Q Exp-mkFunCommon consFun jc opts name = do-  info <- reifyDatatype name-  case info of-    DatatypeInfo { datatypeContext   = ctxt-                 , datatypeName      = parentName-#if MIN_VERSION_th_abstraction(0,3,0)-                 , datatypeInstTypes = instTys-#else-                 , datatypeVars      = instTys-#endif-                 , datatypeVariant   = variant-                 , datatypeCons      = cons-                 } -> do-      -- We force buildTypeInstance here since it performs some checks for whether-      -- or not the provided datatype's kind matches the derived method's-      -- typeclass, and produces errors if it can't.-      !_ <- buildTypeInstance parentName jc ctxt instTys variant-      consFun jc parentName opts instTys cons--dispatchFunByType :: JSONClass-                  -> JSONFun-                  -> Name-                  -> TyVarMap-                  -> Bool -- True if we are using the function argument that works-                          -- on lists (e.g., [a] -> Value). False is we are using-                          -- the function argument that works on single values-                          -- (e.g., a -> Value).-                  -> Type-                  -> Q Exp-dispatchFunByType _ jf _ tvMap list (VarT tyName) =-    varE $ case M.lookup tyName tvMap of-                Just (tfjExp, tfjlExp) -> if list then tfjlExp else tfjExp-                Nothing                -> jsonFunValOrListName list jf Arity0-dispatchFunByType jc jf conName tvMap list (SigT ty _) =-    dispatchFunByType jc jf conName tvMap list ty-dispatchFunByType jc jf conName tvMap list (ForallT _ _ ty) =-    dispatchFunByType jc jf conName tvMap list ty-dispatchFunByType jc jf conName tvMap list ty = do-    let tyCon :: Type-        tyArgs :: [Type]-        tyCon :| tyArgs = unapplyTy ty--        numLastArgs :: Int-        numLastArgs = min (arityInt jc) (length tyArgs)--        lhsArgs, rhsArgs :: [Type]-        (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs--        tyVarNames :: [Name]-        tyVarNames = M.keys tvMap--    itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs-    if any (`mentionsName` tyVarNames) lhsArgs || itf-       then outOfPlaceTyVarError jc conName-       else if any (`mentionsName` tyVarNames) rhsArgs-            then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs)-                         : zipWith (dispatchFunByType jc jf conName tvMap)-                                   (cycle [False,True])-                                   (interleave rhsArgs rhsArgs)-            else varE $ jsonFunValOrListName list jf Arity0--dispatchToJSON-  :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp-dispatchToJSON target jc n tvMap =-    dispatchFunByType jc (targetToJSONFun target) n tvMap False--dispatchParseJSON-  :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp-dispatchParseJSON  jc n tvMap = dispatchFunByType jc ParseJSON  n tvMap False------------------------------------------------------------------------------------- Utility functions------------------------------------------------------------------------------------- For the given Types, generate an instance context and head.-buildTypeInstance :: Name-                  -- ^ The type constructor or data family name-                  -> JSONClass-                  -- ^ The typeclass to derive-                  -> Cxt-                  -- ^ The datatype context-                  -> [Type]-                  -- ^ The types to instantiate the instance with-                  -> DatatypeVariant-                  -- ^ Are we dealing with a data family instance or not-                  -> Q (Cxt, Type)-buildTypeInstance tyConName jc dataCxt varTysOrig variant = do-    -- Make sure to expand through type/kind synonyms! Otherwise, the-    -- eta-reduction check might get tripped up over type variables in a-    -- synonym that are actually dropped.-    -- (See GHC Trac #11416 for a scenario where this actually happened.)-    varTysExp <- mapM resolveTypeSynonyms varTysOrig--    let remainingLength :: Int-        remainingLength = length varTysOrig - arityInt jc--        droppedTysExp :: [Type]-        droppedTysExp = drop remainingLength varTysExp--        droppedStarKindStati :: [StarKindStatus]-        droppedStarKindStati = map canRealizeKindStar droppedTysExp--    -- Check there are enough types to drop and that all of them are either of-    -- kind * or kind k (for some kind variable k). If not, throw an error.-    when (remainingLength < 0 || elem NotKindStar droppedStarKindStati) $-      derivingKindError jc tyConName--    let droppedKindVarNames :: [Name]-        droppedKindVarNames = catKindVarNames droppedStarKindStati--        -- Substitute kind * for any dropped kind variables-        varTysExpSubst :: [Type]-        varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp--        remainingTysExpSubst, droppedTysExpSubst :: [Type]-        (remainingTysExpSubst, droppedTysExpSubst) =-          splitAt remainingLength varTysExpSubst--        -- All of the type variables mentioned in the dropped types-        -- (post-synonym expansion)-        droppedTyVarNames :: [Name]-        droppedTyVarNames = freeVariables droppedTysExpSubst--    -- If any of the dropped types were polykinded, ensure that they are of kind *-    -- after substituting * for the dropped kind variables. If not, throw an error.-    unless (all hasKindStar droppedTysExpSubst) $-      derivingKindError jc tyConName--    let preds    :: [Maybe Pred]-        kvNames  :: [[Name]]-        kvNames' :: [Name]-        -- Derive instance constraints (and any kind variables which are specialized-        -- to * in those constraints)-        (preds, kvNames) = unzip $ map (deriveConstraint jc) remainingTysExpSubst-        kvNames' = concat kvNames--        -- Substitute the kind variables specialized in the constraints with *-        remainingTysExpSubst' :: [Type]-        remainingTysExpSubst' =-          map (substNamesWithKindStar kvNames') remainingTysExpSubst--        -- We now substitute all of the specialized-to-* kind variable names with-        -- *, but in the original types, not the synonym-expanded types. The reason-        -- we do this is a superficial one: we want the derived instance to resemble-        -- the datatype written in source code as closely as possible. For example,-        -- for the following data family instance:-        ---        --   data family Fam a-        --   newtype instance Fam String = Fam String-        ---        -- We'd want to generate the instance:-        ---        --   instance C (Fam String)-        ---        -- Not:-        ---        --   instance C (Fam [Char])-        remainingTysOrigSubst :: [Type]-        remainingTysOrigSubst =-          map (substNamesWithKindStar (droppedKindVarNames `union` kvNames'))-            $ take remainingLength varTysOrig--        isDataFamily :: Bool-        isDataFamily = case variant of-                         Datatype        -> False-                         Newtype         -> False-                         DataInstance    -> True-                         NewtypeInstance -> True--        remainingTysOrigSubst' :: [Type]-        -- See Note [Kind signatures in derived instances] for an explanation-        -- of the isDataFamily check.-        remainingTysOrigSubst' =-          if isDataFamily-             then remainingTysOrigSubst-             else map unSigT remainingTysOrigSubst--        instanceCxt :: Cxt-        instanceCxt = catMaybes preds--        instanceType :: Type-        instanceType = AppT (ConT $ jsonClassName jc)-                     $ applyTyCon tyConName remainingTysOrigSubst'--    -- If the datatype context mentions any of the dropped type variables,-    -- we can't derive an instance, so throw an error.-    when (any (`predMentionsName` droppedTyVarNames) dataCxt) $-      datatypeContextError tyConName instanceType-    -- Also ensure the dropped types can be safely eta-reduced. Otherwise,-    -- throw an error.-    unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $-      etaReductionError instanceType-    return (instanceCxt, instanceType)---- | Attempt to derive a constraint on a Type. If successful, return--- Just the constraint and any kind variable names constrained to *.--- Otherwise, return Nothing and the empty list.------ See Note [Type inference in derived instances] for the heuristics used to--- come up with constraints.-deriveConstraint :: JSONClass -> Type -> (Maybe Pred, [Name])-deriveConstraint jc t-  | not (isTyVar t) = (Nothing, [])-  | hasKindStar t   = (Just (applyCon (jcConstraint Arity0) tName), [])-  | otherwise = case hasKindVarChain 1 t of-      Just ns | jcArity >= Arity1-              -> (Just (applyCon (jcConstraint Arity1) tName), ns)-      _ -> case hasKindVarChain 2 t of-           Just ns | jcArity == Arity2-                   -> (Just (applyCon (jcConstraint Arity2) tName), ns)-           _ -> (Nothing, [])-  where-    tName :: Name-    tName = varTToName t--    jcArity :: Arity-    jcArity = arity jc--    jcConstraint :: Arity -> Name-    jcConstraint = jsonClassName . JSONClass (direction jc)--{--Note [Kind signatures in derived instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It is possible to put explicit kind signatures into the derived instances, e.g.,--  instance C a => C (Data (f :: * -> *)) where ...--But it is preferable to avoid this if possible. If we come up with an incorrect-kind signature (which is entirely possible, since Template Haskell doesn't always-have the best track record with reifying kind signatures), then GHC will flat-out-reject the instance, which is quite unfortunate.--Plain old datatypes have the advantage that you can avoid using any kind signatures-at all in their instances. This is because a datatype declaration uses all type-variables, so the types that we use in a derived instance uniquely determine their-kinds. As long as we plug in the right types, the kind inferencer can do the rest-of the work. For this reason, we use unSigT to remove all kind signatures before-splicing in the instance context and head.--Data family instances are trickier, since a data family can have two instances that-are distinguished by kind alone, e.g.,--  data family Fam (a :: k)-  data instance Fam (a :: * -> *)-  data instance Fam (a :: *)--If we dropped the kind signatures for C (Fam a), then GHC will have no way of-knowing which instance we are talking about. To avoid this scenario, we always-include explicit kind signatures in data family instances. There is a chance that-the inferred kind signatures will be incorrect, but if so, we can always fall back-on the mk- functions.--Note [Type inference in derived instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Type inference is can be tricky to get right, and we want to avoid recreating the-entirety of GHC's type inferencer in Template Haskell. For this reason, we will-probably never come up with derived instance contexts that are as accurate as-GHC's. But that doesn't mean we can't do anything! There are a couple of simple-things we can do to make instance contexts that work for 80% of use cases:--1. If one of the last type parameters is polykinded, then its kind will be-   specialized to * in the derived instance. We note what kind variable the type-   parameter had and substitute it with * in the other types as well. For example,-   imagine you had--     data Data (a :: k) (b :: k)--   Then you'd want to derived instance to be:--     instance C (Data (a :: *))--   Not:--     instance C (Data (a :: k))--2. We naïvely come up with instance constraints using the following criteria:--   (i)   If there's a type parameter n of kind *, generate a ToJSON n/FromJSON n-         constraint.-   (ii)  If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind-         variables), then generate a ToJSON1 n/FromJSON1 n constraint, and if-         k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the-         types. We must consider the case where they are kind variables because-         you might have a scenario like this:--           newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)-             = Compose (f (g a))--         Which would have a derived ToJSON1 instance of:--           instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where ...-   (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are-         * or kind variables), then generate a ToJSON2 n/FromJSON2 n constraint-         and perform kind substitution as in the other cases.--}--checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name-                        -> Q a -> Q a-checkExistentialContext jc tvMap ctxt conName q =-  if (any (`predMentionsName` M.keys tvMap) ctxt-       || M.size tvMap < arityInt jc)-       && not (allowExQuant jc)-     then existentialContextError conName-     else q--{--Note [Matching functions with GADT type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When deriving ToJSON2, there is a tricky corner case to consider:--  data Both a b where-    BothCon :: x -> x -> Both x x--Which encoding functions should be applied to which arguments of BothCon?-We have a choice, since both the function of type (a -> Value) and of type-(b -> Value) can be applied to either argument. In such a scenario, the-second encoding function takes precedence over the first encoding function, so the-derived ToJSON2 instance would be something like:--  instance ToJSON2 Both where-    liftToJSON2 tj1 tj2 p (BothCon x1 x2) = Array $ create $ do-      mv <- unsafeNew 2-      unsafeWrite mv 0 (tj1 x1)-      unsafeWrite mv 1 (tj2 x2)-      return mv--This is not an arbitrary choice, as this definition ensures that-liftToJSON2 toJSON = liftToJSON for a derived ToJSON1 instance for-Both.--}---- A mapping of type variable Names to their encoding/decoding function Names.--- For example, in a ToJSON2 declaration, a TyVarMap might look like------ { a ~> (tj1, tjl1)--- , b ~> (tj2, tjl2) }------ where a and b are the last two type variables of the datatype, tj1 and tjl1 are--- the function arguments of types (a -> Value) and ([a] -> Value), and tj2 and tjl2--- are the function arguments of types (b -> Value) and ([b] -> Value).-type TyVarMap = Map Name (Name, Name)---- | Returns True if a Type has kind *.-hasKindStar :: Type -> Bool-hasKindStar VarT{}         = True-hasKindStar (SigT _ StarT) = True-hasKindStar _              = False---- Returns True is a kind is equal to *, or if it is a kind variable.-isStarOrVar :: Kind -> Bool-isStarOrVar StarT  = True-isStarOrVar VarT{} = True-isStarOrVar _      = False---- Generate a list of fresh names with a common prefix, and numbered suffixes.-newNameList :: String -> Int -> Q [Name]-newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]---- | @hasKindVarChain n kind@ Checks if @kind@ is of the form--- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or--- kind variables.-hasKindVarChain :: Int -> Type -> Maybe [Name]-hasKindVarChain kindArrows t =-  let uk = uncurryKind (tyKind t)-  in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk-        then Just (concatMap freeVariables uk)-        else Nothing---- | If a Type is a SigT, returns its kind signature. Otherwise, return *.-tyKind :: Type -> Kind-tyKind (SigT _ k) = k-tyKind _          = starK---- | Extract Just the Name from a type variable. If the argument Type is not a--- type variable, return Nothing.-varTToNameMaybe :: Type -> Maybe Name-varTToNameMaybe (VarT n)   = Just n-varTToNameMaybe (SigT t _) = varTToNameMaybe t-varTToNameMaybe _          = Nothing---- | Extract the Name from a type variable. If the argument Type is not a--- type variable, throw an error.-varTToName :: Type -> Name-varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe--interleave :: [a] -> [a] -> [a]-interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s-interleave _        _        = []---- | Fully applies a type constructor to its type variables.-applyTyCon :: Name -> [Type] -> Type-applyTyCon = foldl' AppT . ConT---- | Is the given type a variable?-isTyVar :: Type -> Bool-isTyVar (VarT _)   = True-isTyVar (SigT t _) = isTyVar t-isTyVar _          = False---- | Detect if a Name in a list of provided Names occurs as an argument to some--- type family. This makes an effort to exclude /oversaturated/ arguments to--- type families. For instance, if one declared the following type family:------ @--- type family F a :: Type -> Type--- @------ Then in the type @F a b@, we would consider @a@ to be an argument to @F@,--- but not @b@.-isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool-isInTypeFamilyApp names tyFun tyArgs =-  case tyFun of-    ConT tcName -> go tcName-    _           -> return False-  where-    go :: Name -> Q Bool-    go tcName = do-      info <- reify tcName-      case info of-#if MIN_VERSION_template_haskell(2,11,0)-        FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _-          -> withinFirstArgs bndrs-        FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _-          -> withinFirstArgs bndrs-#else-        FamilyI (FamilyD TypeFam _ bndrs _) _-          -> withinFirstArgs bndrs-        FamilyI (ClosedTypeFamilyD _ bndrs _ _) _-          -> withinFirstArgs bndrs-#endif-        _ -> return False-      where-        withinFirstArgs :: [a] -> Q Bool-        withinFirstArgs bndrs =-          let firstArgs = take (length bndrs) tyArgs-              argFVs    = freeVariables firstArgs-          in return $ any (`elem` argFVs) names---- | Peel off a kind signature from a Type (if it has one).-unSigT :: Type -> Type-unSigT (SigT t _) = t-unSigT t          = t---- | Are all of the items in a list (which have an ordering) distinct?------ This uses Set (as opposed to nub) for better asymptotic time complexity.-allDistinct :: Ord a => [a] -> Bool-allDistinct = allDistinct' Set.empty-  where-    allDistinct' :: Ord a => Set a -> [a] -> Bool-    allDistinct' uniqs (x:xs)-        | x `Set.member` uniqs = False-        | otherwise            = allDistinct' (Set.insert x uniqs) xs-    allDistinct' _ _           = True---- | Does the given type mention any of the Names in the list?-mentionsName :: Type -> [Name] -> Bool-mentionsName = go-  where-    go :: Type -> [Name] -> Bool-    go (AppT t1 t2) names = go t1 names || go t2 names-    go (SigT t _k)  names = go t names-                              || go _k names-    go (VarT n)     names = n `elem` names-    go _            _     = False---- | Does an instance predicate mention any of the Names in the list?-predMentionsName :: Pred -> [Name] -> Bool-#if MIN_VERSION_template_haskell(2,10,0)-predMentionsName = mentionsName-#else-predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys-predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names-#endif---- | Split an applied type into its individual components. For example, this:------ @--- Either Int Char--- @------ would split to this:------ @--- [Either, Int, Char]--- @-unapplyTy :: Type -> NonEmpty Type-unapplyTy = NE.reverse . go-  where-    go :: Type -> NonEmpty Type-    go (AppT t1 t2)    = t2 <| go t1-    go (SigT t _)      = go t-    go (ForallT _ _ t) = go t-    go t               = t :| []---- | Split a type signature by the arrows on its spine. For example, this:------ @--- forall a b. (a ~ b) => (a -> b) -> Char -> ()--- @------ would split to this:------ @--- (a ~ b, [a -> b, Char, ()])--- @-uncurryTy :: Type -> (Cxt, NonEmpty Type)-uncurryTy (AppT (AppT ArrowT t1) t2) =-  let (ctxt, tys) = uncurryTy t2-  in (ctxt, t1 <| tys)-uncurryTy (SigT t _) = uncurryTy t-uncurryTy (ForallT _ ctxt t) =-  let (ctxt', tys) = uncurryTy t-  in (ctxt ++ ctxt', tys)-uncurryTy t = ([], t :| [])---- | Like uncurryType, except on a kind level.-uncurryKind :: Kind -> NonEmpty Kind-uncurryKind = snd . uncurryTy--createKindChain :: Int -> Kind-createKindChain = go starK-  where-    go :: Kind -> Int -> Kind-    go k 0 = k-    go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)---- | Makes a string literal expression from a constructor's name.-conNameExp :: Options -> ConstructorInfo -> Q Exp-conNameExp opts = litE-                . stringL-                . constructorTagModifier opts-                . nameBase-                . constructorName---- | Extracts a record field label.-fieldLabel :: Options -- ^ Encoding options-           -> Name-           -> String-fieldLabel opts = fieldLabelModifier opts . nameBase---- | The name of the outermost 'Value' constructor.-valueConName :: Value -> String-valueConName (Object _) = "Object"-valueConName (Array  _) = "Array"-valueConName (String _) = "String"-valueConName (Number _) = "Number"-valueConName (Bool   _) = "Boolean"-valueConName Null       = "Null"--applyCon :: Name -> Name -> Pred-applyCon con t =-#if MIN_VERSION_template_haskell(2,10,0)-          AppT (ConT con) (VarT t)-#else-          ClassP con [VarT t]-#endif---- | Checks to see if the last types in a data family instance can be safely eta---- reduced (i.e., dropped), given the other types. This checks for three conditions:------ (1) All of the dropped types are type variables--- (2) All of the dropped types are distinct--- (3) None of the remaining types mention any of the dropped types-canEtaReduce :: [Type] -> [Type] -> Bool-canEtaReduce remaining dropped =-       all isTyVar dropped-    && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type-                                -- didn't have an Ord instance until template-haskell-2.10.0.0-    && not (any (`mentionsName` droppedNames) remaining)-  where-    droppedNames :: [Name]-    droppedNames = map varTToName dropped------------------------------------------------------------------------------------ Expanding type synonyms----------------------------------------------------------------------------------applySubstitutionKind :: Map Name Kind -> Type -> Type-applySubstitutionKind = applySubstitution--substNameWithKind :: Name -> Kind -> Type -> Type-substNameWithKind n k = applySubstitutionKind (M.singleton n k)--substNamesWithKindStar :: [Name] -> Type -> Type-substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns------------------------------------------------------------------------------------ Error messages------------------------------------------------------------------------------------ | Either the given data type doesn't have enough type variables, or one of--- the type variables to be eta-reduced cannot realize kind *.-derivingKindError :: JSONClass -> Name -> Q a-derivingKindError jc tyConName = fail-  . showString "Cannot derive well-kinded instance of form ‘"-  . showString className-  . showChar ' '-  . showParen True-    ( showString (nameBase tyConName)-    . showString " ..."-    )-  . showString "‘\n\tClass "-  . showString className-  . showString " expects an argument of kind "-  . showString (pprint . createKindChain $ arityInt jc)-  $ ""-  where-    className :: String-    className = nameBase $ jsonClassName jc---- | One of the last type variables cannot be eta-reduced (see the canEtaReduce--- function for the criteria it would have to meet).-etaReductionError :: Type -> Q a-etaReductionError instanceType = fail $-    "Cannot eta-reduce to an instance of form \n\tinstance (...) => "-    ++ pprint instanceType---- | The data type has a DatatypeContext which mentions one of the eta-reduced--- type variables.-datatypeContextError :: Name -> Type -> Q a-datatypeContextError dataName instanceType = fail-    . showString "Can't make a derived instance of ‘"-    . showString (pprint instanceType)-    . showString "‘:\n\tData type ‘"-    . showString (nameBase dataName)-    . showString "‘ must not have a class context involving the last type argument(s)"-    $ ""---- | The data type mentions one of the n eta-reduced type variables in a place other--- than the last nth positions of a data type in a constructor's field.-outOfPlaceTyVarError :: JSONClass -> Name -> a-outOfPlaceTyVarError jc conName = error-    . showString "Constructor ‘"-    . showString (nameBase conName)-    . showString "‘ must only use its last "-    . shows n-    . showString " type variable(s) within the last "-    . shows n-    . showString " argument(s) of a data type"-    $ ""-  where-    n :: Int-    n = arityInt jc---- | The data type has an existential constraint which mentions one of the--- eta-reduced type variables.-existentialContextError :: Name -> a-existentialContextError conName = error-  . showString "Constructor ‘"-  . showString (nameBase conName)-  . showString "‘ must be truly polymorphic in the last argument(s) of the data type"-  $ ""------------------------------------------------------------------------------------ Class-specific constants------------------------------------------------------------------------------------ | A representation of the arity of the ToJSON/FromJSON typeclass being derived.-data Arity = Arity0 | Arity1 | Arity2-  deriving (Enum, Eq, Ord)---- | Whether ToJSON(1)(2) or FromJSON(1)(2) is being derived.-data Direction = To | From---- | A representation of which typeclass method is being spliced in.-data JSONFun = ToJSON | ToEncoding | ParseJSON---- | A refinement of JSONFun to [ToJSON, ToEncoding].-data ToJSONFun = Value | Encoding--targetToJSONFun :: ToJSONFun -> JSONFun-targetToJSONFun Value = ToJSON-targetToJSONFun Encoding = ToEncoding---- | A representation of which typeclass is being derived.-data JSONClass = JSONClass { direction :: Direction, arity :: Arity }--toJSONClass, toJSON1Class, toJSON2Class,-    fromJSONClass, fromJSON1Class, fromJSON2Class :: JSONClass-toJSONClass    = JSONClass To   Arity0-toJSON1Class   = JSONClass To   Arity1-toJSON2Class   = JSONClass To   Arity2-fromJSONClass  = JSONClass From Arity0-fromJSON1Class = JSONClass From Arity1-fromJSON2Class = JSONClass From Arity2--jsonClassName :: JSONClass -> Name-jsonClassName (JSONClass To   Arity0) = ''ToJSON-jsonClassName (JSONClass To   Arity1) = ''ToJSON1-jsonClassName (JSONClass To   Arity2) = ''ToJSON2-jsonClassName (JSONClass From Arity0) = ''FromJSON-jsonClassName (JSONClass From Arity1) = ''FromJSON1-jsonClassName (JSONClass From Arity2) = ''FromJSON2--jsonFunValName :: JSONFun -> Arity -> Name-jsonFunValName ToJSON     Arity0 = 'toJSON-jsonFunValName ToJSON     Arity1 = 'liftToJSON-jsonFunValName ToJSON     Arity2 = 'liftToJSON2-jsonFunValName ToEncoding Arity0 = 'toEncoding-jsonFunValName ToEncoding Arity1 = 'liftToEncoding-jsonFunValName ToEncoding Arity2 = 'liftToEncoding2-jsonFunValName ParseJSON  Arity0 = 'parseJSON-jsonFunValName ParseJSON  Arity1 = 'liftParseJSON-jsonFunValName ParseJSON  Arity2 = 'liftParseJSON2--jsonFunListName :: JSONFun -> Arity -> Name-jsonFunListName ToJSON     Arity0 = 'toJSONList-jsonFunListName ToJSON     Arity1 = 'liftToJSONList-jsonFunListName ToJSON     Arity2 = 'liftToJSONList2-jsonFunListName ToEncoding Arity0 = 'toEncodingList-jsonFunListName ToEncoding Arity1 = 'liftToEncodingList-jsonFunListName ToEncoding Arity2 = 'liftToEncodingList2-jsonFunListName ParseJSON  Arity0 = 'parseJSONList-jsonFunListName ParseJSON  Arity1 = 'liftParseJSONList-jsonFunListName ParseJSON  Arity2 = 'liftParseJSONList2--jsonFunValOrListName :: Bool -- e.g., toJSONList if True, toJSON if False-                     -> JSONFun -> Arity -> Name-jsonFunValOrListName False = jsonFunValName-jsonFunValOrListName True  = jsonFunListName--arityInt :: JSONClass -> Int-arityInt = fromEnum . arity--allowExQuant :: JSONClass -> Bool-allowExQuant (JSONClass To _) = True-allowExQuant _                = False------------------------------------------------------------------------------------ StarKindStatus------------------------------------------------------------------------------------ | Whether a type is not of kind *, is of kind *, or is a kind variable.-data StarKindStatus = NotKindStar-                    | KindStar-                    | IsKindVar Name-  deriving Eq---- | Does a Type have kind * or k (for some kind variable k)?-canRealizeKindStar :: Type -> StarKindStatus-canRealizeKindStar t = case t of-    _ | hasKindStar t -> KindStar-    SigT _ (VarT k) -> IsKindVar k-    _ -> NotKindStar---- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.--- Otherwise, returns 'Nothing'.-starKindStatusToName :: StarKindStatus -> Maybe Name-starKindStatusToName (IsKindVar n) = Just n-starKindStatusToName _             = Nothing---- | Concat together all of the StarKindStatuses that are IsKindVar and extract--- the kind variables' Names out.-catKindVarNames :: [StarKindStatus] -> [Name]-catKindVarNames = mapMaybe starKindStatusToName
− Data/Aeson/Text.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--- |--- Module:      Data.Aeson.Text--- Copyright:   (c) 2012-2016 Bryan O'Sullivan---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Most frequently, you'll probably want to encode straight to UTF-8--- (the standard JSON encoding) using 'encode'.------ You can use the conversions to 'Builder's when embedding JSON messages as--- parts of a protocol.--module Data.Aeson.Text-    (-      encodeToLazyText-    , encodeToTextBuilder-    ) where--import Prelude.Compat--import Data.Aeson.Types (Value(..), ToJSON(..))-import Data.Aeson.Encoding (encodingToLazyByteString)-import Data.Scientific (FPFormat(..), Scientific, base10Exponent)-import Data.Text.Lazy.Builder-import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)-import Numeric (showHex)-import qualified Data.HashMap.Strict as H-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.Encoding as LT-import qualified Data.Vector as V---- | Encode a JSON 'Value' to a "Data.Text.Lazy"------ /Note:/ uses 'toEncoding'-encodeToLazyText :: ToJSON a => a -> LT.Text-encodeToLazyText = LT.decodeUtf8 . encodingToLazyByteString . toEncoding---- | Encode a JSON 'Value' to a "Data.Text" 'Builder', which can be--- embedded efficiently in a text-based protocol.------ If you are going to immediately encode straight to a--- 'L.ByteString', it is more efficient to use 'encode' (lazy ByteString)--- or @'fromEncoding' . 'toEncoding'@ (ByteString.Builder) instead.------ /Note:/ Uses 'toJSON'-encodeToTextBuilder :: ToJSON a => a -> Builder-encodeToTextBuilder =-    go . toJSON-  where-    go Null       = {-# SCC "go/Null" #-} "null"-    go (Bool b)   = {-# SCC "go/Bool" #-} if b then "true" else "false"-    go (Number s) = {-# SCC "go/Number" #-} fromScientific s-    go (String s) = {-# SCC "go/String" #-} string s-    go (Array v)-        | V.null v = {-# SCC "go/Array" #-} "[]"-        | otherwise = {-# SCC "go/Array" #-}-                      singleton '[' <>-                      go (V.unsafeHead v) <>-                      V.foldr f (singleton ']') (V.unsafeTail v)-      where f a z = singleton ',' <> go a <> z-    go (Object m) = {-# SCC "go/Object" #-}-        case H.toList m of-          (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs-          _      -> "{}"-      where f a z     = singleton ',' <> one a <> z-            one (k,v) = string k <> singleton ':' <> go v--string :: T.Text -> Builder-string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"'-  where-    quote q = case T.uncons t of-                Nothing      -> fromText h-                Just (!c,t') -> fromText h <> escape c <> quote t'-        where (h,t) = {-# SCC "break" #-} T.break isEscape q-    isEscape c = c == '\"' ||-                 c == '\\' ||-                 c < '\x20'-    escape '\"' = "\\\""-    escape '\\' = "\\\\"-    escape '\n' = "\\n"-    escape '\r' = "\\r"-    escape '\t' = "\\t"--    escape c-        | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h-        | otherwise  = singleton c-        where h = showHex (fromEnum c) ""--fromScientific :: Scientific -> Builder-fromScientific s = formatScientificBuilder format prec s-  where-    (format, prec)-      | base10Exponent s < 0 = (Generic, Nothing)-      | otherwise            = (Fixed,   Just 0)
− Data/Aeson/Types.hs 
@@ -1,164 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--- |--- Module:      Data.Aeson.Types--- Copyright:   (c) 2011-2016 Bryan O'Sullivan---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Types for working with JSON data.--module Data.Aeson.Types-    (-    -- * Core JSON types-      Value(..)-    , Encoding-    , unsafeToEncoding-    , fromEncoding-    , Series-    , Array-    , emptyArray-    , Pair-    , Object-    , emptyObject-    -- * Convenience types and functions-    , DotNetTime(..)-    , typeMismatch-    , unexpected-    -- * Type conversion-    , Parser-    , Result(..)-    , FromJSON(..)-    , fromJSON-    , parse-    , parseEither-    , parseMaybe-    , parseFail-    , ToJSON(..)-    , KeyValue(..)-    , modifyFailure-    , prependFailure-    , parserThrowError-    , parserCatchError--    -- ** Keys for maps-    , ToJSONKey(..)-    , ToJSONKeyFunction(..)-    , toJSONKeyText-    , contramapToJSONKeyFunction-    , FromJSONKey(..)-    , FromJSONKeyFunction(..)-    , fromJSONKeyCoerce-    , coerceFromJSONKeyFunction-    , mapFromJSONKeyFunction--    -- *** Generic keys-    , GToJSONKey()-    , genericToJSONKey-    , GFromJSONKey()-    , genericFromJSONKey--    -- ** Liftings to unary and binary type constructors-    , FromJSON1(..)-    , parseJSON1-    , FromJSON2(..)-    , parseJSON2-    , ToJSON1(..)-    , toJSON1-    , toEncoding1-    , ToJSON2(..)-    , toJSON2-    , toEncoding2--    -- ** Generic JSON classes-    , GFromJSON-    , FromArgs-    , GToJSON-    , GToEncoding-    , GToJSON'-    , ToArgs-    , Zero-    , One-    , genericToJSON-    , genericLiftToJSON-    , genericToEncoding-    , genericLiftToEncoding-    , genericParseJSON-    , genericLiftParseJSON--    -- * Inspecting @'Value's@-    , withObject-    , withText-    , withArray-    , withScientific-    , withBool-    , withEmbeddedJSON--    , pairs-    , foldable-    , (.:)-    , (.:?)-    , (.:!)-    , (.!=)-    , object-    , parseField-    , parseFieldMaybe-    , parseFieldMaybe'-    , explicitParseField-    , explicitParseFieldMaybe-    , explicitParseFieldMaybe'--    , listEncoding-    , listValue-    , listParser--    -- * Generic and TH encoding configuration-    , Options--    -- ** Options fields-    -- $optionsFields-    , fieldLabelModifier-    , constructorTagModifier-    , allNullaryToStringTag-    , omitNothingFields-    , sumEncoding-    , unwrapUnaryRecords-    , tagSingleConstructors-    , rejectUnknownFields--    -- ** Options utilities-    , SumEncoding(..)-    , camelTo-    , camelTo2-    , defaultOptions-    , defaultTaggedObject--    -- ** Options for object keys-    , JSONKeyOptions-    , keyModifier-    , defaultJSONKeyOptions--    -- * Parsing context-    , (<?>)-    , JSONPath-    , JSONPathElement(..)-    , formatPath-    , formatRelativePath-    ) where--import Prelude.Compat--import Data.Aeson.Encoding (Encoding, unsafeToEncoding, fromEncoding, Series, pairs)-import Data.Aeson.Types.Class-import Data.Aeson.Types.Internal-import Data.Foldable (toList)---- | Encode a 'Foldable' as a JSON array.-foldable :: (Foldable t, ToJSON a) => t a -> Encoding-foldable = toEncoding . toList-{-# INLINE foldable #-}---- $optionsFields--- The functions here are in fact record fields of the 'Options' type.
− Data/Aeson/Types/Class.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Module:      Data.Aeson.Types.Class--- Copyright:   (c) 2011-2016 Bryan O'Sullivan---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Types for working with JSON data.--module Data.Aeson.Types.Class-    (-    -- * Core JSON classes-      FromJSON(..)-    , ToJSON(..)-    -- * Liftings to unary and binary type constructors-    , FromJSON1(..)-    , parseJSON1-    , FromJSON2(..)-    , parseJSON2-    , ToJSON1(..)-    , toJSON1-    , toEncoding1-    , ToJSON2(..)-    , toJSON2-    , toEncoding2-    -- * Generic JSON classes-    , GFromJSON(..)-    , FromArgs(..)-    , GToJSON-    , GToEncoding-    , GToJSON'-    , ToArgs(..)-    , Zero-    , One-    , genericToJSON-    , genericLiftToJSON-    , genericToEncoding-    , genericLiftToEncoding-    , genericParseJSON-    , genericLiftParseJSON-    -- * Classes and types for map keys-    , ToJSONKey(..)-    , ToJSONKeyFunction(..)-    , toJSONKeyText-    , contramapToJSONKeyFunction-    , FromJSONKey(..)-    , FromJSONKeyFunction(..)-    , fromJSONKeyCoerce-    , coerceFromJSONKeyFunction-    , mapFromJSONKeyFunction-    -- ** Generic keys-    , GToJSONKey()-    , genericToJSONKey-    , GFromJSONKey()-    , genericFromJSONKey-    -- * Object key-value pairs-    , KeyValue(..)--    -- * List functions-    , listEncoding-    , listValue-    , listParser--      -- * Inspecting @'Value's@-    , withObject-    , withText-    , withArray-    , withScientific-    , withBool-    , withEmbeddedJSON--    -- * Functions-    , fromJSON-    , ifromJSON-    , typeMismatch-    , unexpected-    , parseField-    , parseFieldMaybe-    , parseFieldMaybe'-    , explicitParseField-    , explicitParseFieldMaybe-    , explicitParseFieldMaybe'-    -- ** Operators-    , (.:)-    , (.:?)-    , (.:!)-    , (.!=)-    ) where---import Data.Aeson.Types.FromJSON-import Data.Aeson.Types.Generic (One, Zero)-import Data.Aeson.Types.ToJSON-import Data.Aeson.Types.Internal (Value)-import Data.Aeson.Encoding (Encoding)--type GToJSON = GToJSON' Value-type GToEncoding = GToJSON' Encoding
− Data/Aeson/Types/FromJSON.hs 
@@ -1,2785 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}--#include "incoherent-compat.h"-#include "overlapping-compat.h"---- TODO: Drop this when we remove support for Data.Attoparsec.Number-{-# OPTIONS_GHC -fno-warn-deprecations #-}--module Data.Aeson.Types.FromJSON-    (-    -- * Core JSON classes-      FromJSON(..)-    -- * Liftings to unary and binary type constructors-    , FromJSON1(..)-    , parseJSON1-    , FromJSON2(..)-    , parseJSON2-    -- * Generic JSON classes-    , GFromJSON(..)-    , FromArgs(..)-    , genericParseJSON-    , genericLiftParseJSON-    -- * Classes and types for map keys-    , FromJSONKey(..)-    , FromJSONKeyFunction(..)-    , fromJSONKeyCoerce-    , coerceFromJSONKeyFunction-    , mapFromJSONKeyFunction--    , GFromJSONKey()-    , genericFromJSONKey--    -- * List functions-    , listParser--    -- * Inspecting @'Value's@-    , withObject-    , withText-    , withArray-    , withScientific-    , withBool-    , withEmbeddedJSON--    -- * Functions-    , fromJSON-    , ifromJSON-    , typeMismatch-    , unexpected-    , parseField-    , parseFieldMaybe-    , parseFieldMaybe'-    , explicitParseField-    , explicitParseFieldMaybe-    , explicitParseFieldMaybe'-    , parseIndexedJSON-    -- ** Operators-    , (.:)-    , (.:?)-    , (.:!)-    , (.!=)--    -- * Internal-    , parseOptionalFieldWith-    ) where--import Prelude.Compat--import Control.Applicative ((<|>), Const(..), liftA2)-import Control.Monad (zipWithM)-import Data.Aeson.Internal.Functions (mapKey)-import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)-import Data.Aeson.Types.Generic-import Data.Aeson.Types.Internal-import Data.Bits (unsafeShiftR)-import Data.Fixed (Fixed, HasResolution (resolution), Nano)-import Data.Functor.Compose (Compose(..))-import Data.Functor.Identity (Identity(..))-import Data.Functor.Product (Product(..))-import Data.Functor.Sum (Sum(..))-import Data.Functor.These (These1 (..))-import Data.Hashable (Hashable(..))-import Data.Int (Int16, Int32, Int64, Int8)-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe (fromMaybe)-import Data.Proxy (Proxy(..))-import Data.Ratio ((%), Ratio)-import Data.Scientific (Scientific, base10Exponent)-import Data.Tagged (Tagged(..))-import Data.Text (Text, pack, unpack)-import Data.These (These (..))-import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)-import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))-import Data.Time.Calendar.Month.Compat (Month)-import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))-import Data.Time.LocalTime.Compat (CalendarDiffTime (..))-import Data.Time.Clock.System.Compat (SystemTime (..))-import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)-import Data.Traversable as Tr (sequence)-import Data.Vector (Vector)-import Data.Version (Version, parseVersion)-import Data.Void (Void)-import Data.Word (Word16, Word32, Word64, Word8)-import Foreign.Storable (Storable)-import Foreign.C.Types (CTime (..))-import GHC.Generics-import Numeric.Natural (Natural)-import Text.ParserCombinators.ReadP (readP_to_S)-import Unsafe.Coerce (unsafeCoerce)-import qualified Data.Aeson.Parser.Time as Time-import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)-import qualified Data.ByteString.Lazy as L-import qualified Data.DList as DList-#if MIN_VERSION_dlist(1,0,0) && __GLASGOW_HASKELL__ >=800-import qualified Data.DList.DNonEmpty as DNE-#endif-import qualified Data.Fix as F-import qualified Data.HashMap.Strict as H-import qualified Data.HashSet as HashSet-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import qualified Data.Map as M-import qualified Data.Monoid as Monoid-import qualified Data.Scientific as Scientific-import qualified Data.Semigroup as Semigroup-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import qualified Data.Strict as S-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as LT-import qualified Data.Tree as Tree-import qualified Data.UUID.Types as UUID-import qualified Data.Vector as V-import qualified Data.Vector.Generic as VG-import qualified Data.Vector.Primitive as VP-import qualified Data.Vector.Storable as VS-import qualified Data.Vector.Unboxed as VU--import qualified GHC.Exts as Exts-import qualified Data.Primitive.Array as PM-import qualified Data.Primitive.SmallArray as PM-import qualified Data.Primitive.Types as PM-import qualified Data.Primitive.PrimArray as PM--import Data.Coerce (Coercible, coerce)--parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a-parseIndexedJSON p idx value = p value <?> Index idx-{-# INLINE parseIndexedJSON #-}--parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)-parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx-  where-    p = withArray "(k, v)" $ \ab ->-        let n = V.length ab-        in if n == 2-             then (,) <$> parseJSONElemAtIndex keyParser 0 ab-                      <*> parseJSONElemAtIndex valParser 1 ab-             else fail $ "cannot unpack array of length " ++-                         show n ++ " into a pair"-{-# INLINE parseIndexedJSONPair #-}--parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a-parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx--parseRealFloat :: RealFloat a => String -> Value -> Parser a-parseRealFloat _    (Number s) = pure $ Scientific.toRealFloat s-parseRealFloat _    Null       = pure (0/0)-parseRealFloat name v          = prependContext name (unexpected v)-{-# INLINE parseRealFloat #-}--parseIntegralFromScientific :: forall a. Integral a => Scientific -> Parser a-parseIntegralFromScientific s =-    case Scientific.floatingOrInteger s :: Either Double a of-        Right x -> pure x-        Left _  -> fail $ "unexpected floating number " ++ show s-{-# INLINE parseIntegralFromScientific #-}--parseIntegral :: Integral a => String -> Value -> Parser a-parseIntegral name =-    prependContext name . withBoundedScientific' parseIntegralFromScientific-{-# INLINE parseIntegral #-}--parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => Scientific -> Parser a-parseBoundedIntegralFromScientific s = maybe-    (fail $ "value is either floating or will cause over or underflow " ++ show s)-    pure-    (Scientific.toBoundedInteger s)-{-# INLINE parseBoundedIntegralFromScientific #-}--parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a-parseBoundedIntegral name =-    prependContext name . withScientific' parseBoundedIntegralFromScientific-{-# INLINE parseBoundedIntegral #-}--parseScientificText :: Text -> Parser Scientific-parseScientificText-    = either fail pure-    . A.parseOnly (A.scientific <* A.endOfInput)-    . T.encodeUtf8--parseIntegralText :: Integral a => String -> Text -> Parser a-parseIntegralText name t =-    prependContext name $-            parseScientificText t-        >>= rejectLargeExponent-        >>= parseIntegralFromScientific-  where-    rejectLargeExponent :: Scientific -> Parser Scientific-    rejectLargeExponent s = withBoundedScientific' pure (Number s)-{-# INLINE parseIntegralText #-}--parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a-parseBoundedIntegralText name t =-    prependContext name $-        parseScientificText t >>= parseBoundedIntegralFromScientific--parseOptionalFieldWith :: (Value -> Parser (Maybe a))-                       -> Object -> Text -> Parser (Maybe a)-parseOptionalFieldWith pj obj key =-    case H.lookup key obj of-     Nothing -> pure Nothing-     Just v  -> pj v <?> Key key-{-# INLINE parseOptionalFieldWith #-}------------------------------------------------------------------------------------ Generics------------------------------------------------------------------------------------ | Class of generic representation types that can be converted from JSON.-class GFromJSON arity f where-    -- | This method (applied to 'defaultOptions') is used as the-    -- default generic implementation of 'parseJSON' (if the @arity@ is 'Zero')-    -- or 'liftParseJSON' (if the @arity@ is 'One').-    gParseJSON :: Options -> FromArgs arity a -> Value -> Parser (f a)---- | A 'FromArgs' value either stores nothing (for 'FromJSON') or it stores the--- two function arguments that decode occurrences of the type parameter (for--- 'FromJSON1').-data FromArgs arity a where-    NoFromArgs :: FromArgs Zero a-    From1Args  :: (Value -> Parser a) -> (Value -> Parser [a]) -> FromArgs One a---- | A configurable generic JSON decoder. This function applied to--- 'defaultOptions' is used as the default for 'parseJSON' when the--- type is an instance of 'Generic'.-genericParseJSON :: (Generic a, GFromJSON Zero (Rep a))-                 => Options -> Value -> Parser a-genericParseJSON opts = fmap to . gParseJSON opts NoFromArgs---- | A configurable generic JSON decoder. This function applied to--- 'defaultOptions' is used as the default for 'liftParseJSON' when the--- type is an instance of 'Generic1'.-genericLiftParseJSON :: (Generic1 f, GFromJSON One (Rep1 f))-                     => Options -> (Value -> Parser a) -> (Value -> Parser [a])-                     -> Value -> Parser (f a)-genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)------------------------------------------------------------------------------------ Class------------------------------------------------------------------------------------ | A type that can be converted from JSON, with the possibility of--- failure.------ In many cases, you can get the compiler to generate parsing code--- for you (see below).  To begin, let's cover writing an instance by--- hand.------ There are various reasons a conversion could fail.  For example, an--- 'Object' could be missing a required key, an 'Array' could be of--- the wrong size, or a value could be of an incompatible type.------ The basic ways to signal a failed conversion are as follows:------ * 'fail' yields a custom error message: it is the recommended way of--- reporting a failure;------ * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:--- use it when the error is meant to be caught by some @('<|>')@;------ * 'typeMismatch' can be used to report a failure when the encountered value--- is not of the expected JSON type; 'unexpected' is an appropriate alternative--- when more than one type may be expected, or to keep the expected type--- implicit.------ 'prependFailure' (or 'modifyFailure') add more information to a parser's--- error messages.------ An example type and instance using 'typeMismatch' and 'prependFailure':------ @--- \-- Allow ourselves to write 'Text' literals.--- {-\# LANGUAGE OverloadedStrings #-}------ data Coord = Coord { x :: Double, y :: Double }------ instance 'FromJSON' Coord where---     'parseJSON' ('Object' v) = Coord---         '<$>' v '.:' \"x\"---         '<*>' v '.:' \"y\"------     \-- We do not expect a non-'Object' value here.---     \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'---     \-- gives a much more informative error message.---     'parseJSON' invalid    =---         'prependFailure' "parsing Coord failed, "---             ('typeMismatch' \"Object\" invalid)--- @------ For this common case of only being concerned with a single--- type of JSON value, the functions 'withObject', 'withScientific', etc.--- are provided. Their use is to be preferred when possible, since--- they are more terse. Using 'withObject', we can rewrite the above instance--- (assuming the same language extension and data type) as:------ @--- instance 'FromJSON' Coord where---     'parseJSON' = 'withObject' \"Coord\" $ \\v -> Coord---         '<$>' v '.:' \"x\"---         '<*>' v '.:' \"y\"--- @------ Instead of manually writing your 'FromJSON' instance, there are two options--- to do it automatically:------ * "Data.Aeson.TH" provides Template Haskell functions which will derive an--- instance at compile time. The generated instance is optimized for your type--- so it will probably be more efficient than the following option.------ * The compiler can provide a default generic implementation for--- 'parseJSON'.------ To use the second, simply add a @deriving 'Generic'@ clause to your--- datatype and declare a 'FromJSON' instance for your datatype without giving--- a definition for 'parseJSON'.------ For example, the previous example can be simplified to just:------ @--- {-\# LANGUAGE DeriveGeneric \#-}------ import "GHC.Generics"------ data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'------ instance 'FromJSON' Coord--- @------ The default implementation will be equivalent to--- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different--- options, you can customize the generic decoding by defining:------ @--- customOptions = 'defaultOptions'---                 { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'---                 }------ instance 'FromJSON' Coord where---     'parseJSON' = 'genericParseJSON' customOptions--- @-class FromJSON a where-    parseJSON :: Value -> Parser a--    default parseJSON :: (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a-    parseJSON = genericParseJSON defaultOptions--    parseJSONList :: Value -> Parser [a]-    parseJSONList = withArray "[]" $ \a ->-          zipWithM (parseIndexedJSON parseJSON) [0..]-        . V.toList-        $ a------------------------------------------------------------------------------------  Classes and types for map keys------------------------------------------------------------------------------------ | Read the docs for 'ToJSONKey' first. This class is a conversion---   in the opposite direction. If you have a newtype wrapper around 'Text',---   the recommended way to define instances is with generalized newtype deriving:------   > newtype SomeId = SomeId { getSomeId :: Text }---   >   deriving (Eq,Ord,Hashable,FromJSONKey)------   If you have a sum of nullary constructors, you may use the generic---   implementation:------ @--- data Color = Red | Green | Blue---   deriving Generic------ instance 'FromJSONKey' Color where---   'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'--- @-class FromJSONKey a where-    -- | Strategy for parsing the key of a map-like container.-    fromJSONKey :: FromJSONKeyFunction a-    default fromJSONKey :: FromJSON a => FromJSONKeyFunction a-    fromJSONKey = FromJSONKeyValue parseJSON--    -- | This is similar in spirit to the 'readList' method of 'Read'.-    --   It makes it possible to give 'String' keys special treatment-    --   without using @OverlappingInstances@. End users should always-    --   be able to use the default implementation of this method.-    fromJSONKeyList :: FromJSONKeyFunction [a]-    default fromJSONKeyList :: FromJSON a => FromJSONKeyFunction [a]-    fromJSONKeyList = FromJSONKeyValue parseJSON---- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the---   'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'---   instance. The other three data constructors for this type all correspond to---   'ToJSONKeyText'. Strictly speaking, 'FromJSONKeyTextParser' is more powerful than---   'FromJSONKeyText', which is in turn more powerful than 'FromJSONKeyCoerce'.---   For performance reasons, these exist as three options instead of one.-data FromJSONKeyFunction a where-    FromJSONKeyCoerce :: Coercible Text a => FromJSONKeyFunction a-      -- ^ uses 'coerce'-    FromJSONKeyText :: !(Text -> a) -> FromJSONKeyFunction a-      -- ^ conversion from 'Text' that always succeeds-    FromJSONKeyTextParser :: !(Text -> Parser a) -> FromJSONKeyFunction a-      -- ^ conversion from 'Text' that may fail-    FromJSONKeyValue :: !(Value -> Parser a) -> FromJSONKeyFunction a-      -- ^ conversion for non-textual keys---- | Only law abiding up to interpretation-instance Functor FromJSONKeyFunction where-    fmap h FromJSONKeyCoerce         = FromJSONKeyText (h . coerce)-    fmap h (FromJSONKeyText f)       = FromJSONKeyText (h . f)-    fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)-    fmap h (FromJSONKeyValue f)      = FromJSONKeyValue (fmap h . f)---- | Construct 'FromJSONKeyFunction' for types coercible from 'Text'. This--- conversion is still unsafe, as 'Hashable' and 'Eq' instances of @a@ should be--- compatible with 'Text' i.e. hash values should be equal for wrapped values as well.--- This property will always be maintained if the 'Hashable' and 'Eq' instances--- are derived with generalized newtype deriving.--- compatible with 'Text' i.e. hash values be equal for wrapped values as well.------ On pre GHC 7.8 this is unconstrainted function.-fromJSONKeyCoerce ::-    Coercible Text a =>-    FromJSONKeyFunction a-fromJSONKeyCoerce = FromJSONKeyCoerce---- | Semantically the same as @coerceFromJSONKeyFunction = fmap coerce = coerce@.------ See note on 'fromJSONKeyCoerce'.-coerceFromJSONKeyFunction ::-    Coercible a b =>-    FromJSONKeyFunction a -> FromJSONKeyFunction b-coerceFromJSONKeyFunction = coerce--{-# RULES-  "FromJSONKeyCoerce: fmap coerce" forall x .-                                   fmap coerce x = coerceFromJSONKeyFunction x-  #-}---- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.-mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b-mapFromJSONKeyFunction = fmap---- | 'fromJSONKey' for 'Generic' types.--- These types must be sums of nullary constructors, whose names will be used--- as keys for JSON objects.------ See also 'genericToJSONKey'.------ === __Example__------ @--- data Color = Red | Green | Blue---   deriving 'Generic'------ instance 'FromJSONKey' Color where---   'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'--- @-genericFromJSONKey :: forall a. (Generic a, GFromJSONKey (Rep a))-             => JSONKeyOptions-             -> FromJSONKeyFunction a-genericFromJSONKey opts = FromJSONKeyTextParser $ \t ->-    case parseSumFromString (keyModifier opts) t of-        Nothing -> fail $-            "invalid key " ++ show t ++ ", expected one of " ++ show cnames-        Just k -> pure (to k)-  where-    cnames = unTagged2 (constructorTags (keyModifier opts) :: Tagged2 (Rep a) [String])--class    (ConstructorNames f, SumFromString f) => GFromJSONKey f where-instance (ConstructorNames f, SumFromString f) => GFromJSONKey f where------------------------------------------------------------------------------------ Functions needed for documentation------------------------------------------------------------------------------------ | Fail parsing due to a type mismatch, with a descriptive message.------ The following wrappers should generally be prefered:--- 'withObject', 'withArray', 'withText', 'withBool'.------ ==== Error message example------ > typeMismatch "Object" (String "oops")--- > -- Error: "expected Object, but encountered String"-typeMismatch :: String -- ^ The name of the JSON type being parsed-                       -- (@\"Object\"@, @\"Array\"@, @\"String\"@, @\"Number\"@,-                       -- @\"Boolean\"@, or @\"Null\"@).-             -> Value  -- ^ The actual value encountered.-             -> Parser a-typeMismatch expected actual =-    fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual---- | Fail parsing due to a type mismatch, when the expected types are implicit.------ ==== Error message example------ > unexpected (String "oops")--- > -- Error: "unexpected String"-unexpected :: Value -> Parser a-unexpected actual = fail $ "unexpected " ++ typeOf actual---- | JSON type of a value, name of the head constructor.-typeOf :: Value -> String-typeOf v = case v of-    Object _ -> "Object"-    Array _  -> "Array"-    String _ -> "String"-    Number _ -> "Number"-    Bool _   -> "Boolean"-    Null     -> "Null"------------------------------------------------------------------------------------ Lifings of FromJSON and ToJSON to unary and binary type constructors------------------------------------------------------------------------------------ | Lifting of the 'FromJSON' class to unary type constructors.------ Instead of manually writing your 'FromJSON1' instance, there are two options--- to do it automatically:------ * "Data.Aeson.TH" provides Template Haskell functions which will derive an--- instance at compile time. The generated instance is optimized for your type--- so it will probably be more efficient than the following option.------ * The compiler can provide a default generic implementation for--- 'liftParseJSON'.------ To use the second, simply add a @deriving 'Generic1'@ clause to your--- datatype and declare a 'FromJSON1' instance for your datatype without giving--- a definition for 'liftParseJSON'.------ For example:------ @--- {-\# LANGUAGE DeriveGeneric \#-}------ import "GHC.Generics"------ data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'------ instance 'FromJSON' a => 'FromJSON1' (Pair a)--- @------ If the default implementation doesn't give exactly the results you want,--- you can customize the generic decoding with only a tiny amount of--- effort, using 'genericLiftParseJSON' with your preferred 'Options':------ @--- customOptions = 'defaultOptions'---                 { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'---                 }------ instance 'FromJSON' a => 'FromJSON1' (Pair a) where---     'liftParseJSON' = 'genericLiftParseJSON' customOptions--- @-class FromJSON1 f where-    liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)--    default liftParseJSON :: (Generic1 f, GFromJSON One (Rep1 f))-                          => (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)-    liftParseJSON = genericLiftParseJSON defaultOptions--    liftParseJSONList :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser [f a]-    liftParseJSONList f g v = listParser (liftParseJSON f g) v---- | Lift the standard 'parseJSON' function through the type constructor.-parseJSON1 :: (FromJSON1 f, FromJSON a) => Value -> Parser (f a)-parseJSON1 = liftParseJSON parseJSON parseJSONList-{-# INLINE parseJSON1 #-}---- | Lifting of the 'FromJSON' class to binary type constructors.------ Instead of manually writing your 'FromJSON2' instance, "Data.Aeson.TH"--- provides Template Haskell functions which will derive an instance at compile time.---- The compiler cannot provide a default generic implementation for 'liftParseJSON2',--- unlike 'parseJSON' and 'liftParseJSON'.-class FromJSON2 f where-    liftParseJSON2-        :: (Value -> Parser a)-        -> (Value -> Parser [a])-        -> (Value -> Parser b)-        -> (Value -> Parser [b])-        -> Value -> Parser (f a b)-    liftParseJSONList2-        :: (Value -> Parser a)-        -> (Value -> Parser [a])-        -> (Value -> Parser b)-        -> (Value -> Parser [b])-        -> Value -> Parser [f a b]-    liftParseJSONList2 fa ga fb gb = withArray "[]" $ \vals ->-        fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)---- | Lift the standard 'parseJSON' function through the type constructor.-parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)-parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList-{-# INLINE parseJSON2 #-}------------------------------------------------------------------------------------ List functions------------------------------------------------------------------------------------ | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.-listParser :: (Value -> Parser a) -> Value -> Parser [a]-listParser f (Array xs) = fmap V.toList (V.mapM f xs)-listParser _ v          = typeMismatch "Array" v-{-# INLINE listParser #-}------------------------------------------------------------------------------------ [] instances----------------------------------------------------------------------------------instance FromJSON1 [] where-    liftParseJSON _ p' = p'-    {-# INLINE liftParseJSON #-}--instance (FromJSON a) => FromJSON [a] where-    parseJSON = parseJSON1------------------------------------------------------------------------------------ Functions------------------------------------------------------------------------------------ | Add context to a failure message, indicating the name of the structure--- being parsed.------ > prependContext "MyType" (fail "[error message]")--- > -- Error: "parsing MyType failed, [error message]"-prependContext :: String -> Parser a -> Parser a-prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")---- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@--- is an 'Data.Aeson.Object' and fails otherwise.------ ==== Error message example------ > withObject "MyType" f (String "oops")--- > -- Error: "parsing MyType failed, expected Object, but encountered String"-withObject :: String -> (Object -> Parser a) -> Value -> Parser a-withObject _    f (Object obj) = f obj-withObject name _ v            = prependContext name (typeMismatch "Object" v)-{-# INLINE withObject #-}---- | @'withText' name f value@ applies @f@ to the 'Text' when @value@ is a--- 'Data.Aeson.String' and fails otherwise.------ ==== Error message example------ > withText "MyType" f Null--- > -- Error: "parsing MyType failed, expected String, but encountered Null"-withText :: String -> (Text -> Parser a) -> Value -> Parser a-withText _    f (String txt) = f txt-withText name _ v            = prependContext name (typeMismatch "String" v)-{-# INLINE withText #-}---- | @'withArray' expected f value@ applies @f@ to the 'Array' when @value@ is--- an 'Data.Aeson.Array' and fails otherwise.------ ==== Error message example------ > withArray "MyType" f (String "oops")--- > -- Error: "parsing MyType failed, expected Array, but encountered String"-withArray :: String -> (Array -> Parser a) -> Value -> Parser a-withArray _    f (Array arr) = f arr-withArray name _ v           = prependContext name (typeMismatch "Array" v)-{-# INLINE withArray #-}---- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number--- when @value@ is a 'Data.Aeson.Number' and fails using 'typeMismatch'--- otherwise.------ /Warning/: If you are converting from a scientific to an unbounded--- type such as 'Integer' you may want to add a restriction on the--- size of the exponent (see 'withBoundedScientific') to prevent--- malicious input from filling up the memory of the target system.------ ==== Error message example------ > withScientific "MyType" f (String "oops")--- > -- Error: "parsing MyType failed, expected Number, but encountered String"-withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a-withScientific _ f (Number scientific) = f scientific-withScientific name _ v = prependContext name (typeMismatch "Number" v)-{-# INLINE withScientific #-}---- | A variant of 'withScientific' which doesn't use 'prependContext', so that--- such context can be added separately in a way that also applies when the--- continuation @f :: Scientific -> Parser a@ fails.------ /Warning/: If you are converting from a scientific to an unbounded--- type such as 'Integer' you may want to add a restriction on the--- size of the exponent (see 'withBoundedScientific') to prevent--- malicious input from filling up the memory of the target system.------ ==== Error message examples------ > withScientific' f (String "oops")--- > -- Error: "unexpected String"--- >--- > prependContext "MyType" (withScientific' f (String "oops"))--- > -- Error: "parsing MyType failed, unexpected String"-withScientific' :: (Scientific -> Parser a) -> Value -> Parser a-withScientific' f v = case v of-    Number n -> f n-    _ -> typeMismatch "Number" v-{-# INLINE withScientific' #-}---- | @'withBoundedScientific' name f value@ applies @f@ to the 'Scientific' number--- when @value@ is a 'Number' with exponent less than or equal to 1024.-withBoundedScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a-withBoundedScientific name f v = withBoundedScientific_ (prependContext name) f v-{-# INLINE withBoundedScientific #-}---- | A variant of 'withBoundedScientific' which doesn't use 'prependContext',--- so that such context can be added separately in a way that also applies--- when the continuation @f :: Scientific -> Parser a@ fails.-withBoundedScientific' :: (Scientific -> Parser a) -> Value -> Parser a-withBoundedScientific' f v = withBoundedScientific_ id f v-{-# INLINE withBoundedScientific' #-}---- | A variant of 'withBoundedScientific_' parameterized by a function to apply--- to the 'Parser' in case of failure.-withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a-withBoundedScientific_ whenFail f (Number scientific) =-    if exp10 > 1024-    then whenFail (fail msg)-    else f scientific-  where-    exp10 = base10Exponent scientific-    msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"-withBoundedScientific_ whenFail _ v =-    whenFail (typeMismatch "Number" v)-{-# INLINE withBoundedScientific_ #-}---- | @'withBool' expected f value@ applies @f@ to the 'Bool' when @value@ is a--- 'Boolean' and fails otherwise.------ ==== Error message example------ > withBool "MyType" f (String "oops")--- > -- Error: "parsing MyType failed, expected Boolean, but encountered String"-withBool :: String -> (Bool -> Parser a) -> Value -> Parser a-withBool _    f (Bool arr) = f arr-withBool name _ v          = prependContext name (typeMismatch "Boolean" v)-{-# INLINE withBool #-}---- | Decode a nested JSON-encoded string.-withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a-withEmbeddedJSON _ innerParser (String txt) =-    either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)-    where-        eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON-        eitherFormatError = either (Left . uncurry formatError) Right-withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v)-{-# INLINE withEmbeddedJSON #-}---- | Convert a value from JSON, failing if the types do not match.-fromJSON :: (FromJSON a) => Value -> Result a-fromJSON = parse parseJSON-{-# INLINE fromJSON #-}---- | Convert a value from JSON, failing if the types do not match.-ifromJSON :: (FromJSON a) => Value -> IResult a-ifromJSON = iparse parseJSON-{-# INLINE ifromJSON #-}---- | Retrieve the value associated with the given key of an 'Object'.--- The result is 'empty' if the key is not present or the value cannot--- be converted to the desired type.------ This accessor is appropriate if the key and value /must/ be present--- in an object for it to be valid.  If the key and value are--- optional, use '.:?' instead.-(.:) :: (FromJSON a) => Object -> Text -> Parser a-(.:) = explicitParseField parseJSON-{-# INLINE (.:) #-}---- | Retrieve the value associated with the given key of an 'Object'. The--- result is 'Nothing' if the key is not present or if its value is 'Null',--- or 'empty' if the value cannot be converted to the desired type.------ This accessor is most useful if the key and value can be absent--- from an object without affecting its validity.  If the key and--- value are mandatory, use '.:' instead.-(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)-(.:?) = explicitParseFieldMaybe parseJSON-{-# INLINE (.:?) #-}---- | Retrieve the value associated with the given key of an 'Object'.--- The result is 'Nothing' if the key is not present or 'empty' if the--- value cannot be converted to the desired type.------ This differs from '.:?' by attempting to parse 'Null' the same as any--- other JSON value, instead of interpreting it as 'Nothing'.-(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)-(.:!) = explicitParseFieldMaybe' parseJSON-{-# INLINE (.:!) #-}---- | Function variant of '.:'.-parseField :: (FromJSON a) => Object -> Text -> Parser a-parseField = (.:)-{-# INLINE parseField #-}---- | Function variant of '.:?'.-parseFieldMaybe :: (FromJSON a) => Object -> Text -> Parser (Maybe a)-parseFieldMaybe = (.:?)-{-# INLINE parseFieldMaybe #-}---- | Function variant of '.:!'.-parseFieldMaybe' :: (FromJSON a) => Object -> Text -> Parser (Maybe a)-parseFieldMaybe' = (.:!)-{-# INLINE parseFieldMaybe' #-}---- | Variant of '.:' with explicit parser function.------ E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@-explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a-explicitParseField p obj key = case H.lookup key obj of-    Nothing -> fail $ "key " ++ show key ++ " not found"-    Just v  -> p v <?> Key key-{-# INLINE explicitParseField #-}---- | Variant of '.:?' with explicit parser function.-explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)-explicitParseFieldMaybe p obj key = case H.lookup key obj of-    Nothing -> pure Nothing-    Just v  -> liftParseJSON p (listParser p) v <?> Key key -- listParser isn't used by maybe instance.-{-# INLINE explicitParseFieldMaybe #-}---- | Variant of '.:!' with explicit parser function.-explicitParseFieldMaybe' :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)-explicitParseFieldMaybe' p obj key = case H.lookup key obj of-    Nothing -> pure Nothing-    Just v  -> Just <$> p v <?> Key key-{-# INLINE explicitParseFieldMaybe' #-}---- | Helper for use in combination with '.:?' to provide default--- values for optional JSON object fields.------ This combinator is most useful if the key and value can be absent--- from an object without affecting its validity and we know a default--- value to assign in that case.  If the key and value are mandatory,--- use '.:' instead.------ Example usage:------ @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\"--- v2 <- o '.:'  \"mandatory_field\"--- v3 <- o '.:?' \"opt_field2\"--- @-(.!=) :: Parser (Maybe a) -> a -> Parser a-pmval .!= val = fromMaybe val <$> pmval-{-# INLINE (.!=) #-}------------------------------------------------------------------------------------- Generic parseJSON----------------------------------------------------------------------------------instance GFromJSON arity V1 where-    -- Whereof we cannot format, thereof we cannot parse:-    gParseJSON _ _ _ = fail "Attempted to parse empty type"---instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where-    -- Meta-information, which is not handled elsewhere, is just added to the-    -- parsed value:-    gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs---- Information for error messages--type TypeName = String-type ConName = String---- | Add the name of the type being parsed to a parser's error messages.-contextType :: TypeName -> Parser a -> Parser a-contextType = prependContext---- | Add the tagKey that will be looked up while building an ADT--- | Produce the error equivalent to--- | Left "Error in $: parsing T failed, expected an object with keys "tag" and--- | "contents", where "tag" i-- |s associated to one of ["Foo", "Bar"],--- | The parser returned error was: could not find key "tag"-contextTag :: Text -> [String] -> Parser a -> Parser a-contextTag tagKey cnames = prependFailure-  ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++-  " containing one of " ++ show cnames ++ ", ")---- | Add the name of the constructor being parsed to a parser's error messages.-contextCons :: ConName -> TypeName -> Parser a -> Parser a-contextCons cname tname = prependContext (showCons cname tname)---- | Render a constructor as @\"MyType(MyConstructor)\"@.-showCons :: ConName -> TypeName -> String-showCons cname tname = tname ++ "(" ++ cname ++ ")"-------------------------------------------------------------------------------------- Parsing single fields--instance (FromJSON a) => GFromJSON arity (K1 i a) where-    -- Constant values are decoded using their FromJSON instance:-    gParseJSON _opts _ = fmap K1 . parseJSON--instance GFromJSON One Par1 where-    -- Direct occurrences of the last type parameter are decoded with the-    -- function passed in as an argument:-    gParseJSON _opts (From1Args pj _) = fmap Par1 . pj--instance (FromJSON1 f) => GFromJSON One (Rec1 f) where-    -- Recursive occurrences of the last type parameter are decoded using their-    -- FromJSON1 instance:-    gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl--instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where-    -- If an occurrence of the last type parameter is nested inside two-    -- composed types, it is decoded by using the outermost type's FromJSON1-    -- instance to generically decode the innermost type:-    gParseJSON opts fargs =-        let gpj = gParseJSON opts fargs in-        fmap Comp1 . liftParseJSON gpj (listParser gpj)------------------------------------------------------------------------------------instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where-    -- Meta-information, which is not handled elsewhere, is just added to the-    -- parsed value:-    gParseJSON opts fargs = fmap M1 . gParseJSON' (tname :* opts :* fargs)-      where-        tname = moduleName proxy ++ "." ++ datatypeName proxy-        proxy = undefined :: M1 _i d _f _p---- | 'GFromJSON', after unwrapping the 'D1' constructor, now carrying the data--- type's name.-class GFromJSON' arity f where-    gParseJSON' :: TypeName :* Options :* FromArgs arity a-                -> Value-                -> Parser (f a)---- | Single constructor.-instance ( ConsFromJSON arity a-         , AllNullary         (C1 c a) allNullary-         , ParseSum     arity (C1 c a) allNullary-         , Constructor c-         ) => GFromJSON' arity (C1 c a) where-    -- The option 'tagSingleConstructors' determines whether to wrap-    -- a single-constructor type.-    gParseJSON' p@(_ :* opts :* _)-        | tagSingleConstructors opts-            = (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))-            . parseSum p-        | otherwise = fmap M1 . consParseJSON (cname :* p)-      where-        cname = conName (undefined :: M1 _i c _f _p)---- | Multiple constructors.-instance ( AllNullary          (a :+: b) allNullary-         , ParseSum      arity (a :+: b) allNullary-         ) => GFromJSON' arity (a :+: b) where-    -- If all constructors of a sum datatype are nullary and the-    -- 'allNullaryToStringTag' option is set they are expected to be-    -- encoded as strings.  This distinction is made by 'parseSum':-    gParseJSON' p =-        (unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->-                                        Parser ((a :+: b) _d))-                   . parseSum p------------------------------------------------------------------------------------class ParseSum arity f allNullary where-    parseSum :: TypeName :* Options :* FromArgs arity a-             -> Value-             -> Tagged allNullary (Parser (f a))--instance ( ConstructorNames        f-         , SumFromString           f-         , FromPair          arity f-         , FromTaggedObject  arity f-         , FromUntaggedValue arity f-         ) => ParseSum       arity f True where-    parseSum p@(tname :* opts :* _)-        | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts-        | otherwise                  = Tagged . parseNonAllNullarySum p--instance ( ConstructorNames        f-         , FromPair          arity f-         , FromTaggedObject  arity f-         , FromUntaggedValue arity f-         ) => ParseSum       arity f False where-    parseSum p = Tagged . parseNonAllNullarySum p------------------------------------------------------------------------------------parseAllNullarySum :: (SumFromString f, ConstructorNames f)-                   => TypeName -> Options -> Value -> Parser (f a)-parseAllNullarySum tname opts =-    withText tname $ \tag ->-        maybe (badTag tag) return $-            parseSumFromString modifier tag-  where-    badTag tag = failWithCTags tname modifier $ \cnames ->-        "expected one of the tags " ++ show cnames ++-        ", but found tag " ++ show tag-    modifier = constructorTagModifier opts---- | Fail with an informative error message about a mismatched tag.--- The error message is parameterized by the list of expected tags,--- to be inferred from the result type of the parser.-failWithCTags-  :: forall f a t. ConstructorNames f-  => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)-failWithCTags tname modifier f =-    contextType tname . fail $ f cnames-  where-    cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])--class SumFromString f where-    parseSumFromString :: (String -> String) -> Text -> Maybe (f a)--instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where-    parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>-                                  (R1 <$> parseSumFromString opts key)--instance (Constructor c) => SumFromString (C1 c U1) where-    parseSumFromString modifier key-        | key == name = Just $ M1 U1-        | otherwise   = Nothing-      where-        name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)---- For genericFromJSONKey-instance SumFromString a => SumFromString (D1 d a) where-    parseSumFromString modifier key = M1 <$> parseSumFromString modifier key---- | List of all constructor tags.-constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]-constructorTags modifier =-    fmap DList.toList (constructorNames' modifier)---- | List of all constructor names of an ADT, after a given conversion--- function. (Better inlining.)-class ConstructorNames a where-    constructorNames' :: (String -> t) -> Tagged2 a (DList.DList t)--instance (ConstructorNames a, ConstructorNames b) => ConstructorNames (a :+: b) where-    constructorNames' = liftA2 append constructorNames' constructorNames'-      where-        append-          :: Tagged2 a (DList.DList t)-          -> Tagged2 b (DList.DList t)-          -> Tagged2 (a :+: b) (DList.DList t)-        append (Tagged2 xs) (Tagged2 ys) = Tagged2 (DList.append xs ys)--instance Constructor c => ConstructorNames (C1 c a) where-    constructorNames' f = Tagged2 (pure (f cname))-      where-        cname = conName (undefined :: M1 _i c _f _p)---- For genericFromJSONKey-instance ConstructorNames a => ConstructorNames (D1 d a) where-    constructorNames' = retag . constructorNames'-      where-        retag :: Tagged2 a u -> Tagged2 (D1 d a) u-        retag (Tagged2 x) = Tagged2 x-----------------------------------------------------------------------------------parseNonAllNullarySum :: forall f c arity.-                         ( FromPair          arity f-                         , FromTaggedObject  arity f-                         , FromUntaggedValue arity f-                         , ConstructorNames        f-                         ) => TypeName :* Options :* FromArgs arity c-                           -> Value -> Parser (f c)-parseNonAllNullarySum p@(tname :* opts :* _) =-    case sumEncoding opts of-      TaggedObject{..} ->-          withObject tname $ \obj -> do-              tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey-              fromMaybe (badTag tag <?> Key tagKey) $-                  parseFromTaggedObject (tag :* contentsFieldName :* p) obj-        where-          tagKey = pack tagFieldName-          badTag tag = failWith_ $ \cnames ->-              "expected tag field to be one of " ++ show cnames ++-              ", but found tag " ++ show tag-          cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])--      ObjectWithSingleField ->-          withObject tname $ \obj -> case H.toList obj of-              [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $-                  parsePair (tag :* p) v-              _ -> contextType tname . fail $-                  "expected an Object with a single pair, but found " ++-                  show (H.size obj) ++ " pairs"-        where-          badTag tag = failWith_ $ \cnames ->-              "expected an Object with a single pair where the tag is one of " ++-              show cnames ++ ", but found tag " ++ show tag--      TwoElemArray ->-          withArray tname $ \arr -> case V.length arr of-              2 | String tag <- V.unsafeIndex arr 0 ->-                  maybe (badTag tag <?> Index 0) (<?> Index 1) $-                      parsePair (tag :* p) (V.unsafeIndex arr 1)-                | otherwise ->-                  contextType tname $-                      fail "tag element is not a String" <?> Index 0-              len -> contextType tname . fail $-                  "expected a 2-element Array, but encountered an Array of length " ++-                  show len-        where-          badTag tag = failWith_ $ \cnames ->-              "expected tag of the 2-element Array to be one of " ++-              show cnames ++ ", but found tag " ++ show tag--      UntaggedValue -> parseUntaggedValue p-  where-    failWith_ = failWithCTags tname (constructorTagModifier opts)------------------------------------------------------------------------------------class FromTaggedObject arity f where-    -- The first two components of the parameter tuple are: the constructor tag-    -- to match against, and the contents field name.-    parseFromTaggedObject-        :: Text :* String :* TypeName :* Options :* FromArgs arity a-        -> Object-        -> Maybe (Parser (f a))--instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>-    FromTaggedObject arity (a :+: b) where-        parseFromTaggedObject p obj =-            (fmap L1 <$> parseFromTaggedObject p obj) <|>-            (fmap R1 <$> parseFromTaggedObject p obj)--instance ( IsRecord                f isRecord-         , FromTaggedObject' arity f isRecord-         , Constructor c-         ) => FromTaggedObject arity (C1 c f) where-    parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))-        | tag == tag'-        = Just . fmap M1 .-            (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .-            parseFromTaggedObject' (contentsFieldName :* cname :* p)-        | otherwise = const Nothing-      where-        tag' = pack $ constructorTagModifier opts cname-        cname = conName (undefined :: M1 _i c _f _p)------------------------------------------------------------------------------------class FromTaggedObject' arity f isRecord where-    -- The first component of the parameter tuple is the contents field name.-    parseFromTaggedObject'-        :: String :* ConName :* TypeName :* Options :* FromArgs arity a-        -> Object -> Tagged isRecord (Parser (f a))--instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where-    -- Records are unpacked in the tagged object-    parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)--instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where-    -- Nonnullary nonrecords are encoded in the contents field-    parseFromTaggedObject' p obj = Tagged $ do-        contents <- contextCons cname tname (obj .: key)-        consParseJSON p' contents <?> Key key-      where-        key = pack contentsFieldName-        contentsFieldName :* p'@(cname :* tname :* _) = p--instance OVERLAPPING_ FromTaggedObject' arity U1 False where-    -- Nullary constructors don't need a contents field-    parseFromTaggedObject' _ _ = Tagged (pure U1)-------------------------------------------------------------------------------------- | Constructors need to be decoded differently depending on whether they're--- a record or not. This distinction is made by 'ConsParseJSON'.-class ConsFromJSON arity f where-    consParseJSON-        :: ConName :* TypeName :* Options :* FromArgs arity a-        -> Value -> Parser (f a)--class ConsFromJSON' arity f isRecord where-    consParseJSON'-        :: ConName :* TypeName :* Options :* FromArgs arity a-        -> Value -> Tagged isRecord (Parser (f a))--instance ( IsRecord            f isRecord-         , ConsFromJSON' arity f isRecord-         ) => ConsFromJSON arity f where-    consParseJSON p =-      (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))-          . consParseJSON' p--instance OVERLAPPING_-         ( GFromJSON arity a, RecordFromJSON arity (S1 s a)-         ) => ConsFromJSON' arity (S1 s a) True where-    consParseJSON' p@(cname :* tname :* opts :* fargs)-        | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs-        | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))--instance RecordFromJSON arity f => ConsFromJSON' arity f True where-    consParseJSON' p@(cname :* tname :* _) =-        Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))--instance OVERLAPPING_-         ConsFromJSON' arity U1 False where-    -- Empty constructors are expected to be encoded as an empty array:-    consParseJSON' (cname :* tname :* _) v =-        Tagged . contextCons cname tname $ case v of-            Array a | V.null a -> pure U1-                    | otherwise -> fail_ a-            _ -> typeMismatch "Array" v-      where-        fail_ a = fail $-            "expected an empty Array, but encountered an Array of length " ++-            show (V.length a)--instance OVERLAPPING_-         GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where-    consParseJSON' (_ :* _ :* opts :* fargs) =-        Tagged . fmap M1 . gParseJSON opts fargs--instance (ProductFromJSON arity f, ProductSize f-         ) => ConsFromJSON' arity f False where-    consParseJSON' p = Tagged . productParseJSON0 p------------------------------------------------------------------------------------class FieldNames f where-    fieldNames :: f a -> [String] -> [String]--instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where-    fieldNames _ =-      fieldNames (undefined :: a x) .-      fieldNames (undefined :: b y)--instance (Selector s) => FieldNames (S1 s f) where-    fieldNames _ = (selName (undefined :: M1 _i s _f _p) :)--class RecordFromJSON arity f where-    recordParseJSON-        :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a-        -> Object -> Parser (f a)--instance ( FieldNames f-         , RecordFromJSON' arity f-         ) => RecordFromJSON arity f where-    recordParseJSON (fromTaggedSum :* p@(cname :* tname :* opts :* _)) =-        \obj -> checkUnknown obj >> recordParseJSON' p obj-        where-            knownFields :: H.HashMap Text ()-            knownFields = H.fromList $ map ((,()) . pack) $-                [tagFieldName (sumEncoding opts) | fromTaggedSum] <>-                (fieldLabelModifier opts <$> fieldNames (undefined :: f a) [])--            checkUnknown =-                if not (rejectUnknownFields opts)-                then \_ -> return ()-                else \obj -> case H.keys (H.difference obj knownFields) of-                    [] -> return ()-                    unknownFields -> contextCons cname tname $-                        fail ("unknown fields: " ++ show unknownFields)--class RecordFromJSON' arity f where-    recordParseJSON'-        :: ConName :* TypeName :* Options :* FromArgs arity a-        -> Object -> Parser (f a)--instance ( RecordFromJSON' arity a-         , RecordFromJSON' arity b-         ) => RecordFromJSON' arity (a :*: b) where-    recordParseJSON' p obj =-        (:*:) <$> recordParseJSON' p obj-              <*> recordParseJSON' p obj--instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>-         RecordFromJSON' arity (S1 s a) where-    recordParseJSON' (cname :* tname :* opts :* fargs) obj = do-        fv <- contextCons cname tname (obj .: label)-        M1 <$> gParseJSON opts fargs fv <?> Key label-      where-        label = pack $ fieldLabelModifier opts sname-        sname = selName (undefined :: M1 _i s _f _p)--instance INCOHERENT_ (Selector s, FromJSON a) =>-         RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where-    recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label-      where-        label = fieldLabelModifier opts sname-        sname = selName (undefined :: M1 _i s _f _p)---- Parse an Option like a Maybe.-instance INCOHERENT_ (Selector s, FromJSON a) =>-         RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where-    recordParseJSON' p obj = wrap <$> recordParseJSON' p obj-      where-        wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p-        wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))------------------------------------------------------------------------------------productParseJSON0-    :: forall f arity a. (ProductFromJSON arity f, ProductSize f)-    => ConName :* TypeName :* Options :* FromArgs arity a-    -> Value -> Parser (f a)-    -- Products are expected to be encoded to an array. Here we check whether we-    -- got an array of the same size as the product, then parse each of the-    -- product's elements using productParseJSON:-productParseJSON0 p@(cname :* tname :* _ :* _) =-    withArray (showCons cname tname) $ \arr ->-        let lenArray = V.length arr-            lenProduct = (unTagged2 :: Tagged2 f Int -> Int)-                         productSize in-        if lenArray == lenProduct-        then productParseJSON p arr 0 lenProduct-        else contextCons cname tname $-             fail $ "expected an Array of length " ++ show lenProduct ++-                    ", but encountered an Array of length " ++ show lenArray------class ProductFromJSON arity f where-    productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a-                 -> Array -> Int -> Int-                 -> Parser (f a)--instance ( ProductFromJSON    arity a-         , ProductFromJSON    arity b-         ) => ProductFromJSON arity (a :*: b) where-    productParseJSON p arr ix len =-        (:*:) <$> productParseJSON p arr ix  lenL-              <*> productParseJSON p arr ixR lenR-        where-          lenL = len `unsafeShiftR` 1-          ixR  = ix + lenL-          lenR = len - lenL--instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where-    productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =-        M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix------------------------------------------------------------------------------------class FromPair arity f where-    -- The first component of the parameter tuple is the tag to match.-    parsePair :: Text :* TypeName :* Options :* FromArgs arity a-              -> Value-              -> Maybe (Parser (f a))--instance ( FromPair arity a-         , FromPair arity b-         ) => FromPair arity (a :+: b) where-    parsePair p pair =-        (fmap L1 <$> parsePair p pair) <|>-        (fmap R1 <$> parsePair p pair)--instance ( Constructor c-         , ConsFromJSON arity a-         ) => FromPair arity (C1 c a) where-    parsePair (tag :* p@(_ :* opts :* _)) v-        | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v-        | otherwise   = Nothing-      where-        tag' = pack $ constructorTagModifier opts cname-        cname = conName (undefined :: M1 _i c _a _p)------------------------------------------------------------------------------------class FromUntaggedValue arity f where-    parseUntaggedValue :: TypeName :* Options :* FromArgs arity a-                       -> Value-                       -> Parser (f a)--instance-    ( FromUntaggedValue    arity a-    , FromUntaggedValue    arity b-    ) => FromUntaggedValue arity (a :+: b)-  where-    parseUntaggedValue p value =-        L1 <$> parseUntaggedValue p value <|>-        R1 <$> parseUntaggedValue p value--instance OVERLAPPABLE_-    ( ConsFromJSON arity a-    , Constructor c-    ) => FromUntaggedValue arity (C1 c a)-  where-    parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)-      where-        cname = conName (undefined :: M1 _i c _f _p)--instance OVERLAPPING_-    ( Constructor c )-    => FromUntaggedValue arity (C1 c U1)-  where-    parseUntaggedValue (tname :* opts :* _) v =-        contextCons cname tname $ case v of-            String tag-                | tag == tag' -> pure $ M1 U1-                | otherwise -> fail_ tag-            _ -> typeMismatch "String" v-      where-        tag' = pack $ constructorTagModifier opts cname-        cname = conName (undefined :: M1 _i c _f _p)-        fail_ tag = fail $-          "expected tag " ++ show tag' ++ ", but found tag " ++ show tag------------------------------------------------------------------------------------ Instances-------------------------------------------------------------------------------------------------------------------------------------------------------------------- base-----------------------------------------------------------------------------------instance FromJSON2 Const where-    liftParseJSON2 p _ _ _ = fmap Const . p-    {-# INLINE liftParseJSON2 #-}--instance FromJSON a => FromJSON1 (Const a) where-    liftParseJSON _ _ = fmap Const . parseJSON-    {-# INLINE liftParseJSON #-}--instance FromJSON a => FromJSON (Const a b) where-    {-# INLINE parseJSON #-}-    parseJSON = fmap Const . parseJSON--instance (FromJSON a, FromJSONKey a) => FromJSONKey (Const a b) where-    fromJSONKey = fmap Const fromJSONKey---instance FromJSON1 Maybe where-    liftParseJSON _ _ Null = pure Nothing-    liftParseJSON p _ a    = Just <$> p a-    {-# INLINE liftParseJSON #-}--instance (FromJSON a) => FromJSON (Maybe a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}----instance FromJSON2 Either where-    liftParseJSON2 pA _ pB _ (Object (H.toList -> [(key, value)]))-        | key == left  = Left  <$> pA value <?> Key left-        | key == right = Right <$> pB value <?> Key right-      where-        left, right :: Text-        left  = "Left"-        right = "Right"--    liftParseJSON2 _ _ _ _ _ = fail $-        "expected an object with a single property " ++-        "where the property key should be either " ++-        "\"Left\" or \"Right\""-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a) => FromJSON1 (Either a) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}--instance FromJSON Void where-    parseJSON _ = fail "Cannot parse Void"-    {-# INLINE parseJSON #-}--instance FromJSON Bool where-    parseJSON (Bool b) = pure b-    parseJSON v = typeMismatch "Bool" v-    {-# INLINE parseJSON #-}--instance FromJSONKey Bool where-    fromJSONKey = FromJSONKeyTextParser $ \t -> case t of-        "true"  -> pure True-        "false" -> pure False-        _       -> fail $ "cannot parse key " ++ show t ++ " into Bool"--instance FromJSON Ordering where-  parseJSON = withText "Ordering" $ \s ->-    case s of-      "LT" -> return LT-      "EQ" -> return EQ-      "GT" -> return GT-      _ -> fail $ "parsing Ordering failed, unexpected " ++ show s ++-                  " (expected \"LT\", \"EQ\", or \"GT\")"--instance FromJSON () where-    parseJSON = withArray "()" $ \v ->-                  if V.null v-                    then pure ()-                    else prependContext "()" $ fail "expected an empty array"-    {-# INLINE parseJSON #-}--instance FromJSON Char where-    parseJSON = withText "Char" parseChar-    {-# INLINE parseJSON #-}--    parseJSONList (String s) = pure (T.unpack s)-    parseJSONList v = typeMismatch "String" v-    {-# INLINE parseJSONList #-}--parseChar :: Text -> Parser Char-parseChar t =-    if T.compareLength t 1 == EQ-      then pure $ T.head t-      else prependContext "Char" $ fail "expected a string of length 1"--instance FromJSON Double where-    parseJSON = parseRealFloat "Double"-    {-# INLINE parseJSON #-}--instance FromJSONKey Double where-    fromJSONKey = FromJSONKeyTextParser $ \t -> case t of-        "NaN"       -> pure (0/0)-        "Infinity"  -> pure (1/0)-        "-Infinity" -> pure (negate 1/0)-        _           -> Scientific.toRealFloat <$> parseScientificText t--instance FromJSON Float where-    parseJSON = parseRealFloat "Float"-    {-# INLINE parseJSON #-}--instance FromJSONKey Float where-    fromJSONKey = FromJSONKeyTextParser $ \t -> case t of-        "NaN"       -> pure (0/0)-        "Infinity"  -> pure (1/0)-        "-Infinity" -> pure (negate 1/0)-        _           -> Scientific.toRealFloat <$> parseScientificText t--instance (FromJSON a, Integral a) => FromJSON (Ratio a) where-    parseJSON (Number x)-      | exp10 <= 1024-      , exp10 >= -1024 = return $! realToFrac x-      | otherwise      = prependContext "Ratio" $ fail msg-      where-        exp10 = base10Exponent x-        msg = "found a number with exponent " ++ show exp10-           ++ ", but it must not be greater than 1024 or less than -1024"-    parseJSON o = objParser o-      where-        objParser = withObject "Rational" $ \obj -> do-            numerator <- obj .: "numerator"-            denominator <- obj .: "denominator"-            if denominator == 0-            then fail "Ratio denominator was 0"-            else pure $ numerator % denominator-    {-# INLINE parseJSON #-}---- | This instance includes a bounds check to prevent maliciously--- large inputs to fill up the memory of the target system. You can--- newtype 'Scientific' and provide your own instance using--- 'withScientific' if you want to allow larger inputs.-instance HasResolution a => FromJSON (Fixed a) where-    parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac)-    {-# INLINE parseJSON #-}--instance FromJSON Int where-    parseJSON = parseBoundedIntegral "Int"-    {-# INLINE parseJSON #-}--instance FromJSONKey Int where-    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"---- | This instance includes a bounds check to prevent maliciously--- large inputs to fill up the memory of the target system. You can--- newtype 'Scientific' and provide your own instance using--- 'withScientific' if you want to allow larger inputs.-instance FromJSON Integer where-    parseJSON = parseIntegral "Integer"-    {-# INLINE parseJSON #-}--instance FromJSONKey Integer where-    fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer"--instance FromJSON Natural where-    parseJSON value = do-        integer <- parseIntegral "Natural" value-        parseNatural integer--instance FromJSONKey Natural where-    fromJSONKey = FromJSONKeyTextParser $ \text -> do-        integer <- parseIntegralText "Natural" text-        parseNatural integer--parseNatural :: Integer -> Parser Natural-parseNatural integer =-    if integer < 0 then-        fail $ "parsing Natural failed, unexpected negative number " <> show integer-    else-        pure $ fromIntegral integer--instance FromJSON Int8 where-    parseJSON = parseBoundedIntegral "Int8"-    {-# INLINE parseJSON #-}--instance FromJSONKey Int8 where-    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int8"--instance FromJSON Int16 where-    parseJSON = parseBoundedIntegral "Int16"-    {-# INLINE parseJSON #-}--instance FromJSONKey Int16 where-    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int16"--instance FromJSON Int32 where-    parseJSON = parseBoundedIntegral "Int32"-    {-# INLINE parseJSON #-}--instance FromJSONKey Int32 where-    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int32"--instance FromJSON Int64 where-    parseJSON = parseBoundedIntegral "Int64"-    {-# INLINE parseJSON #-}--instance FromJSONKey Int64 where-    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int64"--instance FromJSON Word where-    parseJSON = parseBoundedIntegral "Word"-    {-# INLINE parseJSON #-}--instance FromJSONKey Word where-    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word"--instance FromJSON Word8 where-    parseJSON = parseBoundedIntegral "Word8"-    {-# INLINE parseJSON #-}--instance FromJSONKey Word8 where-    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word8"--instance FromJSON Word16 where-    parseJSON = parseBoundedIntegral "Word16"-    {-# INLINE parseJSON #-}--instance FromJSONKey Word16 where-    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word16"--instance FromJSON Word32 where-    parseJSON = parseBoundedIntegral "Word32"-    {-# INLINE parseJSON #-}--instance FromJSONKey Word32 where-    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word32"--instance FromJSON Word64 where-    parseJSON = parseBoundedIntegral "Word64"-    {-# INLINE parseJSON #-}--instance FromJSONKey Word64 where-    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64"--instance FromJSON CTime where-    parseJSON = fmap CTime . parseJSON-    {-# INLINE parseJSON #-}--instance FromJSON Text where-    parseJSON = withText "Text" pure-    {-# INLINE parseJSON #-}--instance FromJSONKey Text where-    fromJSONKey = fromJSONKeyCoerce---instance FromJSON LT.Text where-    parseJSON = withText "Lazy Text" $ pure . LT.fromStrict-    {-# INLINE parseJSON #-}--instance FromJSONKey LT.Text where-    fromJSONKey = FromJSONKeyText LT.fromStrict---instance FromJSON Version where-    parseJSON = withText "Version" parseVersionText-    {-# INLINE parseJSON #-}--instance FromJSONKey Version where-    fromJSONKey = FromJSONKeyTextParser parseVersionText--parseVersionText :: Text -> Parser Version-parseVersionText = go . readP_to_S parseVersion . unpack-  where-    go [(v,[])] = return v-    go (_ : xs) = go xs-    go _        = fail "parsing Version failed"------------------------------------------------------------------------------------ semigroups NonEmpty----------------------------------------------------------------------------------instance FromJSON1 NonEmpty where-    liftParseJSON p _ = withArray "NonEmpty" $-        (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList-      where-        ne []     = fail "parsing NonEmpty failed, unexpected empty list"-        ne (x:xs) = pure (x :| xs)-    {-# INLINE liftParseJSON #-}--instance (FromJSON a) => FromJSON (NonEmpty a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}------------------------------------------------------------------------------------ scientific----------------------------------------------------------------------------------instance FromJSON Scientific where-    parseJSON = withScientific "Scientific" pure-    {-# INLINE parseJSON #-}------------------------------------------------------------------------------------ DList----------------------------------------------------------------------------------instance FromJSON1 DList.DList where-    liftParseJSON p _ = withArray "DList" $-      fmap DList.fromList .-      Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a) => FromJSON (DList.DList a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}--#if MIN_VERSION_dlist(1,0,0) && __GLASGOW_HASKELL__ >=800--- | @since 1.5.3.0-instance FromJSON1 DNE.DNonEmpty where-    liftParseJSON p _ = withArray "DNonEmpty" $-        (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList-      where-        ne []     = fail "parsing DNonEmpty failed, unexpected empty list"-        ne (x:xs) = pure (DNE.fromNonEmpty (x :| xs))-    {-# INLINE liftParseJSON #-}---- | @since 1.5.3.0-instance (FromJSON a) => FromJSON (DNE.DNonEmpty a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}-#endif------------------------------------------------------------------------------------ transformers - Functors----------------------------------------------------------------------------------instance FromJSON1 Identity where-    liftParseJSON p _ a = Identity <$> p a-    {-# INLINE liftParseJSON #-}--    liftParseJSONList _ p a = fmap Identity <$> p a-    {-# INLINE liftParseJSONList #-}--instance (FromJSON a) => FromJSON (Identity a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}--    parseJSONList = liftParseJSONList parseJSON parseJSONList-    {-# INLINE parseJSONList #-}--instance (FromJSONKey a) => FromJSONKey (Identity a) where-    fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a)-    fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])---instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Compose f g) where-    liftParseJSON p pl a = Compose <$> liftParseJSON g gl a-      where-        g  = liftParseJSON p pl-        gl = liftParseJSONList p pl-    {-# INLINE liftParseJSON #-}--    liftParseJSONList p pl a = map Compose <$> liftParseJSONList g gl a-      where-        g  = liftParseJSON p pl-        gl = liftParseJSONList p pl-    {-# INLINE liftParseJSONList #-}--instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Compose f g a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}--    parseJSONList = liftParseJSONList parseJSON parseJSONList-    {-# INLINE parseJSONList #-}---instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Product f g) where-    liftParseJSON p pl a = uncurry Pair <$> liftParseJSON2 px pxl py pyl a-      where-        px  = liftParseJSON p pl-        pxl = liftParseJSONList p pl-        py  = liftParseJSON p pl-        pyl = liftParseJSONList p pl-    {-# INLINE liftParseJSON #-}--instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Product f g a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}---instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where-    liftParseJSON p pl (Object (H.toList -> [(key, value)]))-        | key == inl = InL <$> liftParseJSON p pl value <?> Key inl-        | key == inr = InR <$> liftParseJSON p pl value <?> Key inl-      where-        inl, inr :: Text-        inl = "InL"-        inr = "InR"--    liftParseJSON _ _ _ = fail $-        "parsing Sum failed, expected an object with a single property " ++-        "where the property key should be either " ++-        "\"InL\" or \"InR\""-    {-# INLINE liftParseJSON #-}--instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}------------------------------------------------------------------------------------ containers----------------------------------------------------------------------------------instance FromJSON1 Seq.Seq where-    liftParseJSON p _ = withArray "Seq" $-      fmap Seq.fromList .-      Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a) => FromJSON (Seq.Seq a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}---instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where-    parseJSON = fmap Set.fromList . parseJSON-    {-# INLINE parseJSON #-}---instance FromJSON IntSet.IntSet where-    parseJSON = fmap IntSet.fromList . parseJSON-    {-# INLINE parseJSON #-}---instance FromJSON1 IntMap.IntMap where-    liftParseJSON p pl = fmap IntMap.fromList . liftParseJSON p' pl'-      where-        p'  = liftParseJSON2     parseJSON parseJSONList p pl-        pl' = liftParseJSONList2 parseJSON parseJSONList p pl-    {-# INLINE liftParseJSON #-}--instance FromJSON a => FromJSON (IntMap.IntMap a) where-    parseJSON = fmap IntMap.fromList . parseJSON-    {-# INLINE parseJSON #-}---instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where-    liftParseJSON p _ = case fromJSONKey of-        FromJSONKeyCoerce -> withObject "Map" $-            fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)-        FromJSONKeyText f -> withObject "Map" $-            fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)-        FromJSONKeyTextParser f -> withObject "Map" $-            H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)-        FromJSONKeyValue f -> withArray "Map" $ \arr ->-            fmap M.fromList . Tr.sequence .-                zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr-    {-# INLINE liftParseJSON #-}--instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (M.Map k v) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}---instance FromJSON1 Tree.Tree where-    liftParseJSON p pl = go-      where-        go v = uncurry Tree.Node <$> liftParseJSON2 p pl p' pl' v--        p' = liftParseJSON go (listParser go)-        pl'= liftParseJSONList go (listParser go)--instance (FromJSON v) => FromJSON (Tree.Tree v) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}------------------------------------------------------------------------------------ uuid----------------------------------------------------------------------------------instance FromJSON UUID.UUID where-    parseJSON = withText "UUID" $-        maybe (fail "invalid UUID") pure . UUID.fromText--instance FromJSONKey UUID.UUID where-    fromJSONKey = FromJSONKeyTextParser $-        maybe (fail "invalid UUID") pure . UUID.fromText------------------------------------------------------------------------------------ vector----------------------------------------------------------------------------------instance FromJSON1 Vector where-    liftParseJSON p _ = withArray "Vector" $-        V.mapM (uncurry $ parseIndexedJSON p) . V.indexed-    {-# INLINE liftParseJSON #-}--instance (FromJSON a) => FromJSON (Vector a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}---vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)-vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry $ parseIndexedJSON parseJSON) . V.indexed-{-# INLINE vectorParseJSON #-}--instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where-    parseJSON = vectorParseJSON "Data.Vector.Storable.Vector"--instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where-    parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector"-    {-# INLINE parseJSON #-}--instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where-    parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector"-    {-# INLINE parseJSON #-}------------------------------------------------------------------------------------ unordered-containers----------------------------------------------------------------------------------instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where-    parseJSON = fmap HashSet.fromList . parseJSON-    {-# INLINE parseJSON #-}---instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where-    liftParseJSON p _ = case fromJSONKey of-        FromJSONKeyCoerce -> withObject "HashMap ~Text" $-            uc . H.traverseWithKey (\k v -> p v <?> Key k)-        FromJSONKeyText f -> withObject "HashMap" $-            fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)-        FromJSONKeyTextParser f -> withObject "HashMap" $-            H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)-        FromJSONKeyValue f -> withArray "Map" $ \arr ->-            fmap H.fromList . Tr.sequence .-                zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr-      where-        uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v)-        uc = unsafeCoerce--instance (FromJSON v, FromJSONKey k, Eq k, Hashable k) => FromJSON (H.HashMap k v) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}------------------------------------------------------------------------------------ aeson----------------------------------------------------------------------------------instance FromJSON Value where-    parseJSON = pure-    {-# INLINE parseJSON #-}--instance FromJSON DotNetTime where-    parseJSON = withText "DotNetTime" $ \t ->-        let (s,m) = T.splitAt (T.length t - 5) t-            t'    = T.concat [s,".",m]-        in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of-             Just d -> pure (DotNetTime d)-             _      -> fail "could not parse .NET time"-    {-# INLINE parseJSON #-}------------------------------------------------------------------------------------ primitive----------------------------------------------------------------------------------instance FromJSON a => FromJSON (PM.Array a) where-  -- note: we could do better than this if vector exposed the data-  -- constructor in Data.Vector.-  parseJSON = fmap Exts.fromList . parseJSON--instance FromJSON a => FromJSON (PM.SmallArray a) where-  parseJSON = fmap Exts.fromList . parseJSON--instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where-  parseJSON = fmap Exts.fromList . parseJSON------------------------------------------------------------------------------------ time----------------------------------------------------------------------------------instance FromJSON Day where-    parseJSON = withText "Day" (Time.run Time.day)--instance FromJSONKey Day where-    fromJSONKey = FromJSONKeyTextParser (Time.run Time.day)---instance FromJSON TimeOfDay where-    parseJSON = withText "TimeOfDay" (Time.run Time.timeOfDay)--instance FromJSONKey TimeOfDay where-    fromJSONKey = FromJSONKeyTextParser (Time.run Time.timeOfDay)---instance FromJSON LocalTime where-    parseJSON = withText "LocalTime" (Time.run Time.localTime)--instance FromJSONKey LocalTime where-    fromJSONKey = FromJSONKeyTextParser (Time.run Time.localTime)----- | Supported string formats:------ @YYYY-MM-DD HH:MM Z@--- @YYYY-MM-DD HH:MM:SS Z@--- @YYYY-MM-DD HH:MM:SS.SSS Z@------ The first space may instead be a @T@, and the second space is--- optional.  The @Z@ represents UTC.  The @Z@ may be replaced with a--- time zone offset of the form @+0000@ or @-08:00@, where the first--- two digits are hours, the @:@ is optional and the second two digits--- (also optional) are minutes.-instance FromJSON ZonedTime where-    parseJSON = withText "ZonedTime" (Time.run Time.zonedTime)--instance FromJSONKey ZonedTime where-    fromJSONKey = FromJSONKeyTextParser (Time.run Time.zonedTime)---instance FromJSON UTCTime where-    parseJSON = withText "UTCTime" (Time.run Time.utcTime)--instance FromJSONKey UTCTime where-    fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)----- | This instance includes a bounds check to prevent maliciously--- large inputs to fill up the memory of the target system. You can--- newtype 'Scientific' and provide your own instance using--- 'withScientific' if you want to allow larger inputs.-instance FromJSON NominalDiffTime where-    parseJSON = withBoundedScientific "NominalDiffTime" $ pure . realToFrac-    {-# INLINE parseJSON #-}----- | This instance includes a bounds check to prevent maliciously--- large inputs to fill up the memory of the target system. You can--- newtype 'Scientific' and provide your own instance using--- 'withScientific' if you want to allow larger inputs.-instance FromJSON DiffTime where-    parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac-    {-# INLINE parseJSON #-}--instance FromJSON SystemTime where-    parseJSON v = prependContext "SystemTime" $ do-        n <- parseJSON v-        let n' = floor (n * fromInteger (resolution n) :: Nano)-        let (secs, nano) = n' `divMod` resolution n-        return (MkSystemTime (fromInteger secs) (fromInteger nano))--instance FromJSON CalendarDiffTime where-    parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime-        <$> obj .: "months"-        <*> obj .: "time"--instance FromJSON CalendarDiffDays where-    parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays-        <$> obj .: "months"-        <*> obj .: "days"--instance FromJSON DayOfWeek where-    parseJSON = withText "DaysOfWeek" parseDayOfWeek--parseDayOfWeek :: T.Text -> Parser DayOfWeek-parseDayOfWeek t = case T.toLower t of-    "monday"    -> return Monday-    "tuesday"   -> return Tuesday-    "wednesday" -> return Wednesday-    "thursday"  -> return Thursday-    "friday"    -> return Friday-    "saturday"  -> return Saturday-    "sunday"    -> return Sunday-    _           -> fail "Invalid week day"--instance FromJSONKey DayOfWeek where-    fromJSONKey = FromJSONKeyTextParser parseDayOfWeek--instance FromJSON QuarterOfYear where-    parseJSON = withText "DaysOfWeek" parseQuarterOfYear--parseQuarterOfYear :: T.Text -> Parser QuarterOfYear-parseQuarterOfYear t = case T.toLower t of-    "q1" -> return Q1-    "q2" -> return Q2-    "q3" -> return Q3-    "q4" -> return Q4-    _    -> fail "Invalid quarter of year"--instance FromJSONKey QuarterOfYear where-    fromJSONKey = FromJSONKeyTextParser parseQuarterOfYear--instance FromJSON Quarter where-    parseJSON = withText "Quarter" (Time.run Time.quarter)--instance FromJSONKey Quarter where-    fromJSONKey = FromJSONKeyTextParser (Time.run Time.quarter)--instance FromJSON Month where-    parseJSON = withText "Month" (Time.run Time.month)--instance FromJSONKey Month where-    fromJSONKey = FromJSONKeyTextParser (Time.run Time.month)------------------------------------------------------------------------------------ base Monoid/Semigroup----------------------------------------------------------------------------------instance FromJSON1 Monoid.Dual where-    liftParseJSON p _ = fmap Monoid.Dual . p-    {-# INLINE liftParseJSON #-}--instance FromJSON a => FromJSON (Monoid.Dual a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}---instance FromJSON1 Monoid.First where-    liftParseJSON p p' = fmap Monoid.First . liftParseJSON p p'-    {-# INLINE liftParseJSON #-}--instance FromJSON a => FromJSON (Monoid.First a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}---instance FromJSON1 Monoid.Last where-    liftParseJSON p p' = fmap Monoid.Last . liftParseJSON p p'-    {-# INLINE liftParseJSON #-}--instance FromJSON a => FromJSON (Monoid.Last a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}---instance FromJSON1 Semigroup.Min where-    liftParseJSON p _ a = Semigroup.Min <$> p a-    {-# INLINE liftParseJSON #-}--    liftParseJSONList _ p a = fmap Semigroup.Min <$> p a-    {-# INLINE liftParseJSONList #-}--instance (FromJSON a) => FromJSON (Semigroup.Min a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}--    parseJSONList = liftParseJSONList parseJSON parseJSONList-    {-# INLINE parseJSONList #-}---instance FromJSON1 Semigroup.Max where-    liftParseJSON p _ a = Semigroup.Max <$> p a-    {-# INLINE liftParseJSON #-}--    liftParseJSONList _ p a = fmap Semigroup.Max <$> p a-    {-# INLINE liftParseJSONList #-}--instance (FromJSON a) => FromJSON (Semigroup.Max a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}--    parseJSONList = liftParseJSONList parseJSON parseJSONList-    {-# INLINE parseJSONList #-}---instance FromJSON1 Semigroup.First where-    liftParseJSON p _ a = Semigroup.First <$> p a-    {-# INLINE liftParseJSON #-}--    liftParseJSONList _ p a = fmap Semigroup.First <$> p a-    {-# INLINE liftParseJSONList #-}--instance (FromJSON a) => FromJSON (Semigroup.First a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}--    parseJSONList = liftParseJSONList parseJSON parseJSONList-    {-# INLINE parseJSONList #-}---instance FromJSON1 Semigroup.Last where-    liftParseJSON p _ a = Semigroup.Last <$> p a-    {-# INLINE liftParseJSON #-}--    liftParseJSONList _ p a = fmap Semigroup.Last <$> p a-    {-# INLINE liftParseJSONList #-}--instance (FromJSON a) => FromJSON (Semigroup.Last a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}--    parseJSONList = liftParseJSONList parseJSON parseJSONList-    {-# INLINE parseJSONList #-}---instance FromJSON1 Semigroup.WrappedMonoid where-    liftParseJSON p _ a = Semigroup.WrapMonoid <$> p a-    {-# INLINE liftParseJSON #-}--    liftParseJSONList _ p a = fmap Semigroup.WrapMonoid <$> p a-    {-# INLINE liftParseJSONList #-}--instance (FromJSON a) => FromJSON (Semigroup.WrappedMonoid a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}--    parseJSONList = liftParseJSONList parseJSON parseJSONList-    {-# INLINE parseJSONList #-}---instance FromJSON1 Semigroup.Option where-    liftParseJSON p p' = fmap Semigroup.Option . liftParseJSON p p'-    {-# INLINE liftParseJSON #-}--instance FromJSON a => FromJSON (Semigroup.Option a) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}------------------------------------------------------------------------------------ data-fix------------------------------------------------------------------------------------ | @since 1.5.3.0-instance FromJSON1 f => FromJSON (F.Fix f) where-    parseJSON = go where go = fmap F.Fix . liftParseJSON go parseJSONList---- | @since 1.5.3.0-instance (FromJSON1 f, Functor f) => FromJSON (F.Mu f) where-    parseJSON = fmap (F.unfoldMu F.unFix) . parseJSON---- | @since 1.5.3.0-instance (FromJSON1 f, Functor f) => FromJSON (F.Nu f) where-    parseJSON = fmap (F.unfoldNu F.unFix) . parseJSON------------------------------------------------------------------------------------ strict------------------------------------------------------------------------------------ | @since 1.5.3.0-instance (FromJSON a, FromJSON b) => FromJSON (S.These a b) where-    parseJSON = fmap S.toStrict . parseJSON---- | @since 1.5.3.0-instance FromJSON2 S.These where-    liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs---- | @since 1.5.3.0-instance FromJSON a => FromJSON1 (S.These a) where-    liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas---- | @since 1.5.3.0-instance (FromJSON a, FromJSON b) => FromJSON (S.Pair a b) where-    parseJSON = fmap S.toStrict . parseJSON---- | @since 1.5.3.0-instance FromJSON2 S.Pair where-    liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs---- | @since 1.5.3.0-instance FromJSON a => FromJSON1 (S.Pair a) where-    liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas---- | @since 1.5.3.0-instance (FromJSON a, FromJSON b) => FromJSON (S.Either a b) where-    parseJSON = fmap S.toStrict . parseJSON---- | @since 1.5.3.0-instance FromJSON2 S.Either where-    liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs---- | @since 1.5.3.0-instance FromJSON a => FromJSON1 (S.Either a) where-    liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas---- | @since 1.5.3.0-instance FromJSON a => FromJSON (S.Maybe a) where-    parseJSON = fmap S.toStrict . parseJSON---- | @since 1.5.3.0-instance FromJSON1 S.Maybe where-    liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas------------------------------------------------------------------------------------ tagged----------------------------------------------------------------------------------instance FromJSON1 Proxy where-    {-# INLINE liftParseJSON #-}-    liftParseJSON _ _ = fromNull "Proxy" Proxy--instance FromJSON (Proxy a) where-    {-# INLINE parseJSON #-}-    parseJSON = fromNull "Proxy" Proxy--fromNull :: String -> a -> Value -> Parser a-fromNull _ a Null = pure a-fromNull c _ v    = prependContext c (typeMismatch "Null" v)--instance FromJSON2 Tagged where-    liftParseJSON2 _ _ p _ = fmap Tagged . p-    {-# INLINE liftParseJSON2 #-}--instance FromJSON1 (Tagged a) where-    liftParseJSON p _ = fmap Tagged . p-    {-# INLINE liftParseJSON #-}--instance FromJSON b => FromJSON (Tagged a b) where-    parseJSON = parseJSON1-    {-# INLINE parseJSON #-}--instance FromJSONKey b => FromJSONKey (Tagged a b) where-    fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b)-    fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList------------------------------------------------------------------------------------ these------------------------------------------------------------------------------------ | @since 1.5.1.0-instance (FromJSON a, FromJSON b) => FromJSON (These a b) where-    parseJSON = withObject "These a b" (p . H.toList)-      where-        p [("This", a), ("That", b)] = These <$> parseJSON a <*> parseJSON b-        p [("That", b), ("This", a)] = These <$> parseJSON a <*> parseJSON b-        p [("This", a)] = This <$> parseJSON a-        p [("That", b)] = That <$> parseJSON b-        p _  = fail "Expected object with 'This' and 'That' keys only"---- | @since 1.5.1.0-instance FromJSON a => FromJSON1 (These a) where-    liftParseJSON pb _ = withObject "These a b" (p . H.toList)-      where-        p [("This", a), ("That", b)] = These <$> parseJSON a <*> pb b-        p [("That", b), ("This", a)] = These <$> parseJSON a <*> pb b-        p [("This", a)] = This <$> parseJSON a-        p [("That", b)] = That <$> pb b-        p _  = fail "Expected object with 'This' and 'That' keys only"---- | @since 1.5.1.0-instance FromJSON2 These where-    liftParseJSON2 pa _ pb _ = withObject "These a b" (p . H.toList)-      where-        p [("This", a), ("That", b)] = These <$> pa a <*> pb b-        p [("That", b), ("This", a)] = These <$> pa a <*> pb b-        p [("This", a)] = This <$> pa a-        p [("That", b)] = That <$> pb b-        p _  = fail "Expected object with 'This' and 'That' keys only"---- | @since 1.5.1.0-instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (These1 f g) where-    liftParseJSON px pl = withObject "These1" (p . H.toList)-      where-        p [("This", a), ("That", b)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b-        p [("That", b), ("This", a)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b-        p [("This", a)] = This1 <$> liftParseJSON px pl a-        p [("That", b)] = That1 <$> liftParseJSON px pl b-        p _  = fail "Expected object with 'This' and 'That' keys only"---- | @since 1.5.1.0-instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (These1 f g a) where-    parseJSON = parseJSON1------------------------------------------------------------------------------------ Instances for converting from map keys----------------------------------------------------------------------------------instance (FromJSON a, FromJSON b) => FromJSONKey (a,b)-instance (FromJSON a, FromJSON b, FromJSON c) => FromJSONKey (a,b,c)-instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)--instance FromJSONKey Char where-    fromJSONKey = FromJSONKeyTextParser parseChar-    fromJSONKeyList = FromJSONKeyText T.unpack--instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where-    fromJSONKey = fromJSONKeyList------------------------------------------------------------------------------------ Tuple instances, see tuple-instances-from.hs----------------------------------------------------------------------------------instance FromJSON2 (,) where-    liftParseJSON2 pA _ pB _ = withArray "(a, b)" $ \t ->-        let n = V.length t-        in if n == 2-            then (,)-                <$> parseJSONElemAtIndex pA 0 t-                <*> parseJSONElemAtIndex pB 1 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 2"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a) => FromJSON1 ((,) a) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b) => FromJSON (a, b) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a) => FromJSON2 ((,,) a) where-    liftParseJSON2 pB _ pC _ = withArray "(a, b, c)" $ \t ->-        let n = V.length t-        in if n == 3-            then (,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex pB 1 t-                <*> parseJSONElemAtIndex pC 2 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 3"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b) => FromJSON1 ((,,) a b) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a, b, c) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b) => FromJSON2 ((,,,) a b) where-    liftParseJSON2 pC _ pD _ = withArray "(a, b, c, d)" $ \t ->-        let n = V.length t-        in if n == 4-            then (,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex pC 2 t-                <*> parseJSONElemAtIndex pD 3 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 4"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON1 ((,,,) a b c) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a, b, c, d) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON2 ((,,,,) a b c) where-    liftParseJSON2 pD _ pE _ = withArray "(a, b, c, d, e)" $ \t ->-        let n = V.length t-        in if n == 5-            then (,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex pD 3 t-                <*> parseJSONElemAtIndex pE 4 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 5"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON1 ((,,,,) a b c d) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON (a, b, c, d, e) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON2 ((,,,,,) a b c d) where-    liftParseJSON2 pE _ pF _ = withArray "(a, b, c, d, e, f)" $ \t ->-        let n = V.length t-        in if n == 6-            then (,,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex parseJSON 3 t-                <*> parseJSONElemAtIndex pE 4 t-                <*> parseJSONElemAtIndex pF 5 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 6"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON1 ((,,,,,) a b c d e) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON (a, b, c, d, e, f) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON2 ((,,,,,,) a b c d e) where-    liftParseJSON2 pF _ pG _ = withArray "(a, b, c, d, e, f, g)" $ \t ->-        let n = V.length t-        in if n == 7-            then (,,,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex parseJSON 3 t-                <*> parseJSONElemAtIndex parseJSON 4 t-                <*> parseJSONElemAtIndex pF 5 t-                <*> parseJSONElemAtIndex pG 6 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 7"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON1 ((,,,,,,) a b c d e f) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON (a, b, c, d, e, f, g) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON2 ((,,,,,,,) a b c d e f) where-    liftParseJSON2 pG _ pH _ = withArray "(a, b, c, d, e, f, g, h)" $ \t ->-        let n = V.length t-        in if n == 8-            then (,,,,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex parseJSON 3 t-                <*> parseJSONElemAtIndex parseJSON 4 t-                <*> parseJSONElemAtIndex parseJSON 5 t-                <*> parseJSONElemAtIndex pG 6 t-                <*> parseJSONElemAtIndex pH 7 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 8"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON1 ((,,,,,,,) a b c d e f g) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h) => FromJSON (a, b, c, d, e, f, g, h) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON2 ((,,,,,,,,) a b c d e f g) where-    liftParseJSON2 pH _ pI _ = withArray "(a, b, c, d, e, f, g, h, i)" $ \t ->-        let n = V.length t-        in if n == 9-            then (,,,,,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex parseJSON 3 t-                <*> parseJSONElemAtIndex parseJSON 4 t-                <*> parseJSONElemAtIndex parseJSON 5 t-                <*> parseJSONElemAtIndex parseJSON 6 t-                <*> parseJSONElemAtIndex pH 7 t-                <*> parseJSONElemAtIndex pI 8 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 9"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h) => FromJSON1 ((,,,,,,,,) a b c d e f g h) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i) => FromJSON (a, b, c, d, e, f, g, h, i) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h) => FromJSON2 ((,,,,,,,,,) a b c d e f g h) where-    liftParseJSON2 pI _ pJ _ = withArray "(a, b, c, d, e, f, g, h, i, j)" $ \t ->-        let n = V.length t-        in if n == 10-            then (,,,,,,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex parseJSON 3 t-                <*> parseJSONElemAtIndex parseJSON 4 t-                <*> parseJSONElemAtIndex parseJSON 5 t-                <*> parseJSONElemAtIndex parseJSON 6 t-                <*> parseJSONElemAtIndex parseJSON 7 t-                <*> parseJSONElemAtIndex pI 8 t-                <*> parseJSONElemAtIndex pJ 9 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 10"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i) => FromJSON1 ((,,,,,,,,,) a b c d e f g h i) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j) => FromJSON (a, b, c, d, e, f, g, h, i, j) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i) => FromJSON2 ((,,,,,,,,,,) a b c d e f g h i) where-    liftParseJSON2 pJ _ pK _ = withArray "(a, b, c, d, e, f, g, h, i, j, k)" $ \t ->-        let n = V.length t-        in if n == 11-            then (,,,,,,,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex parseJSON 3 t-                <*> parseJSONElemAtIndex parseJSON 4 t-                <*> parseJSONElemAtIndex parseJSON 5 t-                <*> parseJSONElemAtIndex parseJSON 6 t-                <*> parseJSONElemAtIndex parseJSON 7 t-                <*> parseJSONElemAtIndex parseJSON 8 t-                <*> parseJSONElemAtIndex pJ 9 t-                <*> parseJSONElemAtIndex pK 10 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 11"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j) => FromJSON1 ((,,,,,,,,,,) a b c d e f g h i j) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k) => FromJSON (a, b, c, d, e, f, g, h, i, j, k) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j) => FromJSON2 ((,,,,,,,,,,,) a b c d e f g h i j) where-    liftParseJSON2 pK _ pL _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l)" $ \t ->-        let n = V.length t-        in if n == 12-            then (,,,,,,,,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex parseJSON 3 t-                <*> parseJSONElemAtIndex parseJSON 4 t-                <*> parseJSONElemAtIndex parseJSON 5 t-                <*> parseJSONElemAtIndex parseJSON 6 t-                <*> parseJSONElemAtIndex parseJSON 7 t-                <*> parseJSONElemAtIndex parseJSON 8 t-                <*> parseJSONElemAtIndex parseJSON 9 t-                <*> parseJSONElemAtIndex pK 10 t-                <*> parseJSONElemAtIndex pL 11 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 12"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k) => FromJSON1 ((,,,,,,,,,,,) a b c d e f g h i j k) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k) => FromJSON2 ((,,,,,,,,,,,,) a b c d e f g h i j k) where-    liftParseJSON2 pL _ pM _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m)" $ \t ->-        let n = V.length t-        in if n == 13-            then (,,,,,,,,,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex parseJSON 3 t-                <*> parseJSONElemAtIndex parseJSON 4 t-                <*> parseJSONElemAtIndex parseJSON 5 t-                <*> parseJSONElemAtIndex parseJSON 6 t-                <*> parseJSONElemAtIndex parseJSON 7 t-                <*> parseJSONElemAtIndex parseJSON 8 t-                <*> parseJSONElemAtIndex parseJSON 9 t-                <*> parseJSONElemAtIndex parseJSON 10 t-                <*> parseJSONElemAtIndex pL 11 t-                <*> parseJSONElemAtIndex pM 12 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 13"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l) => FromJSON1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l, m) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l) => FromJSON2 ((,,,,,,,,,,,,,) a b c d e f g h i j k l) where-    liftParseJSON2 pM _ pN _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m, n)" $ \t ->-        let n = V.length t-        in if n == 14-            then (,,,,,,,,,,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex parseJSON 3 t-                <*> parseJSONElemAtIndex parseJSON 4 t-                <*> parseJSONElemAtIndex parseJSON 5 t-                <*> parseJSONElemAtIndex parseJSON 6 t-                <*> parseJSONElemAtIndex parseJSON 7 t-                <*> parseJSONElemAtIndex parseJSON 8 t-                <*> parseJSONElemAtIndex parseJSON 9 t-                <*> parseJSONElemAtIndex parseJSON 10 t-                <*> parseJSONElemAtIndex parseJSON 11 t-                <*> parseJSONElemAtIndex pM 12 t-                <*> parseJSONElemAtIndex pN 13 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 14"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m) => FromJSON1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m, FromJSON n) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}---instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m) => FromJSON2 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m) where-    liftParseJSON2 pN _ pO _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)" $ \t ->-        let n = V.length t-        in if n == 15-            then (,,,,,,,,,,,,,,)-                <$> parseJSONElemAtIndex parseJSON 0 t-                <*> parseJSONElemAtIndex parseJSON 1 t-                <*> parseJSONElemAtIndex parseJSON 2 t-                <*> parseJSONElemAtIndex parseJSON 3 t-                <*> parseJSONElemAtIndex parseJSON 4 t-                <*> parseJSONElemAtIndex parseJSON 5 t-                <*> parseJSONElemAtIndex parseJSON 6 t-                <*> parseJSONElemAtIndex parseJSON 7 t-                <*> parseJSONElemAtIndex parseJSON 8 t-                <*> parseJSONElemAtIndex parseJSON 9 t-                <*> parseJSONElemAtIndex parseJSON 10 t-                <*> parseJSONElemAtIndex parseJSON 11 t-                <*> parseJSONElemAtIndex parseJSON 12 t-                <*> parseJSONElemAtIndex pN 13 t-                <*> parseJSONElemAtIndex pO 14 t-            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 15"-    {-# INLINE liftParseJSON2 #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m, FromJSON n) => FromJSON1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) where-    liftParseJSON = liftParseJSON2 parseJSON parseJSONList-    {-# INLINE liftParseJSON #-}--instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m, FromJSON n, FromJSON o) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where-    parseJSON = parseJSON2-    {-# INLINE parseJSON #-}
− Data/Aeson/Types/Generic.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--#include "overlapping-compat.h"---- |--- Module:      Data.Aeson.Types.Generic--- Copyright:   (c) 2012-2016 Bryan O'Sullivan---              (c) 2011, 2012 Bas Van Dijk---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Helpers for generic derivations.--module Data.Aeson.Types.Generic-    (-      IsRecord-    , AllNullary-    , Tagged2(..)-    , True-    , False-    , And-    , Zero-    , One-    , ProductSize(..)-    , (:*)(..)-    ) where--import Prelude.Compat--import GHC.Generics------------------------------------------------------------------------------------class IsRecord (f :: * -> *) isRecord | f -> isRecord--instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord-#if MIN_VERSION_base(4,9,0)-instance OVERLAPPING_ IsRecord (M1 S ('MetaSel 'Nothing u ss ds) f) False-#else-instance OVERLAPPING_ IsRecord (M1 S NoSelector f) False-#endif-instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord-instance IsRecord (K1 i c) True-instance IsRecord Par1 True-instance IsRecord (Rec1 f) True-instance IsRecord (f :.: g) True-instance IsRecord U1 False------------------------------------------------------------------------------------class AllNullary (f :: * -> *) allNullary | f -> allNullary--instance ( AllNullary a allNullaryL-         , AllNullary b allNullaryR-         , And allNullaryL allNullaryR allNullary-         ) => AllNullary (a :+: b) allNullary-instance AllNullary a allNullary => AllNullary (M1 i c a) allNullary-instance AllNullary (a :*: b) False-instance AllNullary (a :.: b) False-instance AllNullary (K1 i c) False-instance AllNullary Par1 False-instance AllNullary (Rec1 f) False-instance AllNullary U1 True--newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}-  deriving Functor------------------------------------------------------------------------------------data True-data False--class    And bool1 bool2 bool3 | bool1 bool2 -> bool3--instance And True  True  True-instance And False False False-instance And False True  False-instance And True  False False-------------------------------------------------------------------------------------- | A type-level indicator that 'ToJSON' or 'FromJSON' is being derived generically.-data Zero---- | A type-level indicator that 'ToJSON1' or 'FromJSON1' is being derived generically.-data One------------------------------------------------------------------------------------class ProductSize f where-    productSize :: Tagged2 f Int--instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where-    productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +-                            unTagged2 (productSize :: Tagged2 b Int)--instance ProductSize (S1 s a) where-    productSize = Tagged2 1-------------------------------------------------------------------------------------- | Simple extensible tuple type to simplify passing around many parameters.-data a :* b = a :* b--infixr 1 :*
− Data/Aeson/Types/Internal.hs 
@@ -1,821 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE StandaloneDeriving #-}-#if __GLASGOW_HASKELL__ >= 800--- a) THQ works on cross-compilers and unregisterised GHCs--- b) may make compilation faster as no dynamic loading is ever needed (not sure about this)--- c) removes one hindrance to have code inferred as SafeHaskell safe-{-# LANGUAGE TemplateHaskellQuotes #-}-#else-{-# LANGUAGE TemplateHaskell #-}-#endif---- |--- Module:      Data.Aeson.Types.Internal--- Copyright:   (c) 2011-2016 Bryan O'Sullivan---              (c) 2011 MailRank, Inc.--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Types for working with JSON data.--module Data.Aeson.Types.Internal-    (-    -- * Core JSON types-      Value(..)-    , Array-    , emptyArray, isEmptyArray-    , Pair-    , Object-    , emptyObject--    -- * Type conversion-    , Parser-    , Result(..)-    , IResult(..)-    , JSONPathElement(..)-    , JSONPath-    , iparse-    , parse-    , parseEither-    , parseMaybe-    , parseFail-    , modifyFailure-    , prependFailure-    , parserThrowError-    , parserCatchError-    , formatError-    , formatPath-    , formatRelativePath-    , (<?>)-    -- * Constructors and accessors-    , object--    -- * Generic and TH encoding configuration-    , Options(-          fieldLabelModifier-        , constructorTagModifier-        , allNullaryToStringTag-        , omitNothingFields-        , sumEncoding-        , unwrapUnaryRecords-        , tagSingleConstructors-        , rejectUnknownFields-        )--    , SumEncoding(..)-    , JSONKeyOptions(keyModifier)-    , defaultOptions-    , defaultTaggedObject-    , defaultJSONKeyOptions--    -- * Used for changing CamelCase names into something else.-    , camelTo-    , camelTo2--    -- * Other types-    , DotNetTime(..)-    ) where--import Prelude.Compat--import Control.Applicative (Alternative(..))-import Control.Arrow (first)-import Control.DeepSeq (NFData(..))-import Control.Monad (MonadPlus(..), ap)-import Data.Char (isLower, isUpper, toLower, isAlpha, isAlphaNum)-import Data.Data (Data)-import Data.Foldable (foldl')-import Data.HashMap.Strict (HashMap)-import Data.Hashable (Hashable(..))-import Data.List (intercalate)-import Data.Scientific (Scientific)-import Data.String (IsString(..))-import Data.Text (Text, pack, unpack)-import Data.Time (UTCTime)-import Data.Time.Format (FormatTime)-import Data.Typeable (Typeable)-import Data.Vector (Vector)-import GHC.Generics (Generic)-import qualified Control.Monad as Monad-import qualified Control.Monad.Fail as Fail-import qualified Data.HashMap.Strict as H-import qualified Data.Scientific as S-import qualified Data.Vector as V-import qualified Language.Haskell.TH.Syntax as TH---- | Elements of a JSON path used to describe the location of an--- error.-data JSONPathElement = Key Text-                       -- ^ JSON path element of a key into an object,-                       -- \"object.key\".-                     | Index {-# UNPACK #-} !Int-                       -- ^ JSON path element of an index into an-                       -- array, \"array[index]\".-                       deriving (Eq, Show, Typeable, Ord)-type JSONPath = [JSONPathElement]---- | The internal result of running a 'Parser'.-data IResult a = IError JSONPath String-               | ISuccess a-               deriving (Eq, Show, Typeable)---- | The result of running a 'Parser'.-data Result a = Error String-              | Success a-                deriving (Eq, Show, Typeable)--instance NFData JSONPathElement where-  rnf (Key t)   = rnf t-  rnf (Index i) = rnf i--instance (NFData a) => NFData (IResult a) where-    rnf (ISuccess a)      = rnf a-    rnf (IError path err) = rnf path `seq` rnf err--instance (NFData a) => NFData (Result a) where-    rnf (Success a) = rnf a-    rnf (Error err) = rnf err--instance Functor IResult where-    fmap f (ISuccess a)      = ISuccess (f a)-    fmap _ (IError path err) = IError path err-    {-# INLINE fmap #-}--instance Functor Result where-    fmap f (Success a) = Success (f a)-    fmap _ (Error err) = Error err-    {-# INLINE fmap #-}--instance Monad.Monad IResult where-    return = pure-    {-# INLINE return #-}--    ISuccess a      >>= k = k a-    IError path err >>= _ = IError path err-    {-# INLINE (>>=) #-}--#if !(MIN_VERSION_base(4,13,0))-    fail = Fail.fail-    {-# INLINE fail #-}-#endif--instance Fail.MonadFail IResult where-    fail err = IError [] err-    {-# INLINE fail #-}--instance Monad.Monad Result where-    return = pure-    {-# INLINE return #-}--    Success a >>= k = k a-    Error err >>= _ = Error err-    {-# INLINE (>>=) #-}--#if !(MIN_VERSION_base(4,13,0))-    fail = Fail.fail-    {-# INLINE fail #-}-#endif--instance Fail.MonadFail Result where-    fail err = Error err-    {-# INLINE fail #-}--instance Applicative IResult where-    pure  = ISuccess-    {-# INLINE pure #-}-    (<*>) = ap-    {-# INLINE (<*>) #-}--instance Applicative Result where-    pure  = Success-    {-# INLINE pure #-}-    (<*>) = ap-    {-# INLINE (<*>) #-}--instance MonadPlus IResult where-    mzero = fail "mzero"-    {-# INLINE mzero #-}-    mplus a@(ISuccess _) _ = a-    mplus _ b             = b-    {-# INLINE mplus #-}--instance MonadPlus Result where-    mzero = fail "mzero"-    {-# INLINE mzero #-}-    mplus a@(Success _) _ = a-    mplus _ b             = b-    {-# INLINE mplus #-}--instance Alternative IResult where-    empty = mzero-    {-# INLINE empty #-}-    (<|>) = mplus-    {-# INLINE (<|>) #-}--instance Alternative Result where-    empty = mzero-    {-# INLINE empty #-}-    (<|>) = mplus-    {-# INLINE (<|>) #-}--instance Semigroup (IResult a) where-    (<>) = mplus-    {-# INLINE (<>) #-}--instance Monoid (IResult a) where-    mempty  = fail "mempty"-    {-# INLINE mempty #-}-    mappend = (<>)-    {-# INLINE mappend #-}--instance Semigroup (Result a) where-    (<>) = mplus-    {-# INLINE (<>) #-}--instance Monoid (Result a) where-    mempty  = fail "mempty"-    {-# INLINE mempty #-}-    mappend = (<>)-    {-# INLINE mappend #-}--instance Foldable IResult where-    foldMap _ (IError _ _) = mempty-    foldMap f (ISuccess y) = f y-    {-# INLINE foldMap #-}--    foldr _ z (IError _ _) = z-    foldr f z (ISuccess y) = f y z-    {-# INLINE foldr #-}--instance Foldable Result where-    foldMap _ (Error _)   = mempty-    foldMap f (Success y) = f y-    {-# INLINE foldMap #-}--    foldr _ z (Error _)   = z-    foldr f z (Success y) = f y z-    {-# INLINE foldr #-}--instance Traversable IResult where-    traverse _ (IError path err) = pure (IError path err)-    traverse f (ISuccess a)      = ISuccess <$> f a-    {-# INLINE traverse #-}--instance Traversable Result where-    traverse _ (Error err) = pure (Error err)-    traverse f (Success a) = Success <$> f a-    {-# INLINE traverse #-}---- | Failure continuation.-type Failure f r   = JSONPath -> String -> f r--- | Success continuation.-type Success a f r = a -> f r---- | A JSON parser.  N.B. This might not fit your usual understanding of---  "parser".  Instead you might like to think of 'Parser' as a "parse result",--- i.e. a parser to which the input has already been applied.-newtype Parser a = Parser {-      runParser :: forall f r.-                   JSONPath-                -> Failure f r-                -> Success a f r-                -> f r-    }--instance Monad.Monad Parser where-    m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks-                                       in runParser m path kf ks'-    {-# INLINE (>>=) #-}-    return = pure-    {-# INLINE return #-}--#if !(MIN_VERSION_base(4,13,0))-    fail = Fail.fail-    {-# INLINE fail #-}-#endif--instance Fail.MonadFail Parser where-    fail msg = Parser $ \path kf _ks -> kf (reverse path) msg-    {-# INLINE fail #-}--instance Functor Parser where-    fmap f m = Parser $ \path kf ks -> let ks' a = ks (f a)-                                        in runParser m path kf ks'-    {-# INLINE fmap #-}--instance Applicative Parser where-    pure a = Parser $ \_path _kf ks -> ks a-    {-# INLINE pure #-}-    (<*>) = apP-    {-# INLINE (<*>) #-}--instance Alternative Parser where-    empty = fail "empty"-    {-# INLINE empty #-}-    (<|>) = mplus-    {-# INLINE (<|>) #-}--instance MonadPlus Parser where-    mzero = fail "mzero"-    {-# INLINE mzero #-}-    mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks-                                         in runParser a path kf' ks-    {-# INLINE mplus #-}--instance Semigroup (Parser a) where-    (<>) = mplus-    {-# INLINE (<>) #-}--instance Monoid (Parser a) where-    mempty  = fail "mempty"-    {-# INLINE mempty #-}-    mappend = (<>)-    {-# INLINE mappend #-}---- | Raise a parsing failure with some custom message.-parseFail :: String -> Parser a-parseFail = fail--apP :: Parser (a -> b) -> Parser a -> Parser b-apP d e = do-  b <- d-  b <$> e-{-# INLINE apP #-}---- | A JSON \"object\" (key\/value map).-type Object = HashMap Text Value---- | A JSON \"array\" (sequence).-type Array = Vector Value---- | A JSON value represented as a Haskell value.-data Value = Object !Object-           | Array !Array-           | String !Text-           | Number !Scientific-           | Bool !Bool-           | Null-             deriving (Eq, Read, Show, Typeable, Data, Generic)---- |------ The ordering is total, consistent with 'Eq' instance.--- However, nothing else about the ordering is specified,--- and it may change from environment to environment and version to version--- of either this package or its dependencies ('hashable' and 'unordered-containers').------ @since 1.5.2.0-deriving instance Ord Value--- standalone deriving to attach since annotation.---- | A newtype wrapper for 'UTCTime' that uses the same non-standard--- serialization format as Microsoft .NET, whose--- <https://msdn.microsoft.com/en-us/library/system.datetime(v=vs.110).aspx System.DateTime>--- type is by default serialized to JSON as in the following example:------ > /Date(1302547608878)/------ The number represents milliseconds since the Unix epoch.-newtype DotNetTime = DotNetTime {-      fromDotNetTime :: UTCTime-      -- ^ Acquire the underlying value.-    } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)--instance NFData Value where-    rnf (Object o) = rnf o-    rnf (Array a)  = foldl' (\x y -> rnf y `seq` x) () a-    rnf (String s) = rnf s-    rnf (Number n) = rnf n-    rnf (Bool b)   = rnf b-    rnf Null       = ()--instance IsString Value where-    fromString = String . pack-    {-# INLINE fromString #-}--hashValue :: Int -> Value -> Int-hashValue s (Object o)   = s `hashWithSalt` (0::Int) `hashWithSalt` o-hashValue s (Array a)    = foldl' hashWithSalt-                              (s `hashWithSalt` (1::Int)) a-hashValue s (String str) = s `hashWithSalt` (2::Int) `hashWithSalt` str-hashValue s (Number n)   = s `hashWithSalt` (3::Int) `hashWithSalt` n-hashValue s (Bool b)     = s `hashWithSalt` (4::Int) `hashWithSalt` b-hashValue s Null         = s `hashWithSalt` (5::Int)--instance Hashable Value where-    hashWithSalt = hashValue---- @since 0.11.0.0-instance TH.Lift Value where-    lift Null = [| Null |]-    lift (Bool b) = [| Bool b |]-    lift (Number n) = [| Number (S.scientific c e) |]-      where-        c = S.coefficient n-        e = S.base10Exponent n-    lift (String t) = [| String (pack s) |]-      where s = unpack t-    lift (Array a) = [| Array (V.fromList a') |]-      where a' = V.toList a-    lift (Object o) = [| Object (H.fromList . map (first pack) $ o') |]-      where o' = map (first unpack) . H.toList $ o-#if MIN_VERSION_template_haskell(2,17,0)-    liftTyped = TH.unsafeCodeCoerce . TH.lift-#elif MIN_VERSION_template_haskell(2,16,0)-    liftTyped = TH.unsafeTExpCoerce . TH.lift-#endif---- | The empty array.-emptyArray :: Value-emptyArray = Array V.empty---- | Determines if the 'Value' is an empty 'Array'.--- Note that: @isEmptyArray 'emptyArray'@.-isEmptyArray :: Value -> Bool-isEmptyArray (Array arr) = V.null arr-isEmptyArray _ = False---- | The empty object.-emptyObject :: Value-emptyObject = Object H.empty---- | Run a 'Parser'.-parse :: (a -> Parser b) -> a -> Result b-parse m v = runParser (m v) [] (const Error) Success-{-# INLINE parse #-}---- | Run a 'Parser'.-iparse :: (a -> Parser b) -> a -> IResult b-iparse m v = runParser (m v) [] IError ISuccess-{-# INLINE iparse #-}---- | Run a 'Parser' with a 'Maybe' result type.-parseMaybe :: (a -> Parser b) -> a -> Maybe b-parseMaybe m v = runParser (m v) [] (\_ _ -> Nothing) Just-{-# INLINE parseMaybe #-}---- | Run a 'Parser' with an 'Either' result type.  If the parse fails,--- the 'Left' payload will contain an error message.-parseEither :: (a -> Parser b) -> a -> Either String b-parseEither m v = runParser (m v) [] onError Right-  where onError path msg = Left (formatError path msg)-{-# INLINE parseEither #-}---- | Annotate an error message with a--- <http://goessner.net/articles/JsonPath/ JSONPath> error location.-formatError :: JSONPath -> String -> String-formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg---- | Format a <http://goessner.net/articles/JsonPath/ JSONPath> as a 'String',--- representing the root object as @$@.-formatPath :: JSONPath -> String-formatPath path = "$" ++ formatRelativePath path---- | Format a <http://goessner.net/articles/JsonPath/ JSONPath> as a 'String'--- which represents the path relative to some root object.-formatRelativePath :: JSONPath -> String-formatRelativePath path = format "" path-  where-    format :: String -> JSONPath -> String-    format pfx []                = pfx-    format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts-    format pfx (Key key:parts)   = format (pfx ++ formatKey key) parts--    formatKey :: Text -> String-    formatKey key-       | isIdentifierKey strKey = "." ++ strKey-       | otherwise              = "['" ++ escapeKey strKey ++ "']"-      where strKey = unpack key--    isIdentifierKey :: String -> Bool-    isIdentifierKey []     = False-    isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs--    escapeKey :: String -> String-    escapeKey = concatMap escapeChar--    escapeChar :: Char -> String-    escapeChar '\'' = "\\'"-    escapeChar '\\' = "\\\\"-    escapeChar c    = [c]---- | A key\/value pair for an 'Object'.-type Pair = (Text, Value)---- | Create a 'Value' from a list of name\/value 'Pair's.  If duplicate--- keys arise, earlier keys and their associated values win.-object :: [Pair] -> Value-object = Object . H.fromList-{-# INLINE object #-}---- | Add JSON Path context to a parser------ When parsing a complex structure, it helps to annotate (sub)parsers--- with context, so that if an error occurs, you can find its location.------ > withObject "Person" $ \o ->--- >   Person--- >     <$> o .: "name" <?> Key "name"--- >     <*> o .: "age"  <?> Key "age"------ (Standard methods like '(.:)' already do this.)------ With such annotations, if an error occurs, you will get a JSON Path--- location of that error.------ Since 0.10-(<?>) :: Parser a -> JSONPathElement -> Parser a-p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks---- | If the inner @Parser@ failed, modify the failure message using the--- provided function. This allows you to create more descriptive error messages.--- For example:------ > parseJSON (Object o) = modifyFailure--- >     ("Parsing of the Foo value failed: " ++)--- >     (Foo <$> o .: "someField")------ Since 0.6.2.0-modifyFailure :: (String -> String) -> Parser a -> Parser a-modifyFailure f (Parser p) = Parser $ \path kf ks ->-    p path (\p' m -> kf p' (f m)) ks---- | If the inner 'Parser' failed, prepend the given string to the failure--- message.------ @--- 'prependFailure' s = 'modifyFailure' (s '++')--- @-prependFailure :: String -> Parser a -> Parser a-prependFailure = modifyFailure . (++)---- | Throw a parser error with an additional path.------ @since 1.2.1.0-parserThrowError :: JSONPath -> String -> Parser a-parserThrowError path' msg = Parser $ \path kf _ks ->-    kf (reverse path ++ path') msg---- | A handler function to handle previous errors and return to normal execution.------ @since 1.2.1.0-parserCatchError :: Parser a -> (JSONPath -> String -> Parser a) -> Parser a-parserCatchError (Parser p) handler = Parser $ \path kf ks ->-    p path (\e msg -> runParser (handler e msg) path kf ks) ks------------------------------------------------------------------------------------- Generic and TH encoding configuration------------------------------------------------------------------------------------- | Options that specify how to encode\/decode your datatype to\/from JSON.------ Options can be set using record syntax on 'defaultOptions' with the fields--- below.-data Options = Options-    { fieldLabelModifier :: String -> String-      -- ^ Function applied to field labels.-      -- Handy for removing common record prefixes for example.-    , constructorTagModifier :: String -> String-      -- ^ Function applied to constructor tags which could be handy-      -- for lower-casing them for example.-    , allNullaryToStringTag :: Bool-      -- ^ If 'True' the constructors of a datatype, with /all/-      -- nullary constructors, will be encoded to just a string with-      -- the constructor tag. If 'False' the encoding will always-      -- follow the `sumEncoding`.-    , omitNothingFields :: Bool-      -- ^ If 'True', record fields with a 'Nothing' value will be-      -- omitted from the resulting object. If 'False', the resulting-      -- object will include those fields mapping to @null@.-      ---      -- Note that this /does not/ affect parsing: 'Maybe' fields are-      -- optional regardless of the value of 'omitNothingFields', subject-      -- to the note below.-      ---      -- === Note-      ---      -- Setting 'omitNothingFields' to 'True' only affects fields which are of-      -- type 'Maybe' /uniformly/ in the 'ToJSON' instance.-      -- In particular, if the type of a field is declared as a type variable, it-      -- will not be omitted from the JSON object, unless the field is-      -- specialized upfront in the instance.-      ---      -- The same holds for 'Maybe' fields being optional in the 'FromJSON' instance.-      ---      -- ==== __Example__-      ---      -- The generic instance for the following type @Fruit@ depends on whether-      -- the instance head is @Fruit a@ or @Fruit (Maybe a)@.-      ---      -- @-      -- data Fruit a = Fruit-      --   { apples :: a  -- A field whose type is a type variable.-      --   , oranges :: 'Maybe' Int-      --   } deriving 'Generic'-      ---      -- -- apples required, oranges optional-      -- -- Even if 'Data.Aeson.fromJSON' is then specialized to (Fruit ('Maybe' a)).-      -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit a)-      ---      -- -- apples optional, oranges optional-      -- -- In this instance, the field apples is uniformly of type ('Maybe' a).-      -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit ('Maybe' a))-      ---      -- options :: 'Options'-      -- options = 'defaultOptions' { 'omitNothingFields' = 'True' }-      ---      -- -- apples always present in the output, oranges is omitted if 'Nothing'-      -- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit a) where-      --   'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options-      ---      -- -- both apples and oranges are omitted if 'Nothing'-      -- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit ('Maybe' a)) where-      --   'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options-      -- @-    , sumEncoding :: SumEncoding-      -- ^ Specifies how to encode constructors of a sum datatype.-    , unwrapUnaryRecords :: Bool-      -- ^ Hide the field name when a record constructor has only one-      -- field, like a newtype.-    , tagSingleConstructors :: Bool-      -- ^ Encode types with a single constructor as sums,-      -- so that `allNullaryToStringTag` and `sumEncoding` apply.-    , rejectUnknownFields :: Bool-      -- ^ Applies only to 'Data.Aeson.FromJSON' instances. If a field appears in-      -- the parsed object map, but does not appear in the target object, parsing-      -- will fail, with an error message indicating which fields were unknown.-    }--instance Show Options where-  show (Options f c a o s u t r) =-       "Options {"-    ++ intercalate ", "-      [ "fieldLabelModifier =~ " ++ show (f "exampleField")-      , "constructorTagModifier =~ " ++ show (c "ExampleConstructor")-      , "allNullaryToStringTag = " ++ show a-      , "omitNothingFields = " ++ show o-      , "sumEncoding = " ++ show s-      , "unwrapUnaryRecords = " ++ show u-      , "tagSingleConstructors = " ++ show t-      , "rejectUnknownFields = " ++ show r-      ]-    ++ "}"---- | Specifies how to encode constructors of a sum datatype.-data SumEncoding =-    TaggedObject { tagFieldName      :: String-                 , contentsFieldName :: String-                 }-    -- ^ A constructor will be encoded to an object with a field-    -- 'tagFieldName' which specifies the constructor tag (modified by-    -- the 'constructorTagModifier'). If the constructor is a record-    -- the encoded record fields will be unpacked into this object. So-    -- make sure that your record doesn't have a field with the same-    -- label as the 'tagFieldName'. Otherwise the tag gets overwritten-    -- by the encoded value of that field! If the constructor is not a-    -- record the encoded constructor contents will be stored under-    -- the 'contentsFieldName' field.-  | UntaggedValue-    -- ^ Constructor names won't be encoded. Instead only the contents of the-    -- constructor will be encoded as if the type had a single constructor. JSON-    -- encodings have to be disjoint for decoding to work properly.-    ---    -- When decoding, constructors are tried in the order of definition. If some-    -- encodings overlap, the first one defined will succeed.-    ---    -- /Note:/ Nullary constructors are encoded as strings (using-    -- 'constructorTagModifier'). Having a nullary constructor alongside a-    -- single field constructor that encodes to a string leads to ambiguity.-    ---    -- /Note:/ Only the last error is kept when decoding, so in the case of-    -- malformed JSON, only an error for the last constructor will be reported.-  | ObjectWithSingleField-    -- ^ A constructor will be encoded to an object with a single-    -- field named after the constructor tag (modified by the-    -- 'constructorTagModifier') which maps to the encoded contents of-    -- the constructor.-  | TwoElemArray-    -- ^ A constructor will be encoded to a 2-element array where the-    -- first element is the tag of the constructor (modified by the-    -- 'constructorTagModifier') and the second element the encoded-    -- contents of the constructor.-    deriving (Eq, Show)---- | Options for encoding keys with 'Data.Aeson.Types.genericFromJSONKey' and--- 'Data.Aeson.Types.genericToJSONKey'.-data JSONKeyOptions = JSONKeyOptions-    { keyModifier :: String -> String-      -- ^ Function applied to keys. Its result is what goes into the encoded-      -- 'Value'.-      ---      -- === __Example__-      ---      -- The following instances encode the constructor @Bar@ to lower-case keys-      -- @\"bar\"@.-      ---      -- @-      -- data Foo = Bar-      --   deriving 'Generic'-      ---      -- opts :: 'JSONKeyOptions'-      -- opts = 'defaultJSONKeyOptions' { 'keyModifier' = 'toLower' }-      ---      -- instance 'ToJSONKey' Foo where-      --   'toJSONKey' = 'genericToJSONKey' opts-      ---      -- instance 'FromJSONKey' Foo where-      --   'fromJSONKey' = 'genericFromJSONKey' opts-      -- @-    }---- | Default encoding 'Options':------ @--- 'Options'--- { 'fieldLabelModifier'      = id--- , 'constructorTagModifier'  = id--- , 'allNullaryToStringTag'   = True--- , 'omitNothingFields'       = False--- , 'sumEncoding'             = 'defaultTaggedObject'--- , 'unwrapUnaryRecords'      = False--- , 'tagSingleConstructors'   = False--- , 'rejectUnknownFields'     = False--- }--- @-defaultOptions :: Options-defaultOptions = Options-                 { fieldLabelModifier      = id-                 , constructorTagModifier  = id-                 , allNullaryToStringTag   = True-                 , omitNothingFields       = False-                 , sumEncoding             = defaultTaggedObject-                 , unwrapUnaryRecords      = False-                 , tagSingleConstructors   = False-                 , rejectUnknownFields     = False-                 }---- | Default 'TaggedObject' 'SumEncoding' options:------ @--- defaultTaggedObject = 'TaggedObject'---                       { 'tagFieldName'      = \"tag\"---                       , 'contentsFieldName' = \"contents\"---                       }--- @-defaultTaggedObject :: SumEncoding-defaultTaggedObject = TaggedObject-                      { tagFieldName      = "tag"-                      , contentsFieldName = "contents"-                      }---- | Default 'JSONKeyOptions':------ @--- defaultJSONKeyOptions = 'JSONKeyOptions'---                         { 'keyModifier' = 'id'---                         }--- @-defaultJSONKeyOptions :: JSONKeyOptions-defaultJSONKeyOptions = JSONKeyOptions id---- | Converts from CamelCase to another lower case, interspersing---   the character between all capital letters and their previous---   entries, except those capital letters that appear together,---   like 'API'.------   For use by Aeson template haskell calls.------   > camelTo '_' 'CamelCaseAPI' == "camel_case_api"-camelTo :: Char -> String -> String-{-# DEPRECATED camelTo "Use camelTo2 for better results" #-}-camelTo c = lastWasCap True-  where-    lastWasCap :: Bool    -- ^ Previous was a capital letter-              -> String  -- ^ The remaining string-              -> String-    lastWasCap _    []           = []-    lastWasCap prev (x : xs)     = if isUpper x-                                      then if prev-                                             then toLower x : lastWasCap True xs-                                             else c : toLower x : lastWasCap True xs-                                      else x : lastWasCap False xs---- | Better version of 'camelTo'. Example where it works better:------   > camelTo '_' 'CamelAPICase' == "camel_apicase"---   > camelTo2 '_' 'CamelAPICase' == "camel_api_case"-camelTo2 :: Char -> String -> String-camelTo2 c = map toLower . go2 . go1-    where go1 "" = ""-          go1 (x:u:l:xs) | isUpper u && isLower l = x : c : u : l : go1 xs-          go1 (x:xs) = x : go1 xs-          go2 "" = ""-          go2 (l:u:xs) | isLower l && isUpper u = l : c : u : go2 xs-          go2 (x:xs) = x : go2 xs
− Data/Aeson/Types/ToJSON.hs 
@@ -1,3046 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--#include "overlapping-compat.h"-#include "incoherent-compat.h"---- TODO: Drop this when we remove support for Data.Attoparsec.Number-{-# OPTIONS_GHC -fno-warn-deprecations #-}--module Data.Aeson.Types.ToJSON-    (-    -- * Core JSON classes-      ToJSON(..)-    -- * Liftings to unary and binary type constructors-    , ToJSON1(..)-    , toJSON1-    , toEncoding1-    , ToJSON2(..)-    , toJSON2-    , toEncoding2-    -- * Generic JSON classes-    , GToJSON'(..)-    , ToArgs(..)-    , genericToJSON-    , genericToEncoding-    , genericLiftToJSON-    , genericLiftToEncoding-    -- * Classes and types for map keys-    , ToJSONKey(..)-    , ToJSONKeyFunction(..)-    , toJSONKeyText-    , contramapToJSONKeyFunction--    , GToJSONKey()-    , genericToJSONKey--    -- * Object key-value pairs-    , KeyValue(..)-    , KeyValuePair(..)-    , FromPairs(..)-    -- * Functions needed for documentation-    -- * Encoding functions-    , listEncoding-    , listValue-    ) where--import Prelude.Compat--import Control.Applicative (Const(..))-import Control.Monad.ST (ST)-import Data.Aeson.Encoding (Encoding, Encoding', Series, dict, emptyArray_)-import Data.Aeson.Encoding.Internal ((>*<))-import Data.Aeson.Internal.Functions (mapHashKeyVal, mapKeyVal)-import Data.Aeson.Types.Generic (AllNullary, False, IsRecord, One, ProductSize, Tagged2(..), True, Zero, productSize)-import Data.Aeson.Types.Internal-import Data.Attoparsec.Number (Number(..))-import Data.Bits (unsafeShiftR)-import Data.DList (DList)-import Data.Fixed (Fixed, HasResolution, Nano)-import Data.Foldable (toList)-import Data.Functor.Compose (Compose(..))-import Data.Functor.Contravariant (Contravariant (..))-import Data.Functor.Identity (Identity(..))-import Data.Functor.Product (Product(..))-import Data.Functor.Sum (Sum(..))-import Data.Functor.These (These1 (..))-import Data.Int (Int16, Int32, Int64, Int8)-import Data.List (intersperse)-import Data.List.NonEmpty (NonEmpty(..))-import Data.Proxy (Proxy(..))-import Data.Ratio (Ratio, denominator, numerator)-import Data.Scientific (Scientific)-import Data.Tagged (Tagged(..))-import Data.Text (Text, pack)-import Data.These (These (..))-import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)-import Data.Time.Calendar.Month.Compat (Month)-import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))-import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))-import Data.Time.LocalTime.Compat (CalendarDiffTime (..))-import Data.Time.Clock.System.Compat (SystemTime (..))-import Data.Time.Format.Compat (FormatTime, formatTime, defaultTimeLocale)-import Data.Vector (Vector)-import Data.Version (Version, showVersion)-import Data.Void (Void, absurd)-import Data.Word (Word16, Word32, Word64, Word8)-import Foreign.Storable (Storable)-import Foreign.C.Types (CTime (..))-import GHC.Generics-import Numeric.Natural (Natural)-import qualified Data.Aeson.Encoding as E-import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)-import qualified Data.ByteString.Lazy as L-import qualified Data.DList as DList-#if MIN_VERSION_dlist(1,0,0) && __GLASGOW_HASKELL__ >=800-import qualified Data.DList.DNonEmpty as DNE-#endif-import qualified Data.Fix as F-import qualified Data.HashMap.Strict as H-import qualified Data.HashSet as HashSet-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import qualified Data.List.NonEmpty as NE-import qualified Data.Map as M-import qualified Data.Monoid as Monoid-import qualified Data.Scientific as Scientific-import qualified Data.Semigroup as Semigroup-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import qualified Data.Strict as S-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as LT-import qualified Data.Tree as Tree-import qualified Data.UUID.Types as UUID-import qualified Data.Vector as V-import qualified Data.Vector.Generic as VG-import qualified Data.Vector.Mutable as VM-import qualified Data.Vector.Primitive as VP-import qualified Data.Vector.Storable as VS-import qualified Data.Vector.Unboxed as VU--import qualified Data.Aeson.Encoding.Builder as EB-import qualified Data.ByteString.Builder as B--import qualified GHC.Exts as Exts-import qualified Data.Primitive.Array as PM-import qualified Data.Primitive.SmallArray as PM-import qualified Data.Primitive.Types as PM-import qualified Data.Primitive.PrimArray as PM--toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value-toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)-{-# INLINE toJSONPair #-}--realFloatToJSON :: RealFloat a => a -> Value-realFloatToJSON d-    | isNaN d || isInfinite d = Null-    | otherwise = Number $ Scientific.fromFloatDigits d-{-# INLINE realFloatToJSON #-}------------------------------------------------------------------------------------ Generics------------------------------------------------------------------------------------ | Class of generic representation types that can be converted to--- JSON.-class GToJSON' enc arity f where-    -- | This method (applied to 'defaultOptions') is used as the-    -- default generic implementation of 'toJSON'-    -- (with @enc ~ 'Value'@ and @arity ~ 'Zero'@)-    -- and 'liftToJSON' (if the @arity@ is 'One').-    ---    -- It also provides a generic implementation of 'toEncoding'-    -- (with @enc ~ 'Encoding'@ and @arity ~ 'Zero'@)-    -- and 'liftToEncoding' (if the @arity@ is 'One').-    gToJSON :: Options -> ToArgs enc arity a -> f a -> enc---- | A 'ToArgs' value either stores nothing (for 'ToJSON') or it stores the two--- function arguments that encode occurrences of the type parameter (for--- 'ToJSON1').-data ToArgs res arity a where-    NoToArgs :: ToArgs res Zero a-    To1Args  :: (a -> res) -> ([a] -> res) -> ToArgs res One a---- | A configurable generic JSON creator. This function applied to--- 'defaultOptions' is used as the default for 'toJSON' when the type--- is an instance of 'Generic'.-genericToJSON :: (Generic a, GToJSON' Value Zero (Rep a))-              => Options -> a -> Value-genericToJSON opts = gToJSON opts NoToArgs . from---- | A configurable generic JSON creator. This function applied to--- 'defaultOptions' is used as the default for 'liftToJSON' when the type--- is an instance of 'Generic1'.-genericLiftToJSON :: (Generic1 f, GToJSON' Value One (Rep1 f))-                  => Options -> (a -> Value) -> ([a] -> Value)-                  -> f a -> Value-genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1---- | A configurable generic JSON encoder. This function applied to--- 'defaultOptions' is used as the default for 'toEncoding' when the type--- is an instance of 'Generic'.-genericToEncoding :: (Generic a, GToJSON' Encoding Zero (Rep a))-                  => Options -> a -> Encoding-genericToEncoding opts = gToJSON opts NoToArgs . from---- | A configurable generic JSON encoder. This function applied to--- 'defaultOptions' is used as the default for 'liftToEncoding' when the type--- is an instance of 'Generic1'.-genericLiftToEncoding :: (Generic1 f, GToJSON' Encoding One (Rep1 f))-                      => Options -> (a -> Encoding) -> ([a] -> Encoding)-                      -> f a -> Encoding-genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1------------------------------------------------------------------------------------ Class------------------------------------------------------------------------------------ | A type that can be converted to JSON.------ Instances in general /must/ specify 'toJSON' and /should/ (but don't need--- to) specify 'toEncoding'.------ An example type and instance:------ @--- \-- Allow ourselves to write 'Text' literals.--- {-\# LANGUAGE OverloadedStrings #-}------ data Coord = Coord { x :: Double, y :: Double }------ instance 'ToJSON' Coord where---   'toJSON' (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]------   'toEncoding' (Coord x y) = 'pairs' (\"x\" '.=' x '<>' \"y\" '.=' y)--- @------ Instead of manually writing your 'ToJSON' instance, there are two options--- to do it automatically:------ * "Data.Aeson.TH" provides Template Haskell functions which will derive an--- instance at compile time. The generated instance is optimized for your type--- so it will probably be more efficient than the following option.------ * The compiler can provide a default generic implementation for--- 'toJSON'.------ To use the second, simply add a @deriving 'Generic'@ clause to your--- datatype and declare a 'ToJSON' instance. If you require nothing other than--- 'defaultOptions', it is sufficient to write (and this is the only--- alternative where the default 'toJSON' implementation is sufficient):------ @--- {-\# LANGUAGE DeriveGeneric \#-}------ import "GHC.Generics"------ data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'------ instance 'ToJSON' Coord where---     'toEncoding' = 'genericToEncoding' 'defaultOptions'--- @------ If on the other hand you wish to customize the generic decoding, you have--- to implement both methods:------ @--- customOptions = 'defaultOptions'---                 { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'---                 }------ instance 'ToJSON' Coord where---     'toJSON'     = 'genericToJSON' customOptions---     'toEncoding' = 'genericToEncoding' customOptions--- @------ Previous versions of this library only had the 'toJSON' method. Adding--- 'toEncoding' had two reasons:------ 1. toEncoding is more efficient for the common case that the output of--- 'toJSON' is directly serialized to a @ByteString@.--- Further, expressing either method in terms of the other would be--- non-optimal.------ 2. The choice of defaults allows a smooth transition for existing users:--- Existing instances that do not define 'toEncoding' still--- compile and have the correct semantics. This is ensured by making--- the default implementation of 'toEncoding' use 'toJSON'. This produces--- correct results, but since it performs an intermediate conversion to a--- 'Value', it will be less efficient than directly emitting an 'Encoding'.--- (this also means that specifying nothing more than--- @instance ToJSON Coord@ would be sufficient as a generically decoding--- instance, but there probably exists no good reason to not specify--- 'toEncoding' in new instances.)-class ToJSON a where-    -- | Convert a Haskell value to a JSON-friendly intermediate type.-    toJSON     :: a -> Value--    default toJSON :: (Generic a, GToJSON' Value Zero (Rep a)) => a -> Value-    toJSON = genericToJSON defaultOptions--    -- | Encode a Haskell value as JSON.-    ---    -- The default implementation of this method creates an-    -- intermediate 'Value' using 'toJSON'.  This provides-    -- source-level compatibility for people upgrading from older-    -- versions of this library, but obviously offers no performance-    -- advantage.-    ---    -- To benefit from direct encoding, you /must/ provide an-    -- implementation for this method.  The easiest way to do so is by-    -- having your types implement 'Generic' using the @DeriveGeneric@-    -- extension, and then have GHC generate a method body as follows.-    ---    -- @-    -- instance 'ToJSON' Coord where-    --     'toEncoding' = 'genericToEncoding' 'defaultOptions'-    -- @--    toEncoding :: a -> Encoding-    toEncoding = E.value . toJSON-    {-# INLINE toEncoding #-}--    toJSONList :: [a] -> Value-    toJSONList = listValue toJSON-    {-# INLINE toJSONList #-}--    toEncodingList :: [a] -> Encoding-    toEncodingList = listEncoding toEncoding-    {-# INLINE toEncodingList #-}------------------------------------------------------------------------------------ Object key-value pairs------------------------------------------------------------------------------------ | A key-value pair for encoding a JSON object.-class KeyValue kv where-    (.=) :: ToJSON v => Text -> v -> kv-    infixr 8 .=--instance KeyValue Series where-    name .= value = E.pair name (toEncoding value)-    {-# INLINE (.=) #-}--instance KeyValue Pair where-    name .= value = (name, toJSON value)-    {-# INLINE (.=) #-}---- | Constructs a singleton 'H.HashMap'. For calling functions that---   demand an 'Object' for constructing objects. To be used in---   conjunction with 'mconcat'. Prefer to use 'object' where possible.-instance KeyValue Object where-    name .= value = H.singleton name (toJSON value)-    {-# INLINE (.=) #-}------------------------------------------------------------------------------------  Classes and types for map keys------------------------------------------------------------------------------------ | Typeclass for types that can be used as the key of a map-like container---   (like 'Map' or 'HashMap'). For example, since 'Text' has a 'ToJSONKey'---   instance and 'Char' has a 'ToJSON' instance, we can encode a value of---   type 'Map' 'Text' 'Char':------   >>> LBC8.putStrLn $ encode $ Map.fromList [("foo" :: Text, 'a')]---   {"foo":"a"}------   Since 'Int' also has a 'ToJSONKey' instance, we can similarly write:------   >>> LBC8.putStrLn $ encode $ Map.fromList [(5 :: Int, 'a')]---   {"5":"a"}------   JSON documents only accept strings as object keys. For any type---   from @base@ that has a natural textual representation, it can be---   expected that its 'ToJSONKey' instance will choose that representation.------   For data types that lack a natural textual representation, an alternative---   is provided. The map-like container is represented as a JSON array---   instead of a JSON object. Each value in the array is an array with---   exactly two values. The first is the key and the second is the value.------   For example, values of type '[Text]' cannot be encoded to a---   string, so a 'Map' with keys of type '[Text]' is encoded as follows:------   >>> LBC8.putStrLn $ encode $ Map.fromList [(["foo","bar","baz" :: Text], 'a')]---   [[["foo","bar","baz"],"a"]]------   The default implementation of 'ToJSONKey' chooses this method of---   encoding a key, using the 'ToJSON' instance of the type.------   To use your own data type as the key in a map, all that is needed---   is to write a 'ToJSONKey' (and possibly a 'FromJSONKey') instance---   for it. If the type cannot be trivially converted to and from 'Text',---   it is recommended that 'ToJSONKeyValue' is used. Since the default---   implementations of the typeclass methods can build this from a---   'ToJSON' instance, there is nothing that needs to be written:------   > data Foo = Foo { fooAge :: Int, fooName :: Text }---   >   deriving (Eq,Ord,Generic)---   > instance ToJSON Foo---   > instance ToJSONKey Foo------   That's it. We can now write:------   >>> let m = Map.fromList [(Foo 4 "bar",'a'),(Foo 6 "arg",'b')]---   >>> LBC8.putStrLn $ encode m---   [[{"fooName":"bar","fooAge":4},"a"],[{"fooName":"arg","fooAge":6},"b"]]------   The next case to consider is if we have a type that is a---   newtype wrapper around 'Text'. The recommended approach is to use---   generalized newtype deriving:------   > newtype RecordId = RecordId { getRecordId :: Text }---   >   deriving (Eq,Ord,ToJSONKey)------   Then we may write:------   >>> LBC8.putStrLn $ encode $ Map.fromList [(RecordId "abc",'a')]---   {"abc":"a"}------   Simple sum types are a final case worth considering. Suppose we have:------   > data Color = Red | Green | Blue---   >   deriving (Show,Read,Eq,Ord)------   It is possible to get the 'ToJSONKey' instance for free as we did---   with 'Foo'. However, in this case, we have a natural way to go to---   and from 'Text' that does not require any escape sequences. So---   'ToJSONKeyText' can be used instead of 'ToJSONKeyValue' to encode maps---   as objects instead of arrays of pairs. This instance may be---   implemented using generics as follows:------ @--- instance 'ToJSONKey' Color where---   'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'--- @------   === __Low-level implementations__------   The 'Show' instance can be used to help write 'ToJSONKey':------   > instance ToJSONKey Color where---   >   toJSONKey = ToJSONKeyText f g---   >     where f = Text.pack . show---   >           g = text . Text.pack . show---   >           -- text function is from Data.Aeson.Encoding------   The situation of needing to turning function @a -> Text@ into---   a 'ToJSONKeyFunction' is common enough that a special combinator---   is provided for it. The above instance can be rewritten as:------   > instance ToJSONKey Color where---   >   toJSONKey = toJSONKeyText (Text.pack . show)------   The performance of the above instance can be improved by---   not using 'String' as an intermediate step when converting to---   'Text'. One option for improving performance would be to use---   template haskell machinery from the @text-show@ package. However,---   even with the approach, the 'Encoding' (a wrapper around a bytestring---   builder) is generated by encoding the 'Text' to a 'ByteString',---   an intermediate step that could be avoided. The fastest possible---   implementation would be:------   > -- Assuming that OverloadedStrings is enabled---   > instance ToJSONKey Color where---   >   toJSONKey = ToJSONKeyText f g---   >     where f x = case x of {Red -> "Red";Green ->"Green";Blue -> "Blue"}---   >           g x = case x of {Red -> text "Red";Green -> text "Green";Blue -> text "Blue"}---   >           -- text function is from Data.Aeson.Encoding------   This works because GHC can lift the encoded values out of the case---   statements, which means that they are only evaluated once. This---   approach should only be used when there is a serious need to---   maximize performance.--class ToJSONKey a where-    -- | Strategy for rendering the key for a map-like container.-    toJSONKey :: ToJSONKeyFunction a-    default toJSONKey :: ToJSON a => ToJSONKeyFunction a-    toJSONKey = ToJSONKeyValue toJSON toEncoding--    -- | This is similar in spirit to the 'showsList' method of 'Show'.-    --   It makes it possible to give 'String' keys special treatment-    --   without using @OverlappingInstances@. End users should always-    --   be able to use the default implementation of this method.-    toJSONKeyList :: ToJSONKeyFunction [a]-    default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]-    toJSONKeyList = ToJSONKeyValue toJSON toEncoding--data ToJSONKeyFunction a-    = ToJSONKeyText !(a -> Text) !(a -> Encoding' Text)-      -- ^ key is encoded to string, produces object-    | ToJSONKeyValue !(a -> Value) !(a -> Encoding)-      -- ^ key is encoded to value, produces array---- | Helper for creating textual keys.------ @--- instance 'ToJSONKey' MyKey where---     'toJSONKey' = 'toJSONKeyText' myKeyToText---       where---         myKeyToText = Text.pack . show -- or showt from text-show--- @-toJSONKeyText :: (a -> Text) -> ToJSONKeyFunction a-toJSONKeyText f = ToJSONKeyText f (E.text . f)---- | TODO: should this be exported?-toJSONKeyTextEnc :: (a -> Encoding' Text) -> ToJSONKeyFunction a-toJSONKeyTextEnc e = ToJSONKeyText tot e- where-    -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm-    tot = T.dropAround (== '"')-        . T.decodeLatin1-        . L.toStrict-        . E.encodingToLazyByteString-        . e--instance Contravariant ToJSONKeyFunction where-    contramap = contramapToJSONKeyFunction---- | Contravariant map, as 'ToJSONKeyFunction' is a contravariant functor.-contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b-contramapToJSONKeyFunction h x = case x of-    ToJSONKeyText  f g -> ToJSONKeyText (f . h) (g . h)-    ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)---- 'toJSONKey' for 'Generic' types.--- Deriving is supported for enumeration types, i.e. the sums of nullary--- constructors. The names of constructors will be used as keys for JSON--- objects.------ See also 'genericFromJSONKey'.------ === __Example__------ @--- data Color = Red | Green | Blue---   deriving 'Generic'------ instance 'ToJSONKey' Color where---   'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'--- @-genericToJSONKey :: (Generic a, GToJSONKey (Rep a))-           => JSONKeyOptions -> ToJSONKeyFunction a-genericToJSONKey opts = toJSONKeyText (pack . keyModifier opts . getConName . from)--class    GetConName f => GToJSONKey f-instance GetConName f => GToJSONKey f------------------------------------------------------------------------------------ Lifings of FromJSON and ToJSON to unary and binary type constructors------------------------------------------------------------------------------------- | Lifting of the 'ToJSON' class to unary type constructors.------ Instead of manually writing your 'ToJSON1' instance, there are two options--- to do it automatically:------ * "Data.Aeson.TH" provides Template Haskell functions which will derive an--- instance at compile time. The generated instance is optimized for your type--- so it will probably be more efficient than the following option.------ * The compiler can provide a default generic implementation for--- 'toJSON1'.------ To use the second, simply add a @deriving 'Generic1'@ clause to your--- datatype and declare a 'ToJSON1' instance for your datatype without giving--- definitions for 'liftToJSON' or 'liftToEncoding'.------ For example:------ @--- {-\# LANGUAGE DeriveGeneric \#-}------ import "GHC.Generics"------ data Pair = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'------ instance 'ToJSON' a => 'ToJSON1' (Pair a)--- @------ If the default implementation doesn't give exactly the results you want,--- you can customize the generic encoding with only a tiny amount of--- effort, using 'genericLiftToJSON' and 'genericLiftToEncoding' with--- your preferred 'Options':------ @--- customOptions = 'defaultOptions'---                 { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'---                 }------ instance 'ToJSON' a => 'ToJSON1' (Pair a) where---     'liftToJSON'     = 'genericLiftToJSON' customOptions---     'liftToEncoding' = 'genericLiftToEncoding' customOptions--- @------ See also 'ToJSON'.-class ToJSON1 f where-    liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value--    default liftToJSON :: (Generic1 f, GToJSON' Value One (Rep1 f))-                       => (a -> Value) -> ([a] -> Value) -> f a -> Value-    liftToJSON = genericLiftToJSON defaultOptions--    liftToJSONList :: (a -> Value) -> ([a] -> Value) -> [f a] -> Value-    liftToJSONList f g = listValue (liftToJSON f g)--    liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding--    default liftToEncoding :: (Generic1 f, GToJSON' Encoding One (Rep1 f))-                           => (a -> Encoding) -> ([a] -> Encoding)-                           -> f a -> Encoding-    liftToEncoding = genericLiftToEncoding defaultOptions--    liftToEncodingList :: (a -> Encoding) -> ([a] -> Encoding) -> [f a] -> Encoding-    liftToEncodingList f g = listEncoding (liftToEncoding f g)---- | Lift the standard 'toJSON' function through the type constructor.-toJSON1 :: (ToJSON1 f, ToJSON a) => f a -> Value-toJSON1 = liftToJSON toJSON toJSONList-{-# INLINE toJSON1 #-}---- | Lift the standard 'toEncoding' function through the type constructor.-toEncoding1 :: (ToJSON1 f, ToJSON a) => f a -> Encoding-toEncoding1 = liftToEncoding toEncoding toEncodingList-{-# INLINE toEncoding1 #-}---- | Lifting of the 'ToJSON' class to binary type constructors.------ Instead of manually writing your 'ToJSON2' instance, "Data.Aeson.TH"--- provides Template Haskell functions which will derive an instance at compile time.------ The compiler cannot provide a default generic implementation for 'liftToJSON2',--- unlike 'toJSON' and 'liftToJSON'.-class ToJSON2 f where-    liftToJSON2 :: (a -> Value) -> ([a] -> Value) -> (b -> Value) -> ([b] -> Value) -> f a b -> Value-    liftToJSONList2 :: (a -> Value) -> ([a] -> Value) -> (b -> Value) -> ([b] -> Value) -> [f a b] -> Value-    liftToJSONList2 fa ga fb gb = listValue (liftToJSON2 fa ga fb gb)--    liftToEncoding2 :: (a -> Encoding) -> ([a] -> Encoding) -> (b -> Encoding) -> ([b] -> Encoding) -> f a b -> Encoding-    liftToEncodingList2 :: (a -> Encoding) -> ([a] -> Encoding) -> (b -> Encoding) -> ([b] -> Encoding) -> [f a b] -> Encoding-    liftToEncodingList2 fa ga fb gb = listEncoding (liftToEncoding2 fa ga fb gb)---- | Lift the standard 'toJSON' function through the type constructor.-toJSON2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Value-toJSON2 = liftToJSON2 toJSON toJSONList toJSON toJSONList-{-# INLINE toJSON2 #-}---- | Lift the standard 'toEncoding' function through the type constructor.-toEncoding2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Encoding-toEncoding2 = liftToEncoding2 toEncoding toEncodingList toEncoding toEncodingList-{-# INLINE toEncoding2 #-}------------------------------------------------------------------------------------ Encoding functions------------------------------------------------------------------------------------ | Helper function to use with 'liftToEncoding'.--- Useful when writing own 'ToJSON1' instances.------ @--- newtype F a = F [a]------ -- This instance encodes 'String' as an array of chars--- instance 'ToJSON1' F where---     'liftToJSON'     tj _ (F xs) = 'liftToJSON'     tj ('listValue'    tj) xs---     'liftToEncoding' te _ (F xs) = 'liftToEncoding' te ('listEncoding' te) xs------ instance 'Data.Aeson.FromJSON.FromJSON1' F where---     'Data.Aeson.FromJSON.liftParseJSON' p _ v = F \<$\> 'Data.Aeson.FromJSON.liftParseJSON' p ('Data.Aeson.FromJSON.listParser' p) v--- @-listEncoding :: (a -> Encoding) -> [a] -> Encoding-listEncoding = E.list-{-# INLINE listEncoding #-}---- | Helper function to use with 'liftToJSON', see 'listEncoding'.-listValue :: (a -> Value) -> [a] -> Value-listValue f = Array . V.fromList . map f-{-# INLINE listValue #-}------------------------------------------------------------------------------------ [] instances------------------------------------------------------------------------------------ These are needed for key-class default definitions--instance ToJSON1 [] where-    liftToJSON _ to' = to'-    {-# INLINE liftToJSON #-}--    liftToEncoding _ to' = to'-    {-# INLINE liftToEncoding #-}--instance (ToJSON a) => ToJSON [a] where-    {-# SPECIALIZE instance ToJSON String #-}-    {-# SPECIALIZE instance ToJSON [String] #-}-    {-# SPECIALIZE instance ToJSON [Array] #-}-    {-# SPECIALIZE instance ToJSON [Object] #-}--    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}------------------------------------------------------------------------------------ Generic toJSON / toEncoding----------------------------------------------------------------------------------instance OVERLAPPABLE_ (GToJSON' enc arity a) => GToJSON' enc arity (M1 i c a) where-    -- Meta-information, which is not handled elsewhere, is ignored:-    gToJSON opts targs = gToJSON opts targs . unM1-    {-# INLINE gToJSON #-}--instance GToJSON' enc One Par1 where-    -- Direct occurrences of the last type parameter are encoded with the-    -- function passed in as an argument:-    gToJSON _opts (To1Args tj _) = tj . unPar1-    {-# INLINE gToJSON #-}--instance ( ConsToJSON enc arity a-         , AllNullary          (C1 c a) allNullary-         , SumToJSON enc arity (C1 c a) allNullary-         ) => GToJSON' enc arity (D1 d (C1 c a)) where-    -- The option 'tagSingleConstructors' determines whether to wrap-    -- a single-constructor type.-    gToJSON opts targs-        | tagSingleConstructors opts = (unTagged :: Tagged allNullary enc -> enc)-                                     . sumToJSON opts targs-                                     . unM1-        | otherwise = consToJSON opts targs . unM1 . unM1-    {-# INLINE gToJSON #-}--instance (ConsToJSON enc arity a) => GToJSON' enc arity (C1 c a) where-    -- Constructors need to be encoded differently depending on whether they're-    -- a record or not. This distinction is made by 'consToJSON':-    gToJSON opts targs = consToJSON opts targs . unM1-    {-# INLINE gToJSON #-}--instance ( AllNullary       (a :+: b) allNullary-         , SumToJSON  enc arity (a :+: b) allNullary-         ) => GToJSON' enc arity (a :+: b)-  where-    -- If all constructors of a sum datatype are nullary and the-    -- 'allNullaryToStringTag' option is set they are encoded to-    -- strings.  This distinction is made by 'sumToJSON':-    gToJSON opts targs = (unTagged :: Tagged allNullary enc -> enc)-                       . sumToJSON opts targs-    {-# INLINE gToJSON #-}------------------------------------------------------------------------------------- Generic toJSON---- Note: Refactoring 'ToJSON a' to 'ToJSON enc a' (and 'ToJSON1' similarly) is--- possible but makes error messages a bit harder to understand for missing--- instances.--instance GToJSON' Value arity V1 where-    -- Empty values do not exist, which makes the job of formatting them-    -- rather easy:-    gToJSON _ _ x = x `seq` error "case: V1"-    {-# INLINE gToJSON #-}--instance ToJSON a => GToJSON' Value arity (K1 i a) where-    -- Constant values are encoded using their ToJSON instance:-    gToJSON _opts _ = toJSON . unK1-    {-# INLINE gToJSON #-}--instance ToJSON1 f => GToJSON' Value One (Rec1 f) where-    -- Recursive occurrences of the last type parameter are encoded using their-    -- ToJSON1 instance:-    gToJSON _opts (To1Args tj tjl) = liftToJSON tj tjl . unRec1-    {-# INLINE gToJSON #-}--instance GToJSON' Value arity U1 where-    -- Empty constructors are encoded to an empty array:-    gToJSON _opts _ _ = emptyArray-    {-# INLINE gToJSON #-}--instance ( WriteProduct arity a, WriteProduct arity b-         , ProductSize        a, ProductSize        b-         ) => GToJSON' Value arity (a :*: b)-  where-    -- Products are encoded to an array. Here we allocate a mutable vector of-    -- the same size as the product and write the product's elements to it using-    -- 'writeProduct':-    gToJSON opts targs p =-        Array $ V.create $ do-          mv <- VM.unsafeNew lenProduct-          writeProduct opts targs mv 0 lenProduct p-          return mv-        where-          lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)-                       productSize-    {-# INLINE gToJSON #-}--instance ( ToJSON1 f-         , GToJSON' Value One g-         ) => GToJSON' Value One (f :.: g)-  where-    -- If an occurrence of the last type parameter is nested inside two-    -- composed types, it is encoded by using the outermost type's ToJSON1-    -- instance to generically encode the innermost type:-    gToJSON opts targs =-      let gtj = gToJSON opts targs in-      liftToJSON gtj (listValue gtj) . unComp1-    {-# INLINE gToJSON #-}------------------------------------------------------------------------------------- Generic toEncoding--instance ToJSON a => GToJSON' Encoding arity (K1 i a) where-    -- Constant values are encoded using their ToJSON instance:-    gToJSON _opts _ = toEncoding . unK1-    {-# INLINE gToJSON #-}--instance ToJSON1 f => GToJSON' Encoding One (Rec1 f) where-    -- Recursive occurrences of the last type parameter are encoded using their-    -- ToEncoding1 instance:-    gToJSON _opts (To1Args te tel) = liftToEncoding te tel . unRec1-    {-# INLINE gToJSON #-}--instance GToJSON' Encoding arity U1 where-    -- Empty constructors are encoded to an empty array:-    gToJSON _opts _ _ = E.emptyArray_-    {-# INLINE gToJSON #-}--instance ( EncodeProduct  arity a-         , EncodeProduct  arity b-         ) => GToJSON' Encoding arity (a :*: b)-  where-    -- Products are encoded to an array. Here we allocate a mutable vector of-    -- the same size as the product and write the product's elements to it using-    -- 'encodeProduct':-    gToJSON opts targs p = E.list E.retagEncoding [encodeProduct opts targs p]-    {-# INLINE gToJSON #-}--instance ( ToJSON1 f-         , GToJSON' Encoding One g-         ) => GToJSON' Encoding One (f :.: g)-  where-    -- If an occurrence of the last type parameter is nested inside two-    -- composed types, it is encoded by using the outermost type's ToJSON1-    -- instance to generically encode the innermost type:-    gToJSON opts targs =-      let gte = gToJSON opts targs in-      liftToEncoding gte (listEncoding gte) . unComp1-    {-# INLINE gToJSON #-}------------------------------------------------------------------------------------class SumToJSON enc arity f allNullary where-    sumToJSON :: Options -> ToArgs enc arity a-              -> f a -> Tagged allNullary enc--instance ( GetConName f-         , FromString enc-         , TaggedObject                     enc arity f-         , SumToJSON' ObjectWithSingleField enc arity f-         , SumToJSON' TwoElemArray          enc arity f-         , SumToJSON' UntaggedValue         enc arity f-         ) => SumToJSON enc arity f True-  where-    sumToJSON opts targs-        | allNullaryToStringTag opts = Tagged . fromString-                                     . constructorTagModifier opts . getConName-        | otherwise = Tagged . nonAllNullarySumToJSON opts targs--instance ( TaggedObject                     enc arity f-         , SumToJSON' ObjectWithSingleField enc arity f-         , SumToJSON' TwoElemArray          enc arity f-         , SumToJSON' UntaggedValue         enc arity f-         ) => SumToJSON enc arity f False-  where-    sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs--nonAllNullarySumToJSON :: ( TaggedObject                     enc arity f-                          , SumToJSON' ObjectWithSingleField enc arity f-                          , SumToJSON' TwoElemArray          enc arity f-                          , SumToJSON' UntaggedValue         enc arity f-                          ) => Options -> ToArgs enc arity a-                            -> f a -> enc-nonAllNullarySumToJSON opts targs =-    case sumEncoding opts of--      TaggedObject{..}      ->-        taggedObject opts targs tagFieldName contentsFieldName--      ObjectWithSingleField ->-        (unTagged :: Tagged ObjectWithSingleField enc -> enc)-          . sumToJSON' opts targs--      TwoElemArray          ->-        (unTagged :: Tagged TwoElemArray enc -> enc)-          . sumToJSON' opts targs--      UntaggedValue         ->-        (unTagged :: Tagged UntaggedValue enc -> enc)-          . sumToJSON' opts targs------------------------------------------------------------------------------------class FromString enc where-  fromString :: String -> enc--instance FromString Encoding where-  fromString = toEncoding--instance FromString Value where-  fromString = String . pack------------------------------------------------------------------------------------class TaggedObject enc arity f where-    taggedObject :: Options -> ToArgs enc arity a-                 -> String -> String-                 -> f a -> enc--instance ( TaggedObject enc arity a-         , TaggedObject enc arity b-         ) => TaggedObject enc arity (a :+: b)-  where-    taggedObject opts targs tagFieldName contentsFieldName (L1 x) =-        taggedObject opts targs tagFieldName contentsFieldName x-    taggedObject opts targs tagFieldName contentsFieldName (R1 x) =-        taggedObject opts targs tagFieldName contentsFieldName x--instance ( IsRecord                      a isRecord-         , TaggedObject' enc pairs arity a isRecord-         , FromPairs enc pairs-         , FromString enc-         , KeyValuePair enc pairs-         , Constructor c-         ) => TaggedObject enc arity (C1 c a)-  where-    taggedObject opts targs tagFieldName contentsFieldName =-      fromPairs . mappend tag . contents-      where-        tag = tagFieldName `pair`-          (fromString (constructorTagModifier opts (conName (undefined :: t c a p)))-            :: enc)-        contents =-          (unTagged :: Tagged isRecord pairs -> pairs) .-            taggedObject' opts targs contentsFieldName . unM1--class TaggedObject' enc pairs arity f isRecord where-    taggedObject' :: Options -> ToArgs enc arity a-                  -> String -> f a -> Tagged isRecord pairs--instance ( GToJSON' enc arity f-         , KeyValuePair enc pairs-         ) => TaggedObject' enc pairs arity f False-  where-    taggedObject' opts targs contentsFieldName =-        Tagged . (contentsFieldName `pair`) . gToJSON opts targs--instance OVERLAPPING_ Monoid pairs => TaggedObject' enc pairs arity U1 False where-    taggedObject' _ _ _ _ = Tagged mempty--instance ( RecordToPairs enc pairs arity f-         ) => TaggedObject' enc pairs arity f True-  where-    taggedObject' opts targs _ = Tagged . recordToPairs opts targs-------------------------------------------------------------------------------------- | Get the name of the constructor of a sum datatype.-class GetConName f where-    getConName :: f a -> String--instance (GetConName a, GetConName b) => GetConName (a :+: b) where-    getConName (L1 x) = getConName x-    getConName (R1 x) = getConName x--instance (Constructor c) => GetConName (C1 c a) where-    getConName = conName---- For genericToJSONKey-instance GetConName a => GetConName (D1 d a) where-    getConName (M1 x) = getConName x-------------------------------------------------------------------------------------- Reflection of SumEncoding variants--data ObjectWithSingleField-data TwoElemArray-data UntaggedValue------------------------------------------------------------------------------------class SumToJSON' s enc arity f where-    sumToJSON' :: Options -> ToArgs enc arity a-                    -> f a -> Tagged s enc--instance ( SumToJSON' s enc arity a-         , SumToJSON' s enc arity b-         ) => SumToJSON' s enc arity (a :+: b)-  where-    sumToJSON' opts targs (L1 x) = sumToJSON' opts targs x-    sumToJSON' opts targs (R1 x) = sumToJSON' opts targs x------------------------------------------------------------------------------------instance ( GToJSON'    Value arity a-         , ConsToJSON Value arity a-         , Constructor c-         ) => SumToJSON' TwoElemArray Value arity (C1 c a) where-    sumToJSON' opts targs x = Tagged $ Array $ V.create $ do-      mv <- VM.unsafeNew 2-      VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts-                                   $ conName (undefined :: t c a p)-      VM.unsafeWrite mv 1 $ gToJSON opts targs x-      return mv------------------------------------------------------------------------------------instance ( GToJSON'    Encoding arity a-         , ConsToJSON Encoding arity a-         , Constructor c-         ) => SumToJSON' TwoElemArray Encoding arity (C1 c a)-  where-    sumToJSON' opts targs x = Tagged $ E.list id-      [ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))-      , gToJSON opts targs x-      ]------------------------------------------------------------------------------------class ConsToJSON enc arity f where-    consToJSON :: Options -> ToArgs enc arity a-               -> f a -> enc--class ConsToJSON' enc arity f isRecord where-    consToJSON'     :: Options -> ToArgs enc arity a-                    -> f a -> Tagged isRecord enc--instance ( IsRecord                f isRecord-         , ConsToJSON'   enc arity f isRecord-         ) => ConsToJSON enc arity f-  where-    consToJSON opts targs =-        (unTagged :: Tagged isRecord enc -> enc)-      . consToJSON' opts targs-    {-# INLINE consToJSON #-}--instance OVERLAPPING_-         ( RecordToPairs enc pairs arity (S1 s f)-         , FromPairs enc pairs-         , GToJSON' enc arity f-         ) => ConsToJSON' enc arity (S1 s f) True-  where-    consToJSON' opts targs-      | unwrapUnaryRecords opts = Tagged . gToJSON opts targs-      | otherwise = Tagged . fromPairs . recordToPairs opts targs-    {-# INLINE consToJSON' #-}--instance ( RecordToPairs enc pairs arity f-         , FromPairs enc pairs-         ) => ConsToJSON' enc arity f True-  where-    consToJSON' opts targs = Tagged . fromPairs . recordToPairs opts targs-    {-# INLINE consToJSON' #-}--instance GToJSON' enc arity f => ConsToJSON' enc arity f False where-    consToJSON' opts targs = Tagged . gToJSON opts targs-    {-# INLINE consToJSON' #-}------------------------------------------------------------------------------------class RecordToPairs enc pairs arity f where-    -- 1st element: whole thing-    -- 2nd element: in case the record has only 1 field, just the value-    --              of the field (without the key); 'Nothing' otherwise-    recordToPairs :: Options -> ToArgs enc arity a-                  -> f a -> pairs--instance ( Monoid pairs-         , RecordToPairs enc pairs arity a-         , RecordToPairs enc pairs arity b-         ) => RecordToPairs enc pairs arity (a :*: b)-  where-    recordToPairs opts (targs :: ToArgs enc arity p) (a :*: b) =-        pairsOf a `mappend` pairsOf b-      where-        pairsOf :: (RecordToPairs enc pairs arity f) => f p -> pairs-        pairsOf = recordToPairs opts targs-    {-# INLINE recordToPairs #-}--instance ( Selector s-         , GToJSON' enc arity a-         , KeyValuePair enc pairs-         ) => RecordToPairs enc pairs arity (S1 s a)-  where-    recordToPairs = fieldToPair-    {-# INLINE recordToPairs #-}--instance INCOHERENT_-    ( Selector s-    , GToJSON' enc arity (K1 i (Maybe a))-    , KeyValuePair enc pairs-    , Monoid pairs-    ) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a)))-  where-    recordToPairs opts _ (M1 k1) | omitNothingFields opts-                                 , K1 Nothing <- k1 = mempty-    recordToPairs opts targs m1 = fieldToPair opts targs m1-    {-# INLINE recordToPairs #-}--instance INCOHERENT_-    ( Selector s-    , GToJSON' enc arity (K1 i (Maybe a))-    , KeyValuePair enc pairs-    , Monoid pairs-    ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))-  where-    recordToPairs opts targs = recordToPairs opts targs . unwrap-      where-        unwrap :: S1 s (K1 i (Semigroup.Option a)) p -> S1 s (K1 i (Maybe a)) p-        unwrap (M1 (K1 (Semigroup.Option a))) = M1 (K1 a)-    {-# INLINE recordToPairs #-}--fieldToPair :: (Selector s-               , GToJSON' enc arity a-               , KeyValuePair enc pairs)-            => Options -> ToArgs enc arity p-            -> S1 s a p -> pairs-fieldToPair opts targs m1 =-  let key   = fieldLabelModifier opts (selName m1)-      value = gToJSON opts targs (unM1 m1)-  in key `pair` value-{-# INLINE fieldToPair #-}------------------------------------------------------------------------------------class WriteProduct arity f where-    writeProduct :: Options-                 -> ToArgs Value arity a-                 -> VM.MVector s Value-                 -> Int -- ^ index-                 -> Int -- ^ length-                 -> f a-                 -> ST s ()--instance ( WriteProduct arity a-         , WriteProduct arity b-         ) => WriteProduct arity (a :*: b) where-    writeProduct opts targs mv ix len (a :*: b) = do-      writeProduct opts targs mv ix  lenL a-      writeProduct opts targs mv ixR lenR b-        where-          lenL = len `unsafeShiftR` 1-          lenR = len - lenL-          ixR  = ix  + lenL-    {-# INLINE writeProduct #-}--instance OVERLAPPABLE_ (GToJSON' Value arity a) => WriteProduct arity a where-    writeProduct opts targs mv ix _ =-      VM.unsafeWrite mv ix . gToJSON opts targs-    {-# INLINE writeProduct #-}------------------------------------------------------------------------------------class EncodeProduct arity f where-    encodeProduct :: Options -> ToArgs Encoding arity a-                  -> f a -> Encoding' E.InArray--instance ( EncodeProduct    arity a-         , EncodeProduct    arity b-         ) => EncodeProduct arity (a :*: b) where-    encodeProduct opts targs (a :*: b) | omitNothingFields opts =-        E.econcat $ intersperse E.comma $-        filter (not . E.nullEncoding)-        [encodeProduct opts targs a, encodeProduct opts targs b]-    encodeProduct opts targs (a :*: b) =-      encodeProduct opts targs a >*<-      encodeProduct opts targs b-    {-# INLINE encodeProduct #-}--instance OVERLAPPABLE_ (GToJSON' Encoding arity a) => EncodeProduct arity a where-    encodeProduct opts targs a = E.retagEncoding $ gToJSON opts targs a-    {-# INLINE encodeProduct #-}------------------------------------------------------------------------------------instance ( GToJSON'   enc arity a-         , ConsToJSON enc arity a-         , FromPairs  enc pairs-         , KeyValuePair  enc pairs-         , Constructor c-         ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)-  where-    sumToJSON' opts targs =-      Tagged . fromPairs . (typ `pair`) . gToJSON opts targs-        where-          typ = constructorTagModifier opts $-                         conName (undefined :: t c a p)------------------------------------------------------------------------------------instance OVERLAPPABLE_-    ( ConsToJSON enc arity a-    ) => SumToJSON' UntaggedValue enc arity (C1 c a)-  where-    sumToJSON' opts targs = Tagged . gToJSON opts targs--instance OVERLAPPING_-    ( Constructor c-    , FromString enc-    ) => SumToJSON' UntaggedValue enc arity (C1 c U1)-  where-    sumToJSON' opts _ _ = Tagged . fromString $-        constructorTagModifier opts $ conName (undefined :: t c U1 p)------------------------------------------------------------------------------------ Instances-------------------------------------------------------------------------------------------------------------------------------------------------------------------- base----------------------------------------------------------------------------------instance ToJSON2 Const where-    liftToJSON2 t _ _ _ (Const x) = t x-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 t _ _ _ (Const x) = t x-    {-# INLINE liftToEncoding2 #-}--instance ToJSON a => ToJSON1 (Const a) where-    liftToJSON _ _ (Const x) = toJSON x-    {-# INLINE liftToJSON #-}--    liftToEncoding _ _ (Const x) = toEncoding x-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (Const a b) where-    toJSON (Const x) = toJSON x-    {-# INLINE toJSON #-}--    toEncoding (Const x) = toEncoding x-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSONKey a) => ToJSONKey (Const a b) where-    toJSONKey = contramap getConst toJSONKey---instance ToJSON1 Maybe where-    liftToJSON t _ (Just a) = t a-    liftToJSON _  _ Nothing  = Null-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ (Just a) = t a-    liftToEncoding _  _ Nothing  = E.null_-    {-# INLINE liftToEncoding #-}--instance (ToJSON a) => ToJSON (Maybe a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON2 Either where-    liftToJSON2  toA _ _toB _ (Left a)  = Object $ H.singleton "Left"  (toA a)-    liftToJSON2 _toA _  toB _ (Right b) = Object $ H.singleton "Right" (toB b)-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2  toA _ _toB _ (Left a) = E.pairs $ E.pair "Left" $ toA a--    liftToEncoding2 _toA _ toB _ (Right b) = E.pairs $ E.pair "Right" $ toB b-    {-# INLINE liftToEncoding2 #-}--instance (ToJSON a) => ToJSON1 (Either a) where-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}--    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}--    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance ToJSON Void where-    toJSON = absurd-    {-# INLINE toJSON #-}--    toEncoding = absurd-    {-# INLINE toEncoding #-}---instance ToJSON Bool where-    toJSON = Bool-    {-# INLINE toJSON #-}--    toEncoding = E.bool-    {-# INLINE toEncoding #-}--instance ToJSONKey Bool where-    toJSONKey = toJSONKeyText $ \x -> if x then "true" else "false"---instance ToJSON Ordering where-  toJSON     = toJSON     . orderingToText-  toEncoding = toEncoding . orderingToText--orderingToText :: Ordering -> T.Text-orderingToText o = case o of-                     LT -> "LT"-                     EQ -> "EQ"-                     GT -> "GT"--instance ToJSON () where-    toJSON _ = emptyArray-    {-# INLINE toJSON #-}--    toEncoding _ = emptyArray_-    {-# INLINE toEncoding #-}---instance ToJSON Char where-    toJSON = String . T.singleton-    {-# INLINE toJSON #-}--    toJSONList = String . T.pack-    {-# INLINE toJSONList #-}--    toEncoding = E.string . (:[])-    {-# INLINE toEncoding #-}--    toEncodingList = E.string-    {-# INLINE toEncodingList #-}---instance ToJSON Double where-    toJSON = realFloatToJSON-    {-# INLINE toJSON #-}--    toEncoding = E.double-    {-# INLINE toEncoding #-}--instance ToJSONKey Double where-    toJSONKey = toJSONKeyTextEnc E.doubleText-    {-# INLINE toJSONKey #-}---instance ToJSON Number where-    toJSON (D d) = toJSON d-    toJSON (I i) = toJSON i-    {-# INLINE toJSON #-}--    toEncoding (D d) = toEncoding d-    toEncoding (I i) = toEncoding i-    {-# INLINE toEncoding #-}---instance ToJSON Float where-    toJSON = realFloatToJSON-    {-# INLINE toJSON #-}--    toEncoding = E.float-    {-# INLINE toEncoding #-}--instance ToJSONKey Float where-    toJSONKey = toJSONKeyTextEnc E.floatText-    {-# INLINE toJSONKey #-}---instance (ToJSON a, Integral a) => ToJSON (Ratio a) where-    toJSON r = object [ "numerator"   .= numerator   r-                      , "denominator" .= denominator r-                      ]-    {-# INLINE toJSON #-}--    toEncoding r = E.pairs $-        "numerator" .= numerator r <>-        "denominator" .= denominator r-    {-# INLINE toEncoding #-}---instance HasResolution a => ToJSON (Fixed a) where-    toJSON = Number . realToFrac-    {-# INLINE toJSON #-}--    toEncoding = E.scientific . realToFrac-    {-# INLINE toEncoding #-}--instance HasResolution a => ToJSONKey (Fixed a) where-    toJSONKey = toJSONKeyTextEnc (E.scientificText . realToFrac)-    {-# INLINE toJSONKey #-}---instance ToJSON Int where-    toJSON = Number . fromIntegral-    {-# INLINE toJSON #-}--    toEncoding = E.int-    {-# INLINE toEncoding #-}--instance ToJSONKey Int where-    toJSONKey = toJSONKeyTextEnc E.intText-    {-# INLINE toJSONKey #-}---instance ToJSON Integer where-    toJSON = Number . fromInteger-    {-# INLINE toJSON #-}--    toEncoding = E.integer-    {-# INLINE toEncoding #-}--instance ToJSONKey Integer where-    toJSONKey = toJSONKeyTextEnc E.integerText-    {-# INLINE toJSONKey #-}---instance ToJSON Natural where-    toJSON = toJSON . toInteger-    {-# INLINE toJSON #-}--    toEncoding = toEncoding . toInteger-    {-# INLINE toEncoding #-}--instance ToJSONKey Natural where-    toJSONKey = toJSONKeyTextEnc (E.integerText . toInteger)-    {-# INLINE toJSONKey #-}---instance ToJSON Int8 where-    toJSON = Number . fromIntegral-    {-# INLINE toJSON #-}--    toEncoding = E.int8-    {-# INLINE toEncoding #-}--instance ToJSONKey Int8 where-    toJSONKey = toJSONKeyTextEnc E.int8Text-    {-# INLINE toJSONKey #-}---instance ToJSON Int16 where-    toJSON = Number . fromIntegral-    {-# INLINE toJSON #-}--    toEncoding = E.int16-    {-# INLINE toEncoding #-}--instance ToJSONKey Int16 where-    toJSONKey = toJSONKeyTextEnc E.int16Text-    {-# INLINE toJSONKey #-}---instance ToJSON Int32 where-    toJSON = Number . fromIntegral-    {-# INLINE toJSON #-}--    toEncoding = E.int32-    {-# INLINE toEncoding #-}--instance ToJSONKey Int32 where-    toJSONKey = toJSONKeyTextEnc E.int32Text-    {-# INLINE toJSONKey #-}---instance ToJSON Int64 where-    toJSON = Number . fromIntegral-    {-# INLINE toJSON #-}--    toEncoding = E.int64-    {-# INLINE toEncoding #-}--instance ToJSONKey Int64 where-    toJSONKey = toJSONKeyTextEnc E.int64Text-    {-# INLINE toJSONKey #-}--instance ToJSON Word where-    toJSON = Number . fromIntegral-    {-# INLINE toJSON #-}--    toEncoding = E.word-    {-# INLINE toEncoding #-}--instance ToJSONKey Word where-    toJSONKey = toJSONKeyTextEnc E.wordText-    {-# INLINE toJSONKey #-}---instance ToJSON Word8 where-    toJSON = Number . fromIntegral-    {-# INLINE toJSON #-}--    toEncoding = E.word8-    {-# INLINE toEncoding #-}--instance ToJSONKey Word8 where-    toJSONKey = toJSONKeyTextEnc E.word8Text-    {-# INLINE toJSONKey #-}---instance ToJSON Word16 where-    toJSON = Number . fromIntegral-    {-# INLINE toJSON #-}--    toEncoding = E.word16-    {-# INLINE toEncoding #-}--instance ToJSONKey Word16 where-    toJSONKey = toJSONKeyTextEnc E.word16Text-    {-# INLINE toJSONKey #-}---instance ToJSON Word32 where-    toJSON = Number . fromIntegral-    {-# INLINE toJSON #-}--    toEncoding = E.word32-    {-# INLINE toEncoding #-}--instance ToJSONKey Word32 where-    toJSONKey = toJSONKeyTextEnc E.word32Text-    {-# INLINE toJSONKey #-}---instance ToJSON Word64 where-    toJSON = Number . fromIntegral-    {-# INLINE toJSON #-}--    toEncoding = E.word64-    {-# INLINE toEncoding #-}--instance ToJSONKey Word64 where-    toJSONKey = toJSONKeyTextEnc E.word64Text-    {-# INLINE toJSONKey #-}--instance ToJSON CTime where-    toJSON (CTime i) = toJSON i-    {-# INLINE toJSON #-}--    toEncoding (CTime i) = toEncoding i-    {-# INLINE toEncoding #-}--instance ToJSON Text where-    toJSON = String-    {-# INLINE toJSON #-}--    toEncoding = E.text-    {-# INLINE toEncoding #-}--instance ToJSONKey Text where-    toJSONKey = toJSONKeyText id-    {-# INLINE toJSONKey #-}---instance ToJSON LT.Text where-    toJSON = String . LT.toStrict-    {-# INLINE toJSON #-}--    toEncoding = E.lazyText-    {-# INLINE toEncoding #-}--instance ToJSONKey LT.Text where-    toJSONKey = toJSONKeyText LT.toStrict---instance ToJSON Version where-    toJSON = toJSON . showVersion-    {-# INLINE toJSON #-}--    toEncoding = toEncoding . showVersion-    {-# INLINE toEncoding #-}--instance ToJSONKey Version where-    toJSONKey = toJSONKeyText (T.pack . showVersion)------------------------------------------------------------------------------------ semigroups NonEmpty----------------------------------------------------------------------------------instance ToJSON1 NonEmpty where-    liftToJSON t _ = listValue t . NE.toList-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ = listEncoding t . NE.toList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a) => ToJSON (NonEmpty a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}------------------------------------------------------------------------------------ scientific----------------------------------------------------------------------------------instance ToJSON Scientific where-    toJSON = Number-    {-# INLINE toJSON #-}--    toEncoding = E.scientific-    {-# INLINE toEncoding #-}--instance ToJSONKey Scientific where-    toJSONKey = toJSONKeyTextEnc E.scientificText------------------------------------------------------------------------------------ DList----------------------------------------------------------------------------------instance ToJSON1 DList.DList where-    liftToJSON t _ = listValue t . toList-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ = listEncoding t . toList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a) => ToJSON (DList.DList a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}--#if MIN_VERSION_dlist(1,0,0) && __GLASGOW_HASKELL__ >=800--- | @since 1.5.3.0-instance ToJSON1 DNE.DNonEmpty where-    liftToJSON t _ = listValue t . DNE.toList-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ = listEncoding t . DNE.toList-    {-# INLINE liftToEncoding #-}---- | @since 1.5.3.0-instance (ToJSON a) => ToJSON (DNE.DNonEmpty a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}-#endif------------------------------------------------------------------------------------ transformers - Functors----------------------------------------------------------------------------------instance ToJSON1 Identity where-    liftToJSON t _ (Identity a) = t a-    {-# INLINE liftToJSON #-}--    liftToJSONList _ tl xs = tl (map runIdentity xs)-    {-# INLINE liftToJSONList #-}--    liftToEncoding t _ (Identity a) = t a-    {-# INLINE liftToEncoding #-}--    liftToEncodingList _ tl xs = tl (map runIdentity xs)-    {-# INLINE liftToEncodingList #-}--instance (ToJSON a) => ToJSON (Identity a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toJSONList = liftToJSONList toJSON toJSONList-    {-# INLINE toJSONList #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}--    toEncodingList = liftToEncodingList toEncoding toEncodingList-    {-# INLINE toEncodingList #-}--instance (ToJSONKey a) => ToJSONKey (Identity a) where-    toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey-    toJSONKeyList = contramapToJSONKeyFunction (map runIdentity) toJSONKeyList---instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where-    liftToJSON tv tvl (Compose x) = liftToJSON g gl x-      where-        g = liftToJSON tv tvl-        gl = liftToJSONList tv tvl-    {-# INLINE liftToJSON #-}--    liftToJSONList te tel xs = liftToJSONList g gl (map getCompose xs)-      where-        g = liftToJSON te tel-        gl = liftToJSONList te tel-    {-# INLINE liftToJSONList #-}--    liftToEncoding te tel (Compose x) = liftToEncoding g gl x-      where-        g = liftToEncoding te tel-        gl = liftToEncodingList te tel-    {-# INLINE liftToEncoding #-}--    liftToEncodingList te tel xs = liftToEncodingList g gl (map getCompose xs)-      where-        g = liftToEncoding te tel-        gl = liftToEncodingList te tel-    {-# INLINE liftToEncodingList #-}--instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Compose f g a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toJSONList = liftToJSONList toJSON toJSONList-    {-# INLINE toJSONList #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}--    toEncodingList = liftToEncodingList toEncoding toEncodingList-    {-# INLINE toEncodingList #-}---instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Product f g) where-    liftToJSON tv tvl (Pair x y) = liftToJSON2 tx txl ty tyl (x, y)-      where-        tx = liftToJSON tv tvl-        txl = liftToJSONList tv tvl-        ty = liftToJSON tv tvl-        tyl = liftToJSONList tv tvl--    liftToEncoding te tel (Pair x y) = liftToEncoding2 tx txl ty tyl (x, y)-      where-        tx = liftToEncoding te tel-        txl = liftToEncodingList te tel-        ty = liftToEncoding te tel-        tyl = liftToEncodingList te tel--instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Product f g a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}--instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Sum f g) where-    liftToJSON tv tvl (InL x) = Object $ H.singleton "InL" (liftToJSON tv tvl x)-    liftToJSON tv tvl (InR y) = Object $ H.singleton "InR" (liftToJSON tv tvl y)--    liftToEncoding te tel (InL x) = E.pairs $ E.pair "InL" $ liftToEncoding te tel x-    liftToEncoding te tel (InR y) = E.pairs $ E.pair "InR" $ liftToEncoding te tel y--instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Sum f g a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}------------------------------------------------------------------------------------ containers----------------------------------------------------------------------------------instance ToJSON1 Seq.Seq where-    liftToJSON t _ = listValue t . toList-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ = listEncoding t . toList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a) => ToJSON (Seq.Seq a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON1 Set.Set where-    liftToJSON t _ = listValue t . Set.toList-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ = listEncoding t . Set.toList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a) => ToJSON (Set.Set a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON IntSet.IntSet where-    toJSON = toJSON . IntSet.toList-    {-# INLINE toJSON #-}--    toEncoding = toEncoding . IntSet.toList-    {-# INLINE toEncoding #-}---instance ToJSON1 IntMap.IntMap where-    liftToJSON t tol = liftToJSON to' tol' . IntMap.toList-      where-        to'  = liftToJSON2     toJSON toJSONList t tol-        tol' = liftToJSONList2 toJSON toJSONList t tol-    {-# INLINE liftToJSON #-}--    liftToEncoding t tol = liftToEncoding to' tol' . IntMap.toList-      where-        to'  = liftToEncoding2     toEncoding toEncodingList t tol-        tol' = liftToEncodingList2 toEncoding toEncodingList t tol-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (IntMap.IntMap a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSONKey k => ToJSON1 (M.Map k) where-    liftToJSON g _ = case toJSONKey of-        ToJSONKeyText f _ -> Object . mapHashKeyVal f g-        ToJSONKeyValue  f _ -> Array . V.fromList . map (toJSONPair f g) . M.toList-    {-# INLINE liftToJSON #-}--    liftToEncoding g _ = case toJSONKey of-        ToJSONKeyText _ f -> dict f g M.foldrWithKey-        ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . M.toList-      where-        pairEncoding f (a, b) = E.list id [f a, g b]-    {-# INLINE liftToEncoding #-}---instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON1 Tree.Tree where-    liftToJSON t tol = go-      where-        go (Tree.Node root branches) =-            liftToJSON2 t tol to' tol' (root, branches)--        to' = liftToJSON go (listValue go)-        tol' = liftToJSONList go (listValue go)-    {-# INLINE liftToJSON #-}--    liftToEncoding t tol = go-      where-        go (Tree.Node root branches) =-            liftToEncoding2 t tol to' tol' (root, branches)--        to' = liftToEncoding go (listEncoding go)-        tol' = liftToEncodingList go (listEncoding go)-    {-# INLINE liftToEncoding #-}--instance (ToJSON v) => ToJSON (Tree.Tree v) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}------------------------------------------------------------------------------------ uuid----------------------------------------------------------------------------------instance ToJSON UUID.UUID where-    toJSON = toJSON . UUID.toText-    toEncoding = E.unsafeToEncoding . EB.quote . B.byteString . UUID.toASCIIBytes--instance ToJSONKey UUID.UUID where-    toJSONKey = ToJSONKeyText UUID.toText $-        E.unsafeToEncoding . EB.quote . B.byteString . UUID.toASCIIBytes------------------------------------------------------------------------------------ vector----------------------------------------------------------------------------------instance ToJSON1 Vector where-    liftToJSON t _ = Array . V.map t-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ =  listEncoding t . V.toList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a) => ToJSON (Vector a) where-    {-# SPECIALIZE instance ToJSON Array #-}--    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}--encodeVector :: (ToJSON a, VG.Vector v a) => v a -> Encoding-encodeVector = listEncoding toEncoding . VG.toList-{-# INLINE encodeVector #-}--vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value-vectorToJSON = Array . V.map toJSON . V.convert-{-# INLINE vectorToJSON #-}--instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where-    toJSON = vectorToJSON-    {-# INLINE toJSON #-}--    toEncoding = encodeVector-    {-# INLINE toEncoding #-}---instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where-    toJSON = vectorToJSON-    {-# INLINE toJSON #-}--    toEncoding = encodeVector-    {-# INLINE toEncoding #-}---instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where-    toJSON = vectorToJSON-    {-# INLINE toJSON #-}--    toEncoding = encodeVector-    {-# INLINE toEncoding #-}------------------------------------------------------------------------------------ unordered-containers----------------------------------------------------------------------------------instance ToJSON1 HashSet.HashSet where-    liftToJSON t _ = listValue t . HashSet.toList-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ = listEncoding t . HashSet.toList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a) => ToJSON (HashSet.HashSet a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSONKey k => ToJSON1 (H.HashMap k) where-    liftToJSON g _ = case toJSONKey of-        ToJSONKeyText f _ -> Object . mapKeyVal f g-        ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . H.toList-    {-# INLINE liftToJSON #-}--    -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding-    liftToEncoding g _ = case toJSONKey of-        ToJSONKeyText _ f -> dict f g H.foldrWithKey-        ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . H.toList-      where-        pairEncoding f (a, b) = E.list id [f a, g b]-    {-# INLINE liftToEncoding #-}--instance (ToJSON v, ToJSONKey k) => ToJSON (H.HashMap k v) where-    {-# SPECIALIZE instance ToJSON Object #-}--    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}------------------------------------------------------------------------------------ aeson----------------------------------------------------------------------------------instance ToJSON Value where-    toJSON a = a-    {-# INLINE toJSON #-}--    toEncoding = E.value-    {-# INLINE toEncoding #-}--instance ToJSON DotNetTime where-    toJSON = toJSON . dotNetTime--    toEncoding = toEncoding . dotNetTime--dotNetTime :: DotNetTime -> String-dotNetTime (DotNetTime t) = secs ++ formatMillis t ++ ")/"-  where secs  = formatTime defaultTimeLocale "/Date(%s" t--formatMillis :: (FormatTime t) => t -> String-formatMillis = take 3 . formatTime defaultTimeLocale "%q"------------------------------------------------------------------------------------ primitive----------------------------------------------------------------------------------instance ToJSON a => ToJSON (PM.Array a) where-  -- note: we could do better than this if vector exposed the data-  -- constructor in Data.Vector.-  toJSON = toJSON . Exts.toList-  toEncoding = toEncoding . Exts.toList--instance ToJSON a => ToJSON (PM.SmallArray a) where-  toJSON = toJSON . Exts.toList-  toEncoding = toEncoding . Exts.toList--instance (PM.Prim a,ToJSON a) => ToJSON (PM.PrimArray a) where-  toJSON = toJSON . Exts.toList-  toEncoding = toEncoding . Exts.toList------------------------------------------------------------------------------------ time----------------------------------------------------------------------------------instance ToJSON Day where-    toJSON     = stringEncoding . E.day-    toEncoding = E.day--instance ToJSONKey Day where-    toJSONKey = toJSONKeyTextEnc E.day--instance ToJSON Month where-    toJSON     = stringEncoding . E.month-    toEncoding = E.month--instance ToJSONKey Month where-    toJSONKey = toJSONKeyTextEnc E.month--instance ToJSON Quarter where-    toJSON     = stringEncoding . E.quarter-    toEncoding = E.quarter--instance ToJSONKey Quarter where-    toJSONKey = toJSONKeyTextEnc E.quarter--instance ToJSON TimeOfDay where-    toJSON     = stringEncoding . E.timeOfDay-    toEncoding = E.timeOfDay--instance ToJSONKey TimeOfDay where-    toJSONKey = toJSONKeyTextEnc E.timeOfDay---instance ToJSON LocalTime where-    toJSON     = stringEncoding . E.localTime-    toEncoding = E.localTime--instance ToJSONKey LocalTime where-    toJSONKey = toJSONKeyTextEnc E.localTime---instance ToJSON ZonedTime where-    toJSON     = stringEncoding . E.zonedTime-    toEncoding = E.zonedTime--instance ToJSONKey ZonedTime where-    toJSONKey = toJSONKeyTextEnc E.zonedTime---instance ToJSON UTCTime where-    toJSON     = stringEncoding . E.utcTime-    toEncoding = E.utcTime--instance ToJSONKey UTCTime where-    toJSONKey = toJSONKeyTextEnc E.utcTime---- | Encode something t a JSON string.-stringEncoding :: Encoding' Text -> Value-stringEncoding = String-    . T.dropAround (== '"')-    . T.decodeLatin1-    . L.toStrict-    . E.encodingToLazyByteString-{-# INLINE stringEncoding #-}---instance ToJSON NominalDiffTime where-    toJSON = Number . realToFrac-    {-# INLINE toJSON #-}--    toEncoding = E.scientific . realToFrac-    {-# INLINE toEncoding #-}---instance ToJSON DiffTime where-    toJSON = Number . realToFrac-    {-# INLINE toJSON #-}--    toEncoding = E.scientific . realToFrac-    {-# INLINE toEncoding #-}---- | Encoded as number-instance ToJSON SystemTime where-    toJSON (MkSystemTime secs nsecs) =-        toJSON (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)-    toEncoding (MkSystemTime secs nsecs) =-        toEncoding (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)--instance ToJSON CalendarDiffTime where-    toJSON (CalendarDiffTime m nt) = object-        [ "months" .= m-        , "time" .= nt-        ]-    toEncoding (CalendarDiffTime m nt) = E.pairs-        ("months" .= m <> "time" .= nt)--instance ToJSON CalendarDiffDays where-    toJSON (CalendarDiffDays m d) = object-        [ "months" .= m-        , "days" .= d-        ]-    toEncoding (CalendarDiffDays m d) = E.pairs-        ("months" .= m <> "days" .= d)--instance ToJSON DayOfWeek where-    toJSON Monday    = "monday"-    toJSON Tuesday   = "tuesday"-    toJSON Wednesday = "wednesday"-    toJSON Thursday  = "thursday"-    toJSON Friday    = "friday"-    toJSON Saturday  = "saturday"-    toJSON Sunday    = "sunday"--    toEncoding = toEncodingDayOfWeek--toEncodingDayOfWeek :: DayOfWeek -> E.Encoding' a-toEncodingDayOfWeek Monday    = E.unsafeToEncoding "\"monday\""-toEncodingDayOfWeek Tuesday   = E.unsafeToEncoding "\"tuesday\""-toEncodingDayOfWeek Wednesday = E.unsafeToEncoding "\"wednesday\""-toEncodingDayOfWeek Thursday  = E.unsafeToEncoding "\"thursday\""-toEncodingDayOfWeek Friday    = E.unsafeToEncoding "\"friday\""-toEncodingDayOfWeek Saturday  = E.unsafeToEncoding "\"saturday\""-toEncodingDayOfWeek Sunday    = E.unsafeToEncoding "\"sunday\""--instance ToJSONKey DayOfWeek where-    toJSONKey = toJSONKeyTextEnc toEncodingDayOfWeek--instance ToJSON QuarterOfYear where-    toJSON Q1 = "q1"-    toJSON Q2 = "q2"-    toJSON Q3 = "q3"-    toJSON Q4 = "q4"--toEncodingQuarterOfYear :: QuarterOfYear -> E.Encoding' a-toEncodingQuarterOfYear Q1 = E.unsafeToEncoding "\"q1\""-toEncodingQuarterOfYear Q2 = E.unsafeToEncoding "\"q2\""-toEncodingQuarterOfYear Q3 = E.unsafeToEncoding "\"q3\""-toEncodingQuarterOfYear Q4 = E.unsafeToEncoding "\"q4\""--instance ToJSONKey QuarterOfYear where-    toJSONKey = toJSONKeyTextEnc toEncodingQuarterOfYear------------------------------------------------------------------------------------ base Monoid/Semigroup----------------------------------------------------------------------------------instance ToJSON1 Monoid.Dual where-    liftToJSON t _ = t . Monoid.getDual-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ = t . Monoid.getDual-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (Monoid.Dual a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON1 Monoid.First where-    liftToJSON t to' = liftToJSON t to' . Monoid.getFirst-    {-# INLINE liftToJSON #-}--    liftToEncoding t to' = liftToEncoding t to' . Monoid.getFirst-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (Monoid.First a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON1 Monoid.Last where-    liftToJSON t to' = liftToJSON t to' . Monoid.getLast-    {-# INLINE liftToJSON #-}--    liftToEncoding t to' = liftToEncoding t to' . Monoid.getLast-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (Monoid.Last a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON1 Semigroup.Min where-    liftToJSON t _ (Semigroup.Min x) = t x-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ (Semigroup.Min x) = t x-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (Semigroup.Min a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON1 Semigroup.Max where-    liftToJSON t _ (Semigroup.Max x) = t x-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ (Semigroup.Max x) = t x-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (Semigroup.Max a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}--instance ToJSON1 Semigroup.First where-    liftToJSON t _ (Semigroup.First x) = t x-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ (Semigroup.First x) = t x-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (Semigroup.First a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON1 Semigroup.Last where-    liftToJSON t _ (Semigroup.Last x) = t x-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ (Semigroup.Last x) = t x-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (Semigroup.Last a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON1 Semigroup.WrappedMonoid where-    liftToJSON t _ (Semigroup.WrapMonoid x) = t x-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ (Semigroup.WrapMonoid x) = t x-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (Semigroup.WrappedMonoid a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}---instance ToJSON1 Semigroup.Option where-    liftToJSON t to' = liftToJSON t to' . Semigroup.getOption-    {-# INLINE liftToJSON #-}--    liftToEncoding t to' = liftToEncoding t to' . Semigroup.getOption-    {-# INLINE liftToEncoding #-}--instance ToJSON a => ToJSON (Semigroup.Option a) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}------------------------------------------------------------------------------------ data-fix------------------------------------------------------------------------------------ | @since 1.5.3.0-instance ToJSON1 f => ToJSON (F.Fix f) where-    toJSON     = go where go (F.Fix f) = liftToJSON go toJSONList f-    toEncoding = go where go (F.Fix f) = liftToEncoding go toEncodingList f---- | @since 1.5.3.0-instance (ToJSON1 f, Functor f) => ToJSON (F.Mu f) where-    toJSON     = F.foldMu (liftToJSON id (listValue id))-    toEncoding = F.foldMu (liftToEncoding id (listEncoding id))---- | @since 1.5.3.0-instance (ToJSON1 f, Functor f) => ToJSON (F.Nu f) where-    toJSON     = F.foldNu (liftToJSON id (listValue id))-    toEncoding = F.foldNu (liftToEncoding id (listEncoding id))------------------------------------------------------------------------------------ strict------------------------------------------------------------------------------------ | @since 1.5.3.0-instance (ToJSON a, ToJSON b) => ToJSON (S.These a b) where-    toJSON = toJSON . S.toLazy-    toEncoding = toEncoding . S.toLazy---- | @since 1.5.3.0-instance ToJSON2 S.These where-    liftToJSON2 toa toas tob tobs = liftToJSON2 toa toas tob tobs . S.toLazy-    liftToEncoding2 toa toas tob tobs = liftToEncoding2 toa toas tob tobs . S.toLazy---- | @since 1.5.3.0-instance ToJSON a => ToJSON1 (S.These a) where-    liftToJSON toa tos = liftToJSON toa tos . S.toLazy-    liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy---- | @since 1.5.3.0-instance (ToJSON a, ToJSON b) => ToJSON (S.Pair a b) where-    toJSON = toJSON . S.toLazy-    toEncoding = toEncoding . S.toLazy---- | @since 1.5.3.0-instance ToJSON2 S.Pair where-    liftToJSON2 toa toas tob tobs = liftToJSON2 toa toas tob tobs . S.toLazy-    liftToEncoding2 toa toas tob tobs = liftToEncoding2 toa toas tob tobs . S.toLazy---- | @since 1.5.3.0-instance ToJSON a => ToJSON1 (S.Pair a) where-    liftToJSON toa tos = liftToJSON toa tos . S.toLazy-    liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy---- | @since 1.5.3.0-instance (ToJSON a, ToJSON b) => ToJSON (S.Either a b) where-    toJSON = toJSON . S.toLazy-    toEncoding = toEncoding . S.toLazy---- | @since 1.5.3.0-instance ToJSON2 S.Either where-    liftToJSON2 toa toas tob tobs = liftToJSON2 toa toas tob tobs . S.toLazy-    liftToEncoding2 toa toas tob tobs = liftToEncoding2 toa toas tob tobs . S.toLazy---- | @since 1.5.3.0-instance ToJSON a => ToJSON1 (S.Either a) where-    liftToJSON toa tos = liftToJSON toa tos . S.toLazy-    liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy---- | @since 1.5.3.0-instance ToJSON a => ToJSON (S.Maybe a) where-    toJSON = toJSON . S.toLazy-    toEncoding = toEncoding . S.toLazy---- | @since 1.5.3.0-instance ToJSON1 S.Maybe where-    liftToJSON toa tos = liftToJSON toa tos . S.toLazy-    liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy------------------------------------------------------------------------------------ tagged----------------------------------------------------------------------------------instance ToJSON1 Proxy where-    liftToJSON _ _ _ = Null-    {-# INLINE liftToJSON #-}--    liftToEncoding _ _ _ = E.null_-    {-# INLINE liftToEncoding #-}--instance ToJSON (Proxy a) where-    toJSON _ = Null-    {-# INLINE toJSON #-}--    toEncoding _ = E.null_-    {-# INLINE toEncoding #-}---instance ToJSON2 Tagged where-    liftToJSON2 _ _ t _ (Tagged x) = t x-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 _ _ t _ (Tagged x) = t x-    {-# INLINE liftToEncoding2 #-}--instance ToJSON1 (Tagged a) where-    liftToJSON t _ (Tagged x) = t x-    {-# INLINE liftToJSON #-}--    liftToEncoding t _ (Tagged x) = t x-    {-# INLINE liftToEncoding #-}--instance ToJSON b => ToJSON (Tagged a b) where-    toJSON = toJSON1-    {-# INLINE toJSON #-}--    toEncoding = toEncoding1-    {-# INLINE toEncoding #-}--instance ToJSONKey b => ToJSONKey (Tagged a b) where-    toJSONKey = contramapToJSONKeyFunction unTagged toJSONKey-    toJSONKeyList = contramapToJSONKeyFunction (fmap unTagged) toJSONKeyList------------------------------------------------------------------------------------ these------------------------------------------------------------------------------------ | @since 1.5.1.0-instance (ToJSON a, ToJSON b) => ToJSON (These a b) where-    toJSON (This a)    = object [ "This" .= a ]-    toJSON (That b)    = object [ "That" .= b ]-    toJSON (These a b) = object [ "This" .= a, "That" .= b ]--    toEncoding (This a)    = E.pairs $ "This" .= a-    toEncoding (That b)    = E.pairs $ "That" .= b-    toEncoding (These a b) = E.pairs $ "This" .= a <> "That" .= b---- | @since 1.5.1.0-instance ToJSON2 These where-    liftToJSON2  toa _ _tob _ (This a)    = object [ "This" .= toa a ]-    liftToJSON2 _toa _  tob _ (That b)    = object [ "That" .= tob b ]-    liftToJSON2  toa _  tob _ (These a b) = object [ "This" .= toa a, "That" .= tob b ]--    liftToEncoding2  toa _ _tob _ (This a)    = E.pairs $ E.pair "This" (toa a)-    liftToEncoding2 _toa _  tob _ (That b)    = E.pairs $ E.pair "That" (tob b)-    liftToEncoding2  toa _  tob _ (These a b) = E.pairs $ E.pair "This" (toa a) <> E.pair "That" (tob b)---- | @since 1.5.1.0-instance ToJSON a => ToJSON1 (These a) where-    liftToJSON _tob _ (This a)    = object [ "This" .= a ]-    liftToJSON  tob _ (That b)    = object [ "That" .= tob b ]-    liftToJSON  tob _ (These a b) = object [ "This" .= a, "That" .= tob b ]--    liftToEncoding _tob _ (This a)    = E.pairs $ "This" .= a-    liftToEncoding  tob _ (That b)    = E.pairs $ E.pair "That" (tob b)-    liftToEncoding  tob _ (These a b) = E.pairs $ "This" .= a <> E.pair "That" (tob b)---- | @since 1.5.1.0-instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (These1 f g) where-    liftToJSON tx tl (This1 a)    = object [ "This" .= liftToJSON tx tl a ]-    liftToJSON tx tl (That1 b)    = object [ "That" .= liftToJSON tx tl b ]-    liftToJSON tx tl (These1 a b) = object [ "This" .= liftToJSON tx tl a, "That" .= liftToJSON tx tl b ]--    liftToEncoding tx tl (This1 a)    = E.pairs $ E.pair "This" (liftToEncoding tx tl a)-    liftToEncoding tx tl (That1 b)    = E.pairs $ E.pair "That" (liftToEncoding tx tl b)-    liftToEncoding tx tl (These1 a b) = E.pairs $-        pair "This" (liftToEncoding tx tl a) `mappend`-        pair "That" (liftToEncoding tx tl b)---- | @since 1.5.1.0-instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (These1 f g a) where-    toJSON     = toJSON1-    toEncoding = toEncoding1------------------------------------------------------------------------------------ Instances for converting t map keys----------------------------------------------------------------------------------instance (ToJSON a, ToJSON b) => ToJSONKey (a,b)-instance (ToJSON a, ToJSON b, ToJSON c) => ToJSONKey (a,b,c)-instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSONKey (a,b,c,d)--instance ToJSONKey Char where-    toJSONKey = ToJSONKeyText T.singleton (E.string . (:[]))-    toJSONKeyList = toJSONKeyText T.pack--instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where-    toJSONKey = toJSONKeyList------------------------------------------------------------------------------------ Tuple instances----------------------------------------------------------------------------------instance ToJSON2 (,) where-    liftToJSON2 toA _ toB _ (a, b) = Array $ V.create $ do-        mv <- VM.unsafeNew 2-        VM.unsafeWrite mv 0 (toA a)-        VM.unsafeWrite mv 1 (toB b)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toA _ toB _ (a, b) = E.list id [toA a, toB b]-    {-# INLINE liftToEncoding2 #-}--instance (ToJSON a) => ToJSON1 ((,) a) where-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b) => ToJSON (a, b) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a) => ToJSON2 ((,,) a) where-    liftToJSON2 toB _ toC _ (a, b, c) = Array $ V.create $ do-        mv <- VM.unsafeNew 3-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toB b)-        VM.unsafeWrite mv 2 (toC c)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toB _ toC _ (a, b, c) = E.list id-      [ toEncoding a-      , toB b-      , toC c-      ]-    {-# INLINE liftToEncoding2 #-}--instance (ToJSON a, ToJSON b) => ToJSON1 ((,,) a b) where-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a, b, c) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b) => ToJSON2 ((,,,) a b) where-    liftToJSON2 toC _ toD _ (a, b, c, d) = Array $ V.create $ do-        mv <- VM.unsafeNew 4-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toC c)-        VM.unsafeWrite mv 3 (toD d)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toC _ toD _ (a, b, c, d) = E.list id-      [ toEncoding a-      , toEncoding b-      , toC c-      , toD d-      ]-    {-# INLINE liftToEncoding2 #-}--instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON1 ((,,,) a b c) where-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a, b, c, d) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON2 ((,,,,) a b c) where-    liftToJSON2 toD _ toE _ (a, b, c, d, e) = Array $ V.create $ do-        mv <- VM.unsafeNew 5-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toD d)-        VM.unsafeWrite mv 4 (toE e)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toD _ toE _ (a, b, c, d, e) = E.list id-      [ toEncoding a-      , toEncoding b-      , toEncoding c-      , toD d-      , toE e-      ]-    {-# INLINE liftToEncoding2 #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON1 ((,,,,) a b c d) where-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON (a, b, c, d, e) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON2 ((,,,,,) a b c d) where-    liftToJSON2 toE _ toF _ (a, b, c, d, e, f) = Array $ V.create $ do-        mv <- VM.unsafeNew 6-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toJSON d)-        VM.unsafeWrite mv 4 (toE e)-        VM.unsafeWrite mv 5 (toF f)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toE _ toF _ (a, b, c, d, e, f) = E.list id-      [ toEncoding a-      , toEncoding b-      , toEncoding c-      , toEncoding d-      , toE e-      , toF f-      ]-    {-# INLINE liftToEncoding2 #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON1 ((,,,,,) a b c d e) where-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON (a, b, c, d, e, f) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON2 ((,,,,,,) a b c d e) where-    liftToJSON2 toF _ toG _ (a, b, c, d, e, f, g) = Array $ V.create $ do-        mv <- VM.unsafeNew 7-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toJSON d)-        VM.unsafeWrite mv 4 (toJSON e)-        VM.unsafeWrite mv 5 (toF f)-        VM.unsafeWrite mv 6 (toG g)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toF _ toG _ (a, b, c, d, e, f, g) = E.list id-        [ toEncoding a-        , toEncoding b-        , toEncoding c-        , toEncoding d-        , toEncoding e-        , toF f-        , toG g-        ]-    {-# INLINE liftToEncoding2 #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON1 ((,,,,,,) a b c d e f) where-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON (a, b, c, d, e, f, g) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON2 ((,,,,,,,) a b c d e f) where-    liftToJSON2 toG _ toH _ (a, b, c, d, e, f, g, h) = Array $ V.create $ do-        mv <- VM.unsafeNew 8-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toJSON d)-        VM.unsafeWrite mv 4 (toJSON e)-        VM.unsafeWrite mv 5 (toJSON f)-        VM.unsafeWrite mv 6 (toG g)-        VM.unsafeWrite mv 7 (toH h)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toG _ toH _ (a, b, c, d, e, f, g, h) = E.list id-        [ toEncoding a-        , toEncoding b-        , toEncoding c-        , toEncoding d-        , toEncoding e-        , toEncoding f-        , toG g-        , toH h-        ]-    {-# INLINE liftToEncoding2 #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON1 ((,,,,,,,) a b c d e f g) where-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h) => ToJSON (a, b, c, d, e, f, g, h) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON2 ((,,,,,,,,) a b c d e f g) where-    liftToJSON2 toH _ toI _ (a, b, c, d, e, f, g, h, i) = Array $ V.create $ do-        mv <- VM.unsafeNew 9-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toJSON d)-        VM.unsafeWrite mv 4 (toJSON e)-        VM.unsafeWrite mv 5 (toJSON f)-        VM.unsafeWrite mv 6 (toJSON g)-        VM.unsafeWrite mv 7 (toH h)-        VM.unsafeWrite mv 8 (toI i)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toH _ toI _ (a, b, c, d, e, f, g, h, i) = E.list id-        [ toEncoding a-        , toEncoding b-        , toEncoding c-        , toEncoding d-        , toEncoding e-        , toEncoding f-        , toEncoding g-        , toH h-        , toI i-        ]-    {-# INLINE liftToEncoding2 #-}--instance (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-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i) => ToJSON (a, b, c, d, e, f, g, h, i) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h) => ToJSON2 ((,,,,,,,,,) a b c d e f g h) where-    liftToJSON2 toI _ toJ _ (a, b, c, d, e, f, g, h, i, j) = Array $ V.create $ do-        mv <- VM.unsafeNew 10-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toJSON d)-        VM.unsafeWrite mv 4 (toJSON e)-        VM.unsafeWrite mv 5 (toJSON f)-        VM.unsafeWrite mv 6 (toJSON g)-        VM.unsafeWrite mv 7 (toJSON h)-        VM.unsafeWrite mv 8 (toI i)-        VM.unsafeWrite mv 9 (toJ j)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toI _ toJ _ (a, b, c, d, e, f, g, h, i, j) = E.list id-        [ toEncoding a-        , toEncoding b-        , toEncoding c-        , toEncoding d-        , toEncoding e-        , toEncoding f-        , toEncoding g-        , toEncoding h-        , toI i-        , toJ j-        ]-    {-# INLINE liftToEncoding2 #-}--instance (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-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j) => ToJSON (a, b, c, d, e, f, g, h, i, j) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i) => ToJSON2 ((,,,,,,,,,,) a b c d e f g h i) where-    liftToJSON2 toJ _ toK _ (a, b, c, d, e, f, g, h, i, j, k) = Array $ V.create $ do-        mv <- VM.unsafeNew 11-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toJSON d)-        VM.unsafeWrite mv 4 (toJSON e)-        VM.unsafeWrite mv 5 (toJSON f)-        VM.unsafeWrite mv 6 (toJSON g)-        VM.unsafeWrite mv 7 (toJSON h)-        VM.unsafeWrite mv 8 (toJSON i)-        VM.unsafeWrite mv 9 (toJ j)-        VM.unsafeWrite mv 10 (toK k)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toJ _ toK _ (a, b, c, d, e, f, g, h, i, j, k) = E.list id-        [ toEncoding a-        , toEncoding b-        , toEncoding c-        , toEncoding d-        , toEncoding e-        , toEncoding f-        , toEncoding g-        , toEncoding h-        , toEncoding i-        , toJ j-        , toK k-        ]-    {-# INLINE liftToEncoding2 #-}--instance (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-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k) => ToJSON (a, b, c, d, e, f, g, h, i, j, k) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j) => ToJSON2 ((,,,,,,,,,,,) a b c d e f g h i j) where-    liftToJSON2 toK _ toL _ (a, b, c, d, e, f, g, h, i, j, k, l) = Array $ V.create $ do-        mv <- VM.unsafeNew 12-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toJSON d)-        VM.unsafeWrite mv 4 (toJSON e)-        VM.unsafeWrite mv 5 (toJSON f)-        VM.unsafeWrite mv 6 (toJSON g)-        VM.unsafeWrite mv 7 (toJSON h)-        VM.unsafeWrite mv 8 (toJSON i)-        VM.unsafeWrite mv 9 (toJSON j)-        VM.unsafeWrite mv 10 (toK k)-        VM.unsafeWrite mv 11 (toL l)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toK _ toL _ (a, b, c, d, e, f, g, h, i, j, k, l) = E.list id-        [ toEncoding a-        , toEncoding b-        , toEncoding c-        , toEncoding d-        , toEncoding e-        , toEncoding f-        , toEncoding g-        , toEncoding h-        , toEncoding i-        , toEncoding j-        , toK k-        , toL l-        ]-    {-# INLINE liftToEncoding2 #-}--instance (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-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (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 (a, b, c, d, e, f, g, h, i, j, k, l) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k) => ToJSON2 ((,,,,,,,,,,,,) a b c d e f g h i j k) where-    liftToJSON2 toL _ toM _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = Array $ V.create $ do-        mv <- VM.unsafeNew 13-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toJSON d)-        VM.unsafeWrite mv 4 (toJSON e)-        VM.unsafeWrite mv 5 (toJSON f)-        VM.unsafeWrite mv 6 (toJSON g)-        VM.unsafeWrite mv 7 (toJSON h)-        VM.unsafeWrite mv 8 (toJSON i)-        VM.unsafeWrite mv 9 (toJSON j)-        VM.unsafeWrite mv 10 (toJSON k)-        VM.unsafeWrite mv 11 (toL l)-        VM.unsafeWrite mv 12 (toM m)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toL _ toM _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = E.list id-        [ toEncoding a-        , toEncoding b-        , toEncoding c-        , toEncoding d-        , toEncoding e-        , toEncoding f-        , toEncoding g-        , toEncoding h-        , toEncoding i-        , toEncoding j-        , toEncoding k-        , toL l-        , toM m-        ]-    {-# INLINE liftToEncoding2 #-}--instance (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-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (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 (a, b, c, d, e, f, g, h, i, j, k, l, m) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l) => ToJSON2 ((,,,,,,,,,,,,,) a b c d e f g h i j k l) where-    liftToJSON2 toM _ toN _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = Array $ V.create $ do-        mv <- VM.unsafeNew 14-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toJSON d)-        VM.unsafeWrite mv 4 (toJSON e)-        VM.unsafeWrite mv 5 (toJSON f)-        VM.unsafeWrite mv 6 (toJSON g)-        VM.unsafeWrite mv 7 (toJSON h)-        VM.unsafeWrite mv 8 (toJSON i)-        VM.unsafeWrite mv 9 (toJSON j)-        VM.unsafeWrite mv 10 (toJSON k)-        VM.unsafeWrite mv 11 (toJSON l)-        VM.unsafeWrite mv 12 (toM m)-        VM.unsafeWrite mv 13 (toN n)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toM _ toN _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = E.list id-        [ toEncoding a-        , toEncoding b-        , toEncoding c-        , toEncoding d-        , toEncoding e-        , toEncoding f-        , toEncoding g-        , toEncoding h-        , toEncoding i-        , toEncoding j-        , toEncoding k-        , toEncoding l-        , toM m-        , toN n-        ]-    {-# INLINE liftToEncoding2 #-}--instance (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-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (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) => ToJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}--instance (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) => ToJSON2 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m) where-    liftToJSON2 toN _ toO _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = Array $ V.create $ do-        mv <- VM.unsafeNew 15-        VM.unsafeWrite mv 0 (toJSON a)-        VM.unsafeWrite mv 1 (toJSON b)-        VM.unsafeWrite mv 2 (toJSON c)-        VM.unsafeWrite mv 3 (toJSON d)-        VM.unsafeWrite mv 4 (toJSON e)-        VM.unsafeWrite mv 5 (toJSON f)-        VM.unsafeWrite mv 6 (toJSON g)-        VM.unsafeWrite mv 7 (toJSON h)-        VM.unsafeWrite mv 8 (toJSON i)-        VM.unsafeWrite mv 9 (toJSON j)-        VM.unsafeWrite mv 10 (toJSON k)-        VM.unsafeWrite mv 11 (toJSON l)-        VM.unsafeWrite mv 12 (toJSON m)-        VM.unsafeWrite mv 13 (toN n)-        VM.unsafeWrite mv 14 (toO o)-        return mv-    {-# INLINE liftToJSON2 #-}--    liftToEncoding2 toN _ toO _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = E.list id-        [ toEncoding a-        , toEncoding b-        , toEncoding c-        , toEncoding d-        , toEncoding e-        , toEncoding f-        , toEncoding g-        , toEncoding h-        , toEncoding i-        , toEncoding j-        , toEncoding k-        , toEncoding l-        , toEncoding m-        , toN n-        , toO o-        ]-    {-# INLINE liftToEncoding2 #-}--instance (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-    liftToJSON = liftToJSON2 toJSON toJSONList-    {-# INLINE liftToJSON #-}-    liftToEncoding = liftToEncoding2 toEncoding toEncodingList-    {-# INLINE liftToEncoding #-}--instance (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, ToJSON o) => ToJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where-    toJSON = toJSON2-    {-# INLINE toJSON #-}-    toEncoding = toEncoding2-    {-# INLINE toEncoding #-}-------------------------------------------------------------------------------------- | Wrap a list of pairs as an object.-class Monoid pairs => FromPairs enc pairs | enc -> pairs where-  fromPairs :: pairs -> enc--instance (a ~ Value) => FromPairs (Encoding' a) Series where-  fromPairs = E.pairs--instance FromPairs Value (DList Pair) where-  fromPairs = object . toList---- | Like 'KeyValue' but the value is already converted to JSON--- ('Value' or 'Encoding'), and the result actually represents lists of pairs--- so it can be readily concatenated.-class Monoid kv => KeyValuePair v kv where-    pair :: String -> v -> kv--instance (v ~ Value) => KeyValuePair v (DList Pair) where-    pair k v = DList.singleton (pack k .= v)--instance (e ~ Encoding) => KeyValuePair e Series where-    pair = E.pairStr
README.markdown view
@@ -1,7 +1,8 @@-# Welcome to `aeson` [![Hackage](https://img.shields.io/hackage/v/aeson.svg)](https://hackage.haskell.org/package/aeson) [![Build Status](https://travis-ci.org/bos/aeson.svg)](https://travis-ci.org/bos/aeson)+# Welcome to `aeson` -aeson is a fast Haskell library for working with JSON data.+[![Hackage](https://img.shields.io/hackage/v/aeson.svg)](https://hackage.haskell.org/package/aeson) [![Build Status](https://github.com/haskell/aeson/workflows/Haskell-CI/badge.svg)](https://github.com/haskell/aeson/actions?query=workflow%3AHaskell-CI) +aeson is a fast Haskell library for working with JSON data.  # Join in! @@ -9,15 +10,15 @@ and other improvements.  Please report bugs via the-[github issue tracker](http://github.com/bos/aeson/issues).+[github issue tracker](http://github.com/haskell/aeson/issues). -Master [git repository](http://github.com/bos/aeson):+Master [git repository](http://github.com/haskell/aeson): -* `git clone git://github.com/bos/aeson.git`+* `git clone git://github.com/haskell/aeson.git`  See what's changed in recent (and upcoming) releases: -* https://github.com/bos/aeson/blob/master/changelog.md+* https://github.com/haskell/aeson/blob/master/changelog.md  (You can create and contribute changes using either git or Mercurial.)
aeson.cabal view
@@ -1,5 +1,5 @@ name:            aeson-version:         1.5.5.1+version:         1.5.6.0 license:         BSD3 license-file:    LICENSE category:        Text, Web, JSON@@ -26,21 +26,15 @@ extra-source-files:     *.yaml     README.markdown-    benchmarks/*.cabal-    benchmarks/*.hs-    benchmarks/*.py-    benchmarks/Compare/*.hs-    benchmarks/Makefile-    benchmarks/Typed/*.hs-    benchmarks/json-data/*.json     cbits/*.c     changelog.md-    ffi/Data/Aeson/Parser/*.hs     include/*.h     tests/JSONTestSuite/test_parsing/*.json     tests/JSONTestSuite/test_transform/*.json     tests/golden/*.expected-    pure/Data/Aeson/Parser/*.hs+    src-ffi/Data/Aeson/Parser/*.hs+    src-pure/Data/Aeson/Parser/*.hs+    benchmarks/json-data/*.json  flag developer   description: operate in developer mode@@ -64,7 +58,7 @@  library   default-language: Haskell2010-  hs-source-dirs: . attoparsec-iso8601/+  hs-source-dirs: src attoparsec-iso8601/src    exposed-modules:     Data.Aeson@@ -162,18 +156,18 @@    include-dirs: include   if impl(ghcjs) || !flag(cffi)-    hs-source-dirs: pure+    hs-source-dirs: src-pure     other-modules: Data.Aeson.Parser.UnescapePure   else     c-sources: cbits/unescape_string.c     cpp-options: -DCFFI-    hs-source-dirs: ffi+    hs-source-dirs: src-ffi     other-modules: Data.Aeson.Parser.UnescapeFFI  test-suite aeson-tests   default-language: Haskell2010   type: exitcode-stdio-1.0-  hs-source-dirs: tests ffi pure+  hs-source-dirs: tests src-ffi src-pure   main-is: Tests.hs   c-sources: cbits/unescape_string.c   ghc-options: -Wall -threaded -rtsopts@@ -203,7 +197,7 @@     UnitTests.NullaryConstructors    build-depends:-    QuickCheck >= 2.10.0.1 && < 2.15,+    QuickCheck >= 2.14.2 && < 2.15,     aeson,     integer-logarithms >= 1 && <1.1,     attoparsec,@@ -220,6 +214,7 @@     generic-deriving >= 1.10 && < 1.15,     ghc-prim >= 0.2,     hashable >= 1.2.4.0,+    hashable-time >= 0.2.1 && <0.3,     scientific,     strict,     tagged,@@ -253,8 +248,6 @@     build-depends: nats >=1 && <1.2,                    void >=0.7.2 && <0.8 -  if impl(ghc >= 7.8)-    build-depends: hashable-time >= 0.2.0.1 && <0.3    if flag(fast)     ghc-options: -fno-enable-rewrite-rules
− attoparsec-iso8601/Data/Attoparsec/Time.hs 
@@ -1,174 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}--- |--- Module:      Data.Aeson.Parser.Time--- Copyright:   (c) 2015-2016 Bryan O'Sullivan--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable------ Parsers for parsing dates and times.--module Data.Attoparsec.Time-    (-      day-    , localTime-    , timeOfDay-    , timeZone-    , utcTime-    , zonedTime-    , month-    , quarter-    ) where--import Prelude.Compat--import Control.Applicative ((<|>))-import Control.Monad (void, when)-import Data.Attoparsec.Text as A-import Data.Attoparsec.Time.Internal (toPico)-import Data.Bits ((.&.))-import Data.Char (isDigit, ord)-import Data.Fixed (Pico)-import Data.Int (Int64)-import Data.Maybe (fromMaybe)-import Data.Time.Calendar (Day, fromGregorianValid)-import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..), fromYearQuarter)-import Data.Time.Calendar.Month.Compat (Month, fromYearMonthValid)-import Data.Time.Clock (UTCTime(..))-import qualified Data.Text as T-import qualified Data.Time.LocalTime as Local---- | Parse a date of the form @[+,-]YYYY-MM-DD@.-day :: Parser Day-day = do-  absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id-  y <- (decimal <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"-  m <- (twoDigits <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"-  d <- twoDigits <|> fail "date must be of form [+,-]YYYY-MM-DD"-  maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d)---- | Parse a month of the form @[+,-]YYYY-MM@.-month :: Parser Month-month = do-  absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id-  y <- (decimal <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"-  m <- twoDigits <|> fail "month must be of form [+,-]YYYY-MM"-  maybe (fail "invalid month") return (fromYearMonthValid (absOrNeg y) m)---- | Parse a quarter of the form @[+,-]YYYY-QN@.-quarter :: Parser Quarter-quarter = do-  absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id-  y <- (decimal <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"-  _ <- char 'q' <|> char 'Q'-  q <- parseQ-  return $! fromYearQuarter (absOrNeg y) q-  where-    parseQ = Q1 <$ char '1'-      <|> Q2 <$ char '2'-      <|> Q3 <$ char '3'-      <|> Q4 <$ char '4'---- | Parse a two-digit integer (e.g. day of month, hour).-twoDigits :: Parser Int-twoDigits = do-  a <- digit-  b <- digit-  let c2d c = ord c .&. 15-  return $! c2d a * 10 + c2d b---- | Parse a time of the form @HH:MM[:SS[.SSS]]@.-timeOfDay :: Parser Local.TimeOfDay-timeOfDay = do-  h <- twoDigits-  m <- char ':' *> twoDigits-  s <- option 0 (char ':' *> seconds)-  if h < 24 && m < 60 && s < 61-    then return (Local.TimeOfDay h m s)-    else fail "invalid time"--data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64---- | Parse a count of seconds, with the integer part being two digits--- long.-seconds :: Parser Pico-seconds = do-  real <- twoDigits-  mc <- peekChar-  case mc of-    Just '.' -> do-      t <- anyChar *> takeWhile1 isDigit-      return $! parsePicos real t-    _ -> return $! fromIntegral real- where-  parsePicos a0 t = toPico (fromIntegral (t' * 10^n))-    where T n t'  = T.foldl' step (T 12 (fromIntegral a0)) t-          step ma@(T m a) c-              | m <= 0    = ma-              | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15)---- | Parse a time zone, and return 'Nothing' if the offset from UTC is--- zero. (This makes some speedups possible.)-timeZone :: Parser (Maybe Local.TimeZone)-timeZone = do-  let maybeSkip c = do ch <- peekChar'; when (ch == c) (void anyChar)-  maybeSkip ' '-  ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-'-  if ch == 'Z'-    then return Nothing-    else do-      h <- twoDigits-      mm <- peekChar-      m <- case mm of-             Just ':'           -> anyChar *> twoDigits-             Just d | isDigit d -> twoDigits-             _                  -> return 0-      let off | ch == '-' = negate off0-              | otherwise = off0-          off0 = h * 60 + m-      case undefined of-        _   | off == 0 ->-              return Nothing-            | off < -720 || off > 840 || m > 59 ->-              fail "invalid time zone offset"-            | otherwise ->-              let !tz = Local.minutesToTimeZone off-              in return (Just tz)---- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@.--- The space may be replaced with a @T@.  The number of seconds is optional--- and may be followed by a fractional component.-localTime :: Parser Local.LocalTime-localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay-  where daySep = satisfy (\c -> c == 'T' || c == ' ')---- | Behaves as 'zonedTime', but converts any time zone offset into a--- UTC time.-utcTime :: Parser UTCTime-utcTime = do-  lt@(Local.LocalTime d t) <- localTime-  mtz <- timeZone-  case mtz of-    Nothing -> let !tt = Local.timeOfDayToTime t-               in return (UTCTime d tt)-    Just tz -> return $! Local.localTimeToUTC tz lt---- | Parse a date with time zone info. Acceptable formats:------ @YYYY-MM-DD HH:MM Z@--- @YYYY-MM-DD HH:MM:SS Z@--- @YYYY-MM-DD HH:MM:SS.SSS Z@------ The first space may instead be a @T@, and the second space is--- optional.  The @Z@ represents UTC.  The @Z@ may be replaced with a--- time zone offset of the form @+0000@ or @-08:00@, where the first--- two digits are hours, the @:@ is optional and the second two digits--- (also optional) are minutes.-zonedTime :: Parser Local.ZonedTime-zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)--utc :: Local.TimeZone-utc = Local.TimeZone 0 False ""
− attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--- |--- Module:      Data.Aeson.Internal.Time--- Copyright:   (c) 2015-2016 Bryan O'Sullivan--- License:     BSD3--- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>--- Stability:   experimental--- Portability: portable--module Data.Attoparsec.Time.Internal-    (-      TimeOfDay64(..)-    , fromPico-    , toPico-    , diffTimeOfDay64-    , toTimeOfDay64-    ) where--import Prelude.Compat--import Data.Fixed (Fixed(MkFixed), Pico)-import Data.Int (Int64)-import Data.Time (TimeOfDay(..))-import Data.Time.Clock.Compat--toPico :: Integer -> Pico-toPico = MkFixed--fromPico :: Pico -> Integer-fromPico (MkFixed i) = i---- | Like TimeOfDay, but using a fixed-width integer for seconds.-data TimeOfDay64 = TOD {-# UNPACK #-} !Int-                       {-# UNPACK #-} !Int-                       {-# UNPACK #-} !Int64--posixDayLength :: DiffTime-posixDayLength = 86400--diffTimeOfDay64 :: DiffTime -> TimeOfDay64-diffTimeOfDay64 t-  | t >= posixDayLength = TOD 23 59 (60000000000000 + pico (t - posixDayLength))-  | otherwise = TOD (fromIntegral h) (fromIntegral m) s-    where (h,mp) = pico t `quotRem` 3600000000000000-          (m,s)  = mp `quotRem` 60000000000000-          pico   = fromIntegral . diffTimeToPicoseconds--toTimeOfDay64 :: TimeOfDay -> TimeOfDay64-toTimeOfDay64 (TimeOfDay h m s) = TOD h m (fromIntegral (fromPico s))
+ attoparsec-iso8601/src/Data/Attoparsec/Time.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module:      Data.Aeson.Parser.Time+-- Copyright:   (c) 2015-2016 Bryan O'Sullivan+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Parsers for parsing dates and times.++module Data.Attoparsec.Time+    (+      day+    , localTime+    , timeOfDay+    , timeZone+    , utcTime+    , zonedTime+    , month+    , quarter+    ) where++import Prelude.Compat++import Control.Applicative ((<|>))+import Control.Monad (void, when)+import Data.Attoparsec.Text as A+import Data.Attoparsec.Time.Internal (toPico)+import Data.Bits ((.&.))+import Data.Char (isDigit, ord)+import Data.Fixed (Pico)+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Time.Calendar (Day, fromGregorianValid)+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..), fromYearQuarter)+import Data.Time.Calendar.Month.Compat (Month, fromYearMonthValid)+import Data.Time.Clock (UTCTime(..))+import qualified Data.Text as T+import qualified Data.Time.LocalTime as Local++-- | Parse a date of the form @[+,-]YYYY-MM-DD@.+day :: Parser Day+day = do+  absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id+  y <- (decimal <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"+  m <- (twoDigits <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"+  d <- twoDigits <|> fail "date must be of form [+,-]YYYY-MM-DD"+  maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d)++-- | Parse a month of the form @[+,-]YYYY-MM@.+month :: Parser Month+month = do+  absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id+  y <- (decimal <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"+  m <- twoDigits <|> fail "month must be of form [+,-]YYYY-MM"+  maybe (fail "invalid month") return (fromYearMonthValid (absOrNeg y) m)++-- | Parse a quarter of the form @[+,-]YYYY-QN@.+quarter :: Parser Quarter+quarter = do+  absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id+  y <- (decimal <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"+  _ <- char 'q' <|> char 'Q'+  q <- parseQ+  return $! fromYearQuarter (absOrNeg y) q+  where+    parseQ = Q1 <$ char '1'+      <|> Q2 <$ char '2'+      <|> Q3 <$ char '3'+      <|> Q4 <$ char '4'++-- | Parse a two-digit integer (e.g. day of month, hour).+twoDigits :: Parser Int+twoDigits = do+  a <- digit+  b <- digit+  let c2d c = ord c .&. 15+  return $! c2d a * 10 + c2d b++-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.+timeOfDay :: Parser Local.TimeOfDay+timeOfDay = do+  h <- twoDigits+  m <- char ':' *> twoDigits+  s <- option 0 (char ':' *> seconds)+  if h < 24 && m < 60 && s < 61+    then return (Local.TimeOfDay h m s)+    else fail "invalid time"++data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64++-- | Parse a count of seconds, with the integer part being two digits+-- long.+seconds :: Parser Pico+seconds = do+  real <- twoDigits+  mc <- peekChar+  case mc of+    Just '.' -> do+      t <- anyChar *> takeWhile1 isDigit+      return $! parsePicos real t+    _ -> return $! fromIntegral real+ where+  parsePicos a0 t = toPico (fromIntegral (t' * 10^n))+    where T n t'  = T.foldl' step (T 12 (fromIntegral a0)) t+          step ma@(T m a) c+              | m <= 0    = ma+              | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15)++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZone :: Parser (Maybe Local.TimeZone)+timeZone = do+  let maybeSkip c = do ch <- peekChar'; when (ch == c) (void anyChar)+  maybeSkip ' '+  ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-'+  if ch == 'Z'+    then return Nothing+    else do+      h <- twoDigits+      mm <- peekChar+      m <- case mm of+             Just ':'           -> anyChar *> twoDigits+             Just d | isDigit d -> twoDigits+             _                  -> return 0+      let off | ch == '-' = negate off0+              | otherwise = off0+          off0 = h * 60 + m+      case undefined of+        _   | off == 0 ->+              return Nothing+            | off < -720 || off > 840 || m > 59 ->+              fail "invalid time zone offset"+            | otherwise ->+              let !tz = Local.minutesToTimeZone off+              in return (Just tz)++-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@.+-- The space may be replaced with a @T@.  The number of seconds is optional+-- and may be followed by a fractional component.+localTime :: Parser Local.LocalTime+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay+  where daySep = satisfy (\c -> c == 'T' || c == ' ')++-- | Behaves as 'zonedTime', but converts any time zone offset into a+-- UTC time.+utcTime :: Parser UTCTime+utcTime = do+  lt@(Local.LocalTime d t) <- localTime+  mtz <- timeZone+  case mtz of+    Nothing -> let !tt = Local.timeOfDayToTime t+               in return (UTCTime d tt)+    Just tz -> return $! Local.localTimeToUTC tz lt++-- | Parse a date with time zone info. Acceptable formats:+--+-- @YYYY-MM-DD HH:MM Z@+-- @YYYY-MM-DD HH:MM:SS Z@+-- @YYYY-MM-DD HH:MM:SS.SSS Z@+--+-- The first space may instead be a @T@, and the second space is+-- optional.  The @Z@ represents UTC.  The @Z@ may be replaced with a+-- time zone offset of the form @+0000@ or @-08:00@, where the first+-- two digits are hours, the @:@ is optional and the second two digits+-- (also optional) are minutes.+zonedTime :: Parser Local.ZonedTime+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)++utc :: Local.TimeZone+utc = Local.TimeZone 0 False ""
+ attoparsec-iso8601/src/Data/Attoparsec/Time/Internal.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- |+-- Module:      Data.Aeson.Internal.Time+-- Copyright:   (c) 2015-2016 Bryan O'Sullivan+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable++module Data.Attoparsec.Time.Internal+    (+      TimeOfDay64(..)+    , fromPico+    , toPico+    , diffTimeOfDay64+    , toTimeOfDay64+    ) where++import Prelude.Compat++import Data.Fixed (Fixed(MkFixed), Pico)+import Data.Int (Int64)+import Data.Time (TimeOfDay(..))+import Data.Time.Clock.Compat++toPico :: Integer -> Pico+toPico = MkFixed++fromPico :: Pico -> Integer+fromPico (MkFixed i) = i++-- | Like TimeOfDay, but using a fixed-width integer for seconds.+data TimeOfDay64 = TOD {-# UNPACK #-} !Int+                       {-# UNPACK #-} !Int+                       {-# UNPACK #-} !Int64++posixDayLength :: DiffTime+posixDayLength = 86400++diffTimeOfDay64 :: DiffTime -> TimeOfDay64+diffTimeOfDay64 t+  | t >= posixDayLength = TOD 23 59 (60000000000000 + pico (t - posixDayLength))+  | otherwise = TOD (fromIntegral h) (fromIntegral m) s+    where (h,mp) = pico t `quotRem` 3600000000000000+          (m,s)  = mp `quotRem` 60000000000000+          pico   = fromIntegral . diffTimeToPicoseconds++toTimeOfDay64 :: TimeOfDay -> TimeOfDay64+toTimeOfDay64 (TimeOfDay h m s) = TOD h m (fromIntegral (fromPico s))
− benchmarks/AesonEncode.hs 
@@ -1,43 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--module Main (main) where--import Prelude.Compat--import Control.DeepSeq-import Control.Monad (forM_)-import Data.Aeson-import Data.Attoparsec.ByteString (IResult(..), parseWith)-import Data.Char (isDigit)-import Data.Time.Clock-import System.Environment (getArgs)-import System.IO-import qualified Data.ByteString as B--main :: IO ()-main = do-  args0 <- getArgs-  let (cnt,args) = case args0 of-        (i:c:a) | all isDigit i && all isDigit c -> (c,a)-        (c:a) -> (c,a)-        [] -> error "Unexpected empty list"-  let count = read cnt :: Int-  forM_ args $ \arg -> withFile arg ReadMode $ \h -> do-    putStrLn $ arg ++ ":"-    let refill = B.hGet h 16384-    result0 <- parseWith refill json =<< refill-    r0 <- case result0 of-            Done _ r -> return r-            _        -> fail $ "failed to read " ++ show arg-    start <- getCurrentTime-    let loop !n r-            | n >= count = return ()-            | otherwise = {-# SCC "loop" #-}-          rnf (encode r) `seq` loop (n+1) r-    loop 0 r0-    delta <- flip diffUTCTime start `fmap` getCurrentTime-    let rate = fromIntegral count / realToFrac delta :: Double-    putStrLn $ "  " ++ cnt ++ " good, " ++ show delta-    putStrLn $ "  " ++ show (round rate :: Int) ++ " per second"
− benchmarks/AesonFoldable.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--module Main (main) where--import Criterion.Main--import Prelude.Compat--import Data.Foldable (toList)-import qualified Data.Aeson as A-import qualified Data.Sequence as S-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U------------------------------------------------------------------------------------ List----------------------------------------------------------------------------------newtype L f = L { getL :: f Int }--instance Foldable f => A.ToJSON (L f) where-    toJSON = error "do not use this"-    toEncoding = A.toEncoding . toList . getL------------------------------------------------------------------------------------ Foldable----------------------------------------------------------------------------------newtype F f = F { getF :: f Int }--instance Foldable f => A.ToJSON (F f) where-    toJSON = error "do not use this"-    toEncoding = A.foldable . getF------------------------------------------------------------------------------------ Values----------------------------------------------------------------------------------valueList :: [Int]-valueList = [1..1000]--valueSeq :: S.Seq Int-valueSeq = S.fromList valueList--valueVector :: V.Vector Int-valueVector = V.fromList valueList--valueUVector :: U.Vector Int-valueUVector = U.fromList valueList------------------------------------------------------------------------------------ Main----------------------------------------------------------------------------------benchEncode-    :: A.ToJSON a-    => String-    -> a-    -> Benchmark-benchEncode name val-    = bench ("A " ++ name) $ nf A.encode val--main :: IO ()-main =  defaultMain-    [ bgroup "encode"-        [ bgroup "List"-            [ benchEncode "-"     valueList-            , benchEncode "L" $ L valueList-            , benchEncode "F" $ F valueList-            ]-        , bgroup "Seq"-            [ benchEncode "-"     valueSeq-            , benchEncode "L" $ L valueSeq-            , benchEncode "F" $ F valueSeq-            ]-        , bgroup "Vector"-            [ benchEncode "-"     valueVector-            , benchEncode "L" $ L valueVector-            , benchEncode "F" $ F valueVector-            ]-        , bgroup "Vector.Unboxed"-            [ benchEncode "-"     valueUVector-            ]-        ]-    ]
− benchmarks/AesonMap.hs 
@@ -1,214 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RankNTypes #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main (main) where--import Prelude.Compat--import Control.DeepSeq-import Criterion.Main-import Data.Hashable-import Data.Proxy (Proxy (..))-import Data.Tagged (Tagged (..))-import Data.Aeson-import Data.Aeson.Types (fromJSONKeyCoerce)-import qualified Data.ByteString.Lazy as LBS-import qualified Data.HashMap.Strict as HM-import qualified Data.Map as M-import qualified Data.Text as T--value :: Int -> HM.HashMap T.Text T.Text-value n = HM.fromList $ map f [1..n]-  where-    f m = let t = T.pack (show m) in (t, t)------------------------------------------------------------------------------------ Orphans----------------------------------------------------------------------------------instance Hashable b => Hashable (Tagged a b) where-    hashWithSalt salt (Tagged a) = hashWithSalt salt a------------------------------------------------------------------------------------ Text----------------------------------------------------------------------------------newtype T1 = T1 T.Text-  deriving (Eq, Ord)--instance NFData T1 where-    rnf (T1 t) = rnf t-instance Hashable T1 where-    hashWithSalt salt (T1 t) = hashWithSalt salt t--instance FromJSON T1 where-    parseJSON = withText "T1" $ pure . T1-instance FromJSONKey T1 where-    fromJSONKey = FromJSONKeyText T1------------------------------------------------------------------------------------ Coerce----------------------------------------------------------------------------------newtype T2 = T2 T.Text-  deriving (Eq, Ord)--instance NFData T2 where-    rnf (T2 t) = rnf t-instance Hashable T2 where-    hashWithSalt salt (T2 t) = hashWithSalt salt t--instance FromJSON T2 where-    parseJSON = withText "T2" $ pure . T2-instance FromJSONKey T2 where-    fromJSONKey = fromJSONKeyCoerce------------------------------------------------------------------------------------ TextParser----------------------------------------------------------------------------------newtype T3 = T3 T.Text-  deriving (Eq, Ord)--instance NFData T3 where-    rnf (T3 t) = rnf t-instance Hashable T3 where-    hashWithSalt salt (T3 t) = hashWithSalt salt t--instance FromJSON T3 where-    parseJSON = withText "T3" $ pure . T3-instance FromJSONKey T3 where-    fromJSONKey = FromJSONKeyTextParser (pure . T3)------------------------------------------------------------------------------------ Values----------------------------------------------------------------------------------value10, value100, value1000, value10000 :: HM.HashMap T.Text T.Text-value10 = value 10-value100 = value 100-value1000 = value 1000-value10000 = value 10000--encodedValue10 :: LBS.ByteString-encodedValue10 = encode value10--encodedValue100 :: LBS.ByteString-encodedValue100 = encode value100--encodedValue1000 :: LBS.ByteString-encodedValue1000 = encode value1000--encodedValue10000 :: LBS.ByteString-encodedValue10000 = encode value10000------------------------------------------------------------------------------------ Helpers----------------------------------------------------------------------------------decodeHM-    :: (FromJSON (HM.HashMap k T.Text), Eq k, Hashable k)-    => Proxy k -> LBS.ByteString -> Maybe (HM.HashMap k T.Text)-decodeHM _ = decode--decodeMap-    :: (FromJSON (M.Map k T.Text), Ord k)-    => Proxy k -> LBS.ByteString -> Maybe (M.Map k T.Text)-decodeMap _ = decode--proxyText :: Proxy T.Text-proxyText = Proxy--proxyT1 :: Proxy T1-proxyT1 = Proxy--proxyT2 :: Proxy T2-proxyT2 = Proxy--proxyT3 :: Proxy T3-proxyT3 = Proxy--proxyTagged :: Proxy a -> Proxy (Tagged () a)-proxyTagged _ = Proxy------------------------------------------------------------------------------------ Main----------------------------------------------------------------------------------benchDecodeHM-    :: String-    -> LBS.ByteString-    -> Benchmark-benchDecodeHM name val = bgroup name-    [  bench "Text"            $ nf (decodeHM proxyText) val-    ,  bench "Identity"        $ nf (decodeHM proxyT1)   val-    ,  bench "Coerce"          $ nf (decodeHM proxyT2)   val-    ,  bench "Parser"          $ nf (decodeHM proxyT3)   val-    ,  bench "Tagged Text"     $ nf (decodeHM $ proxyTagged proxyText) val-    ,  bench "Tagged Identity" $ nf (decodeHM $ proxyTagged proxyT1)   val-    ,  bench "Tagged Coerce"   $ nf (decodeHM $ proxyTagged proxyT2)   val-    ,  bench "Tagged Parser"   $ nf (decodeHM $ proxyTagged proxyT3)   val-    ]--benchDecodeMap-    :: String-    -> LBS.ByteString-    -> Benchmark-benchDecodeMap name val = bgroup name-    [  bench "Text"           $ nf (decodeMap proxyText) val-    ,  bench "Identity"       $ nf (decodeMap proxyT1)   val-    ,  bench "Coerce"         $ nf (decodeMap proxyT2)   val-    ,  bench "Parser"         $ nf (decodeMap proxyT3)   val-    ]--benchEncodeHM-    :: String-    -> HM.HashMap T.Text T.Text-    -> Benchmark-benchEncodeHM name val = bgroup name-    [ bench "Text"       $ nf encode val-    ]--benchEncodeMap-    :: String-    -> HM.HashMap T.Text T.Text-    -> Benchmark-benchEncodeMap name val = bgroup name-    [ bench "Text"       $ nf encode val'-    ]-  where-    val' :: M.Map T.Text T.Text-    val' = M.fromList . HM.toList $ val--main :: IO ()-main = defaultMain-    [ bgroup "decode"-        [ bgroup "HashMap"-            [ benchDecodeHM "10"    encodedValue10-            , benchDecodeHM "100"   encodedValue100-            , benchDecodeHM "1000"  encodedValue1000-            , benchDecodeHM "10000" encodedValue10000-            ]-        , bgroup "Map"-            [ benchDecodeMap "10"    encodedValue10-            , benchDecodeMap "100"   encodedValue100-            , benchDecodeMap "1000"  encodedValue1000-            , benchDecodeMap "10000" encodedValue10000-            ]-        ]-    , bgroup "encode"-        [ bgroup "HashMap"-            [ benchEncodeHM "100"   value100-            , benchEncodeHM "1000"  value1000-            , benchEncodeHM "10000" value10000-            ]-        , bgroup "Map"-            [ benchEncodeMap "100"   value100-            , benchEncodeMap "1000"  value1000-            , benchEncodeMap "10000" value10000-            ]-        ]-    ]
− benchmarks/AesonParse.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--module Main (main) where--import Prelude.Compat--import Data.Aeson-import Control.Monad-import Data.Attoparsec.ByteString (IResult(..), parseWith)-import Data.Time.Clock-import System.Environment (getArgs)-import System.IO-import qualified Data.ByteString as B--main :: IO ()-main = do-  (bs:cnt:args) <- getArgs-  let count = read cnt :: Int-      blkSize = read bs-  forM_ args $ \arg -> withFile arg ReadMode $ \h -> do-    putStrLn $ arg ++ ":"-    start <- getCurrentTime-    let loop !good !bad-            | good+bad >= count = return (good, bad)-            | otherwise = do-          hSeek h AbsoluteSeek 0-          let refill = B.hGet h blkSize-          result <- parseWith refill json =<< refill-          case result of-            Done _ _ -> loop (good+1) bad-            _        -> loop good (bad+1)-    (good, _) <- loop 0 0-    delta <- flip diffUTCTime start `fmap` getCurrentTime-    putStrLn $ "  " ++ show good ++ " good, " ++ show delta-    let rate = fromIntegral count / realToFrac delta :: Double-    putStrLn $ "  " ++ show (round rate :: Int) ++ " per second"
− benchmarks/AesonTuples.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Main (main) where--import Prelude.Compat--import Control.DeepSeq (deepseq)-import Criterion.Main-import Data.Aeson------------------------------------------------------------------------------------type FJ a = Value -> Result a--type T2 = (Int, Int)-type T3 = (Int, Int, Int)-type T4 = (Int, Int, Int, Int)--t2 :: T2-t2 = (1, 2)--t3 :: T3-t3 = (1, 2, 3)--t4 :: T4-t4 = (1, 2, 3, 4)--main :: IO ()-main = let v2 = toJSON t2-           v3 = toJSON t3-           v4 = toJSON t4-       in t2 `deepseq` t3 `deepseq` t4 `deepseq`-          v2 `deepseq` v3 `deepseq` v4 `deepseq`-            defaultMain-              [ bgroup "t2"-                [ bench "toJSON"   (nf toJSON t2)-                , bench "fromJSON" (nf (fromJSON :: FJ T2) v2)-                ]-              , bgroup "t3"-                [ bench "toJSON"   (nf toJSON t3)-                , bench "fromJSON" (nf (fromJSON :: FJ T3) v3)-                ]-              , bgroup "t4"-                [ bench "toJSON"   (nf toJSON t4)-                , bench "fromJSON" (nf (fromJSON :: FJ T4) v4)-                ]-              ]
− benchmarks/AutoCompare.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Main (main) where--import Control.DeepSeq-import Control.Monad-import Criterion.Main-import Data.Aeson--import qualified Auto.T.D as T-import qualified Auto.T.BigRecord as T-import qualified Auto.T.BigProduct as T-import qualified Auto.T.BigSum as T-import qualified Auto.G.D as G-import qualified Auto.G.BigRecord as G-import qualified Auto.G.BigProduct as G-import qualified Auto.G.BigSum as G------------------------------------------------------------------------------------runBench :: IO ()-runBench = defaultMain-  [ compareBench "D" T.d G.d-  , compareBench "BigRecord" T.bigRecord G.bigRecord-  , compareBench "BigProduct" T.bigProduct G.bigProduct-  , compareBench "BigSum" T.bigSum G.bigSum-  ]--group :: String -> Benchmarkable -> Benchmarkable -> Benchmark-group n th gen = bgroup n [ bench "th"      th-                          , bench "generic" gen-                          ]--compareBench-  :: forall a b-  .  (ToJSON a, FromJSON a, NFData a, ToJSON b, FromJSON b, NFData b)-  => String -> a -> b -> Benchmark-compareBench name a b = v `deepseq` bgroup name-  [ group "toJSON"   (nf toJSON a)-                     (nf toJSON b)-  , group "encode"   (nf encode a)-                     (nf encode b)-  , group "fromJSON" (nf (fromJSON :: Value -> Result a) v)-                     (nf (fromJSON :: Value -> Result b) v)-  ] where-    v = toJSON a  -- == toJSON b--sanityCheck :: IO ()-sanityCheck = do-  check T.d-  check G.d-  check T.bigRecord-  check G.bigRecord-  check T.bigProduct-  check G.bigProduct-  check T.bigSum-  check G.bigSum--check :: (Show a, Eq a, FromJSON a, ToJSON a)-      => a -> IO ()-check x = do-  unless (Success x == (fromJSON . toJSON) x) $ fail $ "toJSON: " ++ show x-  unless (Success x == (decode_ . encode) x) $ fail $ "encode: " ++ show x-  where-    decode_ s = case decode s of-      Just v -> fromJSON v-      Nothing -> fail ""--main :: IO ()-main = do-  sanityCheck-  runBench
− benchmarks/Compare.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Main (main) where--import Prelude.Compat--import Compare.BufferBuilder ()-import Criterion.Main-import Data.BufferBuilder.Json-import Twitter-import Twitter.Manual ()-import Typed.Common-import qualified Data.Aeson as Aeson-import qualified Compare.JsonBench as JsonBench--#ifdef MIN_VERSION_json_builder-import Data.Json.Builder-import Compare.JsonBuilder ()-#endif--main :: IO ()-main =-  defaultMain [-     env (load "json-data/twitter100.json") $ \ ~(twtr :: Result) ->-     bgroup "twitter" [-         bench "aeson" $ nf Aeson.encode twtr-       , bench "buffer-builder" $ nf encodeJson twtr-#ifdef MIN_VERSION_json_builder-       , bench "json-builder" $ nf toJsonLBS twtr-#endif-       ]-   , JsonBench.benchmarks-   ]
− benchmarks/Compare/BufferBuilder.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Compare.BufferBuilder () where--import Prelude.Compat hiding ((<>))--import Data.BufferBuilder.Json-import Data.Int (Int64)-import Data.Monoid ((<>))-import Twitter-import qualified Data.BufferBuilder.Utf8 as UB--instance (ToJson a, ToJson b) => ToJson (a,b) where-  toJson (a,b) = array [toJson a, toJson b]--instance ToJson Int64 where-    toJson a = unsafeValueUtf8Builder $-               UB.appendDecimalSignedInt (fromIntegral a)-    {-# INLINE toJson #-}--instance ToJson Metadata where-  toJson Metadata{..} = toJson $-    "result_type" .= result_type--instance ToJson Geo where-  toJson Geo{..} = toJson $-       "type_"       .= type_-    <> "coordinates" .= coordinates--instance ToJson Story where-  toJson Story{..} = toJson $-       "from_user_id_str"  .= from_user_id_str-    <> "profile_image_url" .= profile_image_url-    <> "created_at"        .= created_at-    <> "from_user"         .= from_user-    <> "id_str"            .= id_str-    <> "metadata"          .= metadata-    <> "to_user_id"        .= to_user_id-    <> "text"              .= text-    <> "id"                .= id_-    <> "from_user_id"      .= from_user_id-    <> "geo"               .= geo-    <> "iso_language_code" .= iso_language_code-    <> "to_user_id_str"    .= to_user_id_str-    <> "source"            .= source--instance ToJson Result where-  toJson Result{..} = toJson $-       "results" .= results-    <> "max_id" .= max_id-    <> "since_id" .= since_id-    <> "refresh_url" .= refresh_url-    <> "next_page" .= next_page-    <> "results_per_page" .= results_per_page-    <> "page" .= page-    <> "completed_in" .= completed_in-    <> "since_id_str" .= since_id_str-    <> "max_id_str" .= max_id_str-    <> "query" .= query
− benchmarks/Compare/JsonBench.hs 
@@ -1,339 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}---- Adapted from a buffer-builder benchmark:------ https://github.com/chadaustin/buffer-builder/blob/master/test.json--module Compare.JsonBench (benchmarks) where--import Prelude.Compat hiding ((<>))--import Control.DeepSeq (NFData(..))-import Criterion-import Data.Aeson ((.:))-import Data.Monoid ((<>))-import Data.Text (Text)-import Typed.Common (load)-import qualified Control.Monad.Fail as Fail-import qualified Data.Aeson as Aeson-import qualified Data.BufferBuilder.Json as Json--#ifdef MIN_VERSION_json_builder-import qualified Data.Json.Builder as JB-#endif--data EyeColor = Green | Blue | Brown-    deriving (Eq, Show)-data Gender = Male | Female-    deriving (Eq, Show)-data Fruit = Apple | Strawberry | Banana-    deriving (Eq, Show)-data Friend = Friend-    { fId :: !Int-    , fName :: !Text-    } deriving (Eq, Show)--data User = User-    { uId       :: !Text-    , uIndex    :: !Int-    , uGuid     :: !Text-    , uIsActive :: !Bool-    , uBalance  :: !Text-    , uPicture  :: !Text-    , uAge      :: !Int-    , uEyeColor :: !EyeColor-    , uName     :: !Text-    , uGender   :: !Gender-    , uCompany  :: !Text-    , uEmail    :: !Text-    , uPhone    :: !Text-    , uAddress  :: !Text-    , uAbout    :: !Text-    , uRegistered   :: !Text -- UTCTime?-    , uLatitude :: !Double-    , uLongitude    :: !Double-    , uTags :: ![Text]-    , uFriends  :: ![Friend]-    , uGreeting :: !Text-    , uFavouriteFruit   :: !Fruit-    } deriving (Eq, Show)--instance NFData EyeColor where rnf !_ = ()-instance NFData Gender where rnf !_ = ()-instance NFData Fruit where rnf !_ = ()--instance NFData Friend where-    rnf Friend {..} = rnf fId `seq` rnf fName--instance NFData User where-    rnf User {..} = rnf uId `seq` rnf uIndex `seq` rnf uGuid `seq` rnf uIsActive `seq` rnf uBalance `seq` rnf uPicture `seq` rnf uAge `seq` rnf uEyeColor `seq` rnf uName `seq` rnf uGender `seq` rnf uCompany `seq` rnf uEmail `seq` rnf uPhone `seq` rnf uAddress `seq` rnf uAbout `seq` rnf uRegistered `seq` rnf uLatitude `seq` rnf uLongitude `seq` rnf uTags `seq` rnf uFriends `seq` rnf uGreeting `seq` rnf uFavouriteFruit--eyeColorTable :: [(Text, EyeColor)]-eyeColorTable = [("brown", Brown), ("green", Green), ("blue", Blue)]--genderTable :: [(Text, Gender)]-genderTable = [("male", Male), ("female", Female)]--fruitTable :: [(Text, Fruit)]-fruitTable = [("apple", Apple), ("strawberry", Strawberry), ("banana", Banana)]--enumFromJson :: Fail.MonadFail m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum-enumFromJson enumName table extract v = do-    s <- extract v-    case lookup s table of-        Just r -> return r-        Nothing -> fail $ "Bad " ++ enumName ++ ": " ++ show s----- Aeson instances -----instance Aeson.FromJSON EyeColor where-    parseJSON = enumFromJson "EyeColor" eyeColorTable Aeson.parseJSON--instance Aeson.FromJSON Gender where-    parseJSON = enumFromJson "Gender" genderTable Aeson.parseJSON--instance Aeson.FromJSON Fruit where-    parseJSON = enumFromJson "Fruit" fruitTable Aeson.parseJSON--instance Aeson.FromJSON Friend where-    parseJSON = Aeson.withObject "Friend" $ \o -> do-        fId <- o .: "id"-        fName <- o .: "name"-        return Friend {..}--instance Aeson.FromJSON User where-    parseJSON = Aeson.withObject "User" $ \o -> do-        uId <- o .: "_id"-        uIndex <- o .: "index"-        uGuid <- o .: "guid"-        uIsActive <- o .: "isActive"-        uBalance <- o .: "balance"-        uPicture <- o .: "picture"-        uAge <- o .: "age"-        uEyeColor <- o .: "eyeColor"-        uName <- o .: "name"-        uGender <- o .: "gender"-        uCompany <- o .: "company"-        uEmail <- o .: "email"-        uPhone <- o .: "phone"-        uAddress <- o .: "address"-        uAbout <- o .: "about"-        uRegistered <- o .: "registered"-        uLatitude <- o .: "latitude"-        uLongitude <- o .: "longitude"-        uTags <- o .: "tags"-        uFriends <- o .: "friends"-        uGreeting <- o .: "greeting"-        uFavouriteFruit <- o .: "favoriteFruit"-        return User {..}--instance Aeson.ToJSON EyeColor where-    toJSON ec = Aeson.toJSON $ case ec of-        Green -> "green" :: Text-        Blue -> "blue"-        Brown -> "brown"--    toEncoding ec = Aeson.toEncoding $ case ec of-        Green -> "green" :: Text-        Blue -> "blue"-        Brown -> "brown"--instance Aeson.ToJSON Gender where-    toJSON g = Aeson.toJSON $ case g of-        Male -> "male" :: Text-        Female -> "female"--    toEncoding g = Aeson.toEncoding $ case g of-        Male -> "male" :: Text-        Female -> "female"--instance Aeson.ToJSON Fruit where-    toJSON f = Aeson.toJSON $ case f of-        Apple -> "apple" :: Text-        Banana -> "banana"-        Strawberry -> "strawberry"--    toEncoding f = Aeson.toEncoding $ case f of-        Apple -> "apple" :: Text-        Banana -> "banana"-        Strawberry -> "strawberry"--instance Aeson.ToJSON Friend where-    toJSON Friend {..} = Aeson.object-        [ "id" Aeson..= fId-        , "name" Aeson..= fName-        ]--    toEncoding Friend {..} = Aeson.pairs $-           "id" Aeson..= fId-        <> "name" Aeson..= fName--instance Aeson.ToJSON User where-    toJSON User{..} = Aeson.object-        [ "_id" Aeson..= uId-        , "index" Aeson..= uIndex-        , "guid" Aeson..= uGuid-        , "isActive" Aeson..= uIsActive-        , "balance" Aeson..= uBalance-        , "picture" Aeson..= uPicture-        , "age" Aeson..= uAge-        , "eyeColor" Aeson..= uEyeColor-        , "name" Aeson..= uName-        , "gender" Aeson..= uGender-        , "company" Aeson..= uCompany-        , "email" Aeson..= uEmail-        , "phone" Aeson..= uPhone-        , "address" Aeson..= uAddress-        , "about" Aeson..= uAbout-        , "registered" Aeson..= uRegistered-        , "latitude" Aeson..= uLatitude-        , "longitude" Aeson..= uLongitude-        , "tags" Aeson..= uTags-        , "friends" Aeson..= uFriends-        , "greeting" Aeson..= uGreeting-        , "favoriteFruit" Aeson..= uFavouriteFruit-        ]--    toEncoding User{..} = Aeson.pairs $-          "_id" Aeson..= uId-        <> "index" Aeson..= uIndex-        <> "guid" Aeson..= uGuid-        <> "isActive" Aeson..= uIsActive-        <> "balance" Aeson..= uBalance-        <> "picture" Aeson..= uPicture-        <> "age" Aeson..= uAge-        <> "eyeColor" Aeson..= uEyeColor-        <> "name" Aeson..= uName-        <> "gender" Aeson..= uGender-        <> "company" Aeson..= uCompany-        <> "email" Aeson..= uEmail-        <> "phone" Aeson..= uPhone-        <> "address" Aeson..= uAddress-        <> "about" Aeson..= uAbout-        <> "registered" Aeson..= uRegistered-        <> "latitude" Aeson..= uLatitude-        <> "longitude" Aeson..= uLongitude-        <> "tags" Aeson..= uTags-        <> "friends" Aeson..= uFriends-        <> "greeting" Aeson..= uGreeting-        <> "favoriteFruit" Aeson..= uFavouriteFruit----- BufferBuilder instances -----instance Json.ToJson EyeColor where-    toJson ec = Json.toJson $ case ec of-        Green -> "green" :: Text-        Blue -> "blue"-        Brown -> "brown"--instance Json.ToJson Gender where-    toJson g = Json.toJson $ case g of-        Male -> "male" :: Text-        Female -> "female"--instance Json.ToJson Fruit where-    toJson f = Json.toJson $ case f of-        Apple -> "apple" :: Text-        Strawberry -> "strawberry"-        Banana -> "banana"--instance Json.ToJson Friend where-    toJson Friend{..} = Json.toJson $-            "_id" Json..= fId-            <> "name" Json..= fName--instance Json.ToJson User where-    toJson User{..} = Json.toJson $-            "_id"# Json..=# uId-            <> "index"# Json..=# uIndex-            <> "guid"# Json..=# uGuid-            <> "isActive"# Json..=# uIsActive-            <> "balance"# Json..=# uBalance-            <> "picture"# Json..=# uPicture-            <> "age"# Json..=# uAge-            <> "eyeColor"# Json..=# uEyeColor-            <> "name"# Json..=# uName-            <> "gender"# Json..=# uGender-            <> "company"# Json..=# uCompany-            <> "email"# Json..=# uEmail-            <> "phone"# Json..=# uPhone-            <> "address"# Json..=# uAddress-            <> "about"# Json..=# uAbout-            <> "registered"# Json..=# uRegistered-            <> "latitude"# Json..=# uLatitude-            <> "longitude"# Json..=# uLongitude-            <> "tags"# Json..=# uTags-            <> "friends"# Json..=# uFriends-            <> "greeting"# Json..=# uGreeting-            <> "favoriteFruit"# Json..=# uFavouriteFruit--#ifdef MIN_VERSION_json_builder----- json-builder instances ------instance JB.Value EyeColor where-    toJson ec = JB.toJson $ case ec of-        Green -> "green" :: Text-        Blue -> "blue"-        Brown -> "brown"--instance JB.Value Gender where-    toJson g = JB.toJson $ case g of-        Male -> "male" :: Text-        Female -> "female"--instance JB.Value Fruit where-    toJson f = JB.toJson $ case f of-        Apple -> "apple" :: Text-        Strawberry -> "strawberry"-        Banana -> "banana"--instance JB.Value Friend where-    toJson Friend{..} = JB.toJson $-            ("_id" :: Text) `JB.row` fId-            <> ("name" :: Text) `JB.row` fName--instance JB.Value User where-    toJson User{..} =-        let t :: Text -> Text-            t = id-        in JB.toJson $-               t "_id" `JB.row` uId-            <> t "index" `JB.row` uIndex-            <> t "guid" `JB.row` uGuid-            <> t "isActive" `JB.row` uIsActive-            <> t "balance" `JB.row` uBalance-            <> t "picture" `JB.row` uPicture-            <> t "age" `JB.row` uAge-            <> t "eyeColor" `JB.row` uEyeColor-            <> t "name" `JB.row` uName-            <> t "gender" `JB.row` uGender-            <> t "company" `JB.row` uCompany-            <> t "email" `JB.row` uEmail-            <> t "phone" `JB.row` uPhone-            <> t "address" `JB.row` uAddress-            <> t "about" `JB.row` uAbout-            <> t "registered" `JB.row` uRegistered-            <> t "latitude" `JB.row` uLatitude-            <> t "longitude" `JB.row` uLongitude-            <> t "tags" `JB.row` uTags-            <> t "friends" `JB.row` uFriends-            <> t "greeting" `JB.row` uGreeting-            <> t "favoriteFruit" `JB.row` uFavouriteFruit-#endif--benchmarks :: Benchmark-benchmarks = env (load "json-data/buffer-builder.json") $-    \ ~(parsedUserList :: [User]) ->-    bgroup "json-bench" [-      bench "aeson" $ nf Aeson.encode parsedUserList-    , bench "buffer-builder" $ nf Json.encodeJson parsedUserList-#ifdef MIN_VERSION_json_builder-    , bench "json-builder" $ nf JB.toJsonLBS parsedUserList-#endif-    ]
− benchmarks/Compare/JsonBuilder.hs 
@@ -1,68 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE RecordWildCards #-}--{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Compare.JsonBuilder () where--import Prelude.Compat hiding ((<>))--import Data.Json.Builder-import Data.Monoid ((<>))-import Twitter--instance JsObject Metadata where-    toObject Metadata{..} = row "result_type" result_type--instance Value Metadata where-    toJson = toJson . toObject--instance JsObject Geo where-    toObject Geo{..} =-       row "type_" type_ <>-       row "coordinates" coordinates--instance Value Geo where-    toJson = toJson . toObject--instance Value a => Value (Maybe a) where-    toJson (Just a) = toJson a-    toJson Nothing  = jsNull--instance JsObject Story where-  toObject Story{..} =-    row "from_user_id_str" from_user_id_str <>-    row "profile_image_url" profile_image_url <>-    row "created_at" created_at <>-    row "from_user" from_user <>-    row "id_str" id_str <>-    row "metadata" metadata <>-    row "to_user_id" to_user_id <>-    row "text" text <>-    row "id" id_ <>-    row "from_user_id" from_user_id <>-    row "geo" geo <>-    row "iso_language_code" iso_language_code <>-    row "to_user_id_str" to_user_id_str <>-    row "source" source--instance Value Story where-    toJson = toJson . toObject--instance JsObject Result where-    toObject Result{..} =-      row "results" results <>-      row "max_id" max_id <>-      row "since_id" since_id <>-      row "refresh_url" refresh_url <>-      row "next_page" next_page <>-      row "results_per_page" results_per_page <>-      row "page" page <>-      row "completed_in" completed_in <>-      row "since_id_str" since_id_str <>-      row "max_id_str" max_id_str <>-      row "query" query--instance Value Result where-    toJson = toJson . toObject
− benchmarks/CompareWithJSON.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main (main) where--import Prelude.Compat--import Blaze.ByteString.Builder (toLazyByteString)-import Blaze.ByteString.Builder.Char.Utf8 (fromString)-import Control.DeepSeq (NFData(rnf))-import Criterion.Main-import Data.Maybe (fromMaybe)-import qualified Data.Aeson as A-import qualified Data.Aeson.Text as A-import qualified Data.Aeson.Parser.Internal as I-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text.Lazy          as TL-import qualified Data.Text.Lazy.Builder  as TLB-import qualified Data.Text.Lazy.Encoding as TLE-import qualified Text.JSON as J--instance (NFData v) => NFData (J.JSObject v) where-  rnf o = rnf (J.fromJSObject o)--instance NFData J.JSValue where-  rnf J.JSNull = ()-  rnf (J.JSBool b) = rnf b-  rnf (J.JSRational a b) = rnf a `seq` rnf b-  rnf (J.JSString s) = rnf (J.fromJSString s)-  rnf (J.JSArray lst) = rnf lst-  rnf (J.JSObject o) = rnf o--decodeJ :: String -> J.JSValue-decodeJ s =-  case J.decodeStrict s of-    J.Ok v -> v-    J.Error _ -> error "fail to parse via JSON"--decode :: BL.ByteString -> A.Value-decode s = fromMaybe (error "fail to parse via Aeson") $ A.decode s--decode' :: BL.ByteString -> A.Value-decode' s = fromMaybe (error "fail to parse via Aeson") $ A.decode' s--decodeS :: BS.ByteString -> A.Value-decodeS s = fromMaybe (error "fail to parse via Aeson") $ A.decodeStrict' s--decodeIP :: BL.ByteString -> A.Value-decodeIP s = fromMaybe (error "fail to parse via Parser.decodeWith") $-    I.decodeWith I.jsonEOF A.fromJSON s--encodeJ :: J.JSValue -> BL.ByteString-encodeJ = toLazyByteString . fromString . J.encode--encodeToText :: A.Value -> TL.Text-encodeToText = TLB.toLazyText . A.encodeToTextBuilder . A.toJSON--encodeViaText :: A.Value -> BL.ByteString-encodeViaText = TLE.encodeUtf8 . encodeToText--main :: IO ()-main = do-  let enFile = "json-data/twitter100.json"-      jpFile = "json-data/jp100.json"-  enA <- BL.readFile enFile-  enS <- BS.readFile enFile-  enJ <- readFile enFile-  jpA <- BL.readFile jpFile-  jpS <- BS.readFile jpFile-  jpJ <- readFile jpFile-  defaultMain [-      bgroup "decode" [-        bgroup "en" [-          bench "aeson/lazy"     $ nf decode enA-        , bench "aeson/strict"   $ nf decode' enA-        , bench "aeson/stricter" $ nf decodeS enS-        , bench "aeson/parser"   $ nf decodeIP enA-        , bench "json"           $ nf decodeJ enJ-        ]-      , bgroup "jp" [-          bench "aeson"          $ nf decode jpA-        , bench "aeson/stricter" $ nf decodeS jpS-        , bench "json"           $ nf decodeJ jpJ-        ]-      ]-    , bgroup "encode" [-        bgroup "en" [-          bench "aeson-to-bytestring" $ nf A.encode (decode enA)-        , bench "aeson-via-text-to-bytestring" $ nf encodeViaText (decode enA)-        , bench "aeson-to-text" $ nf encodeToText (decode enA)-        , bench "json"  $ nf encodeJ (decodeJ enJ)-        ]-      , bgroup "jp" [-          bench "aeson-to-bytestring" $ nf A.encode (decode jpA)-        , bench "aeson-via-text-to-bytestring" $ nf encodeViaText (decode jpA)-        , bench "aeson-to-text" $ nf encodeToText (decode jpA)-        , bench "json"  $ nf encodeJ (decodeJ jpJ)-        ]-      ]-    ]
− benchmarks/Dates.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Main (main) where--import Prelude.Compat--import Criterion.Main-import Data.Aeson (decode, encode)-import Data.Time.Clock (UTCTime)-import Data.Time.LocalTime (ZonedTime)-import qualified Data.ByteString.Lazy as BL--utcTime :: BL.ByteString -> Maybe [UTCTime]-utcTime = decode--zTime :: BL.ByteString -> Maybe [ZonedTime]-zTime = decode--main :: IO ()-main = do-  let file1 = BL.readFile "json-data/dates.json"-  let file2 = BL.readFile "json-data/dates-fract.json"-  defaultMain [-      bgroup "decode" [-        bgroup "UTCTime" [-          env file1 $ \bs -> bench "whole" $ nf utcTime bs-        , env file2 $ \bs -> bench "fractional" $ nf utcTime bs-        ]-      , bgroup "ZonedTime" [-          env file1 $ \bs -> bench "whole" $ nf zTime bs-        , env file2 $ \bs -> bench "fractional" $ nf zTime bs-        ]-      ]-    , bgroup "encode" [-        bgroup "UTCTime" [-          env (utcTime <$> file1) $ \ts -> bench "whole" $ nf encode ts-        , env (utcTime <$> file2) $ \ts -> bench "fractional" $ nf encode ts-        ]-      , bgroup "ZonedTime" [-          env (zTime <$> file1) $ \ts -> bench "whole" $ nf encode ts-        , env (zTime <$> file2) $ \ts -> bench "fractional" $ nf encode ts-        ]-      ]-    ]
− benchmarks/Escape.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -fno-warn-name-shadowing #-}--module Main (main) where--import Prelude.Compat--import Criterion.Main-import qualified Data.Aeson.Parser.UnescapeFFI as FFI-import qualified Data.Aeson.Parser.UnescapePure as Pure--import qualified Data.ByteString.Char8 as BS-import System.Environment (getArgs, withArgs)--main :: IO ()-main = do-  args_ <- getArgs-  let (args, p, n) =-        case args_ of-          "--pattern" : p : args_ -> k p args_-          _ -> k "\\\"" args_-      k p args_ =-        case args_ of-          "--repeat" : n : args_ -> (args_, p, read n)-          args_ -> (args_, p, 10000)-      input = BS.concat $ replicate n $ BS.pack p-  withArgs args $ defaultMain-    [ bench "ffi"  $ whnf FFI.unescapeText input-    , bench "pure" $ whnf Pure.unescapeText input-    ]
− benchmarks/Issue673.hs 
@@ -1,165 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--module Main (-    main,-    input17,-    input32,-    input64,-    input128,-    input256,-    input2048,-    input4096,-    input8192,-    input16384,-  ) where--import Criterion.Main-import Prelude.Compat-import Data.Int (Int64)-import Data.Scientific (Scientific)-import Data.Semigroup ((<>))-import Data.Aeson.Parser (scientific)--import qualified Data.Attoparsec.ByteString.Lazy as AttoL-import qualified Data.Attoparsec.ByteString.Char8 as Atto8-import qualified Data.Aeson as A-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Lazy.Char8 as LBS8--decodeInt :: LBS.ByteString -> Maybe Int-decodeInt = A.decode--decodeString :: LBS.ByteString -> Maybe String-decodeString = A.decode--decodeScientific :: LBS.ByteString -> Maybe Scientific-decodeScientific = A.decode--decodeViaRead :: LBS.ByteString -> Integer-decodeViaRead = read . LBS8.unpack--decodeAtto :: LBS.ByteString -> Maybe Scientific-decodeAtto-    = parseOnly (scientific <* AttoL.endOfInput)-  where-    parseOnly p lbs = case AttoL.parse p lbs of-        AttoL.Done _ r -> Just r-        AttoL.Fail {}  -> Nothing--decodeAtto8 :: LBS.ByteString -> Maybe Scientific-decodeAtto8-    = parseOnly (Atto8.scientific <* AttoL.endOfInput)-  where-    parseOnly p lbs = case AttoL.parse p lbs of-        AttoL.Done _ r -> Just r-        AttoL.Fail {}  -> Nothing--generate :: Int64 -> LBS.ByteString-generate n = LBS8.replicate n '1'--input17 :: LBS.ByteString-input17 = generate 17--input32 :: LBS.ByteString-input32 = generate 32--input64 :: LBS.ByteString-input64 = generate 64--input128 :: LBS.ByteString-input128 = generate 128--input256 :: LBS.ByteString-input256 = generate 256--input2048 :: LBS.ByteString-input2048 = generate 2048--input4096 :: LBS.ByteString-input4096 = generate 4096--input8192 :: LBS.ByteString-input8192 = generate 8192--input16384 :: LBS.ByteString-input16384 = generate 16384---main :: IO ()-main =  defaultMain-    -- works on 64bit-    [ benchPair "17" input17-    -- , benchPair "32" input32-    -- , benchPair "64" input64-    -- , benchPair "128" input128-    -- , benchPair "256" input256-    , benchPair "2048" input2048-    , benchPair "4096" input4096-    , benchPair "8192" input8192-    , benchPair "16384" input16384-    ]-  where-    benchPair name input = bgroup name-        [ bench "Int"        $ whnf decodeInt input-        , bench "Simple"     $ whnf bsToIntegerSimple (LBS.toStrict input)-        , bench "Optim"      $ whnf bsToInteger (LBS.toStrict input)-        , bench "Read"       $ whnf decodeViaRead input-        , bench "Scientific" $ whnf decodeScientific input-        , bench "parserA"    $ whnf decodeAtto  input-        , bench "parserS"    $ whnf decodeAtto8  input-        , bench "String"     $ whnf decodeString $ "\"" <> input <> "\""-        ]------------------------------------------------------------------------------------ better fromInteger----------------------------------------------------------------------------------bsToInteger :: BS.ByteString -> Integer-bsToInteger bs-    | l > 40    = valInteger 10 l [ fromIntegral (w - 48) | w <- BS.unpack bs ]-    | otherwise = bsToIntegerSimple bs-  where-    l = BS.length bs--bsToIntegerSimple :: BS.ByteString -> Integer-bsToIntegerSimple = BS.foldl' step 0 where-  step a b = a * 10 + fromIntegral (b - 48) -- 48 = '0'---- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b--- digits are combined into a single radix b^2 digit. This process is--- repeated until we are left with a single digit. This algorithm--- performs well only on large inputs, so we use the simple algorithm--- for smaller inputs.-valInteger :: Integer -> Int -> [Integer] -> Integer-valInteger = go-  where-    go :: Integer -> Int -> [Integer] -> Integer-    go _ _ []  = 0-    go _ _ [d] = d-    go b l ds-        | l > 40 = b' `seq` go b' l' (combine b ds')-        | otherwise = valSimple b ds-      where-        -- ensure that we have an even number of digits-        -- before we call combine:-        ds' = if even l then ds else 0 : ds-        b' = b * b-        l' = (l + 1) `quot` 2--    combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)-      where-        d = d1 * b + d2-    combine _ []  = []-    combine _ [_] = errorWithoutStackTrace "this should not happen"---- The following algorithm is only linear for types whose Num operations--- are in constant time.-valSimple :: Integer -> [Integer] -> Integer-valSimple base = go 0-  where-    go r [] = r-    go r (d : ds) = r' `seq` go r' ds-      where-        r' = r * base + fromIntegral d
− benchmarks/JsonParse.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main (main) where--import Prelude.Compat--import Control.DeepSeq-import Control.Monad-import Data.Time.Clock-import System.Environment (getArgs)-import Text.JSON--instance NFData JSValue where-    rnf JSNull = ()-    rnf (JSBool b) = rnf b-    rnf (JSRational b r) = rnf b `seq` rnf r-    rnf (JSString s) = rnf (fromJSString s)-    rnf (JSArray vs) = rnf vs-    rnf (JSObject kvs) = rnf (fromJSObject kvs)--main :: IO ()-main = do-  (cnt:args) <- getArgs-  let count = read cnt :: Int-  forM_ args $ \arg -> do-    putStrLn $ arg ++ ":"-    start <- getCurrentTime-    let loop !good !bad-            | good+bad >= count = return (good, bad)-            | otherwise = do-          s <- readFile arg-          case decodeStrict s of-            Ok (_::JSValue) -> loop (good+1) 0-            _ -> loop 0 (bad+1)-    (good, _) <- loop 0 0-    end <- getCurrentTime-    putStrLn $ "  " ++ show good ++ " good, " ++ show (diffUTCTime end start)
− benchmarks/Makefile 
@@ -1,15 +0,0 @@-ghc := ghc-ghcflags := -O--binaries := AesonParse AesonEncode JsonParse AesonCompareAutoInstances--all: $(binaries) $(binaries:%=%_p)--%_p: %.hs-	$(ghc) $(ghcflags) -prof -auto-all -rtsopts --make -o $@ $^--%: %.hs-	$(ghc) $(ghcflags) --make -rtsopts -o $@ $^--clean:-	-rm -f *.o *.hi $(binaries) $(binaries:%=%_p)
− benchmarks/Micro.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Main (main) where--import Prelude.Compat--import Criterion.Main---- Encoding is a newtype wrapper around Builder-import Data.Aeson.Encoding (text, string, encodingToLazyByteString)-import qualified Data.Text as T--main :: IO ()-main = do-  let txt = "append (append b (primBounded w1 x1)) (primBounded w2 x2)"-  defaultMain [-    bgroup "string" [-      bench "text" $ nf (encodingToLazyByteString . text) (T.pack txt)-    , bench "string direct" $ nf (encodingToLazyByteString . string) txt-    , bench "string via text" $ nf (encodingToLazyByteString . text . T.pack) txt-    ]-   ]
− benchmarks/Options.hs 
@@ -1,8 +0,0 @@-module Options (opts) where--import Data.Aeson.Types--opts :: Options-opts = defaultOptions-       { sumEncoding = ObjectWithSingleField-       }
− benchmarks/ReadFile.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}--module Main (main) where--import Prelude.Compat--import Control.DeepSeq-import Control.Exception-import Control.Monad-import Data.Aeson-import Data.Aeson.Parser-import Data.Attoparsec-import Data.Time.Clock-import System.Environment (getArgs)-import System.IO-import qualified Data.ByteString as B--main = do-  (cnt:args) <- getArgs-  let count = read cnt :: Int-  forM_ args $ \arg -> withFile arg ReadMode $ \h -> do-    putStrLn $ arg ++ ":"-    start <- getCurrentTime-    let loop !n-            | n >= count = return ()-            | otherwise = do-          let go = do-                s <- B.hGet h 16384-                if B.null s-                  then loop (n+1)-                  else go-          go-    loop 0-    end <- getCurrentTime-    putStrLn $ "  " ++ show (diffUTCTime end start)
− benchmarks/Suite.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE NoImplicitPrelude   #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Main (main) where--import           Data.Aeson-import           Prelude.Compat--import           Control.DeepSeq      (NFData)-import           Criterion.Main       (Benchmark, bench, bgroup, defaultMain,-                                       env, nf)-import           Data.Maybe           (fromMaybe)-import           Data.Proxy           (Proxy (..))-import           Data.Vector          (Vector)-import           System.Environment   (lookupEnv)-import           System.FilePath      ((</>))--import qualified Data.ByteString      as BS-import qualified Data.ByteString.Lazy as LBS--import qualified Twitter-import qualified Twitter.Manual       ()--import qualified GitHub------------------------------------------------------------------------------------ Decode bench----------------------------------------------------------------------------------decodeBench-  :: forall a. (FromJSON a, NFData a)-  => String    -- ^ name-  -> FilePath  -- ^ input file-  -> Proxy a   -- ^ what type-  -> Benchmark-decodeBench name fp _ = bgroup name-    [ env (readL fp) $ \contents -> bench "lazy"   $ nf decL contents-    , env (readS fp) $ \contents -> bench "strict" $ nf decS contents-    ]-  where-    decL :: LBS.ByteString -> Maybe a-    decL = decode--    decS :: BS.ByteString -> Maybe a-    decS = decodeStrict------------------------------------------------------------------------------------ Helpers----------------------------------------------------------------------------------readS :: FilePath -> IO BS.ByteString-readS fp = do-    dataDir <- lookupEnv "AESON_BENCH_DATADIR"-    BS.readFile $ maybe id (</>) dataDir fp--readL :: FilePath -> IO LBS.ByteString-readL fp = do-    dataDir <- lookupEnv "AESON_BENCH_DATADIR"-    LBS.readFile $ fromMaybe "json-data" dataDir </> fp------------------------------------------------------------------------------------ Main----------------------------------------------------------------------------------main :: IO ()-main = defaultMain-  [ bgroup "Examples"-    [ bgroup "decode"-      [ decodeBench "twitter100"    "twitter100.json"    (Proxy :: Proxy Twitter.Result)-      , decodeBench "jp100"         "jp100.json"         (Proxy :: Proxy Twitter.Result)-      , decodeBench "github-issues" "github-issues.json" (Proxy :: Proxy (Vector GitHub.Issue))-      ]-    ]-  ]
− benchmarks/Typed.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Main (main) where--import Prelude.Compat--import Criterion.Main-import qualified Typed.Generic as Generic-import qualified Typed.Manual as Manual-import qualified Typed.TH as TH--main :: IO ()-main = defaultMain [-    Generic.benchmarks-  , Manual.benchmarks-  , TH.benchmarks-  , Generic.decodeBenchmarks-  , Manual.decodeBenchmarks-  , TH.decodeBenchmarks-  ]
− benchmarks/Typed/Common.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--{-# OPTIONS_GHC -fno-warn-unused-imports #-}--module Typed.Common (load) where--import Prelude.Compat--import Data.ByteString.Lazy as L-import System.Exit-import System.IO--import Data.Aeson hiding (Result)--load :: FromJSON a => FilePath -> IO a-load fileName = do-  mv <- eitherDecode' <$> L.readFile fileName-  case mv of-    Right v -> return v-    Left err -> do-      hPutStrLn stderr $ fileName ++ ": JSON decode failed - " ++ err-      exitWith (ExitFailure 1)
− benchmarks/Typed/Generic.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Typed.Generic (benchmarks, decodeBenchmarks) where--import Prelude.Compat--import Data.Aeson hiding (Result)-import Criterion-import Data.ByteString.Lazy as L-import Twitter.Generic-import Typed.Common--encodeDirect :: Result -> L.ByteString-encodeDirect = encode--encodeViaValue :: Result -> L.ByteString-encodeViaValue = encode . toJSON--benchmarks :: Benchmark-benchmarks =-  env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) ->-  bgroup "encodeGeneric" [-      bgroup "direct" [-        bench "twitter100" $ nf encodeDirect twitter100-      , bench "jp100"      $ nf encodeDirect jp100-      ]-    , bgroup "viaValue" [-        bench "twitter100" $ nf encodeViaValue twitter100-      , bench "jp100"      $ nf encodeViaValue jp100-      ]-    ]--decodeDirect :: L.ByteString -> Maybe Result-decodeDirect = decode--decodeBenchmarks :: Benchmark-decodeBenchmarks =-  env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) ->-  bgroup "decodeGeneric"-    [ bgroup "direct"-      [ bench "twitter100" $ nf decodeDirect twitter100-      , bench "jp100"      $ nf decodeDirect jp100-      ]-    ]
− benchmarks/Typed/Manual.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Typed.Manual (benchmarks, decodeBenchmarks) where--import Prelude.Compat--import Data.Aeson hiding (Result)-import Criterion-import Data.ByteString.Lazy as L-import Twitter.Manual-import Typed.Common--encodeDirect :: Result -> L.ByteString-encodeDirect = encode--encodeViaValue :: Result -> L.ByteString-encodeViaValue = encode . toJSON--benchmarks :: Benchmark-benchmarks =-  env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) ->-  bgroup "encodeManual" [-      bgroup "direct" [-        bench "twitter100" $ nf encodeDirect twitter100-      , bench "jp100"      $ nf encodeDirect jp100-      ]-    , bgroup "viaValue" [-        bench "twitter100" $ nf encodeViaValue twitter100-      , bench "jp100"      $ nf encodeViaValue jp100-      ]-    ]--decodeDirect :: L.ByteString -> Maybe Result-decodeDirect = decode--decodeBenchmarks :: Benchmark-decodeBenchmarks =-  env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) ->-  bgroup "decodeManual"-    [ bgroup "direct"-      [ bench "twitter100" $ nf decodeDirect twitter100-      , bench "jp100"      $ nf decodeDirect jp100-      ]-    ]
− benchmarks/Typed/TH.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Typed.TH (benchmarks, decodeBenchmarks) where--import Prelude.Compat--import Data.Aeson hiding (Result)-import Criterion-import Data.ByteString.Lazy as L-import Twitter.TH-import Typed.Common--encodeDirect :: Result -> L.ByteString-encodeDirect = encode--encodeViaValue :: Result -> L.ByteString-encodeViaValue = encode . toJSON--benchmarks :: Benchmark-benchmarks =-  env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) ->-  bgroup "encodeTH" [-      bgroup "direct" [-        bench "twitter100" $ nf encodeDirect twitter100-      , bench "jp100"      $ nf encodeDirect jp100-      ]-    , bgroup "viaValue" [-        bench "twitter100" $ nf encodeViaValue twitter100-      , bench "jp100"      $ nf encodeViaValue jp100-      ]-    ]--decodeDirect :: L.ByteString -> Maybe Result-decodeDirect = decode--decodeBenchmarks :: Benchmark-decodeBenchmarks =-  env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) ->-  bgroup "decodeTH"-    [ bgroup "direct"-      [ bench "twitter100" $ nf decodeDirect twitter100-      , bench "jp100"      $ nf decodeDirect jp100-      ]-    ]
− benchmarks/aeson-benchmarks.cabal 
@@ -1,345 +0,0 @@-cabal-version: >=1.10-name:          aeson-benchmarks-version:       0-build-type:    Simple--library-  default-language: Haskell2010-  hs-source-dirs:   .. ../ffi ../pure ../attoparsec-iso8601-  c-sources:        ../cbits/unescape_string.c-  build-depends:-      attoparsec-    , data-fix-    , base-    , base-compat-batteries-    , bytestring             >=0.10.4-    , containers-    , deepseq-    , dlist-    , ghc-prim-    , hashable-    , mtl-    , primitive-    , scientific-    , syb-    , strict-    , tagged-    , template-haskell-    , text-    , th-abstraction-    , these-    , time-    , time-compat-    , transformers-    , unordered-containers-    , uuid-types-    , vector--  if !impl(ghc >=8.6)-    build-depends: contravariant--  if !impl(ghc >=8.0)-    -- `Data.Semigroup` is available in base only since GHC 8.0 / base 4.9-    build-depends:-        fail-      , semigroups-      , transformers-compat--  if !impl(ghc >=7.10)-    -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8-    build-depends:-        nats-      , void--  include-dirs:     ../include-  ghc-options:      -O2 -Wall-  cpp-options:      -DGENERICS-  exposed-modules:-    Data.Aeson-    Data.Aeson.Encoding-    Data.Aeson.Encoding.Builder-    Data.Aeson.Encoding.Internal-    Data.Aeson.Internal-    Data.Aeson.Internal.Functions-    Data.Aeson.Internal.Time-    Data.Aeson.Parser-    Data.Aeson.Parser.Internal-    Data.Aeson.Parser.Time-    Data.Aeson.Parser.Unescape-    Data.Aeson.Parser.UnescapeFFI-    Data.Aeson.Parser.UnescapePure-    Data.Aeson.Text-    Data.Aeson.TH-    Data.Aeson.Types-    Data.Aeson.Types.Class-    Data.Aeson.Types.FromJSON-    Data.Aeson.Types.Generic-    Data.Aeson.Types.Internal-    Data.Aeson.Types.ToJSON-    Data.Attoparsec.Time-    Data.Attoparsec.Time.Internal---- Idea is to fold as many benchmarks into this as possible.-executable aeson-benchmark-suite-  default-language: Haskell2010-  main-is:          Suite.hs-  hs-source-dirs:   . ../examples/src-  ghc-options:      -Wall -O2 -rtsopts-  build-depends:-      aeson-benchmarks-    , base-    , base-compat-batteries-    , bytestring-    , criterion-    , deepseq-    , filepath-    , template-haskell-    , text-    , time-    , vector--  other-modules:-    GitHub-    Twitter-    Twitter.Manual---- Benchmarks below are haven't been worked out yet--executable aeson-benchmark-auto-compare-  default-language: Haskell2010-  main-is:          AutoCompare.hs-  hs-source-dirs:   .-  ghc-options:      -Wall -O2 -rtsopts-  other-modules:-    Auto.G.BigProduct-    Auto.G.BigRecord-    Auto.G.BigSum-    Auto.G.D-    Auto.T.BigProduct-    Auto.T.BigRecord-    Auto.T.BigSum-    Auto.T.D-    Options--  build-depends:-      aeson-benchmarks-    , base-    , criterion-    , deepseq-    , template-haskell--executable aeson-benchmark-escape-  default-language: Haskell2010-  main-is:          Escape.hs-  hs-source-dirs:   ../examples/src .-  ghc-options:      -Wall -O2 -rtsopts-  build-depends:-      aeson-benchmarks-    , base-    , base-compat-batteries-    , bytestring-    , criterion              >=1.0-    , deepseq-    , ghc-prim-    , text--executable aeson-benchmark-compare-  default-language: Haskell2010-  main-is:          Compare.hs-  hs-source-dirs:   ../examples/src .-  ghc-options:      -Wall -O2 -rtsopts-  other-modules:-    Compare.BufferBuilder-    Compare.JsonBench-    Twitter-    Twitter.Manual-    Typed.Common--  build-depends:-      aeson-benchmarks-    , base-    , base-compat-batteries-    , buffer-builder-    , bytestring-    , criterion              >=1.0-    , deepseq-    , ghc-prim-    , text--  if impl(ghc <8.4)-    other-modules: Compare.JsonBuilder-    build-depends: json-builder--  if !impl(ghc >=8.0)-    build-depends:-        fail-      , semigroups--executable aeson-benchmark-micro-  default-language: Haskell2010-  main-is:          Micro.hs-  hs-source-dirs:   ../examples/src .-  ghc-options:      -Wall -O2 -rtsopts-  build-depends:-      aeson-benchmarks-    , base-    , base-compat-batteries-    , bytestring-    , criterion              >=1.0-    , deepseq-    , ghc-prim-    , text--executable aeson-benchmark-typed-  default-language: Haskell2010-  main-is:          Typed.hs-  hs-source-dirs:   ../examples/src .-  ghc-options:      -Wall -O2 -rtsopts-  other-modules:-    Twitter-    Twitter.Generic-    Twitter.Manual-    Twitter.Options-    Twitter.TH-    Typed.Common-    Typed.Generic-    Typed.Manual-    Typed.TH--  build-depends:-      aeson-benchmarks-    , base-    , base-compat-batteries-    , bytestring-    , criterion              >=1.0-    , deepseq-    , ghc-prim-    , text-    , time--  if impl(ghc <8.0)-    build-depends: semigroups--executable aeson-benchmark-compare-with-json-  default-language: Haskell2010-  main-is:          CompareWithJSON.hs-  ghc-options:      -Wall -O2 -rtsopts-  build-depends:-      aeson-benchmarks-    , base-    , base-compat-batteries-    , blaze-builder-    , bytestring-    , criterion-    , deepseq-    , json-    , text--executable aeson-benchmark-aeson-encode-  default-language: Haskell2010-  main-is:          AesonEncode.hs-  ghc-options:      -Wall -O2 -rtsopts-  build-depends:-      aeson-benchmarks-    , attoparsec-    , base-    , base-compat-batteries-    , bytestring-    , deepseq-    , time--executable aeson-benchmark-aeson-parse-  default-language: Haskell2010-  main-is:          AesonParse.hs-  ghc-options:      -Wall -O2 -rtsopts-  build-depends:-      aeson-benchmarks-    , attoparsec-    , base-    , base-compat-batteries-    , bytestring-    , time--  if !impl(ghc >=8.0)-    build-depends:-        fail-      , semigroups--executable aeson-benchmark-json-parse-  default-language: Haskell2010-  main-is:          JsonParse.hs-  ghc-options:      -Wall -O2 -rtsopts-  build-depends:-      base-    , base-compat-batteries-    , deepseq-    , json-    , time--executable aeson-benchmark-dates-  default-language: Haskell2010-  main-is:          Dates.hs-  ghc-options:      -Wall -O2 -rtsopts-  build-depends:-      aeson-benchmarks-    , base-    , base-compat-batteries-    , bytestring-    , criterion-    , deepseq-    , text-    , time--  if impl(ghc >=8.2)-    ghc-options: -Wno-simplifiable-class-constraints--executable aeson-benchmark-map-  default-language: Haskell2010-  main-is:          AesonMap.hs-  ghc-options:      -Wall -O2 -rtsopts-  build-depends:-      aeson-benchmarks-    , base-    , base-compat-batteries-    , bytestring-    , containers-    , criterion              >=1.0-    , deepseq-    , hashable-    , tagged-    , text-    , unordered-containers--executable aeson-benchmark-foldable-  default-language: Haskell2010-  main-is:          AesonFoldable.hs-  ghc-options:      -Wall -O2 -rtsopts-  build-depends:-      aeson-benchmarks-    , base-    , base-compat-batteries-    , bytestring-    , containers-    , criterion              >=1.0-    , deepseq-    , hashable-    , tagged-    , text-    , unordered-containers-    , vector--executable aeson-issue-673-  default-language: Haskell2010-  main-is:          Issue673.hs-  ghc-options:      -Wall -O1 -rtsopts-  build-depends:-      aeson-benchmarks-    , attoparsec-    , base-    , base-compat-batteries-    , bytestring-    , criterion              >=1.0-    , scientific--  if impl(ghc <8.0)-    build-depends: semigroups
− benchmarks/bench-parse.py 
@@ -1,56 +0,0 @@-#!/usr/bin/env python--import os, re, subprocess, sys--result_re = re.compile(r'^\s*(\d+) good, (\d+\.\d+)s$', re.M)--if len(sys.argv) > 1:-    parser_exe = sys.argv[1]-else:-    parser_exe = ('dist/build/aeson-benchmark-aeson-parse/' +-                  'aeson-benchmark-aeson-parse')--def run(count, filename):-    print '    %s :: %s times' % (filename, count)-    p = subprocess.Popen([parser_exe, '65536', str(count), filename],-                         stdout=subprocess.PIPE)-    output = p.stdout.read()-    p.wait()-    m = result_re.search(output)-    if not m:-        print >> sys.stderr, 'run gave confusing output!?'-        sys.stderr.write(output)-        return-    else:-        #sys.stdout.write(output)-        pass-    good, elapsed = m.groups()-    good, elapsed = int(good), float(elapsed)-    st = os.stat(filename)-    parses_per_second = good / elapsed-    mb_per_second = st.st_size * parses_per_second / 1048576-    print ('      %.3f seconds, %d parses/sec, %.3f MB/sec' %-           (elapsed, parses_per_second, mb_per_second))-    return parses_per_second, mb_per_second, st.st_size, elapsed--def runtimes(count, filename, times=1):-    for i in xrange(times):-        yield run(count, filename)--info = '''-json-data/twitter1.json   60000-json-data/twitter10.json  13000-json-data/twitter20.json   7500-json-data/twitter50.json   2500-json-data/twitter100.json  1000-json-data/jp10.json        4000-json-data/jp50.json        1200-json-data/jp100.json        700-'''--for i in info.strip().splitlines():-    name, count = i.split()-    best = sorted(runtimes(int(count), name, times=3), reverse=True)[0]-    parses_per_second, mb_per_second, size, elapsed = best-    print ('%.1f KB: %d msg\\/sec (%.1f MB\\/sec)' %-           (size / 1024.0, int(round(parses_per_second)), mb_per_second))
− benchmarks/encode.py 
@@ -1,24 +0,0 @@-#!/usr/bin/env python--import json, sys, time--def isint(x):-    try:-        int(x)-        return True-    except:-        return False--if len(sys.argv) > 2 and isint(sys.argv[1]) and isint(sys.argv[2]):-    sys.argv.pop(1)--count = int(sys.argv[1])--for n in sys.argv[2:]:-    print '%s:' % n-    obj = json.load(open(n))-    start = time.time()-    for i in xrange(count):-        json.dumps(obj)-    end = time.time()-    print '  %d good, %gs' % (count, end - start)
− benchmarks/parse.py 
@@ -1,25 +0,0 @@-#!/usr/bin/env python--import json, sys, time--def isint(x):-    try:-        int(x)-        return True-    except:-        return False--if len(sys.argv) > 2 and isint(sys.argv[1]) and isint(sys.argv[2]):-    sys.argv.pop(1)--count = int(sys.argv[1])--for n in sys.argv[2:]:-    print '%s:' % n-    start = time.time()-    fp = open(n)-    for i in xrange(count):-        fp.seek(0)-        val = json.load(fp)-    end = time.time()-    print '  %d good, %gs' % (count, end - start)
changelog.md view
@@ -1,5 +1,8 @@ For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md). +### 1.5.6.0+* Make `Show Value` instance print object keys in lexicographic order.+ ### 1.5.5.1 * Fix a bug in `FromJSON QuarterOfYear` instance.
− ffi/Data/Aeson/Parser/UnescapeFFI.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnliftedFFITypes #-}--module Data.Aeson.Parser.UnescapeFFI-    (-      unescapeText-    ) where--import Control.Exception (evaluate, throw, try)-import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)-import Data.ByteString as B-import Data.ByteString.Internal as B-import Data.Text.Encoding.Error (UnicodeException (..))-import Data.Text.Internal (Text (..))-import Data.Text.Internal.Private (runText)-import Data.Text.Unsafe (unsafeDupablePerformIO)-import Data.Word (Word8)-import Foreign.C.Types (CInt (..), CSize (..))-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Marshal.Utils (with)-import Foreign.Ptr (Ptr, plusPtr)-import Foreign.Storable (peek)-import GHC.Base (MutableByteArray#)-import qualified Data.Text.Array as A--foreign import ccall unsafe "_js_decode_string" c_js_decode-    :: MutableByteArray# s -> Ptr CSize-    -> Ptr Word8 -> Ptr Word8 -> IO CInt--unescapeText' :: ByteString -> Text-#if MIN_VERSION_bytestring(0,11,0)-unescapeText' (BS fp len) = runText $ \done -> do-  let off = 0-#else-unescapeText' (PS fp off len) = runText $ \done -> do-#endif-  let go dest = withForeignPtr fp $ \ptr ->-        with (0::CSize) $ \destOffPtr -> do-          let end = ptr `plusPtr` (off + len)-              loop curPtr = do-                res <- c_js_decode (A.maBA dest) destOffPtr curPtr end-                case res of-                  0 -> do-                    n <- peek destOffPtr-                    unsafeSTToIO (done dest (fromIntegral n))-                  _ ->-                    throw (DecodeError desc Nothing)-          loop (ptr `plusPtr` off)-  (unsafeIOToST . go) =<< A.new len- where-  desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"-{-# INLINE unescapeText' #-}--unescapeText :: ByteString -> Either UnicodeException Text-unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'-{-# INLINE unescapeText #-}
− pure/Data/Aeson/Parser/UnescapePure.hs 
@@ -1,254 +0,0 @@--- WARNING: This file is security sensitive as it uses unsafeWrite which does--- not check bounds. Any changes should be made with care and we would love to--- get informed about them, just cc us in any PR targetting this file: @eskimor @jprider63--- We would be happy to review the changes!---- The security check at the end (pos > length) only works if pos grows--- monotonously, if this condition does not hold, the check is flawed.-module Data.Aeson.Parser.UnescapePure-    (-      unescapeText-    ) where--import Control.Exception (evaluate, throw, try)-import Control.Monad (when)-import Data.ByteString as B-import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))-import Data.Text (Text)-import qualified Data.Text.Array as A-import Data.Text.Encoding.Error (UnicodeException (..))-import Data.Text.Internal.Private (runText)-import Data.Text.Unsafe (unsafeDupablePerformIO)-import Data.Word (Word8, Word16, Word32)-import GHC.ST (ST)---- Different UTF states.-data Utf =-      UtfGround-    | UtfTail1-    | UtfU32e0-    | UtfTail2-    | UtfU32ed-    | Utf843f0-    | UtfTail3-    | Utf843f4-    deriving (Eq)--data State =-      StateNone-    | StateUtf !Utf !Word32-    | StateBackslash-    | StateU0-    | StateU1 !Word16-    | StateU2 !Word16-    | StateU3 !Word16-    | StateS0-    | StateS1-    | StateSU0-    | StateSU1 !Word16-    | StateSU2 !Word16-    | StateSU3 !Word16-    deriving (Eq)---- References:--- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/--- https://github.com/jwilm/vte/blob/master/utf8parse/src/table.rs.in--setByte1 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a-setByte1 point word = point .|. fromIntegral (word .&. 0x3f)-{-# INLINE setByte1 #-}--setByte2 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a-setByte2 point word = point .|. (fromIntegral (word .&. 0x3f) `shiftL` 6)-{-# INLINE setByte2 #-}--setByte2Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a-setByte2Top point word = point .|. (fromIntegral (word .&. 0x1f) `shiftL` 6)-{-# INLINE setByte2Top #-}--setByte3 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a-setByte3 point word = point .|. (fromIntegral (word .&. 0x3f) `shiftL` 12)-{-# INLINE setByte3 #-}--setByte3Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a-setByte3Top point word = point .|. (fromIntegral (word .&. 0xf) `shiftL` 12)-{-# INLINE setByte3Top #-}--setByte4 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a-setByte4 point word = point .|. (fromIntegral (word .&. 0x7) `shiftL` 18)-{-# INLINE setByte4 #-}--decode :: Utf -> Word32 -> Word8 -> (Utf, Word32)-decode UtfGround point word = case word of-    w | 0x00 <= w && w <= 0x7f -> (UtfGround, fromIntegral word)-    w | 0xc2 <= w && w <= 0xdf -> (UtfTail1, setByte2Top point word)-    0xe0                       -> (UtfU32e0, setByte3Top point word)-    w | 0xe1 <= w && w <= 0xec -> (UtfTail2, setByte3Top point word)-    0xed                       -> (UtfU32ed, setByte3Top point word)-    w | 0xee <= w && w <= 0xef -> (UtfTail2, setByte3Top point word)-    0xf0                       -> (Utf843f0, setByte4 point word)-    w | 0xf1 <= w && w <= 0xf3 -> (UtfTail3, setByte4 point word)-    0xf4                       -> (Utf843f4, setByte4 point word)-    _                          -> throwDecodeError--decode UtfU32e0 point word = case word of-    w | 0xa0 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)-    _                          -> throwDecodeError--decode UtfU32ed point word = case word of-    w | 0x80 <= w && w <= 0x9f -> (UtfTail1, setByte2 point word)-    _                          -> throwDecodeError--decode Utf843f0 point word = case word of-    w | 0x90 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)-    _                          -> throwDecodeError--decode Utf843f4 point word = case word of-    w | 0x80 <= w && w <= 0x8f -> (UtfTail2, setByte3 point word)-    _                          -> throwDecodeError--decode UtfTail3 point word = case word of-    w | 0x80 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)-    _                          -> throwDecodeError--decode UtfTail2 point word = case word of-    w | 0x80 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)-    _                          -> throwDecodeError--decode UtfTail1 point word = case word of-    w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)-    _                          -> throwDecodeError--decodeHex :: Word8 -> Word16-decodeHex x-  | 48 <= x && x <=  57 = fromIntegral x - 48  -- 0-9-  | 65 <= x && x <=  70 = fromIntegral x - 55  -- A-F-  | 97 <= x && x <= 102 = fromIntegral x - 87  -- a-f-  | otherwise = throwDecodeError--unescapeText' :: ByteString -> Text-unescapeText' bs = runText $ \done -> do-    dest <- A.new len--    (pos, finalState) <- loop dest (0, StateNone) 0--    -- Check final state. Currently pos gets only increased over time, so this check should catch overflows.-    when ( finalState /= StateNone || pos > len)-      throwDecodeError--    done dest pos -- TODO: pos, pos-1??? XXX--    where-      len = B.length bs--      runUtf dest pos st point c = case decode st point c of-        (UtfGround, 92) -> -- Backslash-            return (pos, StateBackslash)-        (UtfGround, w) | w <= 0xffff ->-            writeAndReturn dest pos (fromIntegral w) StateNone-        (UtfGround, w) -> do-            write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10))-            writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone-        (st', p) ->-            return (pos, StateUtf st' p)--      loop :: A.MArray s -> (Int, State) -> Int -> ST s (Int, State)-      loop _ ps i | i >= len = return ps-      loop dest ps i = do-        let c = B.index bs i -- JP: We can use unsafe index once we prove bounds with Liquid Haskell.-        ps' <- f dest ps c-        loop dest ps' $ i+1--      -- No pending state.-      f dest (pos, StateNone) c = runUtf dest pos UtfGround 0 c--      -- In the middle of parsing a UTF string.-      f dest (pos, StateUtf st point) c = runUtf dest pos st point c--      -- In the middle of escaping a backslash.-      f dest (pos, StateBackslash)  34 = writeAndReturn dest pos 34 StateNone -- "-      f dest (pos, StateBackslash)  92 = writeAndReturn dest pos 92 StateNone -- Backslash-      f dest (pos, StateBackslash)  47 = writeAndReturn dest pos 47 StateNone -- /-      f dest (pos, StateBackslash)  98 = writeAndReturn dest pos  8 StateNone -- b-      f dest (pos, StateBackslash) 102 = writeAndReturn dest pos 12 StateNone -- f-      f dest (pos, StateBackslash) 110 = writeAndReturn dest pos 10 StateNone -- n-      f dest (pos, StateBackslash) 114 = writeAndReturn dest pos 13 StateNone -- r-      f dest (pos, StateBackslash) 116 = writeAndReturn dest pos  9 StateNone -- t-      f    _ (pos, StateBackslash) 117 = return (pos, StateU0)                -- u-      f    _ (  _, StateBackslash) _   = throwDecodeError--      -- Processing '\u'.-      f _ (pos, StateU0) c =-        let w = decodeHex c in-        return (pos, StateU1 (w `shiftL` 12))--      f _ (pos, StateU1 w') c =-        let w = decodeHex c in-        return (pos, StateU2 (w' .|. (w `shiftL` 8)))--      f _ (pos, StateU2 w') c =-        let w = decodeHex c in-        return (pos, StateU3 (w' .|. (w `shiftL` 4)))--      f dest (pos, StateU3 w') c =-        let w = decodeHex c in-        let u = w' .|. w in--        -- Get next state based on surrogates.-        let st-              | u >= 0xd800 && u <= 0xdbff = -- High surrogate.-                StateS0-              | u >= 0xdc00 && u <= 0xdfff = -- Low surrogate.-                throwDecodeError-              | otherwise =-                StateNone-        in-        writeAndReturn dest pos u st--      -- Handle surrogates.-      f _ (pos, StateS0) 92 = return (pos, StateS1) -- Backslash-      f _ (  _, StateS0)  _ = throwDecodeError--      f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u-      f _ (  _, StateS1)   _ = throwDecodeError--      f _ (pos, StateSU0) c =-        let w = decodeHex c in-        return (pos, StateSU1 (w `shiftL` 12))--      f _ (pos, StateSU1 w') c =-        let w = decodeHex c in-        return (pos, StateSU2 (w' .|. (w `shiftL` 8)))--      f _ (pos, StateSU2 w') c =-        let w = decodeHex c in-        return (pos, StateSU3 (w' .|. (w `shiftL` 4)))--      f dest (pos, StateSU3 w') c =-        let w = decodeHex c in-        let u = w' .|. w in--        -- Check if not low surrogate.-        if u < 0xdc00 || u > 0xdfff then-          throwDecodeError-        else-          writeAndReturn dest pos u StateNone--write :: A.MArray s -> Int -> Word16 -> ST s ()-write dest pos char =-    A.unsafeWrite dest pos char-{-# INLINE write #-}--writeAndReturn :: A.MArray s -> Int -> Word16 -> t -> ST s (Int, t)-writeAndReturn dest pos char res = do-    write dest pos char-    return (pos + 1, res)-{-# INLINE writeAndReturn #-}--throwDecodeError :: a-throwDecodeError =-    let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in-    throw (DecodeError desc Nothing)--unescapeText :: ByteString -> Either UnicodeException Text-unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'
+ src-ffi/Data/Aeson/Parser/UnescapeFFI.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}++module Data.Aeson.Parser.UnescapeFFI+    (+      unescapeText+    ) where++import Control.Exception (evaluate, throw, try)+import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)+import Data.ByteString as B+import Data.ByteString.Internal as B+import Data.Text.Encoding.Error (UnicodeException (..))+import Data.Text.Internal (Text (..))+import Data.Text.Internal.Private (runText)+import Data.Text.Unsafe (unsafeDupablePerformIO)+import Data.Word (Word8)+import Foreign.C.Types (CInt (..), CSize (..))+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Utils (with)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peek)+import GHC.Base (MutableByteArray#)+import qualified Data.Text.Array as A++foreign import ccall unsafe "_js_decode_string" c_js_decode+    :: MutableByteArray# s -> Ptr CSize+    -> Ptr Word8 -> Ptr Word8 -> IO CInt++unescapeText' :: ByteString -> Text+#if MIN_VERSION_bytestring(0,11,0)+unescapeText' (BS fp len) = runText $ \done -> do+  let off = 0+#else+unescapeText' (PS fp off len) = runText $ \done -> do+#endif+  let go dest = withForeignPtr fp $ \ptr ->+        with (0::CSize) $ \destOffPtr -> do+          let end = ptr `plusPtr` (off + len)+              loop curPtr = do+                res <- c_js_decode (A.maBA dest) destOffPtr curPtr end+                case res of+                  0 -> do+                    n <- peek destOffPtr+                    unsafeSTToIO (done dest (fromIntegral n))+                  _ ->+                    throw (DecodeError desc Nothing)+          loop (ptr `plusPtr` off)+  (unsafeIOToST . go) =<< A.new len+ where+  desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"+{-# INLINE unescapeText' #-}++unescapeText :: ByteString -> Either UnicodeException Text+unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'+{-# INLINE unescapeText #-}
+ src-pure/Data/Aeson/Parser/UnescapePure.hs view
@@ -0,0 +1,254 @@+-- WARNING: This file is security sensitive as it uses unsafeWrite which does+-- not check bounds. Any changes should be made with care and we would love to+-- get informed about them, just cc us in any PR targetting this file: @eskimor @jprider63+-- We would be happy to review the changes!++-- The security check at the end (pos > length) only works if pos grows+-- monotonously, if this condition does not hold, the check is flawed.+module Data.Aeson.Parser.UnescapePure+    (+      unescapeText+    ) where++import Control.Exception (evaluate, throw, try)+import Control.Monad (when)+import Data.ByteString as B+import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))+import Data.Text (Text)+import qualified Data.Text.Array as A+import Data.Text.Encoding.Error (UnicodeException (..))+import Data.Text.Internal.Private (runText)+import Data.Text.Unsafe (unsafeDupablePerformIO)+import Data.Word (Word8, Word16, Word32)+import GHC.ST (ST)++-- Different UTF states.+data Utf =+      UtfGround+    | UtfTail1+    | UtfU32e0+    | UtfTail2+    | UtfU32ed+    | Utf843f0+    | UtfTail3+    | Utf843f4+    deriving (Eq)++data State =+      StateNone+    | StateUtf !Utf !Word32+    | StateBackslash+    | StateU0+    | StateU1 !Word16+    | StateU2 !Word16+    | StateU3 !Word16+    | StateS0+    | StateS1+    | StateSU0+    | StateSU1 !Word16+    | StateSU2 !Word16+    | StateSU3 !Word16+    deriving (Eq)++-- References:+-- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/+-- https://github.com/jwilm/vte/blob/master/utf8parse/src/table.rs.in++setByte1 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a+setByte1 point word = point .|. fromIntegral (word .&. 0x3f)+{-# INLINE setByte1 #-}++setByte2 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a+setByte2 point word = point .|. (fromIntegral (word .&. 0x3f) `shiftL` 6)+{-# INLINE setByte2 #-}++setByte2Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a+setByte2Top point word = point .|. (fromIntegral (word .&. 0x1f) `shiftL` 6)+{-# INLINE setByte2Top #-}++setByte3 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a+setByte3 point word = point .|. (fromIntegral (word .&. 0x3f) `shiftL` 12)+{-# INLINE setByte3 #-}++setByte3Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a+setByte3Top point word = point .|. (fromIntegral (word .&. 0xf) `shiftL` 12)+{-# INLINE setByte3Top #-}++setByte4 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a+setByte4 point word = point .|. (fromIntegral (word .&. 0x7) `shiftL` 18)+{-# INLINE setByte4 #-}++decode :: Utf -> Word32 -> Word8 -> (Utf, Word32)+decode UtfGround point word = case word of+    w | 0x00 <= w && w <= 0x7f -> (UtfGround, fromIntegral word)+    w | 0xc2 <= w && w <= 0xdf -> (UtfTail1, setByte2Top point word)+    0xe0                       -> (UtfU32e0, setByte3Top point word)+    w | 0xe1 <= w && w <= 0xec -> (UtfTail2, setByte3Top point word)+    0xed                       -> (UtfU32ed, setByte3Top point word)+    w | 0xee <= w && w <= 0xef -> (UtfTail2, setByte3Top point word)+    0xf0                       -> (Utf843f0, setByte4 point word)+    w | 0xf1 <= w && w <= 0xf3 -> (UtfTail3, setByte4 point word)+    0xf4                       -> (Utf843f4, setByte4 point word)+    _                          -> throwDecodeError++decode UtfU32e0 point word = case word of+    w | 0xa0 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)+    _                          -> throwDecodeError++decode UtfU32ed point word = case word of+    w | 0x80 <= w && w <= 0x9f -> (UtfTail1, setByte2 point word)+    _                          -> throwDecodeError++decode Utf843f0 point word = case word of+    w | 0x90 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)+    _                          -> throwDecodeError++decode Utf843f4 point word = case word of+    w | 0x80 <= w && w <= 0x8f -> (UtfTail2, setByte3 point word)+    _                          -> throwDecodeError++decode UtfTail3 point word = case word of+    w | 0x80 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word)+    _                          -> throwDecodeError++decode UtfTail2 point word = case word of+    w | 0x80 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word)+    _                          -> throwDecodeError++decode UtfTail1 point word = case word of+    w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)+    _                          -> throwDecodeError++decodeHex :: Word8 -> Word16+decodeHex x+  | 48 <= x && x <=  57 = fromIntegral x - 48  -- 0-9+  | 65 <= x && x <=  70 = fromIntegral x - 55  -- A-F+  | 97 <= x && x <= 102 = fromIntegral x - 87  -- a-f+  | otherwise = throwDecodeError++unescapeText' :: ByteString -> Text+unescapeText' bs = runText $ \done -> do+    dest <- A.new len++    (pos, finalState) <- loop dest (0, StateNone) 0++    -- Check final state. Currently pos gets only increased over time, so this check should catch overflows.+    when ( finalState /= StateNone || pos > len)+      throwDecodeError++    done dest pos -- TODO: pos, pos-1??? XXX++    where+      len = B.length bs++      runUtf dest pos st point c = case decode st point c of+        (UtfGround, 92) -> -- Backslash+            return (pos, StateBackslash)+        (UtfGround, w) | w <= 0xffff ->+            writeAndReturn dest pos (fromIntegral w) StateNone+        (UtfGround, w) -> do+            write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10))+            writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone+        (st', p) ->+            return (pos, StateUtf st' p)++      loop :: A.MArray s -> (Int, State) -> Int -> ST s (Int, State)+      loop _ ps i | i >= len = return ps+      loop dest ps i = do+        let c = B.index bs i -- JP: We can use unsafe index once we prove bounds with Liquid Haskell.+        ps' <- f dest ps c+        loop dest ps' $ i+1++      -- No pending state.+      f dest (pos, StateNone) c = runUtf dest pos UtfGround 0 c++      -- In the middle of parsing a UTF string.+      f dest (pos, StateUtf st point) c = runUtf dest pos st point c++      -- In the middle of escaping a backslash.+      f dest (pos, StateBackslash)  34 = writeAndReturn dest pos 34 StateNone -- "+      f dest (pos, StateBackslash)  92 = writeAndReturn dest pos 92 StateNone -- Backslash+      f dest (pos, StateBackslash)  47 = writeAndReturn dest pos 47 StateNone -- /+      f dest (pos, StateBackslash)  98 = writeAndReturn dest pos  8 StateNone -- b+      f dest (pos, StateBackslash) 102 = writeAndReturn dest pos 12 StateNone -- f+      f dest (pos, StateBackslash) 110 = writeAndReturn dest pos 10 StateNone -- n+      f dest (pos, StateBackslash) 114 = writeAndReturn dest pos 13 StateNone -- r+      f dest (pos, StateBackslash) 116 = writeAndReturn dest pos  9 StateNone -- t+      f    _ (pos, StateBackslash) 117 = return (pos, StateU0)                -- u+      f    _ (  _, StateBackslash) _   = throwDecodeError++      -- Processing '\u'.+      f _ (pos, StateU0) c =+        let w = decodeHex c in+        return (pos, StateU1 (w `shiftL` 12))++      f _ (pos, StateU1 w') c =+        let w = decodeHex c in+        return (pos, StateU2 (w' .|. (w `shiftL` 8)))++      f _ (pos, StateU2 w') c =+        let w = decodeHex c in+        return (pos, StateU3 (w' .|. (w `shiftL` 4)))++      f dest (pos, StateU3 w') c =+        let w = decodeHex c in+        let u = w' .|. w in++        -- Get next state based on surrogates.+        let st+              | u >= 0xd800 && u <= 0xdbff = -- High surrogate.+                StateS0+              | u >= 0xdc00 && u <= 0xdfff = -- Low surrogate.+                throwDecodeError+              | otherwise =+                StateNone+        in+        writeAndReturn dest pos u st++      -- Handle surrogates.+      f _ (pos, StateS0) 92 = return (pos, StateS1) -- Backslash+      f _ (  _, StateS0)  _ = throwDecodeError++      f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u+      f _ (  _, StateS1)   _ = throwDecodeError++      f _ (pos, StateSU0) c =+        let w = decodeHex c in+        return (pos, StateSU1 (w `shiftL` 12))++      f _ (pos, StateSU1 w') c =+        let w = decodeHex c in+        return (pos, StateSU2 (w' .|. (w `shiftL` 8)))++      f _ (pos, StateSU2 w') c =+        let w = decodeHex c in+        return (pos, StateSU3 (w' .|. (w `shiftL` 4)))++      f dest (pos, StateSU3 w') c =+        let w = decodeHex c in+        let u = w' .|. w in++        -- Check if not low surrogate.+        if u < 0xdc00 || u > 0xdfff then+          throwDecodeError+        else+          writeAndReturn dest pos u StateNone++write :: A.MArray s -> Int -> Word16 -> ST s ()+write dest pos char =+    A.unsafeWrite dest pos char+{-# INLINE write #-}++writeAndReturn :: A.MArray s -> Int -> Word16 -> t -> ST s (Int, t)+writeAndReturn dest pos char res = do+    write dest pos char+    return (pos + 1, res)+{-# INLINE writeAndReturn #-}++throwDecodeError :: a+throwDecodeError =+    let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in+    throw (DecodeError desc Nothing)++unescapeText :: ByteString -> Either UnicodeException Text+unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'
+ src/Data/Aeson.hs view
@@ -0,0 +1,529 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- |+-- Module:      Data.Aeson+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Types and functions for working efficiently with JSON data.+--+-- (A note on naming: in Greek mythology, Aeson was the father of Jason.)++module Data.Aeson+    (+    -- * How to use this library+    -- $use++    -- ** Writing instances by hand+    -- $manual++    -- ** Working with the AST+    -- $ast++    -- ** Decoding to a Haskell value+    -- $haskell++    -- ** Decoding a mixed-type object+    -- $mixed++    -- * Encoding and decoding+    -- $encoding_and_decoding++    -- ** Direct encoding+    -- $encoding+      decode+    , decode'+    , eitherDecode+    , eitherDecode'+    , encode+    , encodeFile+    -- ** Variants for strict bytestrings+    , decodeStrict+    , decodeFileStrict+    , decodeStrict'+    , decodeFileStrict'+    , eitherDecodeStrict+    , eitherDecodeFileStrict+    , eitherDecodeStrict'+    , eitherDecodeFileStrict'+    -- * Core JSON types+    , Value(..)+    , Encoding+    , fromEncoding+    , Array+    , Object+    -- * Convenience types+    , DotNetTime(..)+    -- * Type conversion+    , FromJSON(..)+    , Result(..)+    , fromJSON+    , ToJSON(..)+    , KeyValue(..)+    , (<?>)+    , JSONPath+    -- ** Keys for maps+    , ToJSONKey(..)+    , ToJSONKeyFunction(..)+    , FromJSONKey(..)+    , FromJSONKeyFunction(..)+    -- *** Generic keys+    , GToJSONKey()+    , genericToJSONKey+    , GFromJSONKey()+    , genericFromJSONKey+    -- ** Liftings to unary and binary type constructors+    , FromJSON1(..)+    , parseJSON1+    , FromJSON2(..)+    , parseJSON2+    , ToJSON1(..)+    , toJSON1+    , toEncoding1+    , ToJSON2(..)+    , toJSON2+    , toEncoding2+    -- ** Generic JSON classes and options+    , GFromJSON+    , FromArgs+    , GToJSON+    , GToEncoding+    , GToJSON'+    , ToArgs+    , Zero+    , One+    , genericToJSON+    , genericLiftToJSON+    , genericToEncoding+    , genericLiftToEncoding+    , genericParseJSON+    , genericLiftParseJSON+    -- ** Generic and TH encoding configuration+    , Options+    , defaultOptions+    -- *** Options fields+    -- $optionsFields+    , fieldLabelModifier+    , constructorTagModifier+    , allNullaryToStringTag+    , omitNothingFields+    , sumEncoding+    , unwrapUnaryRecords+    , tagSingleConstructors+    , rejectUnknownFields+    -- *** Options utilities+    , SumEncoding(..)+    , camelTo2+    , defaultTaggedObject+    -- ** Options for object keys+    , JSONKeyOptions+    , keyModifier+    , defaultJSONKeyOptions++    -- * Inspecting @'Value's@+    , withObject+    , withText+    , withArray+    , withScientific+    , withBool+    , withEmbeddedJSON+    -- * Constructors and accessors+    , Series+    , pairs+    , foldable+    , (.:)+    , (.:?)+    , (.:!)+    , (.!=)+    , object+    -- * Parsing+    , json+    , json'+    , parseIndexedJSON+    ) where++import Prelude.Compat++import Data.Aeson.Types.FromJSON (ifromJSON, parseIndexedJSON)+import Data.Aeson.Encoding (encodingToLazyByteString)+import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json')+import Data.Aeson.Types+import Data.Aeson.Types.Internal (formatError)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++-- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.+--+-- This is implemented in terms of the 'ToJSON' class's 'toEncoding' method.+encode :: (ToJSON a) => a -> L.ByteString+encode = encodingToLazyByteString . toEncoding++-- | Efficiently serialize a JSON value as a lazy 'L.ByteString' and write it to a file.+encodeFile :: (ToJSON a) => FilePath -> a -> IO ()+encodeFile fp = L.writeFile fp . encode++-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.+-- If this fails due to incomplete or invalid input, 'Nothing' is+-- returned.+--+-- The input must consist solely of a JSON document, with no trailing+-- data except for whitespace.+--+-- This function parses immediately, but defers conversion.  See+-- 'json' for details.+decode :: (FromJSON a) => L.ByteString -> Maybe a+decode = decodeWith jsonEOF fromJSON+{-# INLINE decode #-}++-- | Efficiently deserialize a JSON value from a strict 'B.ByteString'.+-- If this fails due to incomplete or invalid input, 'Nothing' is+-- returned.+--+-- The input must consist solely of a JSON document, with no trailing+-- data except for whitespace.+--+-- This function parses immediately, but defers conversion.  See+-- 'json' for details.+decodeStrict :: (FromJSON a) => B.ByteString -> Maybe a+decodeStrict = decodeStrictWith jsonEOF fromJSON+{-# INLINE decodeStrict #-}++-- | Efficiently deserialize a JSON value from a file.+-- If this fails due to incomplete or invalid input, 'Nothing' is+-- returned.+--+-- The input file's content must consist solely of a JSON document,+-- with no trailing data except for whitespace.+--+-- This function parses immediately, but defers conversion.  See+-- 'json' for details.+decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a)+decodeFileStrict = fmap decodeStrict . B.readFile++-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.+-- If this fails due to incomplete or invalid input, 'Nothing' is+-- returned.+--+-- The input must consist solely of a JSON document, with no trailing+-- data except for whitespace.+--+-- This function parses and performs conversion immediately.  See+-- 'json'' for details.+decode' :: (FromJSON a) => L.ByteString -> Maybe a+decode' = decodeWith jsonEOF' fromJSON+{-# INLINE decode' #-}++-- | Efficiently deserialize a JSON value from a strict 'B.ByteString'.+-- If this fails due to incomplete or invalid input, 'Nothing' is+-- returned.+--+-- The input must consist solely of a JSON document, with no trailing+-- data except for whitespace.+--+-- This function parses and performs conversion immediately.  See+-- 'json'' for details.+decodeStrict' :: (FromJSON a) => B.ByteString -> Maybe a+decodeStrict' = decodeStrictWith jsonEOF' fromJSON+{-# INLINE decodeStrict' #-}++-- | Efficiently deserialize a JSON value from a file.+-- If this fails due to incomplete or invalid input, 'Nothing' is+-- returned.+--+-- The input file's content must consist solely of a JSON document,+-- with no trailing data except for whitespace.+--+-- This function parses and performs conversion immediately.  See+-- 'json'' for details.+decodeFileStrict' :: (FromJSON a) => FilePath -> IO (Maybe a)+decodeFileStrict' = fmap decodeStrict' . B.readFile++eitherFormatError :: Either (JSONPath, String) a -> Either String a+eitherFormatError = either (Left . uncurry formatError) Right+{-# INLINE eitherFormatError #-}++-- | Like 'decode' but returns an error message when decoding fails.+eitherDecode :: (FromJSON a) => L.ByteString -> Either String a+eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON+{-# INLINE eitherDecode #-}++-- | Like 'decodeStrict' but returns an error message when decoding fails.+eitherDecodeStrict :: (FromJSON a) => B.ByteString -> Either String a+eitherDecodeStrict =+  eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON+{-# INLINE eitherDecodeStrict #-}++-- | Like 'decodeFileStrict' but returns an error message when decoding fails.+eitherDecodeFileStrict :: (FromJSON a) => FilePath -> IO (Either String a)+eitherDecodeFileStrict =+  fmap eitherDecodeStrict . B.readFile+{-# INLINE eitherDecodeFileStrict #-}++-- | Like 'decode'' but returns an error message when decoding fails.+eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a+eitherDecode' = eitherFormatError . eitherDecodeWith jsonEOF' ifromJSON+{-# INLINE eitherDecode' #-}++-- | Like 'decodeStrict'' but returns an error message when decoding fails.+eitherDecodeStrict' :: (FromJSON a) => B.ByteString -> Either String a+eitherDecodeStrict' =+  eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON+{-# INLINE eitherDecodeStrict' #-}++-- | Like 'decodeFileStrict'' but returns an error message when decoding fails.+eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a)+eitherDecodeFileStrict' =+  fmap eitherDecodeStrict' . B.readFile+{-# INLINE eitherDecodeFileStrict' #-}++-- $use+--+-- This section contains basic information on the different ways to+-- work with data using this library. These range from simple but+-- inflexible, to complex but flexible.+--+-- The most common way to use the library is to define a data type,+-- corresponding to some JSON data you want to work with, and then+-- write either a 'FromJSON' instance, a to 'ToJSON' instance, or both+-- for that type.+--+-- For example, given this JSON data:+--+-- > { "name": "Joe", "age": 12 }+--+-- we create a matching data type:+--+-- > {-# LANGUAGE DeriveGeneric #-}+-- >+-- > import GHC.Generics+-- >+-- > data Person = Person {+-- >       name :: Text+-- >     , age  :: Int+-- >     } deriving (Generic, Show)+--+-- The @LANGUAGE@ pragma and 'Generic' instance let us write empty+-- 'FromJSON' and 'ToJSON' instances for which the compiler will+-- generate sensible default implementations.+--+-- @+-- instance 'ToJSON' Person where+--     \-- No need to provide a 'toJSON' implementation.+--+--     \-- For efficiency, we write a simple 'toEncoding' implementation, as+--     \-- the default version uses 'toJSON'.+--     'toEncoding' = 'genericToEncoding' 'defaultOptions'+--+-- instance 'FromJSON' Person+--     \-- No need to provide a 'parseJSON' implementation.+-- @+--+-- We can now encode a value like so:+--+-- > >>> encode (Person {name = "Joe", age = 12})+-- > "{\"name\":\"Joe\",\"age\":12}"++-- $manual+--+-- When necessary, we can write 'ToJSON' and 'FromJSON' instances by+-- hand.  This is valuable when the JSON-on-the-wire and Haskell data+-- are different or otherwise need some more carefully managed+-- translation.  Let's revisit our JSON data:+--+-- > { "name": "Joe", "age": 12 }+--+-- We once again create a matching data type, without bothering to add+-- a 'Generic' instance this time:+--+-- > data Person = Person {+-- >       name :: Text+-- >     , age  :: Int+-- >     } deriving Show+--+-- To decode data, we need to define a 'FromJSON' instance:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > instance FromJSON Person where+-- >     parseJSON = withObject "Person" $ \v -> Person+-- >         <$> v .: "name"+-- >         <*> v .: "age"+--+-- We can now parse the JSON data like so:+--+-- > >>> decode "{\"name\":\"Joe\",\"age\":12}" :: Maybe Person+-- > Just (Person {name = "Joe", age = 12})+--+-- To encode data, we need to define a 'ToJSON' instance. Let's begin+-- with an instance written entirely by hand.+--+-- @+-- instance ToJSON Person where+--     \-- this generates a 'Value'+--     'toJSON' (Person name age) =+--         'object' [\"name\" '.=' name, \"age\" '.=' age]+--+--     \-- this encodes directly to a bytestring Builder+--     'toEncoding' (Person name age) =+--         'pairs' (\"name\" '.=' 'name' '<>' \"age\" '.=' age)+-- @+--+-- We can now encode a value like so:+--+-- > >>> encode (Person {name = "Joe", age = 12})+-- > "{\"name\":\"Joe\",\"age\":12}"+--+-- There are predefined 'FromJSON' and 'ToJSON' instances for many+-- types. Here's an example using lists and 'Int's:+--+-- > >>> decode "[1,2,3]" :: Maybe [Int]+-- > Just [1,2,3]+--+-- And here's an example using the 'Data.Map.Map' type to get a map of+-- 'Int's.+--+-- > >>> decode "{\"foo\":1,\"bar\":2}" :: Maybe (Map String Int)+-- > Just (fromList [("bar",2),("foo",1)])++-- While the notes below focus on decoding, you can apply almost the+-- same techniques to /encoding/ data. (The main difference is that+-- encoding always succeeds, but decoding has to handle the+-- possibility of failure, where an input doesn't match our+-- expectations.)+--+-- See the documentation of 'FromJSON' and 'ToJSON' for some examples+-- of how you can automatically derive instances in many common+-- circumstances.++-- $ast+--+-- Sometimes you want to work with JSON data directly, without first+-- converting it to a custom data type. This can be useful if you want+-- to e.g. convert JSON data to YAML data, without knowing what the+-- contents of the original JSON data was. The 'Value' type, which is+-- an instance of 'FromJSON', is used to represent an arbitrary JSON+-- AST (abstract syntax tree). Example usage:+--+-- > >>> decode "{\"foo\": 123}" :: Maybe Value+-- > Just (Object (fromList [("foo",Number 123)]))+--+-- > >>> decode "{\"foo\": [\"abc\",\"def\"]}" :: Maybe Value+-- > Just (Object (fromList [("foo",Array (fromList [String "abc",String "def"]))]))+--+-- Once you have a 'Value' you can write functions to traverse it and+-- make arbitrary transformations.++-- $haskell+--+-- We can decode to any instance of 'FromJSON':+--+-- > λ> decode "[1,2,3]" :: Maybe [Int]+-- > Just [1,2,3]+--+-- Alternatively, there are instances for standard data types, so you+-- can use them directly. For example, use the 'Data.Map.Map' type to+-- get a map of 'Int's.+--+-- > λ> import Data.Map+-- > λ> decode "{\"foo\":1,\"bar\":2}" :: Maybe (Map String Int)+-- > Just (fromList [("bar",2),("foo",1)])++-- $mixed+--+-- The above approach with maps of course will not work for mixed-type+-- objects that don't follow a strict schema, but there are a couple+-- of approaches available for these.+--+-- The 'Object' type contains JSON objects:+--+-- > λ> decode "{\"name\":\"Dave\",\"age\":2}" :: Maybe Object+-- > Just (fromList [("name",String "Dave"),("age",Number 2)])+--+-- You can extract values from it with a parser using 'parse',+-- 'parseEither' or, in this example, 'parseMaybe':+--+-- > λ> do result <- decode "{\"name\":\"Dave\",\"age\":2}"+-- >       flip parseMaybe result $ \obj -> do+-- >         age <- obj .: "age"+-- >         name <- obj .: "name"+-- >         return (name ++ ": " ++ show (age*2))+-- >+-- > Just "Dave: 4"+--+-- Considering that any type that implements 'FromJSON' can be used+-- here, this is quite a powerful way to parse JSON. See the+-- documentation in 'FromJSON' for how to implement this class for+-- your own data types.+--+-- The downside is that you have to write the parser yourself; the+-- upside is that you have complete control over the way the JSON is+-- parsed.++-- $encoding_and_decoding+--+-- Decoding is a two-step process.+--+-- * When decoding a value, the process is reversed: the bytes are+--   converted to a 'Value', then the 'FromJSON' class is used to+--   convert to the desired type.+--+-- There are two ways to encode a value.+--+-- * Convert to a 'Value' using 'toJSON', then possibly further+--   encode.  This was the only method available in aeson 0.9 and+--   earlier.+--+-- * Directly encode (to what will become a 'L.ByteString') using+--   'toEncoding'.  This is much more efficient (about 3x faster, and+--   less memory intensive besides), but is only available in aeson+--   0.10 and newer.+--+-- For convenience, the 'encode' and 'decode' functions combine both+-- steps.++-- $encoding+--+-- In older versions of this library, encoding a Haskell value+-- involved converting to an intermediate 'Value', then encoding that.+--+-- A \"direct\" encoder converts straight from a source Haskell value+-- to a 'BL.ByteString' without constructing an intermediate 'Value'.+-- This approach is faster than 'toJSON', and allocates less memory.+-- The 'toEncoding' method makes it possible to implement direct+-- encoding with low memory overhead.+--+-- To complicate matters, the default implementation of 'toEncoding'+-- uses 'toJSON'.  Why?  The 'toEncoding' method was added to this+-- library much more recently than 'toJSON'.  Using 'toJSON' ensures+-- that packages written against older versions of this library will+-- compile and produce correct output, but they will not see any+-- speedup from direct encoding.+--+-- To write a minimal implementation of direct encoding, your type+-- must implement GHC's 'Generic' class, and your code should look+-- like this:+--+-- @+--     'toEncoding' = 'genericToEncoding' 'defaultOptions'+-- @+--+-- What if you have more elaborate encoding needs?  For example,+-- perhaps you need to change the names of object keys, omit parts of+-- a value.+--+-- To encode to a JSON \"object\", use the 'pairs' function.+--+-- @+--     'toEncoding' (Person name age) =+--         'pairs' (\"name\" '.=' 'name' '<>' \"age\" '.=' age)+-- @+--+-- Any container type that implements 'Foldable' can be encoded to a+-- JSON \"array\" using 'foldable'.+--+-- > > import Data.Sequence as Seq+-- > > encode (Seq.fromList [1,2,3])+-- > "[1,2,3]"
+ src/Data/Aeson/Encode.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- |+-- Module:      Data.Aeson.Encode+-- Copyright:   (c) 2012-2016 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- This module is left to supply limited backwards-compatibility.++module Data.Aeson.Encode {-# DEPRECATED "Use Data.Aeson or Data.Aeson.Text instead" #-}+    (+      encode+    , encodeToTextBuilder+    ) where+++import Data.ByteString.Lazy (ByteString)+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Aeson as A+import qualified Data.Aeson.Text as A++encode :: A.ToJSON a => a -> ByteString+encode = A.encode+{-# DEPRECATED encode "Use encode from Data.Aeson" #-}++encodeToTextBuilder :: A.Value -> Builder+encodeToTextBuilder = A.encodeToTextBuilder+{-# DEPRECATED encodeToTextBuilder "Use encodeTotextBuilder from Data.Aeson.Text" #-}
+ src/Data/Aeson/Encoding.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- |+--+-- Functions in this module return well-formed 'Encoding''.+-- Polymorphic variants, which return @'Encoding' a@, return a textual JSON+-- value, so it can be used as both @'Encoding'' 'Text'@ and @'Encoding' = 'Encoding'' 'Value'@.++module Data.Aeson.Encoding+    (+    -- * Encoding+      Encoding+    , Encoding'+    , encodingToLazyByteString+    , fromEncoding+    , unsafeToEncoding+    , Series+    , pairs+    , pair+    , pairStr+    , pair'+    -- * Predicates+    , nullEncoding+    -- * Encoding constructors+    , emptyArray_+    , emptyObject_+    , text+    , lazyText+    , string+    , list+    , dict+    , null_+    , bool+    -- ** Decimal numbers+    , int8, int16, int32, int64, int+    , word8, word16, word32, word64, word+    , integer, float, double, scientific++    -- ** Decimal numbers as Text+    , int8Text, int16Text, int32Text, int64Text, intText+    , word8Text, word16Text, word32Text, word64Text, wordText+    , integerText, floatText, doubleText, scientificText++    -- ** Time+    , day+    , month+    , quarter+    , localTime+    , utcTime+    , timeOfDay+    , zonedTime++    -- ** value+    , value+    ) where+++import Data.Aeson.Encoding.Internal
+ src/Data/Aeson/Encoding/Builder.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TupleSections #-}+-- |+-- Module:      Data.Aeson.Encoding.Builder+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2013 Simon Meier <iridcode@gmail.com>+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Efficiently serialize a JSON value using the UTF-8 encoding.++module Data.Aeson.Encoding.Builder+    (+      encodeToBuilder+    , null_+    , bool+    , array+    , emptyArray_+    , emptyObject_+    , object+    , text+    , string+    , unquoted+    , quote+    , scientific+    , day+    , month+    , quarter+    , localTime+    , utcTime+    , timeOfDay+    , zonedTime+    , ascii2+    , ascii4+    , ascii5+    ) where++import Prelude.Compat++import Data.Aeson.Internal.Time+import Data.Aeson.Types.Internal (Value (..))+import Data.ByteString.Builder as B+import Data.ByteString.Builder.Prim as BP+import Data.ByteString.Builder.Scientific (scientificBuilder)+import Data.Char (chr, ord)+import Data.Scientific (Scientific, base10Exponent, coefficient)+import Data.Text.Encoding (encodeUtf8BuilderEscaped)+import Data.Time (UTCTime(..))+import Data.Time.Calendar (Day(..), toGregorian)+import Data.Time.Calendar.Month.Compat (Month, toYearMonth)+import Data.Time.Calendar.Quarter.Compat (Quarter, toYearQuarter, QuarterOfYear (..))+import Data.Time.LocalTime+import Data.Word (Word8)+import qualified Data.HashMap.Strict as HMS+import qualified Data.Text as T+import qualified Data.Vector as V++-- | Encode a JSON value to a "Data.ByteString" 'B.Builder'.+--+-- Use this function if you are encoding over the wire, or need to+-- prepend or append further bytes to the encoded JSON value.+encodeToBuilder :: Value -> Builder+encodeToBuilder Null       = null_+encodeToBuilder (Bool b)   = bool b+encodeToBuilder (Number n) = scientific n+encodeToBuilder (String s) = text s+encodeToBuilder (Array v)  = array v+encodeToBuilder (Object m) = object m++-- | Encode a JSON null.+null_ :: Builder+null_ = BP.primBounded (ascii4 ('n',('u',('l','l')))) ()++-- | Encode a JSON boolean.+bool :: Bool -> Builder+bool = BP.primBounded (BP.condB id (ascii4 ('t',('r',('u','e'))))+                                   (ascii5 ('f',('a',('l',('s','e'))))))++-- | Encode a JSON array.+array :: V.Vector Value -> Builder+array v+  | V.null v  = emptyArray_+  | otherwise = B.char8 '[' <>+                encodeToBuilder (V.unsafeHead v) <>+                V.foldr withComma (B.char8 ']') (V.unsafeTail v)+  where+    withComma a z = B.char8 ',' <> encodeToBuilder a <> z++-- Encode a JSON object.+object :: HMS.HashMap T.Text Value -> Builder+object m = case HMS.toList m of+    (x:xs) -> B.char8 '{' <> one x <> foldr withComma (B.char8 '}') xs+    _      -> emptyObject_+  where+    withComma a z = B.char8 ',' <> one a <> z+    one (k,v)     = text k <> B.char8 ':' <> encodeToBuilder v++-- | Encode a JSON string.+text :: T.Text -> Builder+text t = B.char8 '"' <> unquoted t <> B.char8 '"'++-- | Encode a JSON string, without enclosing quotes.+unquoted :: T.Text -> Builder+unquoted = encodeUtf8BuilderEscaped escapeAscii++-- | Add quotes surrounding a builder+quote :: Builder -> Builder+quote b = B.char8 '"' <> b <> B.char8 '"'++-- | Encode a JSON string.+string :: String -> Builder+string t = B.char8 '"' <> BP.primMapListBounded go t <> B.char8 '"'+  where go = BP.condB (> '\x7f') BP.charUtf8 (c2w >$< escapeAscii)++escapeAscii :: BP.BoundedPrim Word8+escapeAscii =+    BP.condB (== c2w '\\'  ) (ascii2 ('\\','\\')) $+    BP.condB (== c2w '\"'  ) (ascii2 ('\\','"' )) $+    BP.condB (>= c2w '\x20') (BP.liftFixedToBounded BP.word8) $+    BP.condB (== c2w '\n'  ) (ascii2 ('\\','n' )) $+    BP.condB (== c2w '\r'  ) (ascii2 ('\\','r' )) $+    BP.condB (== c2w '\t'  ) (ascii2 ('\\','t' )) $+    BP.liftFixedToBounded hexEscape -- fallback for chars < 0x20+  where+    hexEscape :: BP.FixedPrim Word8+    hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$<+        BP.char8 >*< BP.char8 >*< BP.word16HexFixed+{-# INLINE escapeAscii #-}++c2w :: Char -> Word8+c2w c = fromIntegral (ord c)++-- | Encode a JSON number.+scientific :: Scientific -> Builder+scientific s+    | e < 0 || e > 1024 = scientificBuilder s+    | otherwise = B.integerDec (coefficient s * 10 ^ e)+  where+    e = base10Exponent s++emptyArray_ :: Builder+emptyArray_ = BP.primBounded (ascii2 ('[',']')) ()++emptyObject_ :: Builder+emptyObject_ = BP.primBounded (ascii2 ('{','}')) ()++ascii2 :: (Char, Char) -> BP.BoundedPrim a+ascii2 cs = BP.liftFixedToBounded $ const cs BP.>$< BP.char7 >*< BP.char7+{-# INLINE ascii2 #-}++ascii3 :: (Char, (Char, Char)) -> BP.BoundedPrim a+ascii3 cs = BP.liftFixedToBounded $ const cs >$<+    BP.char7 >*< BP.char7 >*< BP.char7+{-# INLINE ascii3 #-}++ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a+ascii4 cs = BP.liftFixedToBounded $ const cs >$<+    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7+{-# INLINE ascii4 #-}++ascii5 :: (Char, (Char, (Char, (Char, Char)))) -> BP.BoundedPrim a+ascii5 cs = BP.liftFixedToBounded $ const cs >$<+    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7+{-# INLINE ascii5 #-}++ascii6 :: (Char, (Char, (Char, (Char, (Char, Char))))) -> BP.BoundedPrim a+ascii6 cs = BP.liftFixedToBounded $ const cs >$<+    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7+{-# INLINE ascii6 #-}++ascii8 :: (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))+       -> BP.BoundedPrim a+ascii8 cs = BP.liftFixedToBounded $ const cs >$<+    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*<+    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7+{-# INLINE ascii8 #-}++day :: Day -> Builder+day dd = encodeYear yr <>+         BP.primBounded (ascii6 ('-',(mh,(ml,('-',(dh,dl)))))) ()+  where (yr,m,d)    = toGregorian dd+        !(T mh ml)  = twoDigits m+        !(T dh dl)  = twoDigits d+{-# INLINE day #-}++month :: Month -> Builder+month mm = encodeYear yr <>+           BP.primBounded (ascii3 ('-',(mh,ml))) ()+  where (yr,m) = toYearMonth mm+        !(T mh ml) = twoDigits m+{-# INLINE month #-}++quarter :: Quarter -> Builder+quarter qq = encodeYear yr <>+             BP.primBounded (ascii3 ('-',('q',qd))) ()+  where (yr,q) = toYearQuarter qq+        qd = case q of+            Q1 -> '1'+            Q2 -> '2'+            Q3 -> '3'+            Q4 -> '4'+{-# INLINE quarter #-}++-- | Used in encoding day, month, quarter+encodeYear :: Integer -> Builder+encodeYear y+    | y >= 1000 = B.integerDec y+    | y >= 0    = BP.primBounded (ascii4 (padYear y)) ()+    | y >= -999 = BP.primBounded (ascii5 ('-',padYear (- y))) ()+    | otherwise = B.integerDec y+  where+    padYear y' =+        let (ab,c) = fromIntegral y' `quotRem` 10+            (a,b)  = ab `quotRem` 10+        in ('0',(digit a,(digit b,digit c)))+{-# INLINE encodeYear #-}++timeOfDay :: TimeOfDay -> Builder+timeOfDay t = timeOfDay64 (toTimeOfDay64 t)+{-# INLINE timeOfDay #-}++timeOfDay64 :: TimeOfDay64 -> Builder+timeOfDay64 (TOD h m s)+  | frac == 0 = hhmmss -- omit subseconds if 0+  | otherwise = hhmmss <> BP.primBounded showFrac frac+  where+    hhmmss  = BP.primBounded (ascii8 (hh,(hl,(':',(mh,(ml,(':',(sh,sl)))))))) ()+    !(T hh hl)  = twoDigits h+    !(T mh ml)  = twoDigits m+    !(T sh sl)  = twoDigits (fromIntegral real)+    (real,frac) = s `quotRem` pico+    showFrac = ('.',) >$< (BP.liftFixedToBounded BP.char7 >*< trunc12)+    trunc12 = (`quotRem` micro) >$<+              BP.condB (\(_,y) -> y == 0) (fst >$< trunc6) (digits6 >*< trunc6)+    digits6 = ((`quotRem` milli) . fromIntegral) >$< (digits3 >*< digits3)+    trunc6  = ((`quotRem` milli) . fromIntegral) >$<+              BP.condB (\(_,y) -> y == 0) (fst >$< trunc3) (digits3 >*< trunc3)+    digits3 = (`quotRem` 10) >$< (digits2 >*< digits1)+    digits2 = (`quotRem` 10) >$< (digits1 >*< digits1)+    digits1 = BP.liftFixedToBounded (digit >$< BP.char7)+    trunc3  = BP.condB (== 0) BP.emptyB $+              (`quotRem` 100) >$< (digits1 >*< trunc2)+    trunc2  = BP.condB (== 0) BP.emptyB $+              (`quotRem` 10)  >$< (digits1 >*< trunc1)+    trunc1  = BP.condB (== 0) BP.emptyB digits1++    pico       = 1000000000000 -- number of picoseconds  in 1 second+    micro      =       1000000 -- number of microseconds in 1 second+    milli      =          1000 -- number of milliseconds in 1 second++timeZone :: TimeZone -> Builder+timeZone (TimeZone off _ _)+  | off == 0  = B.char7 'Z'+  | otherwise = BP.primBounded (ascii6 (s,(hh,(hl,(':',(mh,ml)))))) ()+  where !s         = if off < 0 then '-' else '+'+        !(T hh hl) = twoDigits h+        !(T mh ml) = twoDigits m+        (h,m)      = abs off `quotRem` 60+{-# INLINE timeZone #-}++dayTime :: Day -> TimeOfDay64 -> Builder+dayTime d t = day d <> B.char7 'T' <> timeOfDay64 t+{-# INLINE dayTime #-}++utcTime :: UTCTime -> B.Builder+utcTime (UTCTime d s) = dayTime d (diffTimeOfDay64 s) <> B.char7 'Z'+{-# INLINE utcTime #-}++localTime :: LocalTime -> Builder+localTime (LocalTime d t) = dayTime d (toTimeOfDay64 t)+{-# INLINE localTime #-}++zonedTime :: ZonedTime -> Builder+zonedTime (ZonedTime t z) = localTime t <> timeZone z+{-# INLINE zonedTime #-}++data T = T {-# UNPACK #-} !Char {-# UNPACK #-} !Char++twoDigits :: Int -> T+twoDigits a     = T (digit hi) (digit lo)+  where (hi,lo) = a `quotRem` 10++digit :: Int -> Char+digit x = chr (x + 48)
+ src/Data/Aeson/Encoding/Internal.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Data.Aeson.Encoding.Internal+    (+    -- * Encoding+      Encoding' (..)+    , Encoding+    , encodingToLazyByteString+    , unsafeToEncoding+    , retagEncoding+    , Series (..)+    , pairs+    , pair+    , pairStr+    , pair'+    -- * Predicates+    , nullEncoding+    -- * Encoding constructors+    , emptyArray_+    , emptyObject_+    , wrapObject+    , wrapArray+    , null_+    , bool+    , text+    , lazyText+    , string+    , list+    , dict+    , tuple+    , (>*<)+    , InArray+    , empty+    , (><)+    , econcat+    -- ** Decimal numbers+    , int8, int16, int32, int64, int+    , word8, word16, word32, word64, word+    , integer, float, double, scientific+    -- ** Decimal numbers as Text+    , int8Text, int16Text, int32Text, int64Text, intText+    , word8Text, word16Text, word32Text, word64Text, wordText+    , integerText, floatText, doubleText, scientificText+    -- ** Time+    , day+    , month+    , quarter+    , localTime+    , utcTime+    , timeOfDay+    , zonedTime+    -- ** value+    , value+    -- ** JSON tokens+    , comma, colon, openBracket, closeBracket, openCurly, closeCurly+    ) where++import Prelude.Compat++import Data.Aeson.Types.Internal (Value)+import Data.ByteString.Builder (Builder, char7, toLazyByteString)+import Data.Int+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime)+import Data.Time.Calendar.Month.Compat (Month)+import Data.Time.Calendar.Quarter.Compat (Quarter)+import Data.Typeable (Typeable)+import Data.Word+import qualified Data.Aeson.Encoding.Builder as EB+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text.Lazy as LT++-- | An encoding of a JSON value.+--+-- @tag@ represents which kind of JSON the Encoding is encoding to,+-- we reuse 'Text' and 'Value' as tags here.+newtype Encoding' tag = Encoding {+      fromEncoding :: Builder+      -- ^ Acquire the underlying bytestring builder.+    } deriving (Typeable)++-- | Often used synonym for 'Encoding''.+type Encoding = Encoding' Value++-- | Make Encoding from Builder.+--+-- Use with care! You have to make sure that the passed Builder+-- is a valid JSON Encoding!+unsafeToEncoding :: Builder -> Encoding' a+unsafeToEncoding = Encoding++encodingToLazyByteString :: Encoding' a -> BSL.ByteString+encodingToLazyByteString = toLazyByteString . fromEncoding+{-# INLINE encodingToLazyByteString #-}++retagEncoding :: Encoding' a -> Encoding' b+retagEncoding = Encoding . fromEncoding++-------------------------------------------------------------------------------+-- Encoding instances+-------------------------------------------------------------------------------++instance Show (Encoding' a) where+    show (Encoding e) = show (toLazyByteString e)++instance Eq (Encoding' a) where+    Encoding a == Encoding b = toLazyByteString a == toLazyByteString b++instance Ord (Encoding' a) where+    compare (Encoding a) (Encoding b) =+      compare (toLazyByteString a) (toLazyByteString b)++-- | A series of values that, when encoded, should be separated by+-- commas. Since 0.11.0.0, the '.=' operator is overloaded to create+-- either @(Text, Value)@ or 'Series'. You can use Series when+-- encoding directly to a bytestring builder as in the following+-- example:+--+-- > toEncoding (Person name age) = pairs ("name" .= name <> "age" .= age)+data Series = Empty+            | Value (Encoding' Series)+            deriving (Typeable)++pair :: Text -> Encoding -> Series+pair name val = pair' (text name) val+{-# INLINE pair #-}++pairStr :: String -> Encoding -> Series+pairStr name val = pair' (string name) val+{-# INLINE pairStr #-}++pair' :: Encoding' Text -> Encoding -> Series+pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val++instance Semigroup Series where+    Empty   <> a       = a+    a       <> Empty   = a+    Value a <> Value b = Value (a >< comma >< b)++instance Monoid Series where+    mempty  = Empty+    mappend = (<>)++nullEncoding :: Encoding' a -> Bool+nullEncoding = BSL.null . toLazyByteString . fromEncoding++emptyArray_ :: Encoding+emptyArray_ = Encoding EB.emptyArray_++emptyObject_ :: Encoding+emptyObject_ = Encoding EB.emptyObject_++wrapArray :: Encoding' a -> Encoding+wrapArray e = retagEncoding $ openBracket >< e >< closeBracket++wrapObject :: Encoding' a -> Encoding+wrapObject e = retagEncoding $ openCurly >< e >< closeCurly++null_ :: Encoding+null_ = Encoding EB.null_++bool :: Bool -> Encoding+bool True = Encoding "true"+bool False = Encoding "false"++-- | Encode a series of key/value pairs, separated by commas.+pairs :: Series -> Encoding+pairs (Value v) = openCurly >< retagEncoding v >< closeCurly+pairs Empty     = emptyObject_+{-# INLINE pairs #-}++list :: (a -> Encoding) -> [a] -> Encoding+list _  []     = emptyArray_+list to' (x:xs) = openBracket >< to' x >< commas xs >< closeBracket+  where+    commas = foldr (\v vs -> comma >< to' v >< vs) empty+{-# INLINE list #-}++-- | Encode as JSON object+dict+    :: (k -> Encoding' Text)                     -- ^ key encoding+    -> (v -> Encoding)                                -- ^ value encoding+    -> (forall a. (k -> v -> a -> a) -> a -> m -> a)  -- ^ @foldrWithKey@ - indexed fold+    -> m                                              -- ^ container+    -> Encoding+dict encodeKey encodeVal foldrWithKey = pairs . foldrWithKey go mempty+  where+    go k v c = Value (encodeKV k v) <> c+    encodeKV k v = retagEncoding (encodeKey k) >< colon >< retagEncoding (encodeVal v)+{-# INLINE dict #-}++-- | Type tag for tuples contents, see 'tuple'.+data InArray++infixr 6 >*<+-- | See 'tuple'.+(>*<) :: Encoding' a -> Encoding' b -> Encoding' InArray+a >*< b = retagEncoding a >< comma >< retagEncoding b+{-# INLINE (>*<) #-}++empty :: Encoding' a+empty = Encoding mempty++econcat :: [Encoding' a] -> Encoding' a+econcat = foldr (><) empty++infixr 6 ><+(><) :: Encoding' a -> Encoding' a -> Encoding' a+Encoding a >< Encoding b = Encoding (a <> b)+{-# INLINE (><) #-}++-- | Encode as a tuple.+--+-- @+-- toEncoding (X a b c) = tuple $+--     toEncoding a >*<+--     toEncoding b >*<+--     toEncoding c+tuple :: Encoding' InArray -> Encoding+tuple b = retagEncoding $ openBracket >< b >< closeBracket+{-# INLINE tuple #-}++text :: Text -> Encoding' a+text = Encoding . EB.text++lazyText :: LT.Text -> Encoding' a+lazyText t = Encoding $+    B.char7 '"' <>+    LT.foldrChunks (\x xs -> EB.unquoted x <> xs) (B.char7 '"') t++string :: String -> Encoding' a+string = Encoding . EB.string++-------------------------------------------------------------------------------+-- chars+-------------------------------------------------------------------------------++comma, colon, openBracket, closeBracket, openCurly, closeCurly :: Encoding' a+comma        = Encoding $ char7 ','+colon        = Encoding $ char7 ':'+openBracket  = Encoding $ char7 '['+closeBracket = Encoding $ char7 ']'+openCurly    = Encoding $ char7 '{'+closeCurly   = Encoding $ char7 '}'++-------------------------------------------------------------------------------+-- Decimal numbers+-------------------------------------------------------------------------------++int8 :: Int8 -> Encoding+int8 = Encoding . B.int8Dec++int16 :: Int16 -> Encoding+int16 = Encoding . B.int16Dec++int32 :: Int32 -> Encoding+int32 = Encoding . B.int32Dec++int64 :: Int64 -> Encoding+int64 = Encoding . B.int64Dec++int :: Int -> Encoding+int = Encoding . B.intDec++word8 :: Word8 -> Encoding+word8 = Encoding . B.word8Dec++word16 :: Word16 -> Encoding+word16 = Encoding . B.word16Dec++word32 :: Word32 -> Encoding+word32 = Encoding . B.word32Dec++word64 :: Word64 -> Encoding+word64 = Encoding . B.word64Dec++word :: Word -> Encoding+word = Encoding . B.wordDec++integer :: Integer -> Encoding+integer = Encoding . B.integerDec++float :: Float -> Encoding+float = realFloatToEncoding $ Encoding . B.floatDec++double :: Double -> Encoding+double = realFloatToEncoding $ Encoding . B.doubleDec++scientific :: Scientific -> Encoding+scientific = Encoding . EB.scientific++realFloatToEncoding :: RealFloat a => (a -> Encoding) -> a -> Encoding+realFloatToEncoding e d+    | isNaN d || isInfinite d = null_+    | otherwise               = e d+{-# INLINE realFloatToEncoding #-}++-------------------------------------------------------------------------------+-- Decimal numbers as Text+-------------------------------------------------------------------------------++int8Text :: Int8 -> Encoding' a+int8Text = Encoding . EB.quote . B.int8Dec++int16Text :: Int16 -> Encoding' a+int16Text = Encoding . EB.quote . B.int16Dec++int32Text :: Int32 -> Encoding' a+int32Text = Encoding . EB.quote . B.int32Dec++int64Text :: Int64 -> Encoding' a+int64Text = Encoding . EB.quote . B.int64Dec++intText :: Int -> Encoding' a+intText = Encoding . EB.quote . B.intDec++word8Text :: Word8 -> Encoding' a+word8Text = Encoding . EB.quote . B.word8Dec++word16Text :: Word16 -> Encoding' a+word16Text = Encoding . EB.quote . B.word16Dec++word32Text :: Word32 -> Encoding' a+word32Text = Encoding . EB.quote . B.word32Dec++word64Text :: Word64 -> Encoding' a+word64Text = Encoding . EB.quote . B.word64Dec++wordText :: Word -> Encoding' a+wordText = Encoding . EB.quote . B.wordDec++integerText :: Integer -> Encoding' a+integerText = Encoding . EB.quote . B.integerDec++floatText :: Float -> Encoding' a+floatText = Encoding . EB.quote . B.floatDec++doubleText :: Double -> Encoding' a+doubleText = Encoding . EB.quote . B.doubleDec++scientificText :: Scientific -> Encoding' a+scientificText = Encoding . EB.quote . EB.scientific++-------------------------------------------------------------------------------+-- time+-------------------------------------------------------------------------------++day :: Day -> Encoding' a+day = Encoding . EB.quote . EB.day++month :: Month -> Encoding' a+month = Encoding . EB.quote . EB.month++quarter :: Quarter -> Encoding' a+quarter = Encoding . EB.quote . EB.quarter++localTime :: LocalTime -> Encoding' a+localTime = Encoding . EB.quote . EB.localTime++utcTime :: UTCTime -> Encoding' a+utcTime = Encoding . EB.quote . EB.utcTime++timeOfDay :: TimeOfDay -> Encoding' a+timeOfDay = Encoding . EB.quote . EB.timeOfDay++zonedTime :: ZonedTime -> Encoding' a+zonedTime = Encoding . EB.quote . EB.zonedTime++-------------------------------------------------------------------------------+-- Value+-------------------------------------------------------------------------------++value :: Value -> Encoding+value = Encoding . EB.encodeToBuilder
+ src/Data/Aeson/Internal.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- |+-- Module:      Data.Aeson.Internal+-- Copyright:   (c) 2015-2016 Bryan O'Sullivan+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Internal types and functions.+--+-- __Note__: all declarations in this module are unstable, and prone+-- to being changed at any time.++module Data.Aeson.Internal+    (+      IResult(..)+    , JSONPathElement(..)+    , JSONPath+    , (<?>)+    , formatError+    , ifromJSON+    , iparse+    ) where+++import Data.Aeson.Types.Internal+import Data.Aeson.Types.FromJSON (ifromJSON)
+ src/Data/Aeson/Internal/Functions.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- |+-- Module:      Data.Aeson.Functions+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable++module Data.Aeson.Internal.Functions+    (+      mapHashKeyVal+    , mapKeyVal+    , mapKey+    ) where++import Prelude.Compat++import Data.Hashable (Hashable)+import qualified Data.HashMap.Strict as H+import qualified Data.Map as M++-- | Transform a 'M.Map' into a 'H.HashMap' while transforming the keys.+mapHashKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)+              -> M.Map k1 v1 -> H.HashMap k2 v2+mapHashKeyVal fk kv = M.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty+{-# INLINE mapHashKeyVal #-}++-- | Transform the keys and values of a 'H.HashMap'.+mapKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)+          -> H.HashMap k1 v1 -> H.HashMap k2 v2+mapKeyVal fk kv = H.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty+{-# INLINE mapKeyVal #-}++-- | Transform the keys of a 'H.HashMap'.+mapKey :: (Eq k2, Hashable k2) => (k1 -> k2) -> H.HashMap k1 v -> H.HashMap k2 v+mapKey fk = mapKeyVal fk id+{-# INLINE mapKey #-}
+ src/Data/Aeson/Internal/Time.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}++-- |+-- Module:      Data.Aeson.Internal.Time+-- Copyright:   (c) 2015-2016 Bryan O'Sullivan+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable++module Data.Aeson.Internal.Time+    (+      TimeOfDay64(..)+    , fromPico+    , toPico+    , diffTimeOfDay64+    , toTimeOfDay64+    ) where++import Data.Attoparsec.Time.Internal
+ src/Data/Aeson/Parser.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- |+-- Module:      Data.Aeson.Parser+-- Copyright:   (c) 2012-2016 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Efficiently and correctly parse a JSON string.  The string must be+-- encoded as UTF-8.+--+-- It can be useful to think of parsing as occurring in two phases:+--+-- * Identification of the textual boundaries of a JSON value.  This+--   is always strict, so that an invalid JSON document can be+--   rejected as soon as possible.+--+-- * Conversion of a JSON value to a Haskell value.  This may be+--   either immediate (strict) or deferred (lazy); see below for+--   details.+--+-- The question of whether to choose a lazy or strict parser is+-- subtle, but it can have significant performance implications,+-- resulting in changes in CPU use and memory footprint of 30% to 50%,+-- or occasionally more.  Measure the performance of your application+-- with each!++module Data.Aeson.Parser+    (+    -- * Lazy parsers+    -- $lazy+      json+    , value+    , jstring+    , scientific+    -- ** Handling objects with duplicate keys+    , jsonWith+    , jsonLast+    , jsonAccum+    , jsonNoDup+    -- * Strict parsers+    -- $strict+    , json'+    , value'+    -- ** Handling objects with duplicate keys+    , jsonWith'+    , jsonLast'+    , jsonAccum'+    , jsonNoDup'+    -- * Decoding without FromJSON instances+    , decodeWith+    , decodeStrictWith+    , eitherDecodeWith+    , eitherDecodeStrictWith+    ) where+++import Data.Aeson.Parser.Internal++-- $lazy+--+-- The 'json' and 'value' parsers decouple identification from+-- conversion.  Identification occurs immediately (so that an invalid+-- JSON document can be rejected as early as possible), but conversion+-- to a Haskell value is deferred until that value is needed.+--+-- This decoupling can be time-efficient if only a smallish subset of+-- elements in a JSON value need to be inspected, since the cost of+-- conversion is zero for uninspected elements.  The trade off is an+-- increase in memory usage, due to allocation of thunks for values+-- that have not yet been converted.++-- $strict+--+-- The 'json'' and 'value'' parsers combine identification with+-- conversion.  They consume more CPU cycles up front, but have a+-- smaller memory footprint.
+ src/Data/Aeson/Parser/Internal.hs view
@@ -0,0 +1,548 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+#if __GLASGOW_HASKELL__ <= 710 && __GLASGOW_HASKELL__ >= 706+-- Work around a compiler bug+{-# OPTIONS_GHC -fsimpl-tick-factor=300 #-}+#endif+-- |+-- Module:      Data.Aeson.Parser.Internal+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Efficiently and correctly parse a JSON string.  The string must be+-- encoded as UTF-8.++module Data.Aeson.Parser.Internal+    (+    -- * Lazy parsers+      json, jsonEOF+    , jsonWith+    , jsonLast+    , jsonAccum+    , jsonNoDup+    , value+    , jstring+    , jstring_+    , scientific+    -- * Strict parsers+    , json', jsonEOF'+    , jsonWith'+    , jsonLast'+    , jsonAccum'+    , jsonNoDup'+    , value'+    -- * Helpers+    , decodeWith+    , decodeStrictWith+    , eitherDecodeWith+    , eitherDecodeStrictWith+    -- ** Handling objects with duplicate keys+    , fromListAccum+    , parseListNoDup+    ) where++import Prelude.Compat++import Control.Applicative ((<|>))+import Control.Monad (void, when)+import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..))+import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)+import Data.Function (fix)+import Data.Functor.Compat (($>))+import Data.Scientific (Scientific)+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Data.Vector (Vector)+import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.Lazy as L+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as C+import qualified Data.ByteString.Builder as B+import qualified Data.HashMap.Strict as H+import qualified Data.Scientific as Sci+import Data.Aeson.Parser.Unescape (unescapeText)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Aeson.Types++#define BACKSLASH 92+#define CLOSE_CURLY 125+#define CLOSE_SQUARE 93+#define COMMA 44+#define DOUBLE_QUOTE 34+#define OPEN_CURLY 123+#define OPEN_SQUARE 91+#define C_0 48+#define C_9 57+#define C_A 65+#define C_F 70+#define C_a 97+#define C_f 102+#define C_n 110+#define C_t 116++-- | Parse any JSON value.+--+-- The conversion of a parsed value to a Haskell value is deferred+-- until the Haskell value is needed.  This may improve performance if+-- only a subset of the results of conversions are needed, but at a+-- cost in thunk allocation.+--+-- This function is an alias for 'value'. In aeson 0.8 and earlier, it+-- parsed only object or array types, in conformance with the+-- now-obsolete RFC 4627.+--+-- ==== Warning+--+-- If an object contains duplicate keys, only the first one will be kept.+-- For a more flexible alternative, see 'jsonWith'.+json :: Parser Value+json = value++-- | Parse any JSON value.+--+-- This is a strict version of 'json' which avoids building up thunks+-- during parsing; it performs all conversions immediately.  Prefer+-- this version if most of the JSON data needs to be accessed.+--+-- This function is an alias for 'value''. In aeson 0.8 and earlier, it+-- parsed only object or array types, in conformance with the+-- now-obsolete RFC 4627.+--+-- ==== Warning+--+-- If an object contains duplicate keys, only the first one will be kept.+-- For a more flexible alternative, see 'jsonWith''.+json' :: Parser Value+json' = value'++-- Open recursion: object_, object_', array_, array_' are parameterized by the+-- toplevel Value parser to be called recursively, to keep the parameter+-- mkObject outside of the recursive loop for proper inlining.++object_ :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value+object_ mkObject val = {-# SCC "object_" #-} Object <$> objectValues mkObject jstring val+{-# INLINE object_ #-}++object_' :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value+object_' mkObject val' = {-# SCC "object_'" #-} do+  !vals <- objectValues mkObject jstring' val'+  return (Object vals)+ where+  jstring' = do+    !s <- jstring+    return s+{-# INLINE object_' #-}++objectValues :: ([(Text, Value)] -> Either String Object)+             -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)+objectValues mkObject str val = do+  skipSpace+  w <- A.peekWord8'+  if w == CLOSE_CURLY+    then A.anyWord8 >> return H.empty+    else loop []+ where+  -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'+  -- and it's much faster because it's doing in place update to the 'HashMap'!+  loop acc = do+    k <- (str A.<?> "object key") <* skipSpace <* (char ':' A.<?> "':'")+    v <- (val A.<?> "object value") <* skipSpace+    ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_CURLY) A.<?> "',' or '}'"+    let acc' = (k, v) : acc+    if ch == COMMA+      then skipSpace >> loop acc'+      else case mkObject acc' of+        Left err -> fail err+        Right obj -> pure obj+{-# INLINE objectValues #-}++array_ :: Parser Value -> Parser Value+array_ val = {-# SCC "array_" #-} Array <$> arrayValues val+{-# INLINE array_ #-}++array_' :: Parser Value -> Parser Value+array_' val = {-# SCC "array_'" #-} do+  !vals <- arrayValues val+  return (Array vals)+{-# INLINE array_' #-}++arrayValues :: Parser Value -> Parser (Vector Value)+arrayValues val = do+  skipSpace+  w <- A.peekWord8'+  if w == CLOSE_SQUARE+    then A.anyWord8 >> return Vector.empty+    else loop [] 1+  where+    loop acc !len = do+      v <- (val A.<?> "json list value") <* skipSpace+      ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_SQUARE) A.<?> "',' or ']'"+      if ch == COMMA+        then skipSpace >> loop (v:acc) (len+1)+        else return (Vector.reverse (Vector.fromListN len (v:acc)))+{-# INLINE arrayValues #-}++-- | Parse any JSON value. Synonym of 'json'.+value :: Parser Value+value = jsonWith (pure . H.fromList)++-- | Parse any JSON value.+--+-- This parser is parameterized by a function to construct an 'Object'+-- from a raw list of key-value pairs, where duplicates are preserved.+-- The pairs appear in __reverse order__ from the source.+--+-- ==== __Examples__+--+-- 'json' keeps only the first occurence of each key, using 'HashMap.Lazy.fromList'.+--+-- @+-- 'json' = 'jsonWith' ('Right' '.' 'H.fromList')+-- @+--+-- 'jsonLast' keeps the last occurence of each key, using+-- @'HashMap.Lazy.fromListWith' ('const' 'id')@.+--+-- @+-- 'jsonLast' = 'jsonWith' ('Right' '.' 'HashMap.Lazy.fromListWith' ('const' 'id'))+-- @+--+-- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using+-- 'fromListAccum'.+--+-- @+-- 'jsonAccum' = 'jsonWith' ('Right' . 'fromListAccum')+-- @+--+-- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'.+--+-- @+-- 'jsonNoDup' = 'jsonWith' 'parseListNoDup'+-- @+jsonWith :: ([(Text, Value)] -> Either String Object) -> Parser Value+jsonWith mkObject = fix $ \value_ -> do+  skipSpace+  w <- A.peekWord8'+  case w of+    DOUBLE_QUOTE  -> A.anyWord8 *> (String <$> jstring_)+    OPEN_CURLY    -> A.anyWord8 *> object_ mkObject value_+    OPEN_SQUARE   -> A.anyWord8 *> array_ value_+    C_f           -> string "false" $> Bool False+    C_t           -> string "true" $> Bool True+    C_n           -> string "null" $> Null+    _              | w >= 48 && w <= 57 || w == 45+                  -> Number <$> scientific+      | otherwise -> fail "not a valid json value"+{-# INLINE jsonWith #-}++-- | Variant of 'json' which keeps only the last occurence of every key.+jsonLast :: Parser Value+jsonLast = jsonWith (Right . H.fromListWith (const id))++-- | Variant of 'json' wrapping all object mappings in 'Array' to preserve+-- key-value pairs with the same keys.+jsonAccum :: Parser Value+jsonAccum = jsonWith (Right . fromListAccum)++-- | Variant of 'json' which fails if any object contains duplicate keys.+jsonNoDup :: Parser Value+jsonNoDup = jsonWith parseListNoDup++-- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all+-- associated values from the original list @kvs@.+--+-- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)]+-- fromList [("apple",Array [Bool False,Bool True]),("orange",Array [Bool False])]+fromListAccum :: [(Text, Value)] -> Object+fromListAccum =+  fmap (Array . Vector.fromList . ($ [])) . H.fromListWith (.) . (fmap . fmap) (:)++-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.+parseListNoDup :: [(Text, Value)] -> Either String Object+parseListNoDup =+  H.traverseWithKey unwrap . H.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just+  where+    unwrap k Nothing = Left $ "found duplicate key: " ++ show k+    unwrap _ (Just v) = Right v++-- | Strict version of 'value'. Synonym of 'json''.+value' :: Parser Value+value' = jsonWith' (pure . H.fromList)++-- | Strict version of 'jsonWith'.+jsonWith' :: ([(Text, Value)] -> Either String Object) -> Parser Value+jsonWith' mkObject = fix $ \value_ -> do+  skipSpace+  w <- A.peekWord8'+  case w of+    DOUBLE_QUOTE  -> do+                     !s <- A.anyWord8 *> jstring_+                     return (String s)+    OPEN_CURLY    -> A.anyWord8 *> object_' mkObject value_+    OPEN_SQUARE   -> A.anyWord8 *> array_' value_+    C_f           -> string "false" $> Bool False+    C_t           -> string "true" $> Bool True+    C_n           -> string "null" $> Null+    _              | w >= 48 && w <= 57 || w == 45+                  -> do+                     !n <- scientific+                     return (Number n)+      | otherwise -> fail "not a valid json value"+{-# INLINE jsonWith' #-}++-- | Variant of 'json'' which keeps only the last occurence of every key.+jsonLast' :: Parser Value+jsonLast' = jsonWith' (pure . H.fromListWith (const id))++-- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve+-- key-value pairs with the same keys.+jsonAccum' :: Parser Value+jsonAccum' = jsonWith' (pure . fromListAccum)++-- | Variant of 'json'' which fails if any object contains duplicate keys.+jsonNoDup' :: Parser Value+jsonNoDup' = jsonWith' parseListNoDup++-- | Parse a quoted JSON string.+jstring :: Parser Text+jstring = A.word8 DOUBLE_QUOTE *> jstring_++-- | Parse a string without a leading quote.+jstring_ :: Parser Text+{-# INLINE jstring_ #-}+jstring_ = do+  -- not sure whether >= or bit hackery is faster+  -- perfectly, we shouldn't care, it's compiler job.+  s <- A.takeWhile (\w -> w /= DOUBLE_QUOTE && w /= BACKSLASH && w >= 0x20 && w < 0x80)+  let txt = unsafeDecodeASCII s+  mw <- A.peekWord8+  case mw of+    Nothing           -> fail "string without end"+    Just DOUBLE_QUOTE -> A.anyWord8 $> txt+    Just w | w < 0x20 -> fail "unescaped control character"+    _                 -> jstringSlow s++-- | The input is assumed to contain only 7bit ASCII characters (i.e. @< 0x80@).+--   We use TE.decodeLatin1 here because TE.decodeASCII is currently (text-1.2.4.0)+--   deprecated and equal to TE.decodeUtf8, which is slower than TE.decodeLatin1.+unsafeDecodeASCII :: B.ByteString -> Text+unsafeDecodeASCII = TE.decodeLatin1++jstringSlow :: B.ByteString -> Parser Text+{-# INLINE jstringSlow #-}+jstringSlow s' = {-# SCC "jstringSlow" #-} do+  s <- A.scan startState go <* A.anyWord8+  case unescapeText (B.append s' s) of+    Right r  -> return r+    Left err -> fail $ show err+ where+    startState              = False+    go a c+      | a                  = Just False+      | c == DOUBLE_QUOTE  = Nothing+      | otherwise = let a' = c == backslash+                    in Just a'+      where backslash = BACKSLASH++decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a+decodeWith p to s =+    case L.parse p s of+      L.Done _ v -> case to v of+                      Success a -> Just a+                      _         -> Nothing+      _          -> Nothing+{-# INLINE decodeWith #-}++decodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString+                 -> Maybe a+decodeStrictWith p to s =+    case either Error to (A.parseOnly p s) of+      Success a -> Just a+      _         -> Nothing+{-# INLINE decodeStrictWith #-}++eitherDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString+                 -> Either (JSONPath, String) a+eitherDecodeWith p to s =+    case L.parse p s of+      L.Done _ v     -> case to v of+                          ISuccess a      -> Right a+                          IError path msg -> Left (path, msg)+      L.Fail notparsed ctx msg -> Left ([], buildMsg notparsed ctx msg)+  where+    buildMsg :: L.ByteString -> [String] -> String -> String+    buildMsg notYetParsed [] msg = msg ++ formatErrorLine notYetParsed+    buildMsg notYetParsed (expectation:_) msg =+      msg ++ ". Expecting " ++ expectation ++ formatErrorLine notYetParsed+{-# INLINE eitherDecodeWith #-}++-- | Grab the first 100 bytes from the non parsed portion and+-- format to get nicer error messages+formatErrorLine :: L.ByteString -> String+formatErrorLine bs =+  C.unpack .+  -- if formatting results in empty ByteString just return that+  -- otherwise construct the error message with the bytestring builder+  (\bs' ->+     if BSL.null bs'+       then BSL.empty+       else+         B.toLazyByteString $+         B.stringUtf8 " at '" <> B.lazyByteString bs' <> B.stringUtf8 "'"+  ) .+  -- if newline is present cut at that position+  BSL.takeWhile (10 /=) .+  -- remove spaces, CR's, tabs, backslashes and quotes characters+  BSL.filter (`notElem` [9, 13, 32, 34, 47, 92]) .+  -- take 100 bytes+  BSL.take 100 $ bs++eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString+                       -> Either (JSONPath, String) a+eitherDecodeStrictWith p to s =+    case either (IError []) to (A.parseOnly p s) of+      ISuccess a      -> Right a+      IError path msg -> Left (path, msg)+{-# INLINE eitherDecodeStrictWith #-}++-- $lazy+--+-- The 'json' and 'value' parsers decouple identification from+-- conversion.  Identification occurs immediately (so that an invalid+-- JSON document can be rejected as early as possible), but conversion+-- to a Haskell value is deferred until that value is needed.+--+-- This decoupling can be time-efficient if only a smallish subset of+-- elements in a JSON value need to be inspected, since the cost of+-- conversion is zero for uninspected elements.  The trade off is an+-- increase in memory usage, due to allocation of thunks for values+-- that have not yet been converted.++-- $strict+--+-- The 'json'' and 'value'' parsers combine identification with+-- conversion.  They consume more CPU cycles up front, but have a+-- smaller memory footprint.++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input.  See also: 'json'.+jsonEOF :: Parser Value+jsonEOF = json <* skipSpace <* endOfInput++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input.  See also: 'json''.+jsonEOF' :: Parser Value+jsonEOF' = json' <* skipSpace <* endOfInput++-- | The only valid whitespace in a JSON document is space, newline,+-- carriage return, and tab.+skipSpace :: Parser ()+skipSpace = A.skipWhile $ \w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09+{-# INLINE skipSpace #-}++------------------ Copy-pasted and adapted from attoparsec ------------------++-- A strict pair+data SP = SP !Integer {-# UNPACK #-}!Int++decimal0 :: Parser Integer+decimal0 = do+  let zero = 48+  digits <- A.takeWhile1 isDigit_w8+  if B.length digits > 1 && B.unsafeHead digits == zero+    then fail "leading zero"+    else return (bsToInteger digits)++-- | Parse a JSON number.+scientific :: Parser Scientific+scientific = do+  let minus = 45+      plus  = 43+  sign <- A.peekWord8'+  let !positive = sign == plus || sign /= minus+  when (sign == plus || sign == minus) $+    void A.anyWord8++  n <- decimal0++  let f fracDigits = SP (B.foldl' step n fracDigits)+                        (negate $ B.length fracDigits)+      step a w = a * 10 + fromIntegral (w - 48)++  dotty <- A.peekWord8+  -- '.' -> ascii 46+  SP c e <- case dotty of+              Just 46 -> A.anyWord8 *> (f <$> A.takeWhile1 isDigit_w8)+              _       -> pure (SP n 0)++  let !signedCoeff | positive  =  c+                   | otherwise = -c++  let littleE = 101+      bigE    = 69+  (A.satisfy (\ex -> ex == littleE || ex == bigE) *>+      fmap (Sci.scientific signedCoeff . (e +)) (signed decimal)) <|>+    return (Sci.scientific signedCoeff    e)+{-# INLINE scientific #-}++------------------ Copy-pasted and adapted from base ------------------------++bsToInteger :: B.ByteString -> Integer+bsToInteger bs+    | l > 40    = valInteger 10 l [ fromIntegral (w - 48) | w <- B.unpack bs ]+    | otherwise = bsToIntegerSimple bs+  where+    l = B.length bs++bsToIntegerSimple :: B.ByteString -> Integer+bsToIntegerSimple = B.foldl' step 0 where+  step a b = a * 10 + fromIntegral (b - 48) -- 48 = '0'++-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b+-- digits are combined into a single radix b^2 digit. This process is+-- repeated until we are left with a single digit. This algorithm+-- performs well only on large inputs, so we use the simple algorithm+-- for smaller inputs.+valInteger :: Integer -> Int -> [Integer] -> Integer+valInteger = go+  where+    go :: Integer -> Int -> [Integer] -> Integer+    go _ _ []  = 0+    go _ _ [d] = d+    go b l ds+        | l > 40 = b' `seq` go b' l' (combine b ds')+        | otherwise = valSimple b ds+      where+        -- ensure that we have an even number of digits+        -- before we call combine:+        ds' = if even l then ds else 0 : ds+        b' = b * b+        l' = (l + 1) `quot` 2++    combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)+      where+        d = d1 * b + d2+    combine _ []  = []+    combine _ [_] = errorWithoutStackTrace "this should not happen"++-- The following algorithm is only linear for types whose Num operations+-- are in constant time.+valSimple :: Integer -> [Integer] -> Integer+valSimple base = go 0+  where+    go r [] = r+    go r (d : ds) = r' `seq` go r' ds+      where+        r' = r * base + fromIntegral d
+ src/Data/Aeson/Parser/Time.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Aeson.Parser.Time+    (+      run+    , day+    , month+    , quarter+    , localTime+    , timeOfDay+    , timeZone+    , utcTime+    , zonedTime+    ) where++import Prelude.Compat++import Data.Attoparsec.Text (Parser)+import Data.Text (Text)+import Data.Time.Calendar (Day)+import Data.Time.Calendar.Quarter.Compat (Quarter)+import Data.Time.Calendar.Month.Compat (Month)+import Data.Time.Clock (UTCTime(..))+import qualified Data.Aeson.Types.Internal as Aeson+import qualified Data.Attoparsec.Text as A+import qualified Data.Attoparsec.Time as T+import qualified Data.Time.LocalTime as Local++-- | Run an attoparsec parser as an aeson parser.+run :: Parser a -> Text -> Aeson.Parser a+run p t = case A.parseOnly (p <* A.endOfInput) t of+            Left err -> fail $ "could not parse date: " ++ err+            Right r  -> return r++-- | Parse a date of the form @[+,-]YYYY-MM-DD@.+day :: Parser Day+day = T.day+{-# INLINE day #-}++-- | Parse a date of the form @[+,-]YYYY-MM@.+month :: Parser Month+month = T.month+{-# INLINE month #-}++-- | Parse a date of the form @[+,-]YYYY-QN@.+quarter :: Parser Quarter+quarter = T.quarter+{-# INLINE quarter #-}++-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.+timeOfDay :: Parser Local.TimeOfDay+timeOfDay = T.timeOfDay+{-# INLINE timeOfDay #-}++-- | Parse a quarter of the form @[+,-]YYYY-QN@.++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZone :: Parser (Maybe Local.TimeZone)+timeZone = T.timeZone+{-# INLINE timeZone #-}++-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@.+-- The space may be replaced with a @T@.  The number of seconds is optional+-- and may be followed by a fractional component.+localTime :: Parser Local.LocalTime+localTime = T.localTime+{-# INLINE localTime #-}++-- | Behaves as 'zonedTime', but converts any time zone offset into a+-- UTC time.+utcTime :: Parser UTCTime+utcTime = T.utcTime+{-# INLINE utcTime #-}++-- | Parse a date with time zone info. Acceptable formats:+--+-- @YYYY-MM-DD HH:MM Z@+-- @YYYY-MM-DD HH:MM:SS Z@+-- @YYYY-MM-DD HH:MM:SS.SSS Z@+--+-- The first space may instead be a @T@, and the second space is+-- optional.  The @Z@ represents UTC.  The @Z@ may be replaced with a+-- time zone offset of the form @+0000@ or @-08:00@, where the first+-- two digits are hours, the @:@ is optional and the second two digits+-- (also optional) are minutes.+zonedTime :: Parser Local.ZonedTime+zonedTime = T.zonedTime+{-# INLINE zonedTime #-}
+ src/Data/Aeson/Parser/Unescape.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE CPP #-}+module Data.Aeson.Parser.Unescape+  (+    unescapeText+  ) where++#ifdef CFFI+import Data.Aeson.Parser.UnescapeFFI (unescapeText)+#else+import Data.Aeson.Parser.UnescapePure (unescapeText)+#endif
+ src/Data/Aeson/QQ/Simple.hs view
@@ -0,0 +1,25 @@+-- | Like @<https://hackage.haskell.org/package/aeson-qq/docs/Data-Aeson-QQ.html Data.Aeson.QQ>@ but without interpolation.+module Data.Aeson.QQ.Simple (aesonQQ) where++import           Data.Aeson+import qualified Data.Text                  as T+import qualified Data.Text.Encoding         as TE+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           Language.Haskell.TH.Syntax (Lift (..))+import           Prelude                    ()+import           Prelude.Compat++aesonQQ :: QuasiQuoter+aesonQQ = QuasiQuoter+    { quoteExp  = aesonExp+    , quotePat  = const $ error "No quotePat defined for jsonQQ"+    , quoteType = const $ error "No quoteType defined for jsonQQ"+    , quoteDec  = const $ error "No quoteDec defined for jsonQQ"+    }++aesonExp :: String -> ExpQ+aesonExp txt =+  case eitherDecodeStrict $ TE.encodeUtf8 $ T.pack txt of+    Left err  -> error $ "Error in aesonExp: " ++ show err+    Right val -> lift (val :: Value)
+ src/Data/Aeson/TH.hs view
@@ -0,0 +1,2019 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ >= 800+-- a) THQ works on cross-compilers and unregisterised GHCs+-- b) may make compilation faster as no dynamic loading is ever needed (not sure about this)+-- c) removes one hindrance to have code inferred as SafeHaskell safe+{-# LANGUAGE TemplateHaskellQuotes #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif++#include "incoherent-compat.h"+#include "overlapping-compat.h"++{-|+Module:      Data.Aeson.TH+Copyright:   (c) 2011-2016 Bryan O'Sullivan+             (c) 2011 MailRank, Inc.+License:     BSD3+Stability:   experimental+Portability: portable++Functions to mechanically derive 'ToJSON' and 'FromJSON' instances. Note that+you need to enable the @TemplateHaskell@ language extension in order to use this+module.++An example shows how instances are generated for arbitrary data types. First we+define a data type:++@+data D a = Nullary+         | Unary Int+         | Product String Char a+         | Record { testOne   :: Double+                  , testTwo   :: Bool+                  , testThree :: D a+                  } deriving Eq+@++Next we derive the necessary instances. Note that we make use of the+feature to change record field names. In this case we drop the first 4+characters of every field name. We also modify constructor names by+lower-casing them:++@+$('deriveJSON' 'defaultOptions'{'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower} ''D)+@++Now we can use the newly created instances.++@+d :: D 'Int'+d = Record { testOne = 3.14159+           , testTwo = 'True'+           , testThree = Product \"test\" \'A\' 123+           }+@++@+fromJSON (toJSON d) == Success d+@++This also works for data family instances, but instead of passing in the data+family name (with double quotes), we pass in a data family instance+constructor (with a single quote):++@+data family DF a+data instance DF Int = DF1 Int+                     | DF2 Int Int+                     deriving Eq++$('deriveJSON' 'defaultOptions' 'DF1)+-- Alternatively, one could pass 'DF2 instead+@++Please note that you can derive instances for tuples using the following syntax:++@+-- FromJSON and ToJSON instances for 4-tuples.+$('deriveJSON' 'defaultOptions' ''(,,,))+@++-}+module Data.Aeson.TH+    (+      -- * Encoding configuration+      Options(..)+    , SumEncoding(..)+    , defaultOptions+    , defaultTaggedObject++     -- * FromJSON and ToJSON derivation+    , deriveJSON+    , deriveJSON1+    , deriveJSON2++    , deriveToJSON+    , deriveToJSON1+    , deriveToJSON2+    , deriveFromJSON+    , deriveFromJSON1+    , deriveFromJSON2++    , mkToJSON+    , mkLiftToJSON+    , mkLiftToJSON2+    , mkToEncoding+    , mkLiftToEncoding+    , mkLiftToEncoding2+    , mkParseJSON+    , mkLiftParseJSON+    , mkLiftParseJSON2+    ) where++import Prelude.Compat hiding (fail)++-- We don't have MonadFail Q, so we should use `fail` from real `Prelude`+import Prelude (fail)++import Control.Applicative ((<|>))+import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))+import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)+import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))+import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)+import Data.Aeson.Types.ToJSON (fromPairs, pair)+import Control.Monad (liftM2, unless, when)+import Data.Foldable (foldr')+#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)+import Data.List (nub)+#endif+import Data.List (foldl', genericLength, intercalate, partition, union)+import Data.List.NonEmpty ((<|), NonEmpty((:|)))+import Data.Map (Map)+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)+import qualified Data.Monoid as Monoid+import Data.Set (Set)+import Language.Haskell.TH hiding (Arity)+import Language.Haskell.TH.Datatype+#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))+import Language.Haskell.TH.Syntax (mkNameG_tc)+#endif+import Text.Printf (printf)+import qualified Data.Aeson.Encoding.Internal as E+import qualified Data.Foldable as F (all)+import qualified Data.HashMap.Strict as H (difference, fromList, keys, lookup, toList)+import qualified Data.List.NonEmpty as NE (length, reverse)+import qualified Data.Map as M (fromList, keys, lookup , singleton, size)+import qualified Data.Semigroup as Semigroup (Option(..))+import qualified Data.Set as Set (empty, insert, member)+import qualified Data.Text as T (Text, pack, unpack)+import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)+import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)++--------------------------------------------------------------------------------+-- Convenience+--------------------------------------------------------------------------------++-- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given+-- data type or data family instance constructor.+--+-- This is a convienience function which is equivalent to calling both+-- 'deriveToJSON' and 'deriveFromJSON'.+deriveJSON :: Options+           -- ^ Encoding options.+           -> Name+           -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'+           -- instances.+           -> Q [Dec]+deriveJSON = deriveJSONBoth deriveToJSON deriveFromJSON++-- | Generates both 'ToJSON1' and 'FromJSON1' instance declarations for the given+-- data type or data family instance constructor.+--+-- This is a convienience function which is equivalent to calling both+-- 'deriveToJSON1' and 'deriveFromJSON1'.+deriveJSON1 :: Options+            -- ^ Encoding options.+            -> Name+            -- ^ Name of the type for which to generate 'ToJSON1' and 'FromJSON1'+            -- instances.+            -> Q [Dec]+deriveJSON1 = deriveJSONBoth deriveToJSON1 deriveFromJSON1++-- | Generates both 'ToJSON2' and 'FromJSON2' instance declarations for the given+-- data type or data family instance constructor.+--+-- This is a convienience function which is equivalent to calling both+-- 'deriveToJSON2' and 'deriveFromJSON2'.+deriveJSON2 :: Options+            -- ^ Encoding options.+            -> Name+            -- ^ Name of the type for which to generate 'ToJSON2' and 'FromJSON2'+            -- instances.+            -> Q [Dec]+deriveJSON2 = deriveJSONBoth deriveToJSON2 deriveFromJSON2++--------------------------------------------------------------------------------+-- ToJSON+--------------------------------------------------------------------------------++{-+TODO: Don't constrain phantom type variables.++data Foo a = Foo Int+instance (ToJSON a) ⇒ ToJSON Foo where ...++The above (ToJSON a) constraint is not necessary and perhaps undesirable.+-}++-- | Generates a 'ToJSON' instance declaration for the given data type or+-- data family instance constructor.+deriveToJSON :: Options+             -- ^ Encoding options.+             -> Name+             -- ^ Name of the type for which to generate a 'ToJSON' instance+             -- declaration.+             -> Q [Dec]+deriveToJSON = deriveToJSONCommon toJSONClass++-- | Generates a 'ToJSON1' instance declaration for the given data type or+-- data family instance constructor.+deriveToJSON1 :: Options+              -- ^ Encoding options.+              -> Name+              -- ^ Name of the type for which to generate a 'ToJSON1' instance+              -- declaration.+              -> Q [Dec]+deriveToJSON1 = deriveToJSONCommon toJSON1Class++-- | Generates a 'ToJSON2' instance declaration for the given data type or+-- data family instance constructor.+deriveToJSON2 :: Options+              -- ^ Encoding options.+              -> Name+              -- ^ Name of the type for which to generate a 'ToJSON2' instance+              -- declaration.+              -> Q [Dec]+deriveToJSON2 = deriveToJSONCommon toJSON2Class++deriveToJSONCommon :: JSONClass+                   -- ^ The ToJSON variant being derived.+                   -> Options+                   -- ^ Encoding options.+                   -> Name+                   -- ^ Name of the type for which to generate an instance.+                   -> Q [Dec]+deriveToJSONCommon = deriveJSONClass [ (ToJSON,     \jc _ -> consToValue Value jc)+                                     , (ToEncoding, \jc _ -> consToValue Encoding jc)+                                     ]++-- | Generates a lambda expression which encodes the given data type or+-- data family instance constructor as a 'Value'.+mkToJSON :: Options -- ^ Encoding options.+         -> Name -- ^ Name of the type to encode.+         -> Q Exp+mkToJSON = mkToJSONCommon toJSONClass++-- | Generates a lambda expression which encodes the given data type or+-- data family instance constructor as a 'Value' by using the given encoding+-- function on occurrences of the last type parameter.+mkLiftToJSON :: Options -- ^ Encoding options.+             -> Name -- ^ Name of the type to encode.+             -> Q Exp+mkLiftToJSON = mkToJSONCommon toJSON1Class++-- | Generates a lambda expression which encodes the given data type or+-- data family instance constructor as a 'Value' by using the given encoding+-- functions on occurrences of the last two type parameters.+mkLiftToJSON2 :: Options -- ^ Encoding options.+              -> Name -- ^ Name of the type to encode.+              -> Q Exp+mkLiftToJSON2 = mkToJSONCommon toJSON2Class++mkToJSONCommon :: JSONClass -- ^ Which class's method is being derived.+               -> Options -- ^ Encoding options.+               -> Name -- ^ Name of the encoded type.+               -> Q Exp+mkToJSONCommon = mkFunCommon (\jc _ -> consToValue Value jc)++-- | Generates a lambda expression which encodes the given data type or+-- data family instance constructor as a JSON string.+mkToEncoding :: Options -- ^ Encoding options.+             -> Name -- ^ Name of the type to encode.+             -> Q Exp+mkToEncoding = mkToEncodingCommon toJSONClass++-- | Generates a lambda expression which encodes the given data type or+-- data family instance constructor as a JSON string by using the given encoding+-- function on occurrences of the last type parameter.+mkLiftToEncoding :: Options -- ^ Encoding options.+                 -> Name -- ^ Name of the type to encode.+                 -> Q Exp+mkLiftToEncoding = mkToEncodingCommon toJSON1Class++-- | Generates a lambda expression which encodes the given data type or+-- data family instance constructor as a JSON string by using the given encoding+-- functions on occurrences of the last two type parameters.+mkLiftToEncoding2 :: Options -- ^ Encoding options.+                  -> Name -- ^ Name of the type to encode.+                  -> Q Exp+mkLiftToEncoding2 = mkToEncodingCommon toJSON2Class++mkToEncodingCommon :: JSONClass -- ^ Which class's method is being derived.+                   -> Options -- ^ Encoding options.+                   -> Name -- ^ Name of the encoded type.+                   -> Q Exp+mkToEncodingCommon = mkFunCommon (\jc _ -> consToValue Encoding jc)++-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates+-- code to generate a 'Value' or 'Encoding' of a number of constructors. All+-- constructors must be from the same type.+consToValue :: ToJSONFun+            -- ^ The method ('toJSON' or 'toEncoding') being derived.+            -> JSONClass+            -- ^ The ToJSON variant being derived.+            -> Options+            -- ^ Encoding options.+            -> [Type]+            -- ^ The types from the data type/data family instance declaration+            -> [ConstructorInfo]+            -- ^ Constructors for which to generate JSON generating code.+            -> Q Exp++consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "+                             ++ "Not a single constructor given!"++consToValue target jc opts instTys cons = do+    value <- newName "value"+    tjs   <- newNameList "_tj"  $ arityInt jc+    tjls  <- newNameList "_tjl" $ arityInt jc+    let zippedTJs      = zip tjs tjls+        interleavedTJs = interleave tjs tjls+        lastTyVars     = map varTToName $ drop (length instTys - arityInt jc) instTys+        tvMap          = M.fromList $ zip lastTyVars zippedTJs+    lamE (map varP $ interleavedTJs ++ [value]) $+        caseE (varE value) (matches tvMap)+  where+    matches tvMap = case cons of+      -- A single constructor is directly encoded. The constructor itself may be+      -- forgotten.+      [con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con]+      _ | allNullaryToStringTag opts && all isNullary cons ->+              [ match (conP conName []) (normalB $ conStr target opts conName) []+              | con <- cons+              , let conName = constructorName con+              ]+        | otherwise -> [argsToValue target jc tvMap opts True con | con <- cons]++-- | Name of the constructor as a quoted 'Value' or 'Encoding'.+conStr :: ToJSONFun -> Options -> Name -> Q Exp+conStr Value opts = appE [|String|] . conTxt opts+conStr Encoding opts = appE [|E.text|] . conTxt opts++-- | Name of the constructor as a quoted 'Text'.+conTxt :: Options -> Name -> Q Exp+conTxt opts = appE [|T.pack|] . stringE . conString opts++-- | Name of the constructor.+conString :: Options -> Name -> String+conString opts = constructorTagModifier opts . nameBase++-- | If constructor is nullary.+isNullary :: ConstructorInfo -> Bool+isNullary ConstructorInfo { constructorVariant = NormalConstructor+                          , constructorFields  = tys } = null tys+isNullary _ = False++-- | Wrap fields of a non-record constructor. See 'sumToValue'.+opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ+opaqueSumToValue target opts multiCons nullary conName value =+  sumToValue target opts multiCons nullary conName+    value+    pairs+  where+    pairs contentsFieldName = pairE contentsFieldName value++-- | Wrap fields of a record constructor. See 'sumToValue'.+recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ+recordSumToValue target opts multiCons nullary conName pairs =+  sumToValue target opts multiCons nullary conName+    (fromPairsE pairs)+    (const pairs)++-- | Wrap fields of a constructor.+sumToValue+  :: ToJSONFun+  -- ^ The method being derived.+  -> Options+  -- ^ Deriving options.+  -> Bool+  -- ^ Does this type have multiple constructors.+  -> Bool+  -- ^ Is this constructor nullary.+  -> Name+  -- ^ Constructor name.+  -> ExpQ+  -- ^ Fields of the constructor as a 'Value' or 'Encoding'.+  -> (String -> ExpQ)+  -- ^ Representation of an 'Object' fragment used for the 'TaggedObject'+  -- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method+  -- being derived.+  --+  -- - For non-records, produces a pair @"contentsFieldName":value@,+  --   given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'.+  -- - For records, produces the list of pairs corresponding to fields of the+  --   encoded value (ignores the argument). See 'recordSumToValue'.+  -> ExpQ+sumToValue target opts multiCons nullary conName value pairs+    | multiCons =+        case sumEncoding opts of+          TwoElemArray ->+            array target [conStr target opts conName, value]+          TaggedObject{tagFieldName, contentsFieldName} ->+            -- TODO: Maybe throw an error in case+            -- tagFieldName overwrites a field in pairs.+            let tag = pairE tagFieldName (conStr target opts conName)+                content = pairs contentsFieldName+            in fromPairsE $+              if nullary then tag else infixApp tag [|(Monoid.<>)|] content+          ObjectWithSingleField ->+            objectE [(conString opts conName, value)]+          UntaggedValue | nullary -> conStr target opts conName+          UntaggedValue -> value+    | otherwise = value++-- | Generates code to generate the JSON encoding of a single constructor.+argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match++-- Polyadic constructors with special case for unary constructors.+argsToValue target jc tvMap opts multiCons+  ConstructorInfo { constructorName    = conName+                  , constructorVariant = NormalConstructor+                  , constructorFields  = argTys } = do+    argTys' <- mapM resolveTypeSynonyms argTys+    let len = length argTys'+    args <- newNameList "arg" len+    let js = case [ dispatchToJSON target jc conName tvMap argTy+                      `appE` varE arg+                  | (arg, argTy) <- zip args argTys'+                  ] of+               -- Single argument is directly converted.+               [e] -> e+               -- Zero and multiple arguments are converted to a JSON array.+               es -> array target es++    match (conP conName $ map varP args)+          (normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js)+          []++-- Records.+argsToValue target jc tvMap opts multiCons+  info@ConstructorInfo { constructorName    = conName+                       , constructorVariant = RecordConstructor fields+                       , constructorFields  = argTys } =+    case (unwrapUnaryRecords opts, not multiCons, argTys) of+      (True,True,[_]) -> argsToValue target jc tvMap opts multiCons+                                     (info{constructorVariant = NormalConstructor})+      _ -> do+        argTys' <- mapM resolveTypeSynonyms argTys+        args <- newNameList "arg" $ length argTys'+        let pairs | omitNothingFields opts = infixApp maybeFields+                                                      [|(Monoid.<>)|]+                                                      restFields+                  | otherwise = mconcatE (map pureToPair argCons)++            argCons = zip3 (map varE args) argTys' fields++            maybeFields = mconcatE (map maybeToPair maybes)++            restFields = mconcatE (map pureToPair rest)++            (maybes0, rest0) = partition isMaybe argCons+            (options, rest) = partition isOption rest0+            maybes = maybes0 ++ map optionToMaybe options++            maybeToPair = toPairLifted True+            pureToPair = toPairLifted False++            toPairLifted lifted (arg, argTy, field) =+              let toValue = dispatchToJSON target jc conName tvMap argTy+                  fieldName = fieldLabel opts field+                  e arg' = pairE fieldName (toValue `appE` arg')+              in if lifted+                then do+                  x <- newName "x"+                  [|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg+                else e arg++        match (conP conName $ map varP args)+              (normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs)+              []++-- Infix constructors.+argsToValue target jc tvMap opts multiCons+  ConstructorInfo { constructorName    = conName+                  , constructorVariant = InfixConstructor+                  , constructorFields  = argTys } = do+    [alTy, arTy] <- mapM resolveTypeSynonyms argTys+    al <- newName "argL"+    ar <- newName "argR"+    match (infixP (varP al) conName (varP ar))+          ( normalB+          $ opaqueSumToValue target opts multiCons False conName+          $ array target+              [ dispatchToJSON target jc conName tvMap aTy+                  `appE` varE a+              | (a, aTy) <- [(al,alTy), (ar,arTy)]+              ]+          )+          []++isMaybe :: (a, Type, b) -> Bool+isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe+isMaybe _                       = False++isOption :: (a, Type, b) -> Bool+isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option+isOption _                       = False++optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)+optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)++(<^>) :: ExpQ -> ExpQ -> ExpQ+(<^>) a b = infixApp a [|(E.><)|] b+infixr 6 <^>++(<%>) :: ExpQ -> ExpQ -> ExpQ+(<%>) a b = a <^> [|E.comma|] <^> b+infixr 4 <%>++-- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').+array :: ToJSONFun -> [ExpQ] -> ExpQ+array Encoding [] = [|E.emptyArray_|]+array Value [] = [|Array V.empty|]+array Encoding es = [|E.wrapArray|] `appE` foldr1 (<%>) es+array Value es = do+  mv <- newName "mv"+  let newMV = bindS (varP mv)+                    ([|VM.unsafeNew|] `appE`+                      litE (integerL $ fromIntegral (length es)))+      stmts = [ noBindS $+                  [|VM.unsafeWrite|] `appE`+                    varE mv `appE`+                      litE (integerL ix) `appE`+                        e+              | (ix, e) <- zip [(0::Integer)..] es+              ]+      ret = noBindS $ [|return|] `appE` varE mv+  [|Array|] `appE`+             (varE 'V.create `appE`+               doE (newMV:stmts++[ret]))++-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.+objectE :: [(String, ExpQ)] -> ExpQ+objectE = fromPairsE . mconcatE . fmap (uncurry pairE)++-- | 'mconcat' a list of fixed length.+--+-- > mconcatE [ [|x|], [|y|], [|z|] ] = [| x <> (y <> z) |]+mconcatE :: [ExpQ] -> ExpQ+mconcatE [] = [|Monoid.mempty|]+mconcatE [x] = x+mconcatE (x : xs) = infixApp x [|(Monoid.<>)|] (mconcatE xs)++fromPairsE :: ExpQ -> ExpQ+fromPairsE = ([|fromPairs|] `appE`)++-- | Create (an encoding of) a key-value pair.+--+-- > pairE "k" [|v|] = [|pair "k" v|]+pairE :: String -> ExpQ -> ExpQ+pairE k v = [|pair k|] `appE` v++--------------------------------------------------------------------------------+-- FromJSON+--------------------------------------------------------------------------------++-- | Generates a 'FromJSON' instance declaration for the given data type or+-- data family instance constructor.+deriveFromJSON :: Options+               -- ^ Encoding options.+               -> Name+               -- ^ Name of the type for which to generate a 'FromJSON' instance+               -- declaration.+               -> Q [Dec]+deriveFromJSON = deriveFromJSONCommon fromJSONClass++-- | Generates a 'FromJSON1' instance declaration for the given data type or+-- data family instance constructor.+deriveFromJSON1 :: Options+                -- ^ Encoding options.+                -> Name+                -- ^ Name of the type for which to generate a 'FromJSON1' instance+                -- declaration.+                -> Q [Dec]+deriveFromJSON1 = deriveFromJSONCommon fromJSON1Class++-- | Generates a 'FromJSON2' instance declaration for the given data type or+-- data family instance constructor.+deriveFromJSON2 :: Options+                -- ^ Encoding options.+                -> Name+                -- ^ Name of the type for which to generate a 'FromJSON3' instance+                -- declaration.+                -> Q [Dec]+deriveFromJSON2 = deriveFromJSONCommon fromJSON2Class++deriveFromJSONCommon :: JSONClass+                     -- ^ The FromJSON variant being derived.+                     -> Options+                     -- ^ Encoding options.+                     -> Name+                     -- ^ Name of the type for which to generate an instance.+                     -- declaration.+                     -> Q [Dec]+deriveFromJSONCommon = deriveJSONClass [(ParseJSON, consFromJSON)]++-- | Generates a lambda expression which parses the JSON encoding of the given+-- data type or data family instance constructor.+mkParseJSON :: Options -- ^ Encoding options.+            -> Name -- ^ Name of the encoded type.+            -> Q Exp+mkParseJSON = mkParseJSONCommon fromJSONClass++-- | Generates a lambda expression which parses the JSON encoding of the given+-- data type or data family instance constructor by using the given parsing+-- function on occurrences of the last type parameter.+mkLiftParseJSON :: Options -- ^ Encoding options.+                -> Name -- ^ Name of the encoded type.+                -> Q Exp+mkLiftParseJSON = mkParseJSONCommon fromJSON1Class++-- | Generates a lambda expression which parses the JSON encoding of the given+-- data type or data family instance constructor by using the given parsing+-- functions on occurrences of the last two type parameters.+mkLiftParseJSON2 :: Options -- ^ Encoding options.+                 -> Name -- ^ Name of the encoded type.+                 -> Q Exp+mkLiftParseJSON2 = mkParseJSONCommon fromJSON2Class++mkParseJSONCommon :: JSONClass -- ^ Which class's method is being derived.+                  -> Options -- ^ Encoding options.+                  -> Name -- ^ Name of the encoded type.+                  -> Q Exp+mkParseJSONCommon = mkFunCommon consFromJSON++-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates+-- code to parse the JSON encoding of a number of constructors. All constructors+-- must be from the same type.+consFromJSON :: JSONClass+             -- ^ The FromJSON variant being derived.+             -> Name+             -- ^ Name of the type to which the constructors belong.+             -> Options+             -- ^ Encoding options+             -> [Type]+             -- ^ The types from the data type/data family instance declaration+             -> [ConstructorInfo]+             -- ^ Constructors for which to generate JSON parsing code.+             -> Q Exp++consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "+                                ++ "Not a single constructor given!"++consFromJSON jc tName opts instTys cons = do+  value <- newName "value"+  pjs   <- newNameList "_pj"  $ arityInt jc+  pjls  <- newNameList "_pjl" $ arityInt jc+  let zippedPJs      = zip pjs pjls+      interleavedPJs = interleave pjs pjls+      lastTyVars     = map varTToName $ drop (length instTys - arityInt jc) instTys+      tvMap          = M.fromList $ zip lastTyVars zippedPJs+  lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap++  where+    checkExi tvMap con = checkExistentialContext jc tvMap+                                                 (constructorContext con)+                                                 (constructorName con)++    lamExpr value tvMap = case cons of+      [con]+        | not (tagSingleConstructors opts)+            -> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value)+      _ | sumEncoding opts == UntaggedValue+            -> parseUntaggedValue tvMap cons value+        | otherwise+            -> caseE (varE value) $+                   if allNullaryToStringTag opts && all isNullary cons+                   then allNullaryMatches+                   else mixedMatches tvMap++    allNullaryMatches =+      [ do txt <- newName "txt"+           match (conP 'String [varP txt])+                 (guardedB $+                  [ liftM2 (,) (normalG $+                                  infixApp (varE txt)+                                           [|(==)|]+                                           (conTxt opts conName)+                               )+                               ([|pure|] `appE` conE conName)+                  | con <- cons+                  , let conName = constructorName con+                  ]+                  +++                  [ liftM2 (,)+                      (normalG [|otherwise|])+                      ( [|noMatchFail|]+                        `appE` litE (stringL $ show tName)+                        `appE` ([|T.unpack|] `appE` varE txt)+                      )+                  ]+                 )+                 []+      , do other <- newName "other"+           match (varP other)+                 (normalB $ [|noStringFail|]+                    `appE` litE (stringL $ show tName)+                    `appE` ([|valueConName|] `appE` varE other)+                 )+                 []+      ]++    mixedMatches tvMap =+        case sumEncoding opts of+          TaggedObject {tagFieldName, contentsFieldName} ->+            parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName+          UntaggedValue -> error "UntaggedValue: Should be handled already"+          ObjectWithSingleField ->+            parseObject $ parseObjectWithSingleField tvMap+          TwoElemArray ->+            [ do arr <- newName "array"+                 match (conP 'Array [varP arr])+                       (guardedB+                        [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)+                                                         [|(==)|]+                                                         (litE $ integerL 2))+                                     (parse2ElemArray tvMap arr)+                        , liftM2 (,) (normalG [|otherwise|])+                                     ([|not2ElemArray|]+                                       `appE` litE (stringL $ show tName)+                                       `appE` ([|V.length|] `appE` varE arr))+                        ]+                       )+                       []+            , do other <- newName "other"+                 match (varP other)+                       ( normalB+                         $ [|noArrayFail|]+                             `appE` litE (stringL $ show tName)+                             `appE` ([|valueConName|] `appE` varE other)+                       )+                       []+            ]++    parseObject f =+        [ do obj <- newName "obj"+             match (conP 'Object [varP obj]) (normalB $ f obj) []+        , do other <- newName "other"+             match (varP other)+                   ( normalB+                     $ [|noObjectFail|]+                         `appE` litE (stringL $ show tName)+                         `appE` ([|valueConName|] `appE` varE other)+                   )+                   []+        ]++    parseTaggedObject tvMap typFieldName valFieldName obj = do+      conKey <- newName "conKey"+      doE [ bindS (varP conKey)+                  (infixApp (varE obj)+                            [|(.:)|]+                            ([|T.pack|] `appE` stringE typFieldName))+          , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject+          ]++    parseUntaggedValue tvMap cons' conVal =+        foldr1 (\e e' -> infixApp e [|(<|>)|] e')+               (map (\x -> parseValue tvMap x conVal) cons')++    parseValue _tvMap+        ConstructorInfo { constructorName    = conName+                        , constructorVariant = NormalConstructor+                        , constructorFields  = [] }+        conVal = do+      str <- newName "str"+      caseE (varE conVal)+        [ match (conP 'String [varP str])+                (guardedB+                  [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName)+                               )+                               ([|pure|] `appE` conE conName)+                  ]+                )+                []+        , matchFailed tName conName "String"+        ]+    parseValue tvMap con conVal =+      checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal)+++    parse2ElemArray tvMap arr = do+      conKey <- newName "conKey"+      conVal <- newName "conVal"+      let letIx n ix =+              valD (varP n)+                   (normalB ([|V.unsafeIndex|] `appE`+                               varE arr `appE`+                               litE (integerL ix)))+                   []+      letE [ letIx conKey 0+           , letIx conVal 1+           ]+           (caseE (varE conKey)+                  [ do txt <- newName "txt"+                       match (conP 'String [varP txt])+                             (normalB $ parseContents tvMap+                                                      txt+                                                      (Right conVal)+                                                      'conNotFoundFail2ElemArray+                             )+                             []+                  , do other <- newName "other"+                       match (varP other)+                             ( normalB+                               $ [|firstElemNoStringFail|]+                                     `appE` litE (stringL $ show tName)+                                     `appE` ([|valueConName|] `appE` varE other)+                             )+                             []+                  ]+           )++    parseObjectWithSingleField tvMap obj = do+      conKey <- newName "conKey"+      conVal <- newName "conVal"+      caseE ([e|H.toList|] `appE` varE obj)+            [ match (listP [tupP [varP conKey, varP conVal]])+                    (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField)+                    []+            , do other <- newName "other"+                 match (varP other)+                       (normalB $ [|wrongPairCountFail|]+                                  `appE` litE (stringL $ show tName)+                                  `appE` ([|show . length|] `appE` varE other)+                       )+                       []+            ]++    parseContents tvMap conKey contents errorFun =+        caseE (varE conKey)+              [ match wildP+                      ( guardedB $+                        [ do g <- normalG $ infixApp (varE conKey)+                                                     [|(==)|]+                                                     ([|T.pack|] `appE`+                                                        conNameExp opts con)+                             e <- checkExi tvMap con $+                                  parseArgs jc tvMap tName opts con contents+                             return (g, e)+                        | con <- cons+                        ]+                        +++                        [ liftM2 (,)+                                 (normalG [e|otherwise|])+                                 ( varE errorFun+                                   `appE` litE (stringL $ show tName)+                                   `appE` listE (map ( litE+                                                     . stringL+                                                     . constructorTagModifier opts+                                                     . nameBase+                                                     . constructorName+                                                     ) cons+                                                )+                                   `appE` ([|T.unpack|] `appE` varE conKey)+                                 )+                        ]+                      )+                      []+              ]++parseNullaryMatches :: Name -> Name -> [Q Match]+parseNullaryMatches tName conName =+    [ do arr <- newName "arr"+         match (conP 'Array [varP arr])+               (guardedB+                [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)+                             ([|pure|] `appE` conE conName)+                , liftM2 (,) (normalG [|otherwise|])+                             (parseTypeMismatch tName conName+                                (litE $ stringL "an empty Array")+                                (infixApp (litE $ stringL "Array of length ")+                                          [|(++)|]+                                          ([|show . V.length|] `appE` varE arr)+                                )+                             )+                ]+               )+               []+    , matchFailed tName conName "Array"+    ]++parseUnaryMatches :: JSONClass -> TyVarMap -> Type -> Name -> [Q Match]+parseUnaryMatches jc tvMap argTy conName =+    [ do arg <- newName "arg"+         match (varP arg)+               ( normalB $ infixApp (conE conName)+                                    [|(<$>)|]+                                    (dispatchParseJSON jc conName tvMap argTy+                                      `appE` varE arg)+               )+               []+    ]++parseRecord :: JSONClass+            -> TyVarMap+            -> [Type]+            -> Options+            -> Name+            -> Name+            -> [Name]+            -> Name+            -> Bool+            -> ExpQ+parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =+    (if rejectUnknownFields opts+     then infixApp checkUnknownRecords [|(>>)|]+     else id) $+    foldl' (\a b -> infixApp a [|(<*>)|] b)+           (infixApp (conE conName) [|(<$>)|] x)+           xs+    where+      tagFieldNameAppender =+          if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id+      knownFields = appE [|H.fromList|] $ listE $+          map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $+              tagFieldNameAppender $ map (fieldLabel opts) fields+      checkUnknownRecords =+          caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields)+              [ match (listP []) (normalB [|return ()|]) []+              , newName "unknownFields" >>=+                  \unknownFields -> match (varP unknownFields)+                      (normalB $ appE [|fail|] $ infixApp+                          (litE (stringL "Unknown fields: "))+                          [|(++)|]+                          (appE [|show|] (varE unknownFields)))+                      []+              ]+      x:xs = [ [|lookupField|]+               `appE` dispatchParseJSON jc conName tvMap argTy+               `appE` litE (stringL $ show tName)+               `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)+               `appE` varE obj+               `appE` ( [|T.pack|] `appE` stringE (fieldLabel opts field)+                      )+             | (field, argTy) <- zip fields argTys+             ]++getValField :: Name -> String -> [MatchQ] -> Q Exp+getValField obj valFieldName matches = do+  val <- newName "val"+  doE [ bindS (varP val) $ infixApp (varE obj)+                                    [|(.:)|]+                                    ([|T.pack|] `appE`+                                       litE (stringL valFieldName))+      , noBindS $ caseE (varE val) matches+      ]++matchCases :: Either (String, Name) Name -> [MatchQ] -> Q Exp+matchCases (Left (valFieldName, obj)) = getValField obj valFieldName+matchCases (Right valName)            = caseE (varE valName)++-- | Generates code to parse the JSON encoding of a single constructor.+parseArgs :: JSONClass -- ^ The FromJSON variant being derived.+          -> TyVarMap -- ^ Maps the last type variables to their decoding+                      --   function arguments.+          -> Name -- ^ Name of the type to which the constructor belongs.+          -> Options -- ^ Encoding options.+          -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.+          -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or+                                        --   Right valName+          -> Q Exp+-- Nullary constructors.+parseArgs _ _ _ _+  ConstructorInfo { constructorName    = conName+                  , constructorVariant = NormalConstructor+                  , constructorFields  = [] }+  (Left _) =+    [|pure|] `appE` conE conName+parseArgs _ _ tName _+  ConstructorInfo { constructorName    = conName+                  , constructorVariant = NormalConstructor+                  , constructorFields  = [] }+  (Right valName) =+    caseE (varE valName) $ parseNullaryMatches tName conName++-- Unary constructors.+parseArgs jc tvMap _ _+  ConstructorInfo { constructorName    = conName+                  , constructorVariant = NormalConstructor+                  , constructorFields  = [argTy] }+  contents = do+    argTy' <- resolveTypeSynonyms argTy+    matchCases contents $ parseUnaryMatches jc tvMap argTy' conName++-- Polyadic constructors.+parseArgs jc tvMap tName _+  ConstructorInfo { constructorName    = conName+                  , constructorVariant = NormalConstructor+                  , constructorFields  = argTys }+  contents = do+    argTys' <- mapM resolveTypeSynonyms argTys+    let len = genericLength argTys'+    matchCases contents $ parseProduct jc tvMap argTys' tName conName len++-- Records.+parseArgs jc tvMap tName opts+  ConstructorInfo { constructorName    = conName+                  , constructorVariant = RecordConstructor fields+                  , constructorFields  = argTys }+  (Left (_, obj)) = do+    argTys' <- mapM resolveTypeSynonyms argTys+    parseRecord jc tvMap argTys' opts tName conName fields obj True+parseArgs jc tvMap tName opts+  info@ConstructorInfo { constructorName    = conName+                       , constructorVariant = RecordConstructor fields+                       , constructorFields  = argTys }+  (Right valName) =+    case (unwrapUnaryRecords opts,argTys) of+      (True,[_])-> parseArgs jc tvMap tName opts+                             (info{constructorVariant = NormalConstructor})+                             (Right valName)+      _ -> do+        obj <- newName "recObj"+        argTys' <- mapM resolveTypeSynonyms argTys+        caseE (varE valName)+          [ match (conP 'Object [varP obj]) (normalB $+              parseRecord jc tvMap argTys' opts tName conName fields obj False) []+          , matchFailed tName conName "Object"+          ]++-- Infix constructors. Apart from syntax these are the same as+-- polyadic constructors.+parseArgs jc tvMap tName _+  ConstructorInfo { constructorName    = conName+                  , constructorVariant = InfixConstructor+                  , constructorFields  = argTys }+  contents = do+    argTys' <- mapM resolveTypeSynonyms argTys+    matchCases contents $ parseProduct jc tvMap argTys' tName conName 2++-- | Generates code to parse the JSON encoding of an n-ary+-- constructor.+parseProduct :: JSONClass -- ^ The FromJSON variant being derived.+             -> TyVarMap -- ^ Maps the last type variables to their decoding+                         --   function arguments.+             -> [Type] -- ^ The argument types of the constructor.+             -> Name -- ^ Name of the type to which the constructor belongs.+             -> Name -- ^ 'Con'structor name.+             -> Integer -- ^ 'Con'structor arity.+             -> [Q Match]+parseProduct jc tvMap argTys tName conName numArgs =+    [ do arr <- newName "arr"+         -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"+         let x:xs = [ dispatchParseJSON jc conName tvMap argTy+                      `appE`+                      infixApp (varE arr)+                               [|V.unsafeIndex|]+                               (litE $ integerL ix)+                    | (argTy, ix) <- zip argTys [0 .. numArgs - 1]+                    ]+         match (conP 'Array [varP arr])+               (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr)+                                           [|(==)|]+                                           (litE $ integerL numArgs)+                                )+                                ( foldl' (\a b -> infixApp a [|(<*>)|] b)+                                         (infixApp (conE conName) [|(<$>)|] x)+                                         xs+                                )+                                ( parseTypeMismatch tName conName+                                    (litE $ stringL $ "Array of length " ++ show numArgs)+                                    ( infixApp (litE $ stringL "Array of length ")+                                               [|(++)|]+                                               ([|show . V.length|] `appE` varE arr)+                                    )+                                )+               )+               []+    , matchFailed tName conName "Array"+    ]++--------------------------------------------------------------------------------+-- Parsing errors+--------------------------------------------------------------------------------++matchFailed :: Name -> Name -> String -> MatchQ+matchFailed tName conName expected = do+  other <- newName "other"+  match (varP other)+        ( normalB $ parseTypeMismatch tName conName+                      (litE $ stringL expected)+                      ([|valueConName|] `appE` varE other)+        )+        []++parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ+parseTypeMismatch tName conName expected actual =+    foldl appE+          [|parseTypeMismatch'|]+          [ litE $ stringL $ nameBase conName+          , litE $ stringL $ show tName+          , expected+          , actual+          ]++class LookupField a where+    lookupField :: (Value -> Parser a) -> String -> String+                -> Object -> T.Text -> Parser a++instance OVERLAPPABLE_ LookupField a where+    lookupField = lookupFieldWith++instance INCOHERENT_ LookupField (Maybe a) where+    lookupField pj _ _ = parseOptionalFieldWith pj++instance INCOHERENT_ LookupField (Semigroup.Option a) where+    lookupField pj tName rec obj key =+        fmap Semigroup.Option+             (lookupField (fmap Semigroup.getOption . pj) tName rec obj key)++lookupFieldWith :: (Value -> Parser a) -> String -> String+                -> Object -> T.Text -> Parser a+lookupFieldWith pj tName rec obj key =+    case H.lookup key obj of+      Nothing -> unknownFieldFail tName rec (T.unpack key)+      Just v  -> pj v <?> Key key++unknownFieldFail :: String -> String -> String -> Parser fail+unknownFieldFail tName rec key =+    fail $ printf "When parsing the record %s of type %s the key %s was not present."+                  rec tName key++noArrayFail :: String -> String -> Parser fail+noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o++noObjectFail :: String -> String -> Parser fail+noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o++firstElemNoStringFail :: String -> String -> Parser fail+firstElemNoStringFail t o = fail $ printf "When parsing %s expected an Array of 2 elements where the first element is a String but got %s at the first element." t o++wrongPairCountFail :: String -> String -> Parser fail+wrongPairCountFail t n =+    fail $ printf "When parsing %s expected an Object with a single tag/contents pair but got %s pairs."+                  t n++noStringFail :: String -> String -> Parser fail+noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o++noMatchFail :: String -> String -> Parser fail+noMatchFail t o =+    fail $ printf "When parsing %s expected a String with the tag of a constructor but got %s." t o++not2ElemArray :: String -> Int -> Parser fail+not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2 elements but got %i elements" t i++conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser fail+conNotFoundFail2ElemArray t cs o =+    fail $ printf "When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s."+                  t (intercalate ", " cs) o++conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser fail+conNotFoundFailObjectSingleField t cs o =+    fail $ printf "When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s."+                  t (intercalate ", " cs) o++conNotFoundFailTaggedObject :: String -> [String] -> String -> Parser fail+conNotFoundFailTaggedObject t cs o =+    fail $ printf "When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s."+                  t (intercalate ", " cs) o++parseTypeMismatch' :: String -> String -> String -> String -> Parser fail+parseTypeMismatch' conName tName expected actual =+    fail $ printf "When parsing the constructor %s of type %s expected %s but got %s."+                  conName tName expected actual++--------------------------------------------------------------------------------+-- Shared ToJSON and FromJSON code+--------------------------------------------------------------------------------++-- | Functionality common to 'deriveJSON', 'deriveJSON1', and 'deriveJSON2'.+deriveJSONBoth :: (Options -> Name -> Q [Dec])+               -- ^ Function which derives a flavor of 'ToJSON'.+               -> (Options -> Name -> Q [Dec])+               -- ^ Function which derives a flavor of 'FromJSON'.+               -> Options+               -- ^ Encoding options.+               -> Name+               -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'+               -- instances.+               -> Q [Dec]+deriveJSONBoth dtj dfj opts name =+    liftM2 (++) (dtj opts name) (dfj opts name)++-- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.+deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]+                                        -> [ConstructorInfo] -> Q Exp)]+                -- ^ The class methods and the functions which derive them.+                -> JSONClass+                -- ^ The class for which to generate an instance.+                -> Options+                -- ^ Encoding options.+                -> Name+                -- ^ Name of the type for which to generate a class instance+                -- declaration.+                -> Q [Dec]+deriveJSONClass consFuns jc opts name = do+  info <- reifyDatatype name+  case info of+    DatatypeInfo { datatypeContext   = ctxt+                 , datatypeName      = parentName+#if MIN_VERSION_th_abstraction(0,3,0)+                 , datatypeInstTypes = instTys+#else+                 , datatypeVars      = instTys+#endif+                 , datatypeVariant   = variant+                 , datatypeCons      = cons+                 } -> do+      (instanceCxt, instanceType)+        <- buildTypeInstance parentName jc ctxt instTys variant+      (:[]) <$> instanceD (return instanceCxt)+                          (return instanceType)+                          (methodDecs parentName instTys cons)+  where+    methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]+    methodDecs parentName instTys cons = flip map consFuns $ \(jf, jfMaker) ->+      funD (jsonFunValName jf (arity jc))+           [ clause []+                    (normalB $ jfMaker jc parentName opts instTys cons)+                    []+           ]++mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)+            -- ^ The function which derives the expression.+            -> JSONClass+            -- ^ Which class's method is being derived.+            -> Options+            -- ^ Encoding options.+            -> Name+            -- ^ Name of the encoded type.+            -> Q Exp+mkFunCommon consFun jc opts name = do+  info <- reifyDatatype name+  case info of+    DatatypeInfo { datatypeContext   = ctxt+                 , datatypeName      = parentName+#if MIN_VERSION_th_abstraction(0,3,0)+                 , datatypeInstTypes = instTys+#else+                 , datatypeVars      = instTys+#endif+                 , datatypeVariant   = variant+                 , datatypeCons      = cons+                 } -> do+      -- We force buildTypeInstance here since it performs some checks for whether+      -- or not the provided datatype's kind matches the derived method's+      -- typeclass, and produces errors if it can't.+      !_ <- buildTypeInstance parentName jc ctxt instTys variant+      consFun jc parentName opts instTys cons++dispatchFunByType :: JSONClass+                  -> JSONFun+                  -> Name+                  -> TyVarMap+                  -> Bool -- True if we are using the function argument that works+                          -- on lists (e.g., [a] -> Value). False is we are using+                          -- the function argument that works on single values+                          -- (e.g., a -> Value).+                  -> Type+                  -> Q Exp+dispatchFunByType _ jf _ tvMap list (VarT tyName) =+    varE $ case M.lookup tyName tvMap of+                Just (tfjExp, tfjlExp) -> if list then tfjlExp else tfjExp+                Nothing                -> jsonFunValOrListName list jf Arity0+dispatchFunByType jc jf conName tvMap list (SigT ty _) =+    dispatchFunByType jc jf conName tvMap list ty+dispatchFunByType jc jf conName tvMap list (ForallT _ _ ty) =+    dispatchFunByType jc jf conName tvMap list ty+dispatchFunByType jc jf conName tvMap list ty = do+    let tyCon :: Type+        tyArgs :: [Type]+        tyCon :| tyArgs = unapplyTy ty++        numLastArgs :: Int+        numLastArgs = min (arityInt jc) (length tyArgs)++        lhsArgs, rhsArgs :: [Type]+        (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++        tyVarNames :: [Name]+        tyVarNames = M.keys tvMap++    itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs+    if any (`mentionsName` tyVarNames) lhsArgs || itf+       then outOfPlaceTyVarError jc conName+       else if any (`mentionsName` tyVarNames) rhsArgs+            then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs)+                         : zipWith (dispatchFunByType jc jf conName tvMap)+                                   (cycle [False,True])+                                   (interleave rhsArgs rhsArgs)+            else varE $ jsonFunValOrListName list jf Arity0++dispatchToJSON+  :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp+dispatchToJSON target jc n tvMap =+    dispatchFunByType jc (targetToJSONFun target) n tvMap False++dispatchParseJSON+  :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp+dispatchParseJSON  jc n tvMap = dispatchFunByType jc ParseJSON  n tvMap False++--------------------------------------------------------------------------------+-- Utility functions+--------------------------------------------------------------------------------++-- For the given Types, generate an instance context and head.+buildTypeInstance :: Name+                  -- ^ The type constructor or data family name+                  -> JSONClass+                  -- ^ The typeclass to derive+                  -> Cxt+                  -- ^ The datatype context+                  -> [Type]+                  -- ^ The types to instantiate the instance with+                  -> DatatypeVariant+                  -- ^ Are we dealing with a data family instance or not+                  -> Q (Cxt, Type)+buildTypeInstance tyConName jc dataCxt varTysOrig variant = do+    -- Make sure to expand through type/kind synonyms! Otherwise, the+    -- eta-reduction check might get tripped up over type variables in a+    -- synonym that are actually dropped.+    -- (See GHC Trac #11416 for a scenario where this actually happened.)+    varTysExp <- mapM resolveTypeSynonyms varTysOrig++    let remainingLength :: Int+        remainingLength = length varTysOrig - arityInt jc++        droppedTysExp :: [Type]+        droppedTysExp = drop remainingLength varTysExp++        droppedStarKindStati :: [StarKindStatus]+        droppedStarKindStati = map canRealizeKindStar droppedTysExp++    -- Check there are enough types to drop and that all of them are either of+    -- kind * or kind k (for some kind variable k). If not, throw an error.+    when (remainingLength < 0 || elem NotKindStar droppedStarKindStati) $+      derivingKindError jc tyConName++    let droppedKindVarNames :: [Name]+        droppedKindVarNames = catKindVarNames droppedStarKindStati++        -- Substitute kind * for any dropped kind variables+        varTysExpSubst :: [Type]+        varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp++        remainingTysExpSubst, droppedTysExpSubst :: [Type]+        (remainingTysExpSubst, droppedTysExpSubst) =+          splitAt remainingLength varTysExpSubst++        -- All of the type variables mentioned in the dropped types+        -- (post-synonym expansion)+        droppedTyVarNames :: [Name]+        droppedTyVarNames = freeVariables droppedTysExpSubst++    -- If any of the dropped types were polykinded, ensure that they are of kind *+    -- after substituting * for the dropped kind variables. If not, throw an error.+    unless (all hasKindStar droppedTysExpSubst) $+      derivingKindError jc tyConName++    let preds    :: [Maybe Pred]+        kvNames  :: [[Name]]+        kvNames' :: [Name]+        -- Derive instance constraints (and any kind variables which are specialized+        -- to * in those constraints)+        (preds, kvNames) = unzip $ map (deriveConstraint jc) remainingTysExpSubst+        kvNames' = concat kvNames++        -- Substitute the kind variables specialized in the constraints with *+        remainingTysExpSubst' :: [Type]+        remainingTysExpSubst' =+          map (substNamesWithKindStar kvNames') remainingTysExpSubst++        -- We now substitute all of the specialized-to-* kind variable names with+        -- *, but in the original types, not the synonym-expanded types. The reason+        -- we do this is a superficial one: we want the derived instance to resemble+        -- the datatype written in source code as closely as possible. For example,+        -- for the following data family instance:+        --+        --   data family Fam a+        --   newtype instance Fam String = Fam String+        --+        -- We'd want to generate the instance:+        --+        --   instance C (Fam String)+        --+        -- Not:+        --+        --   instance C (Fam [Char])+        remainingTysOrigSubst :: [Type]+        remainingTysOrigSubst =+          map (substNamesWithKindStar (droppedKindVarNames `union` kvNames'))+            $ take remainingLength varTysOrig++        isDataFamily :: Bool+        isDataFamily = case variant of+                         Datatype        -> False+                         Newtype         -> False+                         DataInstance    -> True+                         NewtypeInstance -> True++        remainingTysOrigSubst' :: [Type]+        -- See Note [Kind signatures in derived instances] for an explanation+        -- of the isDataFamily check.+        remainingTysOrigSubst' =+          if isDataFamily+             then remainingTysOrigSubst+             else map unSigT remainingTysOrigSubst++        instanceCxt :: Cxt+        instanceCxt = catMaybes preds++        instanceType :: Type+        instanceType = AppT (ConT $ jsonClassName jc)+                     $ applyTyCon tyConName remainingTysOrigSubst'++    -- If the datatype context mentions any of the dropped type variables,+    -- we can't derive an instance, so throw an error.+    when (any (`predMentionsName` droppedTyVarNames) dataCxt) $+      datatypeContextError tyConName instanceType+    -- Also ensure the dropped types can be safely eta-reduced. Otherwise,+    -- throw an error.+    unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $+      etaReductionError instanceType+    return (instanceCxt, instanceType)++-- | Attempt to derive a constraint on a Type. If successful, return+-- Just the constraint and any kind variable names constrained to *.+-- Otherwise, return Nothing and the empty list.+--+-- See Note [Type inference in derived instances] for the heuristics used to+-- come up with constraints.+deriveConstraint :: JSONClass -> Type -> (Maybe Pred, [Name])+deriveConstraint jc t+  | not (isTyVar t) = (Nothing, [])+  | hasKindStar t   = (Just (applyCon (jcConstraint Arity0) tName), [])+  | otherwise = case hasKindVarChain 1 t of+      Just ns | jcArity >= Arity1+              -> (Just (applyCon (jcConstraint Arity1) tName), ns)+      _ -> case hasKindVarChain 2 t of+           Just ns | jcArity == Arity2+                   -> (Just (applyCon (jcConstraint Arity2) tName), ns)+           _ -> (Nothing, [])+  where+    tName :: Name+    tName = varTToName t++    jcArity :: Arity+    jcArity = arity jc++    jcConstraint :: Arity -> Name+    jcConstraint = jsonClassName . JSONClass (direction jc)++{-+Note [Kind signatures in derived instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is possible to put explicit kind signatures into the derived instances, e.g.,++  instance C a => C (Data (f :: * -> *)) where ...++But it is preferable to avoid this if possible. If we come up with an incorrect+kind signature (which is entirely possible, since Template Haskell doesn't always+have the best track record with reifying kind signatures), then GHC will flat-out+reject the instance, which is quite unfortunate.++Plain old datatypes have the advantage that you can avoid using any kind signatures+at all in their instances. This is because a datatype declaration uses all type+variables, so the types that we use in a derived instance uniquely determine their+kinds. As long as we plug in the right types, the kind inferencer can do the rest+of the work. For this reason, we use unSigT to remove all kind signatures before+splicing in the instance context and head.++Data family instances are trickier, since a data family can have two instances that+are distinguished by kind alone, e.g.,++  data family Fam (a :: k)+  data instance Fam (a :: * -> *)+  data instance Fam (a :: *)++If we dropped the kind signatures for C (Fam a), then GHC will have no way of+knowing which instance we are talking about. To avoid this scenario, we always+include explicit kind signatures in data family instances. There is a chance that+the inferred kind signatures will be incorrect, but if so, we can always fall back+on the mk- functions.++Note [Type inference in derived instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Type inference is can be tricky to get right, and we want to avoid recreating the+entirety of GHC's type inferencer in Template Haskell. For this reason, we will+probably never come up with derived instance contexts that are as accurate as+GHC's. But that doesn't mean we can't do anything! There are a couple of simple+things we can do to make instance contexts that work for 80% of use cases:++1. If one of the last type parameters is polykinded, then its kind will be+   specialized to * in the derived instance. We note what kind variable the type+   parameter had and substitute it with * in the other types as well. For example,+   imagine you had++     data Data (a :: k) (b :: k)++   Then you'd want to derived instance to be:++     instance C (Data (a :: *))++   Not:++     instance C (Data (a :: k))++2. We naïvely come up with instance constraints using the following criteria:++   (i)   If there's a type parameter n of kind *, generate a ToJSON n/FromJSON n+         constraint.+   (ii)  If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind+         variables), then generate a ToJSON1 n/FromJSON1 n constraint, and if+         k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the+         types. We must consider the case where they are kind variables because+         you might have a scenario like this:++           newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)+             = Compose (f (g a))++         Which would have a derived ToJSON1 instance of:++           instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where ...+   (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are+         * or kind variables), then generate a ToJSON2 n/FromJSON2 n constraint+         and perform kind substitution as in the other cases.+-}++checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name+                        -> Q a -> Q a+checkExistentialContext jc tvMap ctxt conName q =+  if (any (`predMentionsName` M.keys tvMap) ctxt+       || M.size tvMap < arityInt jc)+       && not (allowExQuant jc)+     then existentialContextError conName+     else q++{-+Note [Matching functions with GADT type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When deriving ToJSON2, there is a tricky corner case to consider:++  data Both a b where+    BothCon :: x -> x -> Both x x++Which encoding functions should be applied to which arguments of BothCon?+We have a choice, since both the function of type (a -> Value) and of type+(b -> Value) can be applied to either argument. In such a scenario, the+second encoding function takes precedence over the first encoding function, so the+derived ToJSON2 instance would be something like:++  instance ToJSON2 Both where+    liftToJSON2 tj1 tj2 p (BothCon x1 x2) = Array $ create $ do+      mv <- unsafeNew 2+      unsafeWrite mv 0 (tj1 x1)+      unsafeWrite mv 1 (tj2 x2)+      return mv++This is not an arbitrary choice, as this definition ensures that+liftToJSON2 toJSON = liftToJSON for a derived ToJSON1 instance for+Both.+-}++-- A mapping of type variable Names to their encoding/decoding function Names.+-- For example, in a ToJSON2 declaration, a TyVarMap might look like+--+-- { a ~> (tj1, tjl1)+-- , b ~> (tj2, tjl2) }+--+-- where a and b are the last two type variables of the datatype, tj1 and tjl1 are+-- the function arguments of types (a -> Value) and ([a] -> Value), and tj2 and tjl2+-- are the function arguments of types (b -> Value) and ([b] -> Value).+type TyVarMap = Map Name (Name, Name)++-- | Returns True if a Type has kind *.+hasKindStar :: Type -> Bool+hasKindStar VarT{}         = True+hasKindStar (SigT _ StarT) = True+hasKindStar _              = False++-- Returns True is a kind is equal to *, or if it is a kind variable.+isStarOrVar :: Kind -> Bool+isStarOrVar StarT  = True+isStarOrVar VarT{} = True+isStarOrVar _      = False++-- Generate a list of fresh names with a common prefix, and numbered suffixes.+newNameList :: String -> Int -> Q [Name]+newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]++-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form+-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or+-- kind variables.+hasKindVarChain :: Int -> Type -> Maybe [Name]+hasKindVarChain kindArrows t =+  let uk = uncurryKind (tyKind t)+  in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk+        then Just (concatMap freeVariables uk)+        else Nothing++-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.+tyKind :: Type -> Kind+tyKind (SigT _ k) = k+tyKind _          = starK++-- | Extract Just the Name from a type variable. If the argument Type is not a+-- type variable, return Nothing.+varTToNameMaybe :: Type -> Maybe Name+varTToNameMaybe (VarT n)   = Just n+varTToNameMaybe (SigT t _) = varTToNameMaybe t+varTToNameMaybe _          = Nothing++-- | Extract the Name from a type variable. If the argument Type is not a+-- type variable, throw an error.+varTToName :: Type -> Name+varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe++interleave :: [a] -> [a] -> [a]+interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s+interleave _        _        = []++-- | Fully applies a type constructor to its type variables.+applyTyCon :: Name -> [Type] -> Type+applyTyCon = foldl' AppT . ConT++-- | Is the given type a variable?+isTyVar :: Type -> Bool+isTyVar (VarT _)   = True+isTyVar (SigT t _) = isTyVar t+isTyVar _          = False++-- | Detect if a Name in a list of provided Names occurs as an argument to some+-- type family. This makes an effort to exclude /oversaturated/ arguments to+-- type families. For instance, if one declared the following type family:+--+-- @+-- type family F a :: Type -> Type+-- @+--+-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,+-- but not @b@.+isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool+isInTypeFamilyApp names tyFun tyArgs =+  case tyFun of+    ConT tcName -> go tcName+    _           -> return False+  where+    go :: Name -> Q Bool+    go tcName = do+      info <- reify tcName+      case info of+#if MIN_VERSION_template_haskell(2,11,0)+        FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+          -> withinFirstArgs bndrs+        FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+          -> withinFirstArgs bndrs+#else+        FamilyI (FamilyD TypeFam _ bndrs _) _+          -> withinFirstArgs bndrs+        FamilyI (ClosedTypeFamilyD _ bndrs _ _) _+          -> withinFirstArgs bndrs+#endif+        _ -> return False+      where+        withinFirstArgs :: [a] -> Q Bool+        withinFirstArgs bndrs =+          let firstArgs = take (length bndrs) tyArgs+              argFVs    = freeVariables firstArgs+          in return $ any (`elem` argFVs) names++-- | Peel off a kind signature from a Type (if it has one).+unSigT :: Type -> Type+unSigT (SigT t _) = t+unSigT t          = t++-- | Are all of the items in a list (which have an ordering) distinct?+--+-- This uses Set (as opposed to nub) for better asymptotic time complexity.+allDistinct :: Ord a => [a] -> Bool+allDistinct = allDistinct' Set.empty+  where+    allDistinct' :: Ord a => Set a -> [a] -> Bool+    allDistinct' uniqs (x:xs)+        | x `Set.member` uniqs = False+        | otherwise            = allDistinct' (Set.insert x uniqs) xs+    allDistinct' _ _           = True++-- | Does the given type mention any of the Names in the list?+mentionsName :: Type -> [Name] -> Bool+mentionsName = go+  where+    go :: Type -> [Name] -> Bool+    go (AppT t1 t2) names = go t1 names || go t2 names+    go (SigT t _k)  names = go t names+                              || go _k names+    go (VarT n)     names = n `elem` names+    go _            _     = False++-- | Does an instance predicate mention any of the Names in the list?+predMentionsName :: Pred -> [Name] -> Bool+#if MIN_VERSION_template_haskell(2,10,0)+predMentionsName = mentionsName+#else+predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys+predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names+#endif++-- | Split an applied type into its individual components. For example, this:+--+-- @+-- Either Int Char+-- @+--+-- would split to this:+--+-- @+-- [Either, Int, Char]+-- @+unapplyTy :: Type -> NonEmpty Type+unapplyTy = NE.reverse . go+  where+    go :: Type -> NonEmpty Type+    go (AppT t1 t2)    = t2 <| go t1+    go (SigT t _)      = go t+    go (ForallT _ _ t) = go t+    go t               = t :| []++-- | Split a type signature by the arrows on its spine. For example, this:+--+-- @+-- forall a b. (a ~ b) => (a -> b) -> Char -> ()+-- @+--+-- would split to this:+--+-- @+-- (a ~ b, [a -> b, Char, ()])+-- @+uncurryTy :: Type -> (Cxt, NonEmpty Type)+uncurryTy (AppT (AppT ArrowT t1) t2) =+  let (ctxt, tys) = uncurryTy t2+  in (ctxt, t1 <| tys)+uncurryTy (SigT t _) = uncurryTy t+uncurryTy (ForallT _ ctxt t) =+  let (ctxt', tys) = uncurryTy t+  in (ctxt ++ ctxt', tys)+uncurryTy t = ([], t :| [])++-- | Like uncurryType, except on a kind level.+uncurryKind :: Kind -> NonEmpty Kind+uncurryKind = snd . uncurryTy++createKindChain :: Int -> Kind+createKindChain = go starK+  where+    go :: Kind -> Int -> Kind+    go k 0 = k+    go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)++-- | Makes a string literal expression from a constructor's name.+conNameExp :: Options -> ConstructorInfo -> Q Exp+conNameExp opts = litE+                . stringL+                . constructorTagModifier opts+                . nameBase+                . constructorName++-- | Extracts a record field label.+fieldLabel :: Options -- ^ Encoding options+           -> Name+           -> String+fieldLabel opts = fieldLabelModifier opts . nameBase++-- | The name of the outermost 'Value' constructor.+valueConName :: Value -> String+valueConName (Object _) = "Object"+valueConName (Array  _) = "Array"+valueConName (String _) = "String"+valueConName (Number _) = "Number"+valueConName (Bool   _) = "Boolean"+valueConName Null       = "Null"++applyCon :: Name -> Name -> Pred+applyCon con t =+#if MIN_VERSION_template_haskell(2,10,0)+          AppT (ConT con) (VarT t)+#else+          ClassP con [VarT t]+#endif++-- | Checks to see if the last types in a data family instance can be safely eta-+-- reduced (i.e., dropped), given the other types. This checks for three conditions:+--+-- (1) All of the dropped types are type variables+-- (2) All of the dropped types are distinct+-- (3) None of the remaining types mention any of the dropped types+canEtaReduce :: [Type] -> [Type] -> Bool+canEtaReduce remaining dropped =+       all isTyVar dropped+    && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type+                                -- didn't have an Ord instance until template-haskell-2.10.0.0+    && not (any (`mentionsName` droppedNames) remaining)+  where+    droppedNames :: [Name]+    droppedNames = map varTToName dropped++-------------------------------------------------------------------------------+-- Expanding type synonyms+-------------------------------------------------------------------------------++applySubstitutionKind :: Map Name Kind -> Type -> Type+applySubstitutionKind = applySubstitution++substNameWithKind :: Name -> Kind -> Type -> Type+substNameWithKind n k = applySubstitutionKind (M.singleton n k)++substNamesWithKindStar :: [Name] -> Type -> Type+substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns++-------------------------------------------------------------------------------+-- Error messages+-------------------------------------------------------------------------------++-- | Either the given data type doesn't have enough type variables, or one of+-- the type variables to be eta-reduced cannot realize kind *.+derivingKindError :: JSONClass -> Name -> Q a+derivingKindError jc tyConName = fail+  . showString "Cannot derive well-kinded instance of form ‘"+  . showString className+  . showChar ' '+  . showParen True+    ( showString (nameBase tyConName)+    . showString " ..."+    )+  . showString "‘\n\tClass "+  . showString className+  . showString " expects an argument of kind "+  . showString (pprint . createKindChain $ arityInt jc)+  $ ""+  where+    className :: String+    className = nameBase $ jsonClassName jc++-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce+-- function for the criteria it would have to meet).+etaReductionError :: Type -> Q a+etaReductionError instanceType = fail $+    "Cannot eta-reduce to an instance of form \n\tinstance (...) => "+    ++ pprint instanceType++-- | The data type has a DatatypeContext which mentions one of the eta-reduced+-- type variables.+datatypeContextError :: Name -> Type -> Q a+datatypeContextError dataName instanceType = fail+    . showString "Can't make a derived instance of ‘"+    . showString (pprint instanceType)+    . showString "‘:\n\tData type ‘"+    . showString (nameBase dataName)+    . showString "‘ must not have a class context involving the last type argument(s)"+    $ ""++-- | The data type mentions one of the n eta-reduced type variables in a place other+-- than the last nth positions of a data type in a constructor's field.+outOfPlaceTyVarError :: JSONClass -> Name -> a+outOfPlaceTyVarError jc conName = error+    . showString "Constructor ‘"+    . showString (nameBase conName)+    . showString "‘ must only use its last "+    . shows n+    . showString " type variable(s) within the last "+    . shows n+    . showString " argument(s) of a data type"+    $ ""+  where+    n :: Int+    n = arityInt jc++-- | The data type has an existential constraint which mentions one of the+-- eta-reduced type variables.+existentialContextError :: Name -> a+existentialContextError conName = error+  . showString "Constructor ‘"+  . showString (nameBase conName)+  . showString "‘ must be truly polymorphic in the last argument(s) of the data type"+  $ ""++-------------------------------------------------------------------------------+-- Class-specific constants+-------------------------------------------------------------------------------++-- | A representation of the arity of the ToJSON/FromJSON typeclass being derived.+data Arity = Arity0 | Arity1 | Arity2+  deriving (Enum, Eq, Ord)++-- | Whether ToJSON(1)(2) or FromJSON(1)(2) is being derived.+data Direction = To | From++-- | A representation of which typeclass method is being spliced in.+data JSONFun = ToJSON | ToEncoding | ParseJSON++-- | A refinement of JSONFun to [ToJSON, ToEncoding].+data ToJSONFun = Value | Encoding++targetToJSONFun :: ToJSONFun -> JSONFun+targetToJSONFun Value = ToJSON+targetToJSONFun Encoding = ToEncoding++-- | A representation of which typeclass is being derived.+data JSONClass = JSONClass { direction :: Direction, arity :: Arity }++toJSONClass, toJSON1Class, toJSON2Class,+    fromJSONClass, fromJSON1Class, fromJSON2Class :: JSONClass+toJSONClass    = JSONClass To   Arity0+toJSON1Class   = JSONClass To   Arity1+toJSON2Class   = JSONClass To   Arity2+fromJSONClass  = JSONClass From Arity0+fromJSON1Class = JSONClass From Arity1+fromJSON2Class = JSONClass From Arity2++jsonClassName :: JSONClass -> Name+jsonClassName (JSONClass To   Arity0) = ''ToJSON+jsonClassName (JSONClass To   Arity1) = ''ToJSON1+jsonClassName (JSONClass To   Arity2) = ''ToJSON2+jsonClassName (JSONClass From Arity0) = ''FromJSON+jsonClassName (JSONClass From Arity1) = ''FromJSON1+jsonClassName (JSONClass From Arity2) = ''FromJSON2++jsonFunValName :: JSONFun -> Arity -> Name+jsonFunValName ToJSON     Arity0 = 'toJSON+jsonFunValName ToJSON     Arity1 = 'liftToJSON+jsonFunValName ToJSON     Arity2 = 'liftToJSON2+jsonFunValName ToEncoding Arity0 = 'toEncoding+jsonFunValName ToEncoding Arity1 = 'liftToEncoding+jsonFunValName ToEncoding Arity2 = 'liftToEncoding2+jsonFunValName ParseJSON  Arity0 = 'parseJSON+jsonFunValName ParseJSON  Arity1 = 'liftParseJSON+jsonFunValName ParseJSON  Arity2 = 'liftParseJSON2++jsonFunListName :: JSONFun -> Arity -> Name+jsonFunListName ToJSON     Arity0 = 'toJSONList+jsonFunListName ToJSON     Arity1 = 'liftToJSONList+jsonFunListName ToJSON     Arity2 = 'liftToJSONList2+jsonFunListName ToEncoding Arity0 = 'toEncodingList+jsonFunListName ToEncoding Arity1 = 'liftToEncodingList+jsonFunListName ToEncoding Arity2 = 'liftToEncodingList2+jsonFunListName ParseJSON  Arity0 = 'parseJSONList+jsonFunListName ParseJSON  Arity1 = 'liftParseJSONList+jsonFunListName ParseJSON  Arity2 = 'liftParseJSONList2++jsonFunValOrListName :: Bool -- e.g., toJSONList if True, toJSON if False+                     -> JSONFun -> Arity -> Name+jsonFunValOrListName False = jsonFunValName+jsonFunValOrListName True  = jsonFunListName++arityInt :: JSONClass -> Int+arityInt = fromEnum . arity++allowExQuant :: JSONClass -> Bool+allowExQuant (JSONClass To _) = True+allowExQuant _                = False++-------------------------------------------------------------------------------+-- StarKindStatus+-------------------------------------------------------------------------------++-- | Whether a type is not of kind *, is of kind *, or is a kind variable.+data StarKindStatus = NotKindStar+                    | KindStar+                    | IsKindVar Name+  deriving Eq++-- | Does a Type have kind * or k (for some kind variable k)?+canRealizeKindStar :: Type -> StarKindStatus+canRealizeKindStar t = case t of+    _ | hasKindStar t -> KindStar+    SigT _ (VarT k) -> IsKindVar k+    _ -> NotKindStar++-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.+-- Otherwise, returns 'Nothing'.+starKindStatusToName :: StarKindStatus -> Maybe Name+starKindStatusToName (IsKindVar n) = Just n+starKindStatusToName _             = Nothing++-- | Concat together all of the StarKindStatuses that are IsKindVar and extract+-- the kind variables' Names out.+catKindVarNames :: [StarKindStatus] -> [Name]+catKindVarNames = mapMaybe starKindStatusToName
+ src/Data/Aeson/Text.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module:      Data.Aeson.Text+-- Copyright:   (c) 2012-2016 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Most frequently, you'll probably want to encode straight to UTF-8+-- (the standard JSON encoding) using 'encode'.+--+-- You can use the conversions to 'Builder's when embedding JSON messages as+-- parts of a protocol.++module Data.Aeson.Text+    (+      encodeToLazyText+    , encodeToTextBuilder+    ) where++import Prelude.Compat++import Data.Aeson.Types (Value(..), ToJSON(..))+import Data.Aeson.Encoding (encodingToLazyByteString)+import Data.Scientific (FPFormat(..), Scientific, base10Exponent)+import Data.Text.Lazy.Builder+import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)+import Numeric (showHex)+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import qualified Data.Vector as V++-- | Encode a JSON 'Value' to a "Data.Text.Lazy"+--+-- /Note:/ uses 'toEncoding'+encodeToLazyText :: ToJSON a => a -> LT.Text+encodeToLazyText = LT.decodeUtf8 . encodingToLazyByteString . toEncoding++-- | Encode a JSON 'Value' to a "Data.Text" 'Builder', which can be+-- embedded efficiently in a text-based protocol.+--+-- If you are going to immediately encode straight to a+-- 'L.ByteString', it is more efficient to use 'encode' (lazy ByteString)+-- or @'fromEncoding' . 'toEncoding'@ (ByteString.Builder) instead.+--+-- /Note:/ Uses 'toJSON'+encodeToTextBuilder :: ToJSON a => a -> Builder+encodeToTextBuilder =+    go . toJSON+  where+    go Null       = {-# SCC "go/Null" #-} "null"+    go (Bool b)   = {-# SCC "go/Bool" #-} if b then "true" else "false"+    go (Number s) = {-# SCC "go/Number" #-} fromScientific s+    go (String s) = {-# SCC "go/String" #-} string s+    go (Array v)+        | V.null v = {-# SCC "go/Array" #-} "[]"+        | otherwise = {-# SCC "go/Array" #-}+                      singleton '[' <>+                      go (V.unsafeHead v) <>+                      V.foldr f (singleton ']') (V.unsafeTail v)+      where f a z = singleton ',' <> go a <> z+    go (Object m) = {-# SCC "go/Object" #-}+        case H.toList m of+          (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs+          _      -> "{}"+      where f a z     = singleton ',' <> one a <> z+            one (k,v) = string k <> singleton ':' <> go v++string :: T.Text -> Builder+string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"'+  where+    quote q = case T.uncons t of+                Nothing      -> fromText h+                Just (!c,t') -> fromText h <> escape c <> quote t'+        where (h,t) = {-# SCC "break" #-} T.break isEscape q+    isEscape c = c == '\"' ||+                 c == '\\' ||+                 c < '\x20'+    escape '\"' = "\\\""+    escape '\\' = "\\\\"+    escape '\n' = "\\n"+    escape '\r' = "\\r"+    escape '\t' = "\\t"++    escape c+        | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h+        | otherwise  = singleton c+        where h = showHex (fromEnum c) ""++fromScientific :: Scientific -> Builder+fromScientific s = formatScientificBuilder format prec s+  where+    (format, prec)+      | base10Exponent s < 0 = (Generic, Nothing)+      | otherwise            = (Fixed,   Just 0)
+ src/Data/Aeson/Types.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- |+-- Module:      Data.Aeson.Types+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Types for working with JSON data.++module Data.Aeson.Types+    (+    -- * Core JSON types+      Value(..)+    , Encoding+    , unsafeToEncoding+    , fromEncoding+    , Series+    , Array+    , emptyArray+    , Pair+    , Object+    , emptyObject+    -- * Convenience types and functions+    , DotNetTime(..)+    , typeMismatch+    , unexpected+    -- * Type conversion+    , Parser+    , Result(..)+    , FromJSON(..)+    , fromJSON+    , parse+    , parseEither+    , parseMaybe+    , parseFail+    , ToJSON(..)+    , KeyValue(..)+    , modifyFailure+    , prependFailure+    , parserThrowError+    , parserCatchError++    -- ** Keys for maps+    , ToJSONKey(..)+    , ToJSONKeyFunction(..)+    , toJSONKeyText+    , contramapToJSONKeyFunction+    , FromJSONKey(..)+    , FromJSONKeyFunction(..)+    , fromJSONKeyCoerce+    , coerceFromJSONKeyFunction+    , mapFromJSONKeyFunction++    -- *** Generic keys+    , GToJSONKey()+    , genericToJSONKey+    , GFromJSONKey()+    , genericFromJSONKey++    -- ** Liftings to unary and binary type constructors+    , FromJSON1(..)+    , parseJSON1+    , FromJSON2(..)+    , parseJSON2+    , ToJSON1(..)+    , toJSON1+    , toEncoding1+    , ToJSON2(..)+    , toJSON2+    , toEncoding2++    -- ** Generic JSON classes+    , GFromJSON+    , FromArgs+    , GToJSON+    , GToEncoding+    , GToJSON'+    , ToArgs+    , Zero+    , One+    , genericToJSON+    , genericLiftToJSON+    , genericToEncoding+    , genericLiftToEncoding+    , genericParseJSON+    , genericLiftParseJSON++    -- * Inspecting @'Value's@+    , withObject+    , withText+    , withArray+    , withScientific+    , withBool+    , withEmbeddedJSON++    , pairs+    , foldable+    , (.:)+    , (.:?)+    , (.:!)+    , (.!=)+    , object+    , parseField+    , parseFieldMaybe+    , parseFieldMaybe'+    , explicitParseField+    , explicitParseFieldMaybe+    , explicitParseFieldMaybe'++    , listEncoding+    , listValue+    , listParser++    -- * Generic and TH encoding configuration+    , Options++    -- ** Options fields+    -- $optionsFields+    , fieldLabelModifier+    , constructorTagModifier+    , allNullaryToStringTag+    , omitNothingFields+    , sumEncoding+    , unwrapUnaryRecords+    , tagSingleConstructors+    , rejectUnknownFields++    -- ** Options utilities+    , SumEncoding(..)+    , camelTo+    , camelTo2+    , defaultOptions+    , defaultTaggedObject++    -- ** Options for object keys+    , JSONKeyOptions+    , keyModifier+    , defaultJSONKeyOptions++    -- * Parsing context+    , (<?>)+    , JSONPath+    , JSONPathElement(..)+    , formatPath+    , formatRelativePath+    ) where++import Prelude.Compat++import Data.Aeson.Encoding (Encoding, unsafeToEncoding, fromEncoding, Series, pairs)+import Data.Aeson.Types.Class+import Data.Aeson.Types.Internal+import Data.Foldable (toList)++-- | Encode a 'Foldable' as a JSON array.+foldable :: (Foldable t, ToJSON a) => t a -> Encoding+foldable = toEncoding . toList+{-# INLINE foldable #-}++-- $optionsFields+-- The functions here are in fact record fields of the 'Options' type.
+ src/Data/Aeson/Types/Class.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module:      Data.Aeson.Types.Class+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Types for working with JSON data.++module Data.Aeson.Types.Class+    (+    -- * Core JSON classes+      FromJSON(..)+    , ToJSON(..)+    -- * Liftings to unary and binary type constructors+    , FromJSON1(..)+    , parseJSON1+    , FromJSON2(..)+    , parseJSON2+    , ToJSON1(..)+    , toJSON1+    , toEncoding1+    , ToJSON2(..)+    , toJSON2+    , toEncoding2+    -- * Generic JSON classes+    , GFromJSON(..)+    , FromArgs(..)+    , GToJSON+    , GToEncoding+    , GToJSON'+    , ToArgs(..)+    , Zero+    , One+    , genericToJSON+    , genericLiftToJSON+    , genericToEncoding+    , genericLiftToEncoding+    , genericParseJSON+    , genericLiftParseJSON+    -- * Classes and types for map keys+    , ToJSONKey(..)+    , ToJSONKeyFunction(..)+    , toJSONKeyText+    , contramapToJSONKeyFunction+    , FromJSONKey(..)+    , FromJSONKeyFunction(..)+    , fromJSONKeyCoerce+    , coerceFromJSONKeyFunction+    , mapFromJSONKeyFunction+    -- ** Generic keys+    , GToJSONKey()+    , genericToJSONKey+    , GFromJSONKey()+    , genericFromJSONKey+    -- * Object key-value pairs+    , KeyValue(..)++    -- * List functions+    , listEncoding+    , listValue+    , listParser++      -- * Inspecting @'Value's@+    , withObject+    , withText+    , withArray+    , withScientific+    , withBool+    , withEmbeddedJSON++    -- * Functions+    , fromJSON+    , ifromJSON+    , typeMismatch+    , unexpected+    , parseField+    , parseFieldMaybe+    , parseFieldMaybe'+    , explicitParseField+    , explicitParseFieldMaybe+    , explicitParseFieldMaybe'+    -- ** Operators+    , (.:)+    , (.:?)+    , (.:!)+    , (.!=)+    ) where+++import Data.Aeson.Types.FromJSON+import Data.Aeson.Types.Generic (One, Zero)+import Data.Aeson.Types.ToJSON+import Data.Aeson.Types.Internal (Value)+import Data.Aeson.Encoding (Encoding)++type GToJSON = GToJSON' Value+type GToEncoding = GToJSON' Encoding
+ src/Data/Aeson/Types/FromJSON.hs view
@@ -0,0 +1,2785 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++#include "incoherent-compat.h"+#include "overlapping-compat.h"++-- TODO: Drop this when we remove support for Data.Attoparsec.Number+{-# OPTIONS_GHC -fno-warn-deprecations #-}++module Data.Aeson.Types.FromJSON+    (+    -- * Core JSON classes+      FromJSON(..)+    -- * Liftings to unary and binary type constructors+    , FromJSON1(..)+    , parseJSON1+    , FromJSON2(..)+    , parseJSON2+    -- * Generic JSON classes+    , GFromJSON(..)+    , FromArgs(..)+    , genericParseJSON+    , genericLiftParseJSON+    -- * Classes and types for map keys+    , FromJSONKey(..)+    , FromJSONKeyFunction(..)+    , fromJSONKeyCoerce+    , coerceFromJSONKeyFunction+    , mapFromJSONKeyFunction++    , GFromJSONKey()+    , genericFromJSONKey++    -- * List functions+    , listParser++    -- * Inspecting @'Value's@+    , withObject+    , withText+    , withArray+    , withScientific+    , withBool+    , withEmbeddedJSON++    -- * Functions+    , fromJSON+    , ifromJSON+    , typeMismatch+    , unexpected+    , parseField+    , parseFieldMaybe+    , parseFieldMaybe'+    , explicitParseField+    , explicitParseFieldMaybe+    , explicitParseFieldMaybe'+    , parseIndexedJSON+    -- ** Operators+    , (.:)+    , (.:?)+    , (.:!)+    , (.!=)++    -- * Internal+    , parseOptionalFieldWith+    ) where++import Prelude.Compat++import Control.Applicative ((<|>), Const(..), liftA2)+import Control.Monad (zipWithM)+import Data.Aeson.Internal.Functions (mapKey)+import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)+import Data.Aeson.Types.Generic+import Data.Aeson.Types.Internal+import Data.Bits (unsafeShiftR)+import Data.Fixed (Fixed, HasResolution (resolution), Nano)+import Data.Functor.Compose (Compose(..))+import Data.Functor.Identity (Identity(..))+import Data.Functor.Product (Product(..))+import Data.Functor.Sum (Sum(..))+import Data.Functor.These (These1 (..))+import Data.Hashable (Hashable(..))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (fromMaybe)+import Data.Proxy (Proxy(..))+import Data.Ratio ((%), Ratio)+import Data.Scientific (Scientific, base10Exponent)+import Data.Tagged (Tagged(..))+import Data.Text (Text, pack, unpack)+import Data.These (These (..))+import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)+import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))+import Data.Time.Calendar.Month.Compat (Month)+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))+import Data.Time.LocalTime.Compat (CalendarDiffTime (..))+import Data.Time.Clock.System.Compat (SystemTime (..))+import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)+import Data.Traversable as Tr (sequence)+import Data.Vector (Vector)+import Data.Version (Version, parseVersion)+import Data.Void (Void)+import Data.Word (Word16, Word32, Word64, Word8)+import Foreign.Storable (Storable)+import Foreign.C.Types (CTime (..))+import GHC.Generics+import Numeric.Natural (Natural)+import Text.ParserCombinators.ReadP (readP_to_S)+import Unsafe.Coerce (unsafeCoerce)+import qualified Data.Aeson.Parser.Time as Time+import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)+import qualified Data.ByteString.Lazy as L+import qualified Data.DList as DList+#if MIN_VERSION_dlist(1,0,0) && __GLASGOW_HASKELL__ >=800+import qualified Data.DList.DNonEmpty as DNE+#endif+import qualified Data.Fix as F+import qualified Data.HashMap.Strict as H+import qualified Data.HashSet as HashSet+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as M+import qualified Data.Monoid as Monoid+import qualified Data.Scientific as Scientific+import qualified Data.Semigroup as Semigroup+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Strict as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Tree as Tree+import qualified Data.UUID.Types as UUID+import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU++import qualified GHC.Exts as Exts+import qualified Data.Primitive.Array as PM+import qualified Data.Primitive.SmallArray as PM+import qualified Data.Primitive.Types as PM+import qualified Data.Primitive.PrimArray as PM++import Data.Coerce (Coercible, coerce)++parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a+parseIndexedJSON p idx value = p value <?> Index idx+{-# INLINE parseIndexedJSON #-}++parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)+parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx+  where+    p = withArray "(k, v)" $ \ab ->+        let n = V.length ab+        in if n == 2+             then (,) <$> parseJSONElemAtIndex keyParser 0 ab+                      <*> parseJSONElemAtIndex valParser 1 ab+             else fail $ "cannot unpack array of length " +++                         show n ++ " into a pair"+{-# INLINE parseIndexedJSONPair #-}++parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a+parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx++parseRealFloat :: RealFloat a => String -> Value -> Parser a+parseRealFloat _    (Number s) = pure $ Scientific.toRealFloat s+parseRealFloat _    Null       = pure (0/0)+parseRealFloat name v          = prependContext name (unexpected v)+{-# INLINE parseRealFloat #-}++parseIntegralFromScientific :: forall a. Integral a => Scientific -> Parser a+parseIntegralFromScientific s =+    case Scientific.floatingOrInteger s :: Either Double a of+        Right x -> pure x+        Left _  -> fail $ "unexpected floating number " ++ show s+{-# INLINE parseIntegralFromScientific #-}++parseIntegral :: Integral a => String -> Value -> Parser a+parseIntegral name =+    prependContext name . withBoundedScientific' parseIntegralFromScientific+{-# INLINE parseIntegral #-}++parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => Scientific -> Parser a+parseBoundedIntegralFromScientific s = maybe+    (fail $ "value is either floating or will cause over or underflow " ++ show s)+    pure+    (Scientific.toBoundedInteger s)+{-# INLINE parseBoundedIntegralFromScientific #-}++parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a+parseBoundedIntegral name =+    prependContext name . withScientific' parseBoundedIntegralFromScientific+{-# INLINE parseBoundedIntegral #-}++parseScientificText :: Text -> Parser Scientific+parseScientificText+    = either fail pure+    . A.parseOnly (A.scientific <* A.endOfInput)+    . T.encodeUtf8++parseIntegralText :: Integral a => String -> Text -> Parser a+parseIntegralText name t =+    prependContext name $+            parseScientificText t+        >>= rejectLargeExponent+        >>= parseIntegralFromScientific+  where+    rejectLargeExponent :: Scientific -> Parser Scientific+    rejectLargeExponent s = withBoundedScientific' pure (Number s)+{-# INLINE parseIntegralText #-}++parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a+parseBoundedIntegralText name t =+    prependContext name $+        parseScientificText t >>= parseBoundedIntegralFromScientific++parseOptionalFieldWith :: (Value -> Parser (Maybe a))+                       -> Object -> Text -> Parser (Maybe a)+parseOptionalFieldWith pj obj key =+    case H.lookup key obj of+     Nothing -> pure Nothing+     Just v  -> pj v <?> Key key+{-# INLINE parseOptionalFieldWith #-}++-------------------------------------------------------------------------------+-- Generics+-------------------------------------------------------------------------------++-- | Class of generic representation types that can be converted from JSON.+class GFromJSON arity f where+    -- | This method (applied to 'defaultOptions') is used as the+    -- default generic implementation of 'parseJSON' (if the @arity@ is 'Zero')+    -- or 'liftParseJSON' (if the @arity@ is 'One').+    gParseJSON :: Options -> FromArgs arity a -> Value -> Parser (f a)++-- | A 'FromArgs' value either stores nothing (for 'FromJSON') or it stores the+-- two function arguments that decode occurrences of the type parameter (for+-- 'FromJSON1').+data FromArgs arity a where+    NoFromArgs :: FromArgs Zero a+    From1Args  :: (Value -> Parser a) -> (Value -> Parser [a]) -> FromArgs One a++-- | A configurable generic JSON decoder. This function applied to+-- 'defaultOptions' is used as the default for 'parseJSON' when the+-- type is an instance of 'Generic'.+genericParseJSON :: (Generic a, GFromJSON Zero (Rep a))+                 => Options -> Value -> Parser a+genericParseJSON opts = fmap to . gParseJSON opts NoFromArgs++-- | A configurable generic JSON decoder. This function applied to+-- 'defaultOptions' is used as the default for 'liftParseJSON' when the+-- type is an instance of 'Generic1'.+genericLiftParseJSON :: (Generic1 f, GFromJSON One (Rep1 f))+                     => Options -> (Value -> Parser a) -> (Value -> Parser [a])+                     -> Value -> Parser (f a)+genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)++-------------------------------------------------------------------------------+-- Class+-------------------------------------------------------------------------------++-- | A type that can be converted from JSON, with the possibility of+-- failure.+--+-- In many cases, you can get the compiler to generate parsing code+-- for you (see below).  To begin, let's cover writing an instance by+-- hand.+--+-- There are various reasons a conversion could fail.  For example, an+-- 'Object' could be missing a required key, an 'Array' could be of+-- the wrong size, or a value could be of an incompatible type.+--+-- The basic ways to signal a failed conversion are as follows:+--+-- * 'fail' yields a custom error message: it is the recommended way of+-- reporting a failure;+--+-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:+-- use it when the error is meant to be caught by some @('<|>')@;+--+-- * 'typeMismatch' can be used to report a failure when the encountered value+-- is not of the expected JSON type; 'unexpected' is an appropriate alternative+-- when more than one type may be expected, or to keep the expected type+-- implicit.+--+-- 'prependFailure' (or 'modifyFailure') add more information to a parser's+-- error messages.+--+-- An example type and instance using 'typeMismatch' and 'prependFailure':+--+-- @+-- \-- Allow ourselves to write 'Text' literals.+-- {-\# LANGUAGE OverloadedStrings #-}+--+-- data Coord = Coord { x :: Double, y :: Double }+--+-- instance 'FromJSON' Coord where+--     'parseJSON' ('Object' v) = Coord+--         '<$>' v '.:' \"x\"+--         '<*>' v '.:' \"y\"+--+--     \-- We do not expect a non-'Object' value here.+--     \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'+--     \-- gives a much more informative error message.+--     'parseJSON' invalid    =+--         'prependFailure' "parsing Coord failed, "+--             ('typeMismatch' \"Object\" invalid)+-- @+--+-- For this common case of only being concerned with a single+-- type of JSON value, the functions 'withObject', 'withScientific', etc.+-- are provided. Their use is to be preferred when possible, since+-- they are more terse. Using 'withObject', we can rewrite the above instance+-- (assuming the same language extension and data type) as:+--+-- @+-- instance 'FromJSON' Coord where+--     'parseJSON' = 'withObject' \"Coord\" $ \\v -> Coord+--         '<$>' v '.:' \"x\"+--         '<*>' v '.:' \"y\"+-- @+--+-- Instead of manually writing your 'FromJSON' instance, there are two options+-- to do it automatically:+--+-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an+-- instance at compile time. The generated instance is optimized for your type+-- so it will probably be more efficient than the following option.+--+-- * The compiler can provide a default generic implementation for+-- 'parseJSON'.+--+-- To use the second, simply add a @deriving 'Generic'@ clause to your+-- datatype and declare a 'FromJSON' instance for your datatype without giving+-- a definition for 'parseJSON'.+--+-- For example, the previous example can be simplified to just:+--+-- @+-- {-\# LANGUAGE DeriveGeneric \#-}+--+-- import "GHC.Generics"+--+-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'+--+-- instance 'FromJSON' Coord+-- @+--+-- The default implementation will be equivalent to+-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different+-- options, you can customize the generic decoding by defining:+--+-- @+-- customOptions = 'defaultOptions'+--                 { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'+--                 }+--+-- instance 'FromJSON' Coord where+--     'parseJSON' = 'genericParseJSON' customOptions+-- @+class FromJSON a where+    parseJSON :: Value -> Parser a++    default parseJSON :: (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a+    parseJSON = genericParseJSON defaultOptions++    parseJSONList :: Value -> Parser [a]+    parseJSONList = withArray "[]" $ \a ->+          zipWithM (parseIndexedJSON parseJSON) [0..]+        . V.toList+        $ a++-------------------------------------------------------------------------------+--  Classes and types for map keys+-------------------------------------------------------------------------------++-- | Read the docs for 'ToJSONKey' first. This class is a conversion+--   in the opposite direction. If you have a newtype wrapper around 'Text',+--   the recommended way to define instances is with generalized newtype deriving:+--+--   > newtype SomeId = SomeId { getSomeId :: Text }+--   >   deriving (Eq,Ord,Hashable,FromJSONKey)+--+--   If you have a sum of nullary constructors, you may use the generic+--   implementation:+--+-- @+-- data Color = Red | Green | Blue+--   deriving Generic+--+-- instance 'FromJSONKey' Color where+--   'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'+-- @+class FromJSONKey a where+    -- | Strategy for parsing the key of a map-like container.+    fromJSONKey :: FromJSONKeyFunction a+    default fromJSONKey :: FromJSON a => FromJSONKeyFunction a+    fromJSONKey = FromJSONKeyValue parseJSON++    -- | This is similar in spirit to the 'readList' method of 'Read'.+    --   It makes it possible to give 'String' keys special treatment+    --   without using @OverlappingInstances@. End users should always+    --   be able to use the default implementation of this method.+    fromJSONKeyList :: FromJSONKeyFunction [a]+    default fromJSONKeyList :: FromJSON a => FromJSONKeyFunction [a]+    fromJSONKeyList = FromJSONKeyValue parseJSON++-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the+--   'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'+--   instance. The other three data constructors for this type all correspond to+--   'ToJSONKeyText'. Strictly speaking, 'FromJSONKeyTextParser' is more powerful than+--   'FromJSONKeyText', which is in turn more powerful than 'FromJSONKeyCoerce'.+--   For performance reasons, these exist as three options instead of one.+data FromJSONKeyFunction a where+    FromJSONKeyCoerce :: Coercible Text a => FromJSONKeyFunction a+      -- ^ uses 'coerce'+    FromJSONKeyText :: !(Text -> a) -> FromJSONKeyFunction a+      -- ^ conversion from 'Text' that always succeeds+    FromJSONKeyTextParser :: !(Text -> Parser a) -> FromJSONKeyFunction a+      -- ^ conversion from 'Text' that may fail+    FromJSONKeyValue :: !(Value -> Parser a) -> FromJSONKeyFunction a+      -- ^ conversion for non-textual keys++-- | Only law abiding up to interpretation+instance Functor FromJSONKeyFunction where+    fmap h FromJSONKeyCoerce         = FromJSONKeyText (h . coerce)+    fmap h (FromJSONKeyText f)       = FromJSONKeyText (h . f)+    fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)+    fmap h (FromJSONKeyValue f)      = FromJSONKeyValue (fmap h . f)++-- | Construct 'FromJSONKeyFunction' for types coercible from 'Text'. This+-- conversion is still unsafe, as 'Hashable' and 'Eq' instances of @a@ should be+-- compatible with 'Text' i.e. hash values should be equal for wrapped values as well.+-- This property will always be maintained if the 'Hashable' and 'Eq' instances+-- are derived with generalized newtype deriving.+-- compatible with 'Text' i.e. hash values be equal for wrapped values as well.+--+-- On pre GHC 7.8 this is unconstrainted function.+fromJSONKeyCoerce ::+    Coercible Text a =>+    FromJSONKeyFunction a+fromJSONKeyCoerce = FromJSONKeyCoerce++-- | Semantically the same as @coerceFromJSONKeyFunction = fmap coerce = coerce@.+--+-- See note on 'fromJSONKeyCoerce'.+coerceFromJSONKeyFunction ::+    Coercible a b =>+    FromJSONKeyFunction a -> FromJSONKeyFunction b+coerceFromJSONKeyFunction = coerce++{-# RULES+  "FromJSONKeyCoerce: fmap coerce" forall x .+                                   fmap coerce x = coerceFromJSONKeyFunction x+  #-}++-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.+mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b+mapFromJSONKeyFunction = fmap++-- | 'fromJSONKey' for 'Generic' types.+-- These types must be sums of nullary constructors, whose names will be used+-- as keys for JSON objects.+--+-- See also 'genericToJSONKey'.+--+-- === __Example__+--+-- @+-- data Color = Red | Green | Blue+--   deriving 'Generic'+--+-- instance 'FromJSONKey' Color where+--   'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'+-- @+genericFromJSONKey :: forall a. (Generic a, GFromJSONKey (Rep a))+             => JSONKeyOptions+             -> FromJSONKeyFunction a+genericFromJSONKey opts = FromJSONKeyTextParser $ \t ->+    case parseSumFromString (keyModifier opts) t of+        Nothing -> fail $+            "invalid key " ++ show t ++ ", expected one of " ++ show cnames+        Just k -> pure (to k)+  where+    cnames = unTagged2 (constructorTags (keyModifier opts) :: Tagged2 (Rep a) [String])++class    (ConstructorNames f, SumFromString f) => GFromJSONKey f where+instance (ConstructorNames f, SumFromString f) => GFromJSONKey f where++-------------------------------------------------------------------------------+-- Functions needed for documentation+-------------------------------------------------------------------------------++-- | Fail parsing due to a type mismatch, with a descriptive message.+--+-- The following wrappers should generally be prefered:+-- 'withObject', 'withArray', 'withText', 'withBool'.+--+-- ==== Error message example+--+-- > typeMismatch "Object" (String "oops")+-- > -- Error: "expected Object, but encountered String"+typeMismatch :: String -- ^ The name of the JSON type being parsed+                       -- (@\"Object\"@, @\"Array\"@, @\"String\"@, @\"Number\"@,+                       -- @\"Boolean\"@, or @\"Null\"@).+             -> Value  -- ^ The actual value encountered.+             -> Parser a+typeMismatch expected actual =+    fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual++-- | Fail parsing due to a type mismatch, when the expected types are implicit.+--+-- ==== Error message example+--+-- > unexpected (String "oops")+-- > -- Error: "unexpected String"+unexpected :: Value -> Parser a+unexpected actual = fail $ "unexpected " ++ typeOf actual++-- | JSON type of a value, name of the head constructor.+typeOf :: Value -> String+typeOf v = case v of+    Object _ -> "Object"+    Array _  -> "Array"+    String _ -> "String"+    Number _ -> "Number"+    Bool _   -> "Boolean"+    Null     -> "Null"++-------------------------------------------------------------------------------+-- Lifings of FromJSON and ToJSON to unary and binary type constructors+-------------------------------------------------------------------------------++-- | Lifting of the 'FromJSON' class to unary type constructors.+--+-- Instead of manually writing your 'FromJSON1' instance, there are two options+-- to do it automatically:+--+-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an+-- instance at compile time. The generated instance is optimized for your type+-- so it will probably be more efficient than the following option.+--+-- * The compiler can provide a default generic implementation for+-- 'liftParseJSON'.+--+-- To use the second, simply add a @deriving 'Generic1'@ clause to your+-- datatype and declare a 'FromJSON1' instance for your datatype without giving+-- a definition for 'liftParseJSON'.+--+-- For example:+--+-- @+-- {-\# LANGUAGE DeriveGeneric \#-}+--+-- import "GHC.Generics"+--+-- data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'+--+-- instance 'FromJSON' a => 'FromJSON1' (Pair a)+-- @+--+-- If the default implementation doesn't give exactly the results you want,+-- you can customize the generic decoding with only a tiny amount of+-- effort, using 'genericLiftParseJSON' with your preferred 'Options':+--+-- @+-- customOptions = 'defaultOptions'+--                 { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'+--                 }+--+-- instance 'FromJSON' a => 'FromJSON1' (Pair a) where+--     'liftParseJSON' = 'genericLiftParseJSON' customOptions+-- @+class FromJSON1 f where+    liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)++    default liftParseJSON :: (Generic1 f, GFromJSON One (Rep1 f))+                          => (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)+    liftParseJSON = genericLiftParseJSON defaultOptions++    liftParseJSONList :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser [f a]+    liftParseJSONList f g v = listParser (liftParseJSON f g) v++-- | Lift the standard 'parseJSON' function through the type constructor.+parseJSON1 :: (FromJSON1 f, FromJSON a) => Value -> Parser (f a)+parseJSON1 = liftParseJSON parseJSON parseJSONList+{-# INLINE parseJSON1 #-}++-- | Lifting of the 'FromJSON' class to binary type constructors.+--+-- Instead of manually writing your 'FromJSON2' instance, "Data.Aeson.TH"+-- provides Template Haskell functions which will derive an instance at compile time.++-- The compiler cannot provide a default generic implementation for 'liftParseJSON2',+-- unlike 'parseJSON' and 'liftParseJSON'.+class FromJSON2 f where+    liftParseJSON2+        :: (Value -> Parser a)+        -> (Value -> Parser [a])+        -> (Value -> Parser b)+        -> (Value -> Parser [b])+        -> Value -> Parser (f a b)+    liftParseJSONList2+        :: (Value -> Parser a)+        -> (Value -> Parser [a])+        -> (Value -> Parser b)+        -> (Value -> Parser [b])+        -> Value -> Parser [f a b]+    liftParseJSONList2 fa ga fb gb = withArray "[]" $ \vals ->+        fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)++-- | Lift the standard 'parseJSON' function through the type constructor.+parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)+parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList+{-# INLINE parseJSON2 #-}++-------------------------------------------------------------------------------+-- List functions+-------------------------------------------------------------------------------++-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.+listParser :: (Value -> Parser a) -> Value -> Parser [a]+listParser f (Array xs) = fmap V.toList (V.mapM f xs)+listParser _ v          = typeMismatch "Array" v+{-# INLINE listParser #-}++-------------------------------------------------------------------------------+-- [] instances+-------------------------------------------------------------------------------++instance FromJSON1 [] where+    liftParseJSON _ p' = p'+    {-# INLINE liftParseJSON #-}++instance (FromJSON a) => FromJSON [a] where+    parseJSON = parseJSON1++-------------------------------------------------------------------------------+-- Functions+-------------------------------------------------------------------------------++-- | Add context to a failure message, indicating the name of the structure+-- being parsed.+--+-- > prependContext "MyType" (fail "[error message]")+-- > -- Error: "parsing MyType failed, [error message]"+prependContext :: String -> Parser a -> Parser a+prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")++-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@+-- is an 'Data.Aeson.Object' and fails otherwise.+--+-- ==== Error message example+--+-- > withObject "MyType" f (String "oops")+-- > -- Error: "parsing MyType failed, expected Object, but encountered String"+withObject :: String -> (Object -> Parser a) -> Value -> Parser a+withObject _    f (Object obj) = f obj+withObject name _ v            = prependContext name (typeMismatch "Object" v)+{-# INLINE withObject #-}++-- | @'withText' name f value@ applies @f@ to the 'Text' when @value@ is a+-- 'Data.Aeson.String' and fails otherwise.+--+-- ==== Error message example+--+-- > withText "MyType" f Null+-- > -- Error: "parsing MyType failed, expected String, but encountered Null"+withText :: String -> (Text -> Parser a) -> Value -> Parser a+withText _    f (String txt) = f txt+withText name _ v            = prependContext name (typeMismatch "String" v)+{-# INLINE withText #-}++-- | @'withArray' expected f value@ applies @f@ to the 'Array' when @value@ is+-- an 'Data.Aeson.Array' and fails otherwise.+--+-- ==== Error message example+--+-- > withArray "MyType" f (String "oops")+-- > -- Error: "parsing MyType failed, expected Array, but encountered String"+withArray :: String -> (Array -> Parser a) -> Value -> Parser a+withArray _    f (Array arr) = f arr+withArray name _ v           = prependContext name (typeMismatch "Array" v)+{-# INLINE withArray #-}++-- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number+-- when @value@ is a 'Data.Aeson.Number' and fails using 'typeMismatch'+-- otherwise.+--+-- /Warning/: If you are converting from a scientific to an unbounded+-- type such as 'Integer' you may want to add a restriction on the+-- size of the exponent (see 'withBoundedScientific') to prevent+-- malicious input from filling up the memory of the target system.+--+-- ==== Error message example+--+-- > withScientific "MyType" f (String "oops")+-- > -- Error: "parsing MyType failed, expected Number, but encountered String"+withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a+withScientific _ f (Number scientific) = f scientific+withScientific name _ v = prependContext name (typeMismatch "Number" v)+{-# INLINE withScientific #-}++-- | A variant of 'withScientific' which doesn't use 'prependContext', so that+-- such context can be added separately in a way that also applies when the+-- continuation @f :: Scientific -> Parser a@ fails.+--+-- /Warning/: If you are converting from a scientific to an unbounded+-- type such as 'Integer' you may want to add a restriction on the+-- size of the exponent (see 'withBoundedScientific') to prevent+-- malicious input from filling up the memory of the target system.+--+-- ==== Error message examples+--+-- > withScientific' f (String "oops")+-- > -- Error: "unexpected String"+-- >+-- > prependContext "MyType" (withScientific' f (String "oops"))+-- > -- Error: "parsing MyType failed, unexpected String"+withScientific' :: (Scientific -> Parser a) -> Value -> Parser a+withScientific' f v = case v of+    Number n -> f n+    _ -> typeMismatch "Number" v+{-# INLINE withScientific' #-}++-- | @'withBoundedScientific' name f value@ applies @f@ to the 'Scientific' number+-- when @value@ is a 'Number' with exponent less than or equal to 1024.+withBoundedScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a+withBoundedScientific name f v = withBoundedScientific_ (prependContext name) f v+{-# INLINE withBoundedScientific #-}++-- | A variant of 'withBoundedScientific' which doesn't use 'prependContext',+-- so that such context can be added separately in a way that also applies+-- when the continuation @f :: Scientific -> Parser a@ fails.+withBoundedScientific' :: (Scientific -> Parser a) -> Value -> Parser a+withBoundedScientific' f v = withBoundedScientific_ id f v+{-# INLINE withBoundedScientific' #-}++-- | A variant of 'withBoundedScientific_' parameterized by a function to apply+-- to the 'Parser' in case of failure.+withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a+withBoundedScientific_ whenFail f (Number scientific) =+    if exp10 > 1024+    then whenFail (fail msg)+    else f scientific+  where+    exp10 = base10Exponent scientific+    msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"+withBoundedScientific_ whenFail _ v =+    whenFail (typeMismatch "Number" v)+{-# INLINE withBoundedScientific_ #-}++-- | @'withBool' expected f value@ applies @f@ to the 'Bool' when @value@ is a+-- 'Boolean' and fails otherwise.+--+-- ==== Error message example+--+-- > withBool "MyType" f (String "oops")+-- > -- Error: "parsing MyType failed, expected Boolean, but encountered String"+withBool :: String -> (Bool -> Parser a) -> Value -> Parser a+withBool _    f (Bool arr) = f arr+withBool name _ v          = prependContext name (typeMismatch "Boolean" v)+{-# INLINE withBool #-}++-- | Decode a nested JSON-encoded string.+withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a+withEmbeddedJSON _ innerParser (String txt) =+    either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)+    where+        eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON+        eitherFormatError = either (Left . uncurry formatError) Right+withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v)+{-# INLINE withEmbeddedJSON #-}++-- | Convert a value from JSON, failing if the types do not match.+fromJSON :: (FromJSON a) => Value -> Result a+fromJSON = parse parseJSON+{-# INLINE fromJSON #-}++-- | Convert a value from JSON, failing if the types do not match.+ifromJSON :: (FromJSON a) => Value -> IResult a+ifromJSON = iparse parseJSON+{-# INLINE ifromJSON #-}++-- | Retrieve the value associated with the given key of an 'Object'.+-- The result is 'empty' if the key is not present or the value cannot+-- be converted to the desired type.+--+-- This accessor is appropriate if the key and value /must/ be present+-- in an object for it to be valid.  If the key and value are+-- optional, use '.:?' instead.+(.:) :: (FromJSON a) => Object -> Text -> Parser a+(.:) = explicitParseField parseJSON+{-# INLINE (.:) #-}++-- | Retrieve the value associated with the given key of an 'Object'. The+-- result is 'Nothing' if the key is not present or if its value is 'Null',+-- or 'empty' if the value cannot be converted to the desired type.+--+-- This accessor is most useful if the key and value can be absent+-- from an object without affecting its validity.  If the key and+-- value are mandatory, use '.:' instead.+(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)+(.:?) = explicitParseFieldMaybe parseJSON+{-# INLINE (.:?) #-}++-- | Retrieve the value associated with the given key of an 'Object'.+-- The result is 'Nothing' if the key is not present or 'empty' if the+-- value cannot be converted to the desired type.+--+-- This differs from '.:?' by attempting to parse 'Null' the same as any+-- other JSON value, instead of interpreting it as 'Nothing'.+(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)+(.:!) = explicitParseFieldMaybe' parseJSON+{-# INLINE (.:!) #-}++-- | Function variant of '.:'.+parseField :: (FromJSON a) => Object -> Text -> Parser a+parseField = (.:)+{-# INLINE parseField #-}++-- | Function variant of '.:?'.+parseFieldMaybe :: (FromJSON a) => Object -> Text -> Parser (Maybe a)+parseFieldMaybe = (.:?)+{-# INLINE parseFieldMaybe #-}++-- | Function variant of '.:!'.+parseFieldMaybe' :: (FromJSON a) => Object -> Text -> Parser (Maybe a)+parseFieldMaybe' = (.:!)+{-# INLINE parseFieldMaybe' #-}++-- | Variant of '.:' with explicit parser function.+--+-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@+explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a+explicitParseField p obj key = case H.lookup key obj of+    Nothing -> fail $ "key " ++ show key ++ " not found"+    Just v  -> p v <?> Key key+{-# INLINE explicitParseField #-}++-- | Variant of '.:?' with explicit parser function.+explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)+explicitParseFieldMaybe p obj key = case H.lookup key obj of+    Nothing -> pure Nothing+    Just v  -> liftParseJSON p (listParser p) v <?> Key key -- listParser isn't used by maybe instance.+{-# INLINE explicitParseFieldMaybe #-}++-- | Variant of '.:!' with explicit parser function.+explicitParseFieldMaybe' :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)+explicitParseFieldMaybe' p obj key = case H.lookup key obj of+    Nothing -> pure Nothing+    Just v  -> Just <$> p v <?> Key key+{-# INLINE explicitParseFieldMaybe' #-}++-- | Helper for use in combination with '.:?' to provide default+-- values for optional JSON object fields.+--+-- This combinator is most useful if the key and value can be absent+-- from an object without affecting its validity and we know a default+-- value to assign in that case.  If the key and value are mandatory,+-- use '.:' instead.+--+-- Example usage:+--+-- @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\"+-- v2 <- o '.:'  \"mandatory_field\"+-- v3 <- o '.:?' \"opt_field2\"+-- @+(.!=) :: Parser (Maybe a) -> a -> Parser a+pmval .!= val = fromMaybe val <$> pmval+{-# INLINE (.!=) #-}++--------------------------------------------------------------------------------+-- Generic parseJSON+-------------------------------------------------------------------------------++instance GFromJSON arity V1 where+    -- Whereof we cannot format, thereof we cannot parse:+    gParseJSON _ _ _ = fail "Attempted to parse empty type"+++instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where+    -- Meta-information, which is not handled elsewhere, is just added to the+    -- parsed value:+    gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs++-- Information for error messages++type TypeName = String+type ConName = String++-- | Add the name of the type being parsed to a parser's error messages.+contextType :: TypeName -> Parser a -> Parser a+contextType = prependContext++-- | Add the tagKey that will be looked up while building an ADT+-- | Produce the error equivalent to+-- | Left "Error in $: parsing T failed, expected an object with keys "tag" and+-- | "contents", where "tag" i-- |s associated to one of ["Foo", "Bar"],+-- | The parser returned error was: could not find key "tag"+contextTag :: Text -> [String] -> Parser a -> Parser a+contextTag tagKey cnames = prependFailure+  ("expected Object with key \"" ++ unpack tagKey ++ "\"" +++  " containing one of " ++ show cnames ++ ", ")++-- | Add the name of the constructor being parsed to a parser's error messages.+contextCons :: ConName -> TypeName -> Parser a -> Parser a+contextCons cname tname = prependContext (showCons cname tname)++-- | Render a constructor as @\"MyType(MyConstructor)\"@.+showCons :: ConName -> TypeName -> String+showCons cname tname = tname ++ "(" ++ cname ++ ")"++--------------------------------------------------------------------------------++-- Parsing single fields++instance (FromJSON a) => GFromJSON arity (K1 i a) where+    -- Constant values are decoded using their FromJSON instance:+    gParseJSON _opts _ = fmap K1 . parseJSON++instance GFromJSON One Par1 where+    -- Direct occurrences of the last type parameter are decoded with the+    -- function passed in as an argument:+    gParseJSON _opts (From1Args pj _) = fmap Par1 . pj++instance (FromJSON1 f) => GFromJSON One (Rec1 f) where+    -- Recursive occurrences of the last type parameter are decoded using their+    -- FromJSON1 instance:+    gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl++instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where+    -- If an occurrence of the last type parameter is nested inside two+    -- composed types, it is decoded by using the outermost type's FromJSON1+    -- instance to generically decode the innermost type:+    gParseJSON opts fargs =+        let gpj = gParseJSON opts fargs in+        fmap Comp1 . liftParseJSON gpj (listParser gpj)++--------------------------------------------------------------------------------++instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where+    -- Meta-information, which is not handled elsewhere, is just added to the+    -- parsed value:+    gParseJSON opts fargs = fmap M1 . gParseJSON' (tname :* opts :* fargs)+      where+        tname = moduleName proxy ++ "." ++ datatypeName proxy+        proxy = undefined :: M1 _i d _f _p++-- | 'GFromJSON', after unwrapping the 'D1' constructor, now carrying the data+-- type's name.+class GFromJSON' arity f where+    gParseJSON' :: TypeName :* Options :* FromArgs arity a+                -> Value+                -> Parser (f a)++-- | Single constructor.+instance ( ConsFromJSON arity a+         , AllNullary         (C1 c a) allNullary+         , ParseSum     arity (C1 c a) allNullary+         , Constructor c+         ) => GFromJSON' arity (C1 c a) where+    -- The option 'tagSingleConstructors' determines whether to wrap+    -- a single-constructor type.+    gParseJSON' p@(_ :* opts :* _)+        | tagSingleConstructors opts+            = (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))+            . parseSum p+        | otherwise = fmap M1 . consParseJSON (cname :* p)+      where+        cname = conName (undefined :: M1 _i c _f _p)++-- | Multiple constructors.+instance ( AllNullary          (a :+: b) allNullary+         , ParseSum      arity (a :+: b) allNullary+         ) => GFromJSON' arity (a :+: b) where+    -- If all constructors of a sum datatype are nullary and the+    -- 'allNullaryToStringTag' option is set they are expected to be+    -- encoded as strings.  This distinction is made by 'parseSum':+    gParseJSON' p =+        (unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->+                                        Parser ((a :+: b) _d))+                   . parseSum p++--------------------------------------------------------------------------------++class ParseSum arity f allNullary where+    parseSum :: TypeName :* Options :* FromArgs arity a+             -> Value+             -> Tagged allNullary (Parser (f a))++instance ( ConstructorNames        f+         , SumFromString           f+         , FromPair          arity f+         , FromTaggedObject  arity f+         , FromUntaggedValue arity f+         ) => ParseSum       arity f True where+    parseSum p@(tname :* opts :* _)+        | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts+        | otherwise                  = Tagged . parseNonAllNullarySum p++instance ( ConstructorNames        f+         , FromPair          arity f+         , FromTaggedObject  arity f+         , FromUntaggedValue arity f+         ) => ParseSum       arity f False where+    parseSum p = Tagged . parseNonAllNullarySum p++--------------------------------------------------------------------------------++parseAllNullarySum :: (SumFromString f, ConstructorNames f)+                   => TypeName -> Options -> Value -> Parser (f a)+parseAllNullarySum tname opts =+    withText tname $ \tag ->+        maybe (badTag tag) return $+            parseSumFromString modifier tag+  where+    badTag tag = failWithCTags tname modifier $ \cnames ->+        "expected one of the tags " ++ show cnames +++        ", but found tag " ++ show tag+    modifier = constructorTagModifier opts++-- | Fail with an informative error message about a mismatched tag.+-- The error message is parameterized by the list of expected tags,+-- to be inferred from the result type of the parser.+failWithCTags+  :: forall f a t. ConstructorNames f+  => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)+failWithCTags tname modifier f =+    contextType tname . fail $ f cnames+  where+    cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])++class SumFromString f where+    parseSumFromString :: (String -> String) -> Text -> Maybe (f a)++instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where+    parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>+                                  (R1 <$> parseSumFromString opts key)++instance (Constructor c) => SumFromString (C1 c U1) where+    parseSumFromString modifier key+        | key == name = Just $ M1 U1+        | otherwise   = Nothing+      where+        name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)++-- For genericFromJSONKey+instance SumFromString a => SumFromString (D1 d a) where+    parseSumFromString modifier key = M1 <$> parseSumFromString modifier key++-- | List of all constructor tags.+constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]+constructorTags modifier =+    fmap DList.toList (constructorNames' modifier)++-- | List of all constructor names of an ADT, after a given conversion+-- function. (Better inlining.)+class ConstructorNames a where+    constructorNames' :: (String -> t) -> Tagged2 a (DList.DList t)++instance (ConstructorNames a, ConstructorNames b) => ConstructorNames (a :+: b) where+    constructorNames' = liftA2 append constructorNames' constructorNames'+      where+        append+          :: Tagged2 a (DList.DList t)+          -> Tagged2 b (DList.DList t)+          -> Tagged2 (a :+: b) (DList.DList t)+        append (Tagged2 xs) (Tagged2 ys) = Tagged2 (DList.append xs ys)++instance Constructor c => ConstructorNames (C1 c a) where+    constructorNames' f = Tagged2 (pure (f cname))+      where+        cname = conName (undefined :: M1 _i c _f _p)++-- For genericFromJSONKey+instance ConstructorNames a => ConstructorNames (D1 d a) where+    constructorNames' = retag . constructorNames'+      where+        retag :: Tagged2 a u -> Tagged2 (D1 d a) u+        retag (Tagged2 x) = Tagged2 x++--------------------------------------------------------------------------------+parseNonAllNullarySum :: forall f c arity.+                         ( FromPair          arity f+                         , FromTaggedObject  arity f+                         , FromUntaggedValue arity f+                         , ConstructorNames        f+                         ) => TypeName :* Options :* FromArgs arity c+                           -> Value -> Parser (f c)+parseNonAllNullarySum p@(tname :* opts :* _) =+    case sumEncoding opts of+      TaggedObject{..} ->+          withObject tname $ \obj -> do+              tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey+              fromMaybe (badTag tag <?> Key tagKey) $+                  parseFromTaggedObject (tag :* contentsFieldName :* p) obj+        where+          tagKey = pack tagFieldName+          badTag tag = failWith_ $ \cnames ->+              "expected tag field to be one of " ++ show cnames +++              ", but found tag " ++ show tag+          cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])++      ObjectWithSingleField ->+          withObject tname $ \obj -> case H.toList obj of+              [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $+                  parsePair (tag :* p) v+              _ -> contextType tname . fail $+                  "expected an Object with a single pair, but found " +++                  show (H.size obj) ++ " pairs"+        where+          badTag tag = failWith_ $ \cnames ->+              "expected an Object with a single pair where the tag is one of " +++              show cnames ++ ", but found tag " ++ show tag++      TwoElemArray ->+          withArray tname $ \arr -> case V.length arr of+              2 | String tag <- V.unsafeIndex arr 0 ->+                  maybe (badTag tag <?> Index 0) (<?> Index 1) $+                      parsePair (tag :* p) (V.unsafeIndex arr 1)+                | otherwise ->+                  contextType tname $+                      fail "tag element is not a String" <?> Index 0+              len -> contextType tname . fail $+                  "expected a 2-element Array, but encountered an Array of length " +++                  show len+        where+          badTag tag = failWith_ $ \cnames ->+              "expected tag of the 2-element Array to be one of " +++              show cnames ++ ", but found tag " ++ show tag++      UntaggedValue -> parseUntaggedValue p+  where+    failWith_ = failWithCTags tname (constructorTagModifier opts)++--------------------------------------------------------------------------------++class FromTaggedObject arity f where+    -- The first two components of the parameter tuple are: the constructor tag+    -- to match against, and the contents field name.+    parseFromTaggedObject+        :: Text :* String :* TypeName :* Options :* FromArgs arity a+        -> Object+        -> Maybe (Parser (f a))++instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>+    FromTaggedObject arity (a :+: b) where+        parseFromTaggedObject p obj =+            (fmap L1 <$> parseFromTaggedObject p obj) <|>+            (fmap R1 <$> parseFromTaggedObject p obj)++instance ( IsRecord                f isRecord+         , FromTaggedObject' arity f isRecord+         , Constructor c+         ) => FromTaggedObject arity (C1 c f) where+    parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))+        | tag == tag'+        = Just . fmap M1 .+            (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .+            parseFromTaggedObject' (contentsFieldName :* cname :* p)+        | otherwise = const Nothing+      where+        tag' = pack $ constructorTagModifier opts cname+        cname = conName (undefined :: M1 _i c _f _p)++--------------------------------------------------------------------------------++class FromTaggedObject' arity f isRecord where+    -- The first component of the parameter tuple is the contents field name.+    parseFromTaggedObject'+        :: String :* ConName :* TypeName :* Options :* FromArgs arity a+        -> Object -> Tagged isRecord (Parser (f a))++instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where+    -- Records are unpacked in the tagged object+    parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)++instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where+    -- Nonnullary nonrecords are encoded in the contents field+    parseFromTaggedObject' p obj = Tagged $ do+        contents <- contextCons cname tname (obj .: key)+        consParseJSON p' contents <?> Key key+      where+        key = pack contentsFieldName+        contentsFieldName :* p'@(cname :* tname :* _) = p++instance OVERLAPPING_ FromTaggedObject' arity U1 False where+    -- Nullary constructors don't need a contents field+    parseFromTaggedObject' _ _ = Tagged (pure U1)++--------------------------------------------------------------------------------++-- | Constructors need to be decoded differently depending on whether they're+-- a record or not. This distinction is made by 'ConsParseJSON'.+class ConsFromJSON arity f where+    consParseJSON+        :: ConName :* TypeName :* Options :* FromArgs arity a+        -> Value -> Parser (f a)++class ConsFromJSON' arity f isRecord where+    consParseJSON'+        :: ConName :* TypeName :* Options :* FromArgs arity a+        -> Value -> Tagged isRecord (Parser (f a))++instance ( IsRecord            f isRecord+         , ConsFromJSON' arity f isRecord+         ) => ConsFromJSON arity f where+    consParseJSON p =+      (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))+          . consParseJSON' p++instance OVERLAPPING_+         ( GFromJSON arity a, RecordFromJSON arity (S1 s a)+         ) => ConsFromJSON' arity (S1 s a) True where+    consParseJSON' p@(cname :* tname :* opts :* fargs)+        | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs+        | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))++instance RecordFromJSON arity f => ConsFromJSON' arity f True where+    consParseJSON' p@(cname :* tname :* _) =+        Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))++instance OVERLAPPING_+         ConsFromJSON' arity U1 False where+    -- Empty constructors are expected to be encoded as an empty array:+    consParseJSON' (cname :* tname :* _) v =+        Tagged . contextCons cname tname $ case v of+            Array a | V.null a -> pure U1+                    | otherwise -> fail_ a+            _ -> typeMismatch "Array" v+      where+        fail_ a = fail $+            "expected an empty Array, but encountered an Array of length " +++            show (V.length a)++instance OVERLAPPING_+         GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where+    consParseJSON' (_ :* _ :* opts :* fargs) =+        Tagged . fmap M1 . gParseJSON opts fargs++instance (ProductFromJSON arity f, ProductSize f+         ) => ConsFromJSON' arity f False where+    consParseJSON' p = Tagged . productParseJSON0 p++--------------------------------------------------------------------------------++class FieldNames f where+    fieldNames :: f a -> [String] -> [String]++instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where+    fieldNames _ =+      fieldNames (undefined :: a x) .+      fieldNames (undefined :: b y)++instance (Selector s) => FieldNames (S1 s f) where+    fieldNames _ = (selName (undefined :: M1 _i s _f _p) :)++class RecordFromJSON arity f where+    recordParseJSON+        :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a+        -> Object -> Parser (f a)++instance ( FieldNames f+         , RecordFromJSON' arity f+         ) => RecordFromJSON arity f where+    recordParseJSON (fromTaggedSum :* p@(cname :* tname :* opts :* _)) =+        \obj -> checkUnknown obj >> recordParseJSON' p obj+        where+            knownFields :: H.HashMap Text ()+            knownFields = H.fromList $ map ((,()) . pack) $+                [tagFieldName (sumEncoding opts) | fromTaggedSum] <>+                (fieldLabelModifier opts <$> fieldNames (undefined :: f a) [])++            checkUnknown =+                if not (rejectUnknownFields opts)+                then \_ -> return ()+                else \obj -> case H.keys (H.difference obj knownFields) of+                    [] -> return ()+                    unknownFields -> contextCons cname tname $+                        fail ("unknown fields: " ++ show unknownFields)++class RecordFromJSON' arity f where+    recordParseJSON'+        :: ConName :* TypeName :* Options :* FromArgs arity a+        -> Object -> Parser (f a)++instance ( RecordFromJSON' arity a+         , RecordFromJSON' arity b+         ) => RecordFromJSON' arity (a :*: b) where+    recordParseJSON' p obj =+        (:*:) <$> recordParseJSON' p obj+              <*> recordParseJSON' p obj++instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>+         RecordFromJSON' arity (S1 s a) where+    recordParseJSON' (cname :* tname :* opts :* fargs) obj = do+        fv <- contextCons cname tname (obj .: label)+        M1 <$> gParseJSON opts fargs fv <?> Key label+      where+        label = pack $ fieldLabelModifier opts sname+        sname = selName (undefined :: M1 _i s _f _p)++instance INCOHERENT_ (Selector s, FromJSON a) =>+         RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where+    recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label+      where+        label = fieldLabelModifier opts sname+        sname = selName (undefined :: M1 _i s _f _p)++-- Parse an Option like a Maybe.+instance INCOHERENT_ (Selector s, FromJSON a) =>+         RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where+    recordParseJSON' p obj = wrap <$> recordParseJSON' p obj+      where+        wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p+        wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))++--------------------------------------------------------------------------------++productParseJSON0+    :: forall f arity a. (ProductFromJSON arity f, ProductSize f)+    => ConName :* TypeName :* Options :* FromArgs arity a+    -> Value -> Parser (f a)+    -- Products are expected to be encoded to an array. Here we check whether we+    -- got an array of the same size as the product, then parse each of the+    -- product's elements using productParseJSON:+productParseJSON0 p@(cname :* tname :* _ :* _) =+    withArray (showCons cname tname) $ \arr ->+        let lenArray = V.length arr+            lenProduct = (unTagged2 :: Tagged2 f Int -> Int)+                         productSize in+        if lenArray == lenProduct+        then productParseJSON p arr 0 lenProduct+        else contextCons cname tname $+             fail $ "expected an Array of length " ++ show lenProduct +++                    ", but encountered an Array of length " ++ show lenArray++--++class ProductFromJSON arity f where+    productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a+                 -> Array -> Int -> Int+                 -> Parser (f a)++instance ( ProductFromJSON    arity a+         , ProductFromJSON    arity b+         ) => ProductFromJSON arity (a :*: b) where+    productParseJSON p arr ix len =+        (:*:) <$> productParseJSON p arr ix  lenL+              <*> productParseJSON p arr ixR lenR+        where+          lenL = len `unsafeShiftR` 1+          ixR  = ix + lenL+          lenR = len - lenL++instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where+    productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =+        M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix++--------------------------------------------------------------------------------++class FromPair arity f where+    -- The first component of the parameter tuple is the tag to match.+    parsePair :: Text :* TypeName :* Options :* FromArgs arity a+              -> Value+              -> Maybe (Parser (f a))++instance ( FromPair arity a+         , FromPair arity b+         ) => FromPair arity (a :+: b) where+    parsePair p pair =+        (fmap L1 <$> parsePair p pair) <|>+        (fmap R1 <$> parsePair p pair)++instance ( Constructor c+         , ConsFromJSON arity a+         ) => FromPair arity (C1 c a) where+    parsePair (tag :* p@(_ :* opts :* _)) v+        | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v+        | otherwise   = Nothing+      where+        tag' = pack $ constructorTagModifier opts cname+        cname = conName (undefined :: M1 _i c _a _p)++--------------------------------------------------------------------------------++class FromUntaggedValue arity f where+    parseUntaggedValue :: TypeName :* Options :* FromArgs arity a+                       -> Value+                       -> Parser (f a)++instance+    ( FromUntaggedValue    arity a+    , FromUntaggedValue    arity b+    ) => FromUntaggedValue arity (a :+: b)+  where+    parseUntaggedValue p value =+        L1 <$> parseUntaggedValue p value <|>+        R1 <$> parseUntaggedValue p value++instance OVERLAPPABLE_+    ( ConsFromJSON arity a+    , Constructor c+    ) => FromUntaggedValue arity (C1 c a)+  where+    parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)+      where+        cname = conName (undefined :: M1 _i c _f _p)++instance OVERLAPPING_+    ( Constructor c )+    => FromUntaggedValue arity (C1 c U1)+  where+    parseUntaggedValue (tname :* opts :* _) v =+        contextCons cname tname $ case v of+            String tag+                | tag == tag' -> pure $ M1 U1+                | otherwise -> fail_ tag+            _ -> typeMismatch "String" v+      where+        tag' = pack $ constructorTagModifier opts cname+        cname = conName (undefined :: M1 _i c _f _p)+        fail_ tag = fail $+          "expected tag " ++ show tag' ++ ", but found tag " ++ show tag++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- base+-------------------------------------------------------------------------------+++instance FromJSON2 Const where+    liftParseJSON2 p _ _ _ = fmap Const . p+    {-# INLINE liftParseJSON2 #-}++instance FromJSON a => FromJSON1 (Const a) where+    liftParseJSON _ _ = fmap Const . parseJSON+    {-# INLINE liftParseJSON #-}++instance FromJSON a => FromJSON (Const a b) where+    {-# INLINE parseJSON #-}+    parseJSON = fmap Const . parseJSON++instance (FromJSON a, FromJSONKey a) => FromJSONKey (Const a b) where+    fromJSONKey = fmap Const fromJSONKey+++instance FromJSON1 Maybe where+    liftParseJSON _ _ Null = pure Nothing+    liftParseJSON p _ a    = Just <$> p a+    {-# INLINE liftParseJSON #-}++instance (FromJSON a) => FromJSON (Maybe a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++++instance FromJSON2 Either where+    liftParseJSON2 pA _ pB _ (Object (H.toList -> [(key, value)]))+        | key == left  = Left  <$> pA value <?> Key left+        | key == right = Right <$> pB value <?> Key right+      where+        left, right :: Text+        left  = "Left"+        right = "Right"++    liftParseJSON2 _ _ _ _ _ = fail $+        "expected an object with a single property " +++        "where the property key should be either " +++        "\"Left\" or \"Right\""+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a) => FromJSON1 (Either a) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}++instance FromJSON Void where+    parseJSON _ = fail "Cannot parse Void"+    {-# INLINE parseJSON #-}++instance FromJSON Bool where+    parseJSON (Bool b) = pure b+    parseJSON v = typeMismatch "Bool" v+    {-# INLINE parseJSON #-}++instance FromJSONKey Bool where+    fromJSONKey = FromJSONKeyTextParser $ \t -> case t of+        "true"  -> pure True+        "false" -> pure False+        _       -> fail $ "cannot parse key " ++ show t ++ " into Bool"++instance FromJSON Ordering where+  parseJSON = withText "Ordering" $ \s ->+    case s of+      "LT" -> return LT+      "EQ" -> return EQ+      "GT" -> return GT+      _ -> fail $ "parsing Ordering failed, unexpected " ++ show s +++                  " (expected \"LT\", \"EQ\", or \"GT\")"++instance FromJSON () where+    parseJSON = withArray "()" $ \v ->+                  if V.null v+                    then pure ()+                    else prependContext "()" $ fail "expected an empty array"+    {-# INLINE parseJSON #-}++instance FromJSON Char where+    parseJSON = withText "Char" parseChar+    {-# INLINE parseJSON #-}++    parseJSONList (String s) = pure (T.unpack s)+    parseJSONList v = typeMismatch "String" v+    {-# INLINE parseJSONList #-}++parseChar :: Text -> Parser Char+parseChar t =+    if T.compareLength t 1 == EQ+      then pure $ T.head t+      else prependContext "Char" $ fail "expected a string of length 1"++instance FromJSON Double where+    parseJSON = parseRealFloat "Double"+    {-# INLINE parseJSON #-}++instance FromJSONKey Double where+    fromJSONKey = FromJSONKeyTextParser $ \t -> case t of+        "NaN"       -> pure (0/0)+        "Infinity"  -> pure (1/0)+        "-Infinity" -> pure (negate 1/0)+        _           -> Scientific.toRealFloat <$> parseScientificText t++instance FromJSON Float where+    parseJSON = parseRealFloat "Float"+    {-# INLINE parseJSON #-}++instance FromJSONKey Float where+    fromJSONKey = FromJSONKeyTextParser $ \t -> case t of+        "NaN"       -> pure (0/0)+        "Infinity"  -> pure (1/0)+        "-Infinity" -> pure (negate 1/0)+        _           -> Scientific.toRealFloat <$> parseScientificText t++instance (FromJSON a, Integral a) => FromJSON (Ratio a) where+    parseJSON (Number x)+      | exp10 <= 1024+      , exp10 >= -1024 = return $! realToFrac x+      | otherwise      = prependContext "Ratio" $ fail msg+      where+        exp10 = base10Exponent x+        msg = "found a number with exponent " ++ show exp10+           ++ ", but it must not be greater than 1024 or less than -1024"+    parseJSON o = objParser o+      where+        objParser = withObject "Rational" $ \obj -> do+            numerator <- obj .: "numerator"+            denominator <- obj .: "denominator"+            if denominator == 0+            then fail "Ratio denominator was 0"+            else pure $ numerator % denominator+    {-# INLINE parseJSON #-}++-- | This instance includes a bounds check to prevent maliciously+-- large inputs to fill up the memory of the target system. You can+-- newtype 'Scientific' and provide your own instance using+-- 'withScientific' if you want to allow larger inputs.+instance HasResolution a => FromJSON (Fixed a) where+    parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac)+    {-# INLINE parseJSON #-}++instance FromJSON Int where+    parseJSON = parseBoundedIntegral "Int"+    {-# INLINE parseJSON #-}++instance FromJSONKey Int where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"++-- | This instance includes a bounds check to prevent maliciously+-- large inputs to fill up the memory of the target system. You can+-- newtype 'Scientific' and provide your own instance using+-- 'withScientific' if you want to allow larger inputs.+instance FromJSON Integer where+    parseJSON = parseIntegral "Integer"+    {-# INLINE parseJSON #-}++instance FromJSONKey Integer where+    fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer"++instance FromJSON Natural where+    parseJSON value = do+        integer <- parseIntegral "Natural" value+        parseNatural integer++instance FromJSONKey Natural where+    fromJSONKey = FromJSONKeyTextParser $ \text -> do+        integer <- parseIntegralText "Natural" text+        parseNatural integer++parseNatural :: Integer -> Parser Natural+parseNatural integer =+    if integer < 0 then+        fail $ "parsing Natural failed, unexpected negative number " <> show integer+    else+        pure $ fromIntegral integer++instance FromJSON Int8 where+    parseJSON = parseBoundedIntegral "Int8"+    {-# INLINE parseJSON #-}++instance FromJSONKey Int8 where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int8"++instance FromJSON Int16 where+    parseJSON = parseBoundedIntegral "Int16"+    {-# INLINE parseJSON #-}++instance FromJSONKey Int16 where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int16"++instance FromJSON Int32 where+    parseJSON = parseBoundedIntegral "Int32"+    {-# INLINE parseJSON #-}++instance FromJSONKey Int32 where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int32"++instance FromJSON Int64 where+    parseJSON = parseBoundedIntegral "Int64"+    {-# INLINE parseJSON #-}++instance FromJSONKey Int64 where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int64"++instance FromJSON Word where+    parseJSON = parseBoundedIntegral "Word"+    {-# INLINE parseJSON #-}++instance FromJSONKey Word where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word"++instance FromJSON Word8 where+    parseJSON = parseBoundedIntegral "Word8"+    {-# INLINE parseJSON #-}++instance FromJSONKey Word8 where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word8"++instance FromJSON Word16 where+    parseJSON = parseBoundedIntegral "Word16"+    {-# INLINE parseJSON #-}++instance FromJSONKey Word16 where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word16"++instance FromJSON Word32 where+    parseJSON = parseBoundedIntegral "Word32"+    {-# INLINE parseJSON #-}++instance FromJSONKey Word32 where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word32"++instance FromJSON Word64 where+    parseJSON = parseBoundedIntegral "Word64"+    {-# INLINE parseJSON #-}++instance FromJSONKey Word64 where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64"++instance FromJSON CTime where+    parseJSON = fmap CTime . parseJSON+    {-# INLINE parseJSON #-}++instance FromJSON Text where+    parseJSON = withText "Text" pure+    {-# INLINE parseJSON #-}++instance FromJSONKey Text where+    fromJSONKey = fromJSONKeyCoerce+++instance FromJSON LT.Text where+    parseJSON = withText "Lazy Text" $ pure . LT.fromStrict+    {-# INLINE parseJSON #-}++instance FromJSONKey LT.Text where+    fromJSONKey = FromJSONKeyText LT.fromStrict+++instance FromJSON Version where+    parseJSON = withText "Version" parseVersionText+    {-# INLINE parseJSON #-}++instance FromJSONKey Version where+    fromJSONKey = FromJSONKeyTextParser parseVersionText++parseVersionText :: Text -> Parser Version+parseVersionText = go . readP_to_S parseVersion . unpack+  where+    go [(v,[])] = return v+    go (_ : xs) = go xs+    go _        = fail "parsing Version failed"++-------------------------------------------------------------------------------+-- semigroups NonEmpty+-------------------------------------------------------------------------------++instance FromJSON1 NonEmpty where+    liftParseJSON p _ = withArray "NonEmpty" $+        (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList+      where+        ne []     = fail "parsing NonEmpty failed, unexpected empty list"+        ne (x:xs) = pure (x :| xs)+    {-# INLINE liftParseJSON #-}++instance (FromJSON a) => FromJSON (NonEmpty a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++-------------------------------------------------------------------------------+-- scientific+-------------------------------------------------------------------------------++instance FromJSON Scientific where+    parseJSON = withScientific "Scientific" pure+    {-# INLINE parseJSON #-}++-------------------------------------------------------------------------------+-- DList+-------------------------------------------------------------------------------++instance FromJSON1 DList.DList where+    liftParseJSON p _ = withArray "DList" $+      fmap DList.fromList .+      Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a) => FromJSON (DList.DList a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++#if MIN_VERSION_dlist(1,0,0) && __GLASGOW_HASKELL__ >=800+-- | @since 1.5.3.0+instance FromJSON1 DNE.DNonEmpty where+    liftParseJSON p _ = withArray "DNonEmpty" $+        (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList+      where+        ne []     = fail "parsing DNonEmpty failed, unexpected empty list"+        ne (x:xs) = pure (DNE.fromNonEmpty (x :| xs))+    {-# INLINE liftParseJSON #-}++-- | @since 1.5.3.0+instance (FromJSON a) => FromJSON (DNE.DNonEmpty a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}+#endif++-------------------------------------------------------------------------------+-- transformers - Functors+-------------------------------------------------------------------------------++instance FromJSON1 Identity where+    liftParseJSON p _ a = Identity <$> p a+    {-# INLINE liftParseJSON #-}++    liftParseJSONList _ p a = fmap Identity <$> p a+    {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Identity a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++    parseJSONList = liftParseJSONList parseJSON parseJSONList+    {-# INLINE parseJSONList #-}++instance (FromJSONKey a) => FromJSONKey (Identity a) where+    fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a)+    fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])+++instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Compose f g) where+    liftParseJSON p pl a = Compose <$> liftParseJSON g gl a+      where+        g  = liftParseJSON p pl+        gl = liftParseJSONList p pl+    {-# INLINE liftParseJSON #-}++    liftParseJSONList p pl a = map Compose <$> liftParseJSONList g gl a+      where+        g  = liftParseJSON p pl+        gl = liftParseJSONList p pl+    {-# INLINE liftParseJSONList #-}++instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Compose f g a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++    parseJSONList = liftParseJSONList parseJSON parseJSONList+    {-# INLINE parseJSONList #-}+++instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Product f g) where+    liftParseJSON p pl a = uncurry Pair <$> liftParseJSON2 px pxl py pyl a+      where+        px  = liftParseJSON p pl+        pxl = liftParseJSONList p pl+        py  = liftParseJSON p pl+        pyl = liftParseJSONList p pl+    {-# INLINE liftParseJSON #-}++instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Product f g a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}+++instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where+    liftParseJSON p pl (Object (H.toList -> [(key, value)]))+        | key == inl = InL <$> liftParseJSON p pl value <?> Key inl+        | key == inr = InR <$> liftParseJSON p pl value <?> Key inl+      where+        inl, inr :: Text+        inl = "InL"+        inr = "InR"++    liftParseJSON _ _ _ = fail $+        "parsing Sum failed, expected an object with a single property " +++        "where the property key should be either " +++        "\"InL\" or \"InR\""+    {-# INLINE liftParseJSON #-}++instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++-------------------------------------------------------------------------------+-- containers+-------------------------------------------------------------------------------++instance FromJSON1 Seq.Seq where+    liftParseJSON p _ = withArray "Seq" $+      fmap Seq.fromList .+      Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a) => FromJSON (Seq.Seq a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}+++instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where+    parseJSON = fmap Set.fromList . parseJSON+    {-# INLINE parseJSON #-}+++instance FromJSON IntSet.IntSet where+    parseJSON = fmap IntSet.fromList . parseJSON+    {-# INLINE parseJSON #-}+++instance FromJSON1 IntMap.IntMap where+    liftParseJSON p pl = fmap IntMap.fromList . liftParseJSON p' pl'+      where+        p'  = liftParseJSON2     parseJSON parseJSONList p pl+        pl' = liftParseJSONList2 parseJSON parseJSONList p pl+    {-# INLINE liftParseJSON #-}++instance FromJSON a => FromJSON (IntMap.IntMap a) where+    parseJSON = fmap IntMap.fromList . parseJSON+    {-# INLINE parseJSON #-}+++instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where+    liftParseJSON p _ = case fromJSONKey of+        FromJSONKeyCoerce -> withObject "Map" $+            fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)+        FromJSONKeyText f -> withObject "Map" $+            fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)+        FromJSONKeyTextParser f -> withObject "Map" $+            H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)+        FromJSONKeyValue f -> withArray "Map" $ \arr ->+            fmap M.fromList . Tr.sequence .+                zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr+    {-# INLINE liftParseJSON #-}++instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (M.Map k v) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}+++instance FromJSON1 Tree.Tree where+    liftParseJSON p pl = go+      where+        go v = uncurry Tree.Node <$> liftParseJSON2 p pl p' pl' v++        p' = liftParseJSON go (listParser go)+        pl'= liftParseJSONList go (listParser go)++instance (FromJSON v) => FromJSON (Tree.Tree v) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++-------------------------------------------------------------------------------+-- uuid+-------------------------------------------------------------------------------++instance FromJSON UUID.UUID where+    parseJSON = withText "UUID" $+        maybe (fail "invalid UUID") pure . UUID.fromText++instance FromJSONKey UUID.UUID where+    fromJSONKey = FromJSONKeyTextParser $+        maybe (fail "invalid UUID") pure . UUID.fromText++-------------------------------------------------------------------------------+-- vector+-------------------------------------------------------------------------------++instance FromJSON1 Vector where+    liftParseJSON p _ = withArray "Vector" $+        V.mapM (uncurry $ parseIndexedJSON p) . V.indexed+    {-# INLINE liftParseJSON #-}++instance (FromJSON a) => FromJSON (Vector a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}+++vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)+vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry $ parseIndexedJSON parseJSON) . V.indexed+{-# INLINE vectorParseJSON #-}++instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where+    parseJSON = vectorParseJSON "Data.Vector.Storable.Vector"++instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where+    parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector"+    {-# INLINE parseJSON #-}++instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where+    parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector"+    {-# INLINE parseJSON #-}++-------------------------------------------------------------------------------+-- unordered-containers+-------------------------------------------------------------------------------++instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where+    parseJSON = fmap HashSet.fromList . parseJSON+    {-# INLINE parseJSON #-}+++instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where+    liftParseJSON p _ = case fromJSONKey of+        FromJSONKeyCoerce -> withObject "HashMap ~Text" $+            uc . H.traverseWithKey (\k v -> p v <?> Key k)+        FromJSONKeyText f -> withObject "HashMap" $+            fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)+        FromJSONKeyTextParser f -> withObject "HashMap" $+            H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)+        FromJSONKeyValue f -> withArray "Map" $ \arr ->+            fmap H.fromList . Tr.sequence .+                zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr+      where+        uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v)+        uc = unsafeCoerce++instance (FromJSON v, FromJSONKey k, Eq k, Hashable k) => FromJSON (H.HashMap k v) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++-------------------------------------------------------------------------------+-- aeson+-------------------------------------------------------------------------------++instance FromJSON Value where+    parseJSON = pure+    {-# INLINE parseJSON #-}++instance FromJSON DotNetTime where+    parseJSON = withText "DotNetTime" $ \t ->+        let (s,m) = T.splitAt (T.length t - 5) t+            t'    = T.concat [s,".",m]+        in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of+             Just d -> pure (DotNetTime d)+             _      -> fail "could not parse .NET time"+    {-# INLINE parseJSON #-}++-------------------------------------------------------------------------------+-- primitive+-------------------------------------------------------------------------------++instance FromJSON a => FromJSON (PM.Array a) where+  -- note: we could do better than this if vector exposed the data+  -- constructor in Data.Vector.+  parseJSON = fmap Exts.fromList . parseJSON++instance FromJSON a => FromJSON (PM.SmallArray a) where+  parseJSON = fmap Exts.fromList . parseJSON++instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where+  parseJSON = fmap Exts.fromList . parseJSON++-------------------------------------------------------------------------------+-- time+-------------------------------------------------------------------------------++instance FromJSON Day where+    parseJSON = withText "Day" (Time.run Time.day)++instance FromJSONKey Day where+    fromJSONKey = FromJSONKeyTextParser (Time.run Time.day)+++instance FromJSON TimeOfDay where+    parseJSON = withText "TimeOfDay" (Time.run Time.timeOfDay)++instance FromJSONKey TimeOfDay where+    fromJSONKey = FromJSONKeyTextParser (Time.run Time.timeOfDay)+++instance FromJSON LocalTime where+    parseJSON = withText "LocalTime" (Time.run Time.localTime)++instance FromJSONKey LocalTime where+    fromJSONKey = FromJSONKeyTextParser (Time.run Time.localTime)+++-- | Supported string formats:+--+-- @YYYY-MM-DD HH:MM Z@+-- @YYYY-MM-DD HH:MM:SS Z@+-- @YYYY-MM-DD HH:MM:SS.SSS Z@+--+-- The first space may instead be a @T@, and the second space is+-- optional.  The @Z@ represents UTC.  The @Z@ may be replaced with a+-- time zone offset of the form @+0000@ or @-08:00@, where the first+-- two digits are hours, the @:@ is optional and the second two digits+-- (also optional) are minutes.+instance FromJSON ZonedTime where+    parseJSON = withText "ZonedTime" (Time.run Time.zonedTime)++instance FromJSONKey ZonedTime where+    fromJSONKey = FromJSONKeyTextParser (Time.run Time.zonedTime)+++instance FromJSON UTCTime where+    parseJSON = withText "UTCTime" (Time.run Time.utcTime)++instance FromJSONKey UTCTime where+    fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)+++-- | This instance includes a bounds check to prevent maliciously+-- large inputs to fill up the memory of the target system. You can+-- newtype 'Scientific' and provide your own instance using+-- 'withScientific' if you want to allow larger inputs.+instance FromJSON NominalDiffTime where+    parseJSON = withBoundedScientific "NominalDiffTime" $ pure . realToFrac+    {-# INLINE parseJSON #-}+++-- | This instance includes a bounds check to prevent maliciously+-- large inputs to fill up the memory of the target system. You can+-- newtype 'Scientific' and provide your own instance using+-- 'withScientific' if you want to allow larger inputs.+instance FromJSON DiffTime where+    parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac+    {-# INLINE parseJSON #-}++instance FromJSON SystemTime where+    parseJSON v = prependContext "SystemTime" $ do+        n <- parseJSON v+        let n' = floor (n * fromInteger (resolution n) :: Nano)+        let (secs, nano) = n' `divMod` resolution n+        return (MkSystemTime (fromInteger secs) (fromInteger nano))++instance FromJSON CalendarDiffTime where+    parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime+        <$> obj .: "months"+        <*> obj .: "time"++instance FromJSON CalendarDiffDays where+    parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays+        <$> obj .: "months"+        <*> obj .: "days"++instance FromJSON DayOfWeek where+    parseJSON = withText "DaysOfWeek" parseDayOfWeek++parseDayOfWeek :: T.Text -> Parser DayOfWeek+parseDayOfWeek t = case T.toLower t of+    "monday"    -> return Monday+    "tuesday"   -> return Tuesday+    "wednesday" -> return Wednesday+    "thursday"  -> return Thursday+    "friday"    -> return Friday+    "saturday"  -> return Saturday+    "sunday"    -> return Sunday+    _           -> fail "Invalid week day"++instance FromJSONKey DayOfWeek where+    fromJSONKey = FromJSONKeyTextParser parseDayOfWeek++instance FromJSON QuarterOfYear where+    parseJSON = withText "DaysOfWeek" parseQuarterOfYear++parseQuarterOfYear :: T.Text -> Parser QuarterOfYear+parseQuarterOfYear t = case T.toLower t of+    "q1" -> return Q1+    "q2" -> return Q2+    "q3" -> return Q3+    "q4" -> return Q4+    _    -> fail "Invalid quarter of year"++instance FromJSONKey QuarterOfYear where+    fromJSONKey = FromJSONKeyTextParser parseQuarterOfYear++instance FromJSON Quarter where+    parseJSON = withText "Quarter" (Time.run Time.quarter)++instance FromJSONKey Quarter where+    fromJSONKey = FromJSONKeyTextParser (Time.run Time.quarter)++instance FromJSON Month where+    parseJSON = withText "Month" (Time.run Time.month)++instance FromJSONKey Month where+    fromJSONKey = FromJSONKeyTextParser (Time.run Time.month)++-------------------------------------------------------------------------------+-- base Monoid/Semigroup+-------------------------------------------------------------------------------++instance FromJSON1 Monoid.Dual where+    liftParseJSON p _ = fmap Monoid.Dual . p+    {-# INLINE liftParseJSON #-}++instance FromJSON a => FromJSON (Monoid.Dual a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}+++instance FromJSON1 Monoid.First where+    liftParseJSON p p' = fmap Monoid.First . liftParseJSON p p'+    {-# INLINE liftParseJSON #-}++instance FromJSON a => FromJSON (Monoid.First a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}+++instance FromJSON1 Monoid.Last where+    liftParseJSON p p' = fmap Monoid.Last . liftParseJSON p p'+    {-# INLINE liftParseJSON #-}++instance FromJSON a => FromJSON (Monoid.Last a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}+++instance FromJSON1 Semigroup.Min where+    liftParseJSON p _ a = Semigroup.Min <$> p a+    {-# INLINE liftParseJSON #-}++    liftParseJSONList _ p a = fmap Semigroup.Min <$> p a+    {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Semigroup.Min a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++    parseJSONList = liftParseJSONList parseJSON parseJSONList+    {-# INLINE parseJSONList #-}+++instance FromJSON1 Semigroup.Max where+    liftParseJSON p _ a = Semigroup.Max <$> p a+    {-# INLINE liftParseJSON #-}++    liftParseJSONList _ p a = fmap Semigroup.Max <$> p a+    {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Semigroup.Max a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++    parseJSONList = liftParseJSONList parseJSON parseJSONList+    {-# INLINE parseJSONList #-}+++instance FromJSON1 Semigroup.First where+    liftParseJSON p _ a = Semigroup.First <$> p a+    {-# INLINE liftParseJSON #-}++    liftParseJSONList _ p a = fmap Semigroup.First <$> p a+    {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Semigroup.First a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++    parseJSONList = liftParseJSONList parseJSON parseJSONList+    {-# INLINE parseJSONList #-}+++instance FromJSON1 Semigroup.Last where+    liftParseJSON p _ a = Semigroup.Last <$> p a+    {-# INLINE liftParseJSON #-}++    liftParseJSONList _ p a = fmap Semigroup.Last <$> p a+    {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Semigroup.Last a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++    parseJSONList = liftParseJSONList parseJSON parseJSONList+    {-# INLINE parseJSONList #-}+++instance FromJSON1 Semigroup.WrappedMonoid where+    liftParseJSON p _ a = Semigroup.WrapMonoid <$> p a+    {-# INLINE liftParseJSON #-}++    liftParseJSONList _ p a = fmap Semigroup.WrapMonoid <$> p a+    {-# INLINE liftParseJSONList #-}++instance (FromJSON a) => FromJSON (Semigroup.WrappedMonoid a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++    parseJSONList = liftParseJSONList parseJSON parseJSONList+    {-# INLINE parseJSONList #-}+++instance FromJSON1 Semigroup.Option where+    liftParseJSON p p' = fmap Semigroup.Option . liftParseJSON p p'+    {-# INLINE liftParseJSON #-}++instance FromJSON a => FromJSON (Semigroup.Option a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++-------------------------------------------------------------------------------+-- data-fix+-------------------------------------------------------------------------------++-- | @since 1.5.3.0+instance FromJSON1 f => FromJSON (F.Fix f) where+    parseJSON = go where go = fmap F.Fix . liftParseJSON go parseJSONList++-- | @since 1.5.3.0+instance (FromJSON1 f, Functor f) => FromJSON (F.Mu f) where+    parseJSON = fmap (F.unfoldMu F.unFix) . parseJSON++-- | @since 1.5.3.0+instance (FromJSON1 f, Functor f) => FromJSON (F.Nu f) where+    parseJSON = fmap (F.unfoldNu F.unFix) . parseJSON++-------------------------------------------------------------------------------+-- strict+-------------------------------------------------------------------------------++-- | @since 1.5.3.0+instance (FromJSON a, FromJSON b) => FromJSON (S.These a b) where+    parseJSON = fmap S.toStrict . parseJSON++-- | @since 1.5.3.0+instance FromJSON2 S.These where+    liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs++-- | @since 1.5.3.0+instance FromJSON a => FromJSON1 (S.These a) where+    liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas++-- | @since 1.5.3.0+instance (FromJSON a, FromJSON b) => FromJSON (S.Pair a b) where+    parseJSON = fmap S.toStrict . parseJSON++-- | @since 1.5.3.0+instance FromJSON2 S.Pair where+    liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs++-- | @since 1.5.3.0+instance FromJSON a => FromJSON1 (S.Pair a) where+    liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas++-- | @since 1.5.3.0+instance (FromJSON a, FromJSON b) => FromJSON (S.Either a b) where+    parseJSON = fmap S.toStrict . parseJSON++-- | @since 1.5.3.0+instance FromJSON2 S.Either where+    liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs++-- | @since 1.5.3.0+instance FromJSON a => FromJSON1 (S.Either a) where+    liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas++-- | @since 1.5.3.0+instance FromJSON a => FromJSON (S.Maybe a) where+    parseJSON = fmap S.toStrict . parseJSON++-- | @since 1.5.3.0+instance FromJSON1 S.Maybe where+    liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas++-------------------------------------------------------------------------------+-- tagged+-------------------------------------------------------------------------------++instance FromJSON1 Proxy where+    {-# INLINE liftParseJSON #-}+    liftParseJSON _ _ = fromNull "Proxy" Proxy++instance FromJSON (Proxy a) where+    {-# INLINE parseJSON #-}+    parseJSON = fromNull "Proxy" Proxy++fromNull :: String -> a -> Value -> Parser a+fromNull _ a Null = pure a+fromNull c _ v    = prependContext c (typeMismatch "Null" v)++instance FromJSON2 Tagged where+    liftParseJSON2 _ _ p _ = fmap Tagged . p+    {-# INLINE liftParseJSON2 #-}++instance FromJSON1 (Tagged a) where+    liftParseJSON p _ = fmap Tagged . p+    {-# INLINE liftParseJSON #-}++instance FromJSON b => FromJSON (Tagged a b) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++instance FromJSONKey b => FromJSONKey (Tagged a b) where+    fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b)+    fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList++-------------------------------------------------------------------------------+-- these+-------------------------------------------------------------------------------++-- | @since 1.5.1.0+instance (FromJSON a, FromJSON b) => FromJSON (These a b) where+    parseJSON = withObject "These a b" (p . H.toList)+      where+        p [("This", a), ("That", b)] = These <$> parseJSON a <*> parseJSON b+        p [("That", b), ("This", a)] = These <$> parseJSON a <*> parseJSON b+        p [("This", a)] = This <$> parseJSON a+        p [("That", b)] = That <$> parseJSON b+        p _  = fail "Expected object with 'This' and 'That' keys only"++-- | @since 1.5.1.0+instance FromJSON a => FromJSON1 (These a) where+    liftParseJSON pb _ = withObject "These a b" (p . H.toList)+      where+        p [("This", a), ("That", b)] = These <$> parseJSON a <*> pb b+        p [("That", b), ("This", a)] = These <$> parseJSON a <*> pb b+        p [("This", a)] = This <$> parseJSON a+        p [("That", b)] = That <$> pb b+        p _  = fail "Expected object with 'This' and 'That' keys only"++-- | @since 1.5.1.0+instance FromJSON2 These where+    liftParseJSON2 pa _ pb _ = withObject "These a b" (p . H.toList)+      where+        p [("This", a), ("That", b)] = These <$> pa a <*> pb b+        p [("That", b), ("This", a)] = These <$> pa a <*> pb b+        p [("This", a)] = This <$> pa a+        p [("That", b)] = That <$> pb b+        p _  = fail "Expected object with 'This' and 'That' keys only"++-- | @since 1.5.1.0+instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (These1 f g) where+    liftParseJSON px pl = withObject "These1" (p . H.toList)+      where+        p [("This", a), ("That", b)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b+        p [("That", b), ("This", a)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b+        p [("This", a)] = This1 <$> liftParseJSON px pl a+        p [("That", b)] = That1 <$> liftParseJSON px pl b+        p _  = fail "Expected object with 'This' and 'That' keys only"++-- | @since 1.5.1.0+instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (These1 f g a) where+    parseJSON = parseJSON1++-------------------------------------------------------------------------------+-- Instances for converting from map keys+-------------------------------------------------------------------------------++instance (FromJSON a, FromJSON b) => FromJSONKey (a,b)+instance (FromJSON a, FromJSON b, FromJSON c) => FromJSONKey (a,b,c)+instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)++instance FromJSONKey Char where+    fromJSONKey = FromJSONKeyTextParser parseChar+    fromJSONKeyList = FromJSONKeyText T.unpack++instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where+    fromJSONKey = fromJSONKeyList++-------------------------------------------------------------------------------+-- Tuple instances, see tuple-instances-from.hs+-------------------------------------------------------------------------------++instance FromJSON2 (,) where+    liftParseJSON2 pA _ pB _ = withArray "(a, b)" $ \t ->+        let n = V.length t+        in if n == 2+            then (,)+                <$> parseJSONElemAtIndex pA 0 t+                <*> parseJSONElemAtIndex pB 1 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 2"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a) => FromJSON1 ((,) a) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b) => FromJSON (a, b) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a) => FromJSON2 ((,,) a) where+    liftParseJSON2 pB _ pC _ = withArray "(a, b, c)" $ \t ->+        let n = V.length t+        in if n == 3+            then (,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex pB 1 t+                <*> parseJSONElemAtIndex pC 2 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 3"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b) => FromJSON1 ((,,) a b) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a, b, c) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b) => FromJSON2 ((,,,) a b) where+    liftParseJSON2 pC _ pD _ = withArray "(a, b, c, d)" $ \t ->+        let n = V.length t+        in if n == 4+            then (,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex pC 2 t+                <*> parseJSONElemAtIndex pD 3 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 4"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON1 ((,,,) a b c) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a, b, c, d) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON2 ((,,,,) a b c) where+    liftParseJSON2 pD _ pE _ = withArray "(a, b, c, d, e)" $ \t ->+        let n = V.length t+        in if n == 5+            then (,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex pD 3 t+                <*> parseJSONElemAtIndex pE 4 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 5"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON1 ((,,,,) a b c d) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON (a, b, c, d, e) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON2 ((,,,,,) a b c d) where+    liftParseJSON2 pE _ pF _ = withArray "(a, b, c, d, e, f)" $ \t ->+        let n = V.length t+        in if n == 6+            then (,,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex parseJSON 3 t+                <*> parseJSONElemAtIndex pE 4 t+                <*> parseJSONElemAtIndex pF 5 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 6"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON1 ((,,,,,) a b c d e) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON (a, b, c, d, e, f) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON2 ((,,,,,,) a b c d e) where+    liftParseJSON2 pF _ pG _ = withArray "(a, b, c, d, e, f, g)" $ \t ->+        let n = V.length t+        in if n == 7+            then (,,,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex parseJSON 3 t+                <*> parseJSONElemAtIndex parseJSON 4 t+                <*> parseJSONElemAtIndex pF 5 t+                <*> parseJSONElemAtIndex pG 6 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 7"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON1 ((,,,,,,) a b c d e f) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON (a, b, c, d, e, f, g) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON2 ((,,,,,,,) a b c d e f) where+    liftParseJSON2 pG _ pH _ = withArray "(a, b, c, d, e, f, g, h)" $ \t ->+        let n = V.length t+        in if n == 8+            then (,,,,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex parseJSON 3 t+                <*> parseJSONElemAtIndex parseJSON 4 t+                <*> parseJSONElemAtIndex parseJSON 5 t+                <*> parseJSONElemAtIndex pG 6 t+                <*> parseJSONElemAtIndex pH 7 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 8"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON1 ((,,,,,,,) a b c d e f g) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h) => FromJSON (a, b, c, d, e, f, g, h) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON2 ((,,,,,,,,) a b c d e f g) where+    liftParseJSON2 pH _ pI _ = withArray "(a, b, c, d, e, f, g, h, i)" $ \t ->+        let n = V.length t+        in if n == 9+            then (,,,,,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex parseJSON 3 t+                <*> parseJSONElemAtIndex parseJSON 4 t+                <*> parseJSONElemAtIndex parseJSON 5 t+                <*> parseJSONElemAtIndex parseJSON 6 t+                <*> parseJSONElemAtIndex pH 7 t+                <*> parseJSONElemAtIndex pI 8 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 9"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h) => FromJSON1 ((,,,,,,,,) a b c d e f g h) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i) => FromJSON (a, b, c, d, e, f, g, h, i) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h) => FromJSON2 ((,,,,,,,,,) a b c d e f g h) where+    liftParseJSON2 pI _ pJ _ = withArray "(a, b, c, d, e, f, g, h, i, j)" $ \t ->+        let n = V.length t+        in if n == 10+            then (,,,,,,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex parseJSON 3 t+                <*> parseJSONElemAtIndex parseJSON 4 t+                <*> parseJSONElemAtIndex parseJSON 5 t+                <*> parseJSONElemAtIndex parseJSON 6 t+                <*> parseJSONElemAtIndex parseJSON 7 t+                <*> parseJSONElemAtIndex pI 8 t+                <*> parseJSONElemAtIndex pJ 9 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 10"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i) => FromJSON1 ((,,,,,,,,,) a b c d e f g h i) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j) => FromJSON (a, b, c, d, e, f, g, h, i, j) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i) => FromJSON2 ((,,,,,,,,,,) a b c d e f g h i) where+    liftParseJSON2 pJ _ pK _ = withArray "(a, b, c, d, e, f, g, h, i, j, k)" $ \t ->+        let n = V.length t+        in if n == 11+            then (,,,,,,,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex parseJSON 3 t+                <*> parseJSONElemAtIndex parseJSON 4 t+                <*> parseJSONElemAtIndex parseJSON 5 t+                <*> parseJSONElemAtIndex parseJSON 6 t+                <*> parseJSONElemAtIndex parseJSON 7 t+                <*> parseJSONElemAtIndex parseJSON 8 t+                <*> parseJSONElemAtIndex pJ 9 t+                <*> parseJSONElemAtIndex pK 10 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 11"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j) => FromJSON1 ((,,,,,,,,,,) a b c d e f g h i j) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k) => FromJSON (a, b, c, d, e, f, g, h, i, j, k) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j) => FromJSON2 ((,,,,,,,,,,,) a b c d e f g h i j) where+    liftParseJSON2 pK _ pL _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l)" $ \t ->+        let n = V.length t+        in if n == 12+            then (,,,,,,,,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex parseJSON 3 t+                <*> parseJSONElemAtIndex parseJSON 4 t+                <*> parseJSONElemAtIndex parseJSON 5 t+                <*> parseJSONElemAtIndex parseJSON 6 t+                <*> parseJSONElemAtIndex parseJSON 7 t+                <*> parseJSONElemAtIndex parseJSON 8 t+                <*> parseJSONElemAtIndex parseJSON 9 t+                <*> parseJSONElemAtIndex pK 10 t+                <*> parseJSONElemAtIndex pL 11 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 12"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k) => FromJSON1 ((,,,,,,,,,,,) a b c d e f g h i j k) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k) => FromJSON2 ((,,,,,,,,,,,,) a b c d e f g h i j k) where+    liftParseJSON2 pL _ pM _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m)" $ \t ->+        let n = V.length t+        in if n == 13+            then (,,,,,,,,,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex parseJSON 3 t+                <*> parseJSONElemAtIndex parseJSON 4 t+                <*> parseJSONElemAtIndex parseJSON 5 t+                <*> parseJSONElemAtIndex parseJSON 6 t+                <*> parseJSONElemAtIndex parseJSON 7 t+                <*> parseJSONElemAtIndex parseJSON 8 t+                <*> parseJSONElemAtIndex parseJSON 9 t+                <*> parseJSONElemAtIndex parseJSON 10 t+                <*> parseJSONElemAtIndex pL 11 t+                <*> parseJSONElemAtIndex pM 12 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 13"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l) => FromJSON1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l, m) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l) => FromJSON2 ((,,,,,,,,,,,,,) a b c d e f g h i j k l) where+    liftParseJSON2 pM _ pN _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m, n)" $ \t ->+        let n = V.length t+        in if n == 14+            then (,,,,,,,,,,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex parseJSON 3 t+                <*> parseJSONElemAtIndex parseJSON 4 t+                <*> parseJSONElemAtIndex parseJSON 5 t+                <*> parseJSONElemAtIndex parseJSON 6 t+                <*> parseJSONElemAtIndex parseJSON 7 t+                <*> parseJSONElemAtIndex parseJSON 8 t+                <*> parseJSONElemAtIndex parseJSON 9 t+                <*> parseJSONElemAtIndex parseJSON 10 t+                <*> parseJSONElemAtIndex parseJSON 11 t+                <*> parseJSONElemAtIndex pM 12 t+                <*> parseJSONElemAtIndex pN 13 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 14"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m) => FromJSON1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m, FromJSON n) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}+++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m) => FromJSON2 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m) where+    liftParseJSON2 pN _ pO _ = withArray "(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)" $ \t ->+        let n = V.length t+        in if n == 15+            then (,,,,,,,,,,,,,,)+                <$> parseJSONElemAtIndex parseJSON 0 t+                <*> parseJSONElemAtIndex parseJSON 1 t+                <*> parseJSONElemAtIndex parseJSON 2 t+                <*> parseJSONElemAtIndex parseJSON 3 t+                <*> parseJSONElemAtIndex parseJSON 4 t+                <*> parseJSONElemAtIndex parseJSON 5 t+                <*> parseJSONElemAtIndex parseJSON 6 t+                <*> parseJSONElemAtIndex parseJSON 7 t+                <*> parseJSONElemAtIndex parseJSON 8 t+                <*> parseJSONElemAtIndex parseJSON 9 t+                <*> parseJSONElemAtIndex parseJSON 10 t+                <*> parseJSONElemAtIndex parseJSON 11 t+                <*> parseJSONElemAtIndex parseJSON 12 t+                <*> parseJSONElemAtIndex pN 13 t+                <*> parseJSONElemAtIndex pO 14 t+            else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 15"+    {-# INLINE liftParseJSON2 #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m, FromJSON n) => FromJSON1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) where+    liftParseJSON = liftParseJSON2 parseJSON parseJSONList+    {-# INLINE liftParseJSON #-}++instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g, FromJSON h, FromJSON i, FromJSON j, FromJSON k, FromJSON l, FromJSON m, FromJSON n, FromJSON o) => FromJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+    parseJSON = parseJSON2+    {-# INLINE parseJSON #-}
+ src/Data/Aeson/Types/Generic.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++#include "overlapping-compat.h"++-- |+-- Module:      Data.Aeson.Types.Generic+-- Copyright:   (c) 2012-2016 Bryan O'Sullivan+--              (c) 2011, 2012 Bas Van Dijk+--              (c) 2011 MailRank, Inc.+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Helpers for generic derivations.++module Data.Aeson.Types.Generic+    (+      IsRecord+    , AllNullary+    , Tagged2(..)+    , True+    , False+    , And+    , Zero+    , One+    , ProductSize(..)+    , (:*)(..)+    ) where++import Prelude.Compat++import GHC.Generics++--------------------------------------------------------------------------------++class IsRecord (f :: * -> *) isRecord | f -> isRecord++instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord+#if MIN_VERSION_base(4,9,0)+instance OVERLAPPING_ IsRecord (M1 S ('MetaSel 'Nothing u ss ds) f) False+#else+instance OVERLAPPING_ IsRecord (M1 S NoSelector f) False+#endif+instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord+instance IsRecord (K1 i c) True+instance IsRecord Par1 True+instance IsRecord (Rec1 f) True+instance IsRecord (f :.: g) True+instance IsRecord U1 False++--------------------------------------------------------------------------------++class AllNullary (f :: * -> *) allNullary | f -> allNullary++instance ( AllNullary a allNullaryL+         , AllNullary b allNullaryR+         , And allNullaryL allNullaryR allNullary+         ) => AllNullary (a :+: b) allNullary+instance AllNullary a allNullary => AllNullary (M1 i c a) allNullary+instance AllNullary (a :*: b) False+instance AllNullary (a :.: b) False+instance AllNullary (K1 i c) False+instance AllNullary Par1 False+instance AllNullary (Rec1 f) False+instance AllNullary U1 True++newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}+  deriving Functor++--------------------------------------------------------------------------------++data True+data False++class    And bool1 bool2 bool3 | bool1 bool2 -> bool3++instance And True  True  True+instance And False False False+instance And False True  False+instance And True  False False++--------------------------------------------------------------------------------++-- | A type-level indicator that 'ToJSON' or 'FromJSON' is being derived generically.+data Zero++-- | A type-level indicator that 'ToJSON1' or 'FromJSON1' is being derived generically.+data One++--------------------------------------------------------------------------------++class ProductSize f where+    productSize :: Tagged2 f Int++instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where+    productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) ++                            unTagged2 (productSize :: Tagged2 b Int)++instance ProductSize (S1 s a) where+    productSize = Tagged2 1++--------------------------------------------------------------------------------++-- | Simple extensible tuple type to simplify passing around many parameters.+data a :* b = a :* b++infixr 1 :*
+ src/Data/Aeson/Types/Internal.hs view
@@ -0,0 +1,845 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE StandaloneDeriving #-}+#if __GLASGOW_HASKELL__ >= 800+-- a) THQ works on cross-compilers and unregisterised GHCs+-- b) may make compilation faster as no dynamic loading is ever needed (not sure about this)+-- c) removes one hindrance to have code inferred as SafeHaskell safe+{-# LANGUAGE TemplateHaskellQuotes #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif++-- |+-- Module:      Data.Aeson.Types.Internal+-- Copyright:   (c) 2011-2016 Bryan O'Sullivan+--              (c) 2011 MailRank, Inc.+-- License:     BSD3+-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>+-- Stability:   experimental+-- Portability: portable+--+-- Types for working with JSON data.++module Data.Aeson.Types.Internal+    (+    -- * Core JSON types+      Value(..)+    , Array+    , emptyArray, isEmptyArray+    , Pair+    , Object+    , emptyObject++    -- * Type conversion+    , Parser+    , Result(..)+    , IResult(..)+    , JSONPathElement(..)+    , JSONPath+    , iparse+    , parse+    , parseEither+    , parseMaybe+    , parseFail+    , modifyFailure+    , prependFailure+    , parserThrowError+    , parserCatchError+    , formatError+    , formatPath+    , formatRelativePath+    , (<?>)+    -- * Constructors and accessors+    , object++    -- * Generic and TH encoding configuration+    , Options(+          fieldLabelModifier+        , constructorTagModifier+        , allNullaryToStringTag+        , omitNothingFields+        , sumEncoding+        , unwrapUnaryRecords+        , tagSingleConstructors+        , rejectUnknownFields+        )++    , SumEncoding(..)+    , JSONKeyOptions(keyModifier)+    , defaultOptions+    , defaultTaggedObject+    , defaultJSONKeyOptions++    -- * Used for changing CamelCase names into something else.+    , camelTo+    , camelTo2++    -- * Other types+    , DotNetTime(..)+    ) where++import Prelude.Compat++import Control.Applicative (Alternative(..))+import Control.Arrow (first)+import Control.DeepSeq (NFData(..))+import Control.Monad (MonadPlus(..), ap)+import Data.Char (isLower, isUpper, toLower, isAlpha, isAlphaNum)+import Data.Data (Data)+import Data.Foldable (foldl')+import Data.HashMap.Strict (HashMap)+import Data.Hashable (Hashable(..))+import Data.List (intercalate, sortBy)+import Data.Ord (comparing)+import Data.Scientific (Scientific)+import Data.String (IsString(..))+import Data.Text (Text, pack, unpack)+import Data.Time (UTCTime)+import Data.Time.Format (FormatTime)+import Data.Typeable (Typeable)+import Data.Vector (Vector)+import GHC.Generics (Generic)+import qualified Control.Monad as Monad+import qualified Control.Monad.Fail as Fail+import qualified Data.HashMap.Strict as H+import qualified Data.Scientific as S+import qualified Data.Vector as V+import qualified Language.Haskell.TH.Syntax as TH++-- | Elements of a JSON path used to describe the location of an+-- error.+data JSONPathElement = Key Text+                       -- ^ JSON path element of a key into an object,+                       -- \"object.key\".+                     | Index {-# UNPACK #-} !Int+                       -- ^ JSON path element of an index into an+                       -- array, \"array[index]\".+                       deriving (Eq, Show, Typeable, Ord)+type JSONPath = [JSONPathElement]++-- | The internal result of running a 'Parser'.+data IResult a = IError JSONPath String+               | ISuccess a+               deriving (Eq, Show, Typeable)++-- | The result of running a 'Parser'.+data Result a = Error String+              | Success a+                deriving (Eq, Show, Typeable)++instance NFData JSONPathElement where+  rnf (Key t)   = rnf t+  rnf (Index i) = rnf i++instance (NFData a) => NFData (IResult a) where+    rnf (ISuccess a)      = rnf a+    rnf (IError path err) = rnf path `seq` rnf err++instance (NFData a) => NFData (Result a) where+    rnf (Success a) = rnf a+    rnf (Error err) = rnf err++instance Functor IResult where+    fmap f (ISuccess a)      = ISuccess (f a)+    fmap _ (IError path err) = IError path err+    {-# INLINE fmap #-}++instance Functor Result where+    fmap f (Success a) = Success (f a)+    fmap _ (Error err) = Error err+    {-# INLINE fmap #-}++instance Monad.Monad IResult where+    return = pure+    {-# INLINE return #-}++    ISuccess a      >>= k = k a+    IError path err >>= _ = IError path err+    {-# INLINE (>>=) #-}++#if !(MIN_VERSION_base(4,13,0))+    fail = Fail.fail+    {-# INLINE fail #-}+#endif++instance Fail.MonadFail IResult where+    fail err = IError [] err+    {-# INLINE fail #-}++instance Monad.Monad Result where+    return = pure+    {-# INLINE return #-}++    Success a >>= k = k a+    Error err >>= _ = Error err+    {-# INLINE (>>=) #-}++#if !(MIN_VERSION_base(4,13,0))+    fail = Fail.fail+    {-# INLINE fail #-}+#endif++instance Fail.MonadFail Result where+    fail err = Error err+    {-# INLINE fail #-}++instance Applicative IResult where+    pure  = ISuccess+    {-# INLINE pure #-}+    (<*>) = ap+    {-# INLINE (<*>) #-}++instance Applicative Result where+    pure  = Success+    {-# INLINE pure #-}+    (<*>) = ap+    {-# INLINE (<*>) #-}++instance MonadPlus IResult where+    mzero = fail "mzero"+    {-# INLINE mzero #-}+    mplus a@(ISuccess _) _ = a+    mplus _ b             = b+    {-# INLINE mplus #-}++instance MonadPlus Result where+    mzero = fail "mzero"+    {-# INLINE mzero #-}+    mplus a@(Success _) _ = a+    mplus _ b             = b+    {-# INLINE mplus #-}++instance Alternative IResult where+    empty = mzero+    {-# INLINE empty #-}+    (<|>) = mplus+    {-# INLINE (<|>) #-}++instance Alternative Result where+    empty = mzero+    {-# INLINE empty #-}+    (<|>) = mplus+    {-# INLINE (<|>) #-}++instance Semigroup (IResult a) where+    (<>) = mplus+    {-# INLINE (<>) #-}++instance Monoid (IResult a) where+    mempty  = fail "mempty"+    {-# INLINE mempty #-}+    mappend = (<>)+    {-# INLINE mappend #-}++instance Semigroup (Result a) where+    (<>) = mplus+    {-# INLINE (<>) #-}++instance Monoid (Result a) where+    mempty  = fail "mempty"+    {-# INLINE mempty #-}+    mappend = (<>)+    {-# INLINE mappend #-}++instance Foldable IResult where+    foldMap _ (IError _ _) = mempty+    foldMap f (ISuccess y) = f y+    {-# INLINE foldMap #-}++    foldr _ z (IError _ _) = z+    foldr f z (ISuccess y) = f y z+    {-# INLINE foldr #-}++instance Foldable Result where+    foldMap _ (Error _)   = mempty+    foldMap f (Success y) = f y+    {-# INLINE foldMap #-}++    foldr _ z (Error _)   = z+    foldr f z (Success y) = f y z+    {-# INLINE foldr #-}++instance Traversable IResult where+    traverse _ (IError path err) = pure (IError path err)+    traverse f (ISuccess a)      = ISuccess <$> f a+    {-# INLINE traverse #-}++instance Traversable Result where+    traverse _ (Error err) = pure (Error err)+    traverse f (Success a) = Success <$> f a+    {-# INLINE traverse #-}++-- | Failure continuation.+type Failure f r   = JSONPath -> String -> f r+-- | Success continuation.+type Success a f r = a -> f r++-- | A JSON parser.  N.B. This might not fit your usual understanding of+--  "parser".  Instead you might like to think of 'Parser' as a "parse result",+-- i.e. a parser to which the input has already been applied.+newtype Parser a = Parser {+      runParser :: forall f r.+                   JSONPath+                -> Failure f r+                -> Success a f r+                -> f r+    }++instance Monad.Monad Parser where+    m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks+                                       in runParser m path kf ks'+    {-# INLINE (>>=) #-}+    return = pure+    {-# INLINE return #-}++#if !(MIN_VERSION_base(4,13,0))+    fail = Fail.fail+    {-# INLINE fail #-}+#endif++instance Fail.MonadFail Parser where+    fail msg = Parser $ \path kf _ks -> kf (reverse path) msg+    {-# INLINE fail #-}++instance Functor Parser where+    fmap f m = Parser $ \path kf ks -> let ks' a = ks (f a)+                                        in runParser m path kf ks'+    {-# INLINE fmap #-}++instance Applicative Parser where+    pure a = Parser $ \_path _kf ks -> ks a+    {-# INLINE pure #-}+    (<*>) = apP+    {-# INLINE (<*>) #-}++instance Alternative Parser where+    empty = fail "empty"+    {-# INLINE empty #-}+    (<|>) = mplus+    {-# INLINE (<|>) #-}++instance MonadPlus Parser where+    mzero = fail "mzero"+    {-# INLINE mzero #-}+    mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks+                                         in runParser a path kf' ks+    {-# INLINE mplus #-}++instance Semigroup (Parser a) where+    (<>) = mplus+    {-# INLINE (<>) #-}++instance Monoid (Parser a) where+    mempty  = fail "mempty"+    {-# INLINE mempty #-}+    mappend = (<>)+    {-# INLINE mappend #-}++-- | Raise a parsing failure with some custom message.+parseFail :: String -> Parser a+parseFail = fail++apP :: Parser (a -> b) -> Parser a -> Parser b+apP d e = do+  b <- d+  b <$> e+{-# INLINE apP #-}++-- | A JSON \"object\" (key\/value map).+type Object = HashMap Text Value++-- | A JSON \"array\" (sequence).+type Array = Vector Value++-- | A JSON value represented as a Haskell value.+data Value = Object !Object+           | Array !Array+           | String !Text+           | Number !Scientific+           | Bool !Bool+           | Null+             deriving (Eq, Read, Typeable, Data, Generic)++-- | Since version 1.5.6.0 version object values are printed in lexicographic key order+--+-- >>> toJSON $ H.fromList [("a", True), ("z", False)]+-- Object (fromList [("a",Bool True),("z",Bool False)])+--+-- >>> toJSON $ H.fromList [("z", False), ("a", True)]+-- Object (fromList [("a",Bool True),("z",Bool False)])+--+instance Show Value where+    showsPrec _ Null = showString "Null"+    showsPrec d (Bool b) = showParen (d > 10)+        $ showString "Bool " . showsPrec 11 b+    showsPrec d (Number s) = showParen (d > 10)+        $ showString "Number " . showsPrec 11 s+    showsPrec d (String s) = showParen (d > 10)+        $ showString "String " . showsPrec 11 s+    showsPrec d (Array xs) = showParen (d > 10)+        $ showString "Array " . showsPrec 11 xs+    showsPrec d (Object xs) = showParen (d > 10)+        $ showString "Object (fromList "+        . showsPrec 11 (sortBy (comparing fst) (H.toList xs))+        . showChar ')'++-- |+--+-- The ordering is total, consistent with 'Eq' instance.+-- However, nothing else about the ordering is specified,+-- and it may change from environment to environment and version to version+-- of either this package or its dependencies ('hashable' and 'unordered-containers').+--+-- @since 1.5.2.0+deriving instance Ord Value+-- standalone deriving to attach since annotation.++-- | A newtype wrapper for 'UTCTime' that uses the same non-standard+-- serialization format as Microsoft .NET, whose+-- <https://msdn.microsoft.com/en-us/library/system.datetime(v=vs.110).aspx System.DateTime>+-- type is by default serialized to JSON as in the following example:+--+-- > /Date(1302547608878)/+--+-- The number represents milliseconds since the Unix epoch.+newtype DotNetTime = DotNetTime {+      fromDotNetTime :: UTCTime+      -- ^ Acquire the underlying value.+    } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)++instance NFData Value where+    rnf (Object o) = rnf o+    rnf (Array a)  = foldl' (\x y -> rnf y `seq` x) () a+    rnf (String s) = rnf s+    rnf (Number n) = rnf n+    rnf (Bool b)   = rnf b+    rnf Null       = ()++instance IsString Value where+    fromString = String . pack+    {-# INLINE fromString #-}++hashValue :: Int -> Value -> Int+hashValue s (Object o)   = s `hashWithSalt` (0::Int) `hashWithSalt` o+hashValue s (Array a)    = foldl' hashWithSalt+                              (s `hashWithSalt` (1::Int)) a+hashValue s (String str) = s `hashWithSalt` (2::Int) `hashWithSalt` str+hashValue s (Number n)   = s `hashWithSalt` (3::Int) `hashWithSalt` n+hashValue s (Bool b)     = s `hashWithSalt` (4::Int) `hashWithSalt` b+hashValue s Null         = s `hashWithSalt` (5::Int)++instance Hashable Value where+    hashWithSalt = hashValue++-- @since 0.11.0.0+instance TH.Lift Value where+    lift Null = [| Null |]+    lift (Bool b) = [| Bool b |]+    lift (Number n) = [| Number (S.scientific c e) |]+      where+        c = S.coefficient n+        e = S.base10Exponent n+    lift (String t) = [| String (pack s) |]+      where s = unpack t+    lift (Array a) = [| Array (V.fromList a') |]+      where a' = V.toList a+    lift (Object o) = [| Object (H.fromList . map (first pack) $ o') |]+      where o' = map (first unpack) . H.toList $ o+#if MIN_VERSION_template_haskell(2,17,0)+    liftTyped = TH.unsafeCodeCoerce . TH.lift+#elif MIN_VERSION_template_haskell(2,16,0)+    liftTyped = TH.unsafeTExpCoerce . TH.lift+#endif++-- | The empty array.+emptyArray :: Value+emptyArray = Array V.empty++-- | Determines if the 'Value' is an empty 'Array'.+-- Note that: @isEmptyArray 'emptyArray'@.+isEmptyArray :: Value -> Bool+isEmptyArray (Array arr) = V.null arr+isEmptyArray _ = False++-- | The empty object.+emptyObject :: Value+emptyObject = Object H.empty++-- | Run a 'Parser'.+parse :: (a -> Parser b) -> a -> Result b+parse m v = runParser (m v) [] (const Error) Success+{-# INLINE parse #-}++-- | Run a 'Parser'.+iparse :: (a -> Parser b) -> a -> IResult b+iparse m v = runParser (m v) [] IError ISuccess+{-# INLINE iparse #-}++-- | Run a 'Parser' with a 'Maybe' result type.+parseMaybe :: (a -> Parser b) -> a -> Maybe b+parseMaybe m v = runParser (m v) [] (\_ _ -> Nothing) Just+{-# INLINE parseMaybe #-}++-- | Run a 'Parser' with an 'Either' result type.  If the parse fails,+-- the 'Left' payload will contain an error message.+parseEither :: (a -> Parser b) -> a -> Either String b+parseEither m v = runParser (m v) [] onError Right+  where onError path msg = Left (formatError path msg)+{-# INLINE parseEither #-}++-- | Annotate an error message with a+-- <http://goessner.net/articles/JsonPath/ JSONPath> error location.+formatError :: JSONPath -> String -> String+formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg++-- | Format a <http://goessner.net/articles/JsonPath/ JSONPath> as a 'String',+-- representing the root object as @$@.+formatPath :: JSONPath -> String+formatPath path = "$" ++ formatRelativePath path++-- | Format a <http://goessner.net/articles/JsonPath/ JSONPath> as a 'String'+-- which represents the path relative to some root object.+formatRelativePath :: JSONPath -> String+formatRelativePath path = format "" path+  where+    format :: String -> JSONPath -> String+    format pfx []                = pfx+    format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts+    format pfx (Key key:parts)   = format (pfx ++ formatKey key) parts++    formatKey :: Text -> String+    formatKey key+       | isIdentifierKey strKey = "." ++ strKey+       | otherwise              = "['" ++ escapeKey strKey ++ "']"+      where strKey = unpack key++    isIdentifierKey :: String -> Bool+    isIdentifierKey []     = False+    isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs++    escapeKey :: String -> String+    escapeKey = concatMap escapeChar++    escapeChar :: Char -> String+    escapeChar '\'' = "\\'"+    escapeChar '\\' = "\\\\"+    escapeChar c    = [c]++-- | A key\/value pair for an 'Object'.+type Pair = (Text, Value)++-- | Create a 'Value' from a list of name\/value 'Pair's.  If duplicate+-- keys arise, earlier keys and their associated values win.+object :: [Pair] -> Value+object = Object . H.fromList+{-# INLINE object #-}++-- | Add JSON Path context to a parser+--+-- When parsing a complex structure, it helps to annotate (sub)parsers+-- with context, so that if an error occurs, you can find its location.+--+-- > withObject "Person" $ \o ->+-- >   Person+-- >     <$> o .: "name" <?> Key "name"+-- >     <*> o .: "age"  <?> Key "age"+--+-- (Standard methods like '(.:)' already do this.)+--+-- With such annotations, if an error occurs, you will get a JSON Path+-- location of that error.+--+-- Since 0.10+(<?>) :: Parser a -> JSONPathElement -> Parser a+p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks++-- | If the inner @Parser@ failed, modify the failure message using the+-- provided function. This allows you to create more descriptive error messages.+-- For example:+--+-- > parseJSON (Object o) = modifyFailure+-- >     ("Parsing of the Foo value failed: " ++)+-- >     (Foo <$> o .: "someField")+--+-- Since 0.6.2.0+modifyFailure :: (String -> String) -> Parser a -> Parser a+modifyFailure f (Parser p) = Parser $ \path kf ks ->+    p path (\p' m -> kf p' (f m)) ks++-- | If the inner 'Parser' failed, prepend the given string to the failure+-- message.+--+-- @+-- 'prependFailure' s = 'modifyFailure' (s '++')+-- @+prependFailure :: String -> Parser a -> Parser a+prependFailure = modifyFailure . (++)++-- | Throw a parser error with an additional path.+--+-- @since 1.2.1.0+parserThrowError :: JSONPath -> String -> Parser a+parserThrowError path' msg = Parser $ \path kf _ks ->+    kf (reverse path ++ path') msg++-- | A handler function to handle previous errors and return to normal execution.+--+-- @since 1.2.1.0+parserCatchError :: Parser a -> (JSONPath -> String -> Parser a) -> Parser a+parserCatchError (Parser p) handler = Parser $ \path kf ks ->+    p path (\e msg -> runParser (handler e msg) path kf ks) ks++--------------------------------------------------------------------------------+-- Generic and TH encoding configuration+--------------------------------------------------------------------------------++-- | Options that specify how to encode\/decode your datatype to\/from JSON.+--+-- Options can be set using record syntax on 'defaultOptions' with the fields+-- below.+data Options = Options+    { fieldLabelModifier :: String -> String+      -- ^ Function applied to field labels.+      -- Handy for removing common record prefixes for example.+    , constructorTagModifier :: String -> String+      -- ^ Function applied to constructor tags which could be handy+      -- for lower-casing them for example.+    , allNullaryToStringTag :: Bool+      -- ^ If 'True' the constructors of a datatype, with /all/+      -- nullary constructors, will be encoded to just a string with+      -- the constructor tag. If 'False' the encoding will always+      -- follow the `sumEncoding`.+    , omitNothingFields :: Bool+      -- ^ If 'True', record fields with a 'Nothing' value will be+      -- omitted from the resulting object. If 'False', the resulting+      -- object will include those fields mapping to @null@.+      --+      -- Note that this /does not/ affect parsing: 'Maybe' fields are+      -- optional regardless of the value of 'omitNothingFields', subject+      -- to the note below.+      --+      -- === Note+      --+      -- Setting 'omitNothingFields' to 'True' only affects fields which are of+      -- type 'Maybe' /uniformly/ in the 'ToJSON' instance.+      -- In particular, if the type of a field is declared as a type variable, it+      -- will not be omitted from the JSON object, unless the field is+      -- specialized upfront in the instance.+      --+      -- The same holds for 'Maybe' fields being optional in the 'FromJSON' instance.+      --+      -- ==== __Example__+      --+      -- The generic instance for the following type @Fruit@ depends on whether+      -- the instance head is @Fruit a@ or @Fruit (Maybe a)@.+      --+      -- @+      -- data Fruit a = Fruit+      --   { apples :: a  -- A field whose type is a type variable.+      --   , oranges :: 'Maybe' Int+      --   } deriving 'Generic'+      --+      -- -- apples required, oranges optional+      -- -- Even if 'Data.Aeson.fromJSON' is then specialized to (Fruit ('Maybe' a)).+      -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit a)+      --+      -- -- apples optional, oranges optional+      -- -- In this instance, the field apples is uniformly of type ('Maybe' a).+      -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit ('Maybe' a))+      --+      -- options :: 'Options'+      -- options = 'defaultOptions' { 'omitNothingFields' = 'True' }+      --+      -- -- apples always present in the output, oranges is omitted if 'Nothing'+      -- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit a) where+      --   'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options+      --+      -- -- both apples and oranges are omitted if 'Nothing'+      -- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit ('Maybe' a)) where+      --   'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options+      -- @+    , sumEncoding :: SumEncoding+      -- ^ Specifies how to encode constructors of a sum datatype.+    , unwrapUnaryRecords :: Bool+      -- ^ Hide the field name when a record constructor has only one+      -- field, like a newtype.+    , tagSingleConstructors :: Bool+      -- ^ Encode types with a single constructor as sums,+      -- so that `allNullaryToStringTag` and `sumEncoding` apply.+    , rejectUnknownFields :: Bool+      -- ^ Applies only to 'Data.Aeson.FromJSON' instances. If a field appears in+      -- the parsed object map, but does not appear in the target object, parsing+      -- will fail, with an error message indicating which fields were unknown.+    }++instance Show Options where+  show (Options f c a o s u t r) =+       "Options {"+    ++ intercalate ", "+      [ "fieldLabelModifier =~ " ++ show (f "exampleField")+      , "constructorTagModifier =~ " ++ show (c "ExampleConstructor")+      , "allNullaryToStringTag = " ++ show a+      , "omitNothingFields = " ++ show o+      , "sumEncoding = " ++ show s+      , "unwrapUnaryRecords = " ++ show u+      , "tagSingleConstructors = " ++ show t+      , "rejectUnknownFields = " ++ show r+      ]+    ++ "}"++-- | Specifies how to encode constructors of a sum datatype.+data SumEncoding =+    TaggedObject { tagFieldName      :: String+                 , contentsFieldName :: String+                 }+    -- ^ A constructor will be encoded to an object with a field+    -- 'tagFieldName' which specifies the constructor tag (modified by+    -- the 'constructorTagModifier'). If the constructor is a record+    -- the encoded record fields will be unpacked into this object. So+    -- make sure that your record doesn't have a field with the same+    -- label as the 'tagFieldName'. Otherwise the tag gets overwritten+    -- by the encoded value of that field! If the constructor is not a+    -- record the encoded constructor contents will be stored under+    -- the 'contentsFieldName' field.+  | UntaggedValue+    -- ^ Constructor names won't be encoded. Instead only the contents of the+    -- constructor will be encoded as if the type had a single constructor. JSON+    -- encodings have to be disjoint for decoding to work properly.+    --+    -- When decoding, constructors are tried in the order of definition. If some+    -- encodings overlap, the first one defined will succeed.+    --+    -- /Note:/ Nullary constructors are encoded as strings (using+    -- 'constructorTagModifier'). Having a nullary constructor alongside a+    -- single field constructor that encodes to a string leads to ambiguity.+    --+    -- /Note:/ Only the last error is kept when decoding, so in the case of+    -- malformed JSON, only an error for the last constructor will be reported.+  | ObjectWithSingleField+    -- ^ A constructor will be encoded to an object with a single+    -- field named after the constructor tag (modified by the+    -- 'constructorTagModifier') which maps to the encoded contents of+    -- the constructor.+  | TwoElemArray+    -- ^ A constructor will be encoded to a 2-element array where the+    -- first element is the tag of the constructor (modified by the+    -- 'constructorTagModifier') and the second element the encoded+    -- contents of the constructor.+    deriving (Eq, Show)++-- | Options for encoding keys with 'Data.Aeson.Types.genericFromJSONKey' and+-- 'Data.Aeson.Types.genericToJSONKey'.+data JSONKeyOptions = JSONKeyOptions+    { keyModifier :: String -> String+      -- ^ Function applied to keys. Its result is what goes into the encoded+      -- 'Value'.+      --+      -- === __Example__+      --+      -- The following instances encode the constructor @Bar@ to lower-case keys+      -- @\"bar\"@.+      --+      -- @+      -- data Foo = Bar+      --   deriving 'Generic'+      --+      -- opts :: 'JSONKeyOptions'+      -- opts = 'defaultJSONKeyOptions' { 'keyModifier' = 'toLower' }+      --+      -- instance 'ToJSONKey' Foo where+      --   'toJSONKey' = 'genericToJSONKey' opts+      --+      -- instance 'FromJSONKey' Foo where+      --   'fromJSONKey' = 'genericFromJSONKey' opts+      -- @+    }++-- | Default encoding 'Options':+--+-- @+-- 'Options'+-- { 'fieldLabelModifier'      = id+-- , 'constructorTagModifier'  = id+-- , 'allNullaryToStringTag'   = True+-- , 'omitNothingFields'       = False+-- , 'sumEncoding'             = 'defaultTaggedObject'+-- , 'unwrapUnaryRecords'      = False+-- , 'tagSingleConstructors'   = False+-- , 'rejectUnknownFields'     = False+-- }+-- @+defaultOptions :: Options+defaultOptions = Options+                 { fieldLabelModifier      = id+                 , constructorTagModifier  = id+                 , allNullaryToStringTag   = True+                 , omitNothingFields       = False+                 , sumEncoding             = defaultTaggedObject+                 , unwrapUnaryRecords      = False+                 , tagSingleConstructors   = False+                 , rejectUnknownFields     = False+                 }++-- | Default 'TaggedObject' 'SumEncoding' options:+--+-- @+-- defaultTaggedObject = 'TaggedObject'+--                       { 'tagFieldName'      = \"tag\"+--                       , 'contentsFieldName' = \"contents\"+--                       }+-- @+defaultTaggedObject :: SumEncoding+defaultTaggedObject = TaggedObject+                      { tagFieldName      = "tag"+                      , contentsFieldName = "contents"+                      }++-- | Default 'JSONKeyOptions':+--+-- @+-- defaultJSONKeyOptions = 'JSONKeyOptions'+--                         { 'keyModifier' = 'id'+--                         }+-- @+defaultJSONKeyOptions :: JSONKeyOptions+defaultJSONKeyOptions = JSONKeyOptions id++-- | Converts from CamelCase to another lower case, interspersing+--   the character between all capital letters and their previous+--   entries, except those capital letters that appear together,+--   like 'API'.+--+--   For use by Aeson template haskell calls.+--+--   > camelTo '_' 'CamelCaseAPI' == "camel_case_api"+camelTo :: Char -> String -> String+{-# DEPRECATED camelTo "Use camelTo2 for better results" #-}+camelTo c = lastWasCap True+  where+    lastWasCap :: Bool    -- ^ Previous was a capital letter+              -> String  -- ^ The remaining string+              -> String+    lastWasCap _    []           = []+    lastWasCap prev (x : xs)     = if isUpper x+                                      then if prev+                                             then toLower x : lastWasCap True xs+                                             else c : toLower x : lastWasCap True xs+                                      else x : lastWasCap False xs++-- | Better version of 'camelTo'. Example where it works better:+--+--   > camelTo '_' 'CamelAPICase' == "camel_apicase"+--   > camelTo2 '_' 'CamelAPICase' == "camel_api_case"+camelTo2 :: Char -> String -> String+camelTo2 c = map toLower . go2 . go1+    where go1 "" = ""+          go1 (x:u:l:xs) | isUpper u && isLower l = x : c : u : l : go1 xs+          go1 (x:xs) = x : go1 xs+          go2 "" = ""+          go2 (l:u:xs) | isLower l && isUpper u = l : c : u : go2 xs+          go2 (x:xs) = x : go2 xs
+ src/Data/Aeson/Types/ToJSON.hs view
@@ -0,0 +1,3046 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++#include "overlapping-compat.h"+#include "incoherent-compat.h"++-- TODO: Drop this when we remove support for Data.Attoparsec.Number+{-# OPTIONS_GHC -fno-warn-deprecations #-}++module Data.Aeson.Types.ToJSON+    (+    -- * Core JSON classes+      ToJSON(..)+    -- * Liftings to unary and binary type constructors+    , ToJSON1(..)+    , toJSON1+    , toEncoding1+    , ToJSON2(..)+    , toJSON2+    , toEncoding2+    -- * Generic JSON classes+    , GToJSON'(..)+    , ToArgs(..)+    , genericToJSON+    , genericToEncoding+    , genericLiftToJSON+    , genericLiftToEncoding+    -- * Classes and types for map keys+    , ToJSONKey(..)+    , ToJSONKeyFunction(..)+    , toJSONKeyText+    , contramapToJSONKeyFunction++    , GToJSONKey()+    , genericToJSONKey++    -- * Object key-value pairs+    , KeyValue(..)+    , KeyValuePair(..)+    , FromPairs(..)+    -- * Functions needed for documentation+    -- * Encoding functions+    , listEncoding+    , listValue+    ) where++import Prelude.Compat++import Control.Applicative (Const(..))+import Control.Monad.ST (ST)+import Data.Aeson.Encoding (Encoding, Encoding', Series, dict, emptyArray_)+import Data.Aeson.Encoding.Internal ((>*<))+import Data.Aeson.Internal.Functions (mapHashKeyVal, mapKeyVal)+import Data.Aeson.Types.Generic (AllNullary, False, IsRecord, One, ProductSize, Tagged2(..), True, Zero, productSize)+import Data.Aeson.Types.Internal+import Data.Attoparsec.Number (Number(..))+import Data.Bits (unsafeShiftR)+import Data.DList (DList)+import Data.Fixed (Fixed, HasResolution, Nano)+import Data.Foldable (toList)+import Data.Functor.Compose (Compose(..))+import Data.Functor.Contravariant (Contravariant (..))+import Data.Functor.Identity (Identity(..))+import Data.Functor.Product (Product(..))+import Data.Functor.Sum (Sum(..))+import Data.Functor.These (These1 (..))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.List (intersperse)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Proxy (Proxy(..))+import Data.Ratio (Ratio, denominator, numerator)+import Data.Scientific (Scientific)+import Data.Tagged (Tagged(..))+import Data.Text (Text, pack)+import Data.These (These (..))+import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)+import Data.Time.Calendar.Month.Compat (Month)+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))+import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))+import Data.Time.LocalTime.Compat (CalendarDiffTime (..))+import Data.Time.Clock.System.Compat (SystemTime (..))+import Data.Time.Format.Compat (FormatTime, formatTime, defaultTimeLocale)+import Data.Vector (Vector)+import Data.Version (Version, showVersion)+import Data.Void (Void, absurd)+import Data.Word (Word16, Word32, Word64, Word8)+import Foreign.Storable (Storable)+import Foreign.C.Types (CTime (..))+import GHC.Generics+import Numeric.Natural (Natural)+import qualified Data.Aeson.Encoding as E+import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)+import qualified Data.ByteString.Lazy as L+import qualified Data.DList as DList+#if MIN_VERSION_dlist(1,0,0) && __GLASGOW_HASKELL__ >=800+import qualified Data.DList.DNonEmpty as DNE+#endif+import qualified Data.Fix as F+import qualified Data.HashMap.Strict as H+import qualified Data.HashSet as HashSet+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import qualified Data.Monoid as Monoid+import qualified Data.Scientific as Scientific+import qualified Data.Semigroup as Semigroup+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Strict as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Tree as Tree+import qualified Data.UUID.Types as UUID+import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Mutable as VM+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU++import qualified Data.Aeson.Encoding.Builder as EB+import qualified Data.ByteString.Builder as B++import qualified GHC.Exts as Exts+import qualified Data.Primitive.Array as PM+import qualified Data.Primitive.SmallArray as PM+import qualified Data.Primitive.Types as PM+import qualified Data.Primitive.PrimArray as PM++toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value+toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)+{-# INLINE toJSONPair #-}++realFloatToJSON :: RealFloat a => a -> Value+realFloatToJSON d+    | isNaN d || isInfinite d = Null+    | otherwise = Number $ Scientific.fromFloatDigits d+{-# INLINE realFloatToJSON #-}++-------------------------------------------------------------------------------+-- Generics+-------------------------------------------------------------------------------++-- | Class of generic representation types that can be converted to+-- JSON.+class GToJSON' enc arity f where+    -- | This method (applied to 'defaultOptions') is used as the+    -- default generic implementation of 'toJSON'+    -- (with @enc ~ 'Value'@ and @arity ~ 'Zero'@)+    -- and 'liftToJSON' (if the @arity@ is 'One').+    --+    -- It also provides a generic implementation of 'toEncoding'+    -- (with @enc ~ 'Encoding'@ and @arity ~ 'Zero'@)+    -- and 'liftToEncoding' (if the @arity@ is 'One').+    gToJSON :: Options -> ToArgs enc arity a -> f a -> enc++-- | A 'ToArgs' value either stores nothing (for 'ToJSON') or it stores the two+-- function arguments that encode occurrences of the type parameter (for+-- 'ToJSON1').+data ToArgs res arity a where+    NoToArgs :: ToArgs res Zero a+    To1Args  :: (a -> res) -> ([a] -> res) -> ToArgs res One a++-- | A configurable generic JSON creator. This function applied to+-- 'defaultOptions' is used as the default for 'toJSON' when the type+-- is an instance of 'Generic'.+genericToJSON :: (Generic a, GToJSON' Value Zero (Rep a))+              => Options -> a -> Value+genericToJSON opts = gToJSON opts NoToArgs . from++-- | A configurable generic JSON creator. This function applied to+-- 'defaultOptions' is used as the default for 'liftToJSON' when the type+-- is an instance of 'Generic1'.+genericLiftToJSON :: (Generic1 f, GToJSON' Value One (Rep1 f))+                  => Options -> (a -> Value) -> ([a] -> Value)+                  -> f a -> Value+genericLiftToJSON opts tj tjl = gToJSON opts (To1Args tj tjl) . from1++-- | A configurable generic JSON encoder. This function applied to+-- 'defaultOptions' is used as the default for 'toEncoding' when the type+-- is an instance of 'Generic'.+genericToEncoding :: (Generic a, GToJSON' Encoding Zero (Rep a))+                  => Options -> a -> Encoding+genericToEncoding opts = gToJSON opts NoToArgs . from++-- | A configurable generic JSON encoder. This function applied to+-- 'defaultOptions' is used as the default for 'liftToEncoding' when the type+-- is an instance of 'Generic1'.+genericLiftToEncoding :: (Generic1 f, GToJSON' Encoding One (Rep1 f))+                      => Options -> (a -> Encoding) -> ([a] -> Encoding)+                      -> f a -> Encoding+genericLiftToEncoding opts te tel = gToJSON opts (To1Args te tel) . from1++-------------------------------------------------------------------------------+-- Class+-------------------------------------------------------------------------------++-- | A type that can be converted to JSON.+--+-- Instances in general /must/ specify 'toJSON' and /should/ (but don't need+-- to) specify 'toEncoding'.+--+-- An example type and instance:+--+-- @+-- \-- Allow ourselves to write 'Text' literals.+-- {-\# LANGUAGE OverloadedStrings #-}+--+-- data Coord = Coord { x :: Double, y :: Double }+--+-- instance 'ToJSON' Coord where+--   'toJSON' (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]+--+--   'toEncoding' (Coord x y) = 'pairs' (\"x\" '.=' x '<>' \"y\" '.=' y)+-- @+--+-- Instead of manually writing your 'ToJSON' instance, there are two options+-- to do it automatically:+--+-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an+-- instance at compile time. The generated instance is optimized for your type+-- so it will probably be more efficient than the following option.+--+-- * The compiler can provide a default generic implementation for+-- 'toJSON'.+--+-- To use the second, simply add a @deriving 'Generic'@ clause to your+-- datatype and declare a 'ToJSON' instance. If you require nothing other than+-- 'defaultOptions', it is sufficient to write (and this is the only+-- alternative where the default 'toJSON' implementation is sufficient):+--+-- @+-- {-\# LANGUAGE DeriveGeneric \#-}+--+-- import "GHC.Generics"+--+-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'+--+-- instance 'ToJSON' Coord where+--     'toEncoding' = 'genericToEncoding' 'defaultOptions'+-- @+--+-- If on the other hand you wish to customize the generic decoding, you have+-- to implement both methods:+--+-- @+-- customOptions = 'defaultOptions'+--                 { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'+--                 }+--+-- instance 'ToJSON' Coord where+--     'toJSON'     = 'genericToJSON' customOptions+--     'toEncoding' = 'genericToEncoding' customOptions+-- @+--+-- Previous versions of this library only had the 'toJSON' method. Adding+-- 'toEncoding' had two reasons:+--+-- 1. toEncoding is more efficient for the common case that the output of+-- 'toJSON' is directly serialized to a @ByteString@.+-- Further, expressing either method in terms of the other would be+-- non-optimal.+--+-- 2. The choice of defaults allows a smooth transition for existing users:+-- Existing instances that do not define 'toEncoding' still+-- compile and have the correct semantics. This is ensured by making+-- the default implementation of 'toEncoding' use 'toJSON'. This produces+-- correct results, but since it performs an intermediate conversion to a+-- 'Value', it will be less efficient than directly emitting an 'Encoding'.+-- (this also means that specifying nothing more than+-- @instance ToJSON Coord@ would be sufficient as a generically decoding+-- instance, but there probably exists no good reason to not specify+-- 'toEncoding' in new instances.)+class ToJSON a where+    -- | Convert a Haskell value to a JSON-friendly intermediate type.+    toJSON     :: a -> Value++    default toJSON :: (Generic a, GToJSON' Value Zero (Rep a)) => a -> Value+    toJSON = genericToJSON defaultOptions++    -- | Encode a Haskell value as JSON.+    --+    -- The default implementation of this method creates an+    -- intermediate 'Value' using 'toJSON'.  This provides+    -- source-level compatibility for people upgrading from older+    -- versions of this library, but obviously offers no performance+    -- advantage.+    --+    -- To benefit from direct encoding, you /must/ provide an+    -- implementation for this method.  The easiest way to do so is by+    -- having your types implement 'Generic' using the @DeriveGeneric@+    -- extension, and then have GHC generate a method body as follows.+    --+    -- @+    -- instance 'ToJSON' Coord where+    --     'toEncoding' = 'genericToEncoding' 'defaultOptions'+    -- @++    toEncoding :: a -> Encoding+    toEncoding = E.value . toJSON+    {-# INLINE toEncoding #-}++    toJSONList :: [a] -> Value+    toJSONList = listValue toJSON+    {-# INLINE toJSONList #-}++    toEncodingList :: [a] -> Encoding+    toEncodingList = listEncoding toEncoding+    {-# INLINE toEncodingList #-}++-------------------------------------------------------------------------------+-- Object key-value pairs+-------------------------------------------------------------------------------++-- | A key-value pair for encoding a JSON object.+class KeyValue kv where+    (.=) :: ToJSON v => Text -> v -> kv+    infixr 8 .=++instance KeyValue Series where+    name .= value = E.pair name (toEncoding value)+    {-# INLINE (.=) #-}++instance KeyValue Pair where+    name .= value = (name, toJSON value)+    {-# INLINE (.=) #-}++-- | Constructs a singleton 'H.HashMap'. For calling functions that+--   demand an 'Object' for constructing objects. To be used in+--   conjunction with 'mconcat'. Prefer to use 'object' where possible.+instance KeyValue Object where+    name .= value = H.singleton name (toJSON value)+    {-# INLINE (.=) #-}++-------------------------------------------------------------------------------+--  Classes and types for map keys+-------------------------------------------------------------------------------++-- | Typeclass for types that can be used as the key of a map-like container+--   (like 'Map' or 'HashMap'). For example, since 'Text' has a 'ToJSONKey'+--   instance and 'Char' has a 'ToJSON' instance, we can encode a value of+--   type 'Map' 'Text' 'Char':+--+--   >>> LBC8.putStrLn $ encode $ Map.fromList [("foo" :: Text, 'a')]+--   {"foo":"a"}+--+--   Since 'Int' also has a 'ToJSONKey' instance, we can similarly write:+--+--   >>> LBC8.putStrLn $ encode $ Map.fromList [(5 :: Int, 'a')]+--   {"5":"a"}+--+--   JSON documents only accept strings as object keys. For any type+--   from @base@ that has a natural textual representation, it can be+--   expected that its 'ToJSONKey' instance will choose that representation.+--+--   For data types that lack a natural textual representation, an alternative+--   is provided. The map-like container is represented as a JSON array+--   instead of a JSON object. Each value in the array is an array with+--   exactly two values. The first is the key and the second is the value.+--+--   For example, values of type '[Text]' cannot be encoded to a+--   string, so a 'Map' with keys of type '[Text]' is encoded as follows:+--+--   >>> LBC8.putStrLn $ encode $ Map.fromList [(["foo","bar","baz" :: Text], 'a')]+--   [[["foo","bar","baz"],"a"]]+--+--   The default implementation of 'ToJSONKey' chooses this method of+--   encoding a key, using the 'ToJSON' instance of the type.+--+--   To use your own data type as the key in a map, all that is needed+--   is to write a 'ToJSONKey' (and possibly a 'FromJSONKey') instance+--   for it. If the type cannot be trivially converted to and from 'Text',+--   it is recommended that 'ToJSONKeyValue' is used. Since the default+--   implementations of the typeclass methods can build this from a+--   'ToJSON' instance, there is nothing that needs to be written:+--+--   > data Foo = Foo { fooAge :: Int, fooName :: Text }+--   >   deriving (Eq,Ord,Generic)+--   > instance ToJSON Foo+--   > instance ToJSONKey Foo+--+--   That's it. We can now write:+--+--   >>> let m = Map.fromList [(Foo 4 "bar",'a'),(Foo 6 "arg",'b')]+--   >>> LBC8.putStrLn $ encode m+--   [[{"fooName":"bar","fooAge":4},"a"],[{"fooName":"arg","fooAge":6},"b"]]+--+--   The next case to consider is if we have a type that is a+--   newtype wrapper around 'Text'. The recommended approach is to use+--   generalized newtype deriving:+--+--   > newtype RecordId = RecordId { getRecordId :: Text }+--   >   deriving (Eq,Ord,ToJSONKey)+--+--   Then we may write:+--+--   >>> LBC8.putStrLn $ encode $ Map.fromList [(RecordId "abc",'a')]+--   {"abc":"a"}+--+--   Simple sum types are a final case worth considering. Suppose we have:+--+--   > data Color = Red | Green | Blue+--   >   deriving (Show,Read,Eq,Ord)+--+--   It is possible to get the 'ToJSONKey' instance for free as we did+--   with 'Foo'. However, in this case, we have a natural way to go to+--   and from 'Text' that does not require any escape sequences. So+--   'ToJSONKeyText' can be used instead of 'ToJSONKeyValue' to encode maps+--   as objects instead of arrays of pairs. This instance may be+--   implemented using generics as follows:+--+-- @+-- instance 'ToJSONKey' Color where+--   'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'+-- @+--+--   === __Low-level implementations__+--+--   The 'Show' instance can be used to help write 'ToJSONKey':+--+--   > instance ToJSONKey Color where+--   >   toJSONKey = ToJSONKeyText f g+--   >     where f = Text.pack . show+--   >           g = text . Text.pack . show+--   >           -- text function is from Data.Aeson.Encoding+--+--   The situation of needing to turning function @a -> Text@ into+--   a 'ToJSONKeyFunction' is common enough that a special combinator+--   is provided for it. The above instance can be rewritten as:+--+--   > instance ToJSONKey Color where+--   >   toJSONKey = toJSONKeyText (Text.pack . show)+--+--   The performance of the above instance can be improved by+--   not using 'String' as an intermediate step when converting to+--   'Text'. One option for improving performance would be to use+--   template haskell machinery from the @text-show@ package. However,+--   even with the approach, the 'Encoding' (a wrapper around a bytestring+--   builder) is generated by encoding the 'Text' to a 'ByteString',+--   an intermediate step that could be avoided. The fastest possible+--   implementation would be:+--+--   > -- Assuming that OverloadedStrings is enabled+--   > instance ToJSONKey Color where+--   >   toJSONKey = ToJSONKeyText f g+--   >     where f x = case x of {Red -> "Red";Green ->"Green";Blue -> "Blue"}+--   >           g x = case x of {Red -> text "Red";Green -> text "Green";Blue -> text "Blue"}+--   >           -- text function is from Data.Aeson.Encoding+--+--   This works because GHC can lift the encoded values out of the case+--   statements, which means that they are only evaluated once. This+--   approach should only be used when there is a serious need to+--   maximize performance.++class ToJSONKey a where+    -- | Strategy for rendering the key for a map-like container.+    toJSONKey :: ToJSONKeyFunction a+    default toJSONKey :: ToJSON a => ToJSONKeyFunction a+    toJSONKey = ToJSONKeyValue toJSON toEncoding++    -- | This is similar in spirit to the 'showsList' method of 'Show'.+    --   It makes it possible to give 'String' keys special treatment+    --   without using @OverlappingInstances@. End users should always+    --   be able to use the default implementation of this method.+    toJSONKeyList :: ToJSONKeyFunction [a]+    default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]+    toJSONKeyList = ToJSONKeyValue toJSON toEncoding++data ToJSONKeyFunction a+    = ToJSONKeyText !(a -> Text) !(a -> Encoding' Text)+      -- ^ key is encoded to string, produces object+    | ToJSONKeyValue !(a -> Value) !(a -> Encoding)+      -- ^ key is encoded to value, produces array++-- | Helper for creating textual keys.+--+-- @+-- instance 'ToJSONKey' MyKey where+--     'toJSONKey' = 'toJSONKeyText' myKeyToText+--       where+--         myKeyToText = Text.pack . show -- or showt from text-show+-- @+toJSONKeyText :: (a -> Text) -> ToJSONKeyFunction a+toJSONKeyText f = ToJSONKeyText f (E.text . f)++-- | TODO: should this be exported?+toJSONKeyTextEnc :: (a -> Encoding' Text) -> ToJSONKeyFunction a+toJSONKeyTextEnc e = ToJSONKeyText tot e+ where+    -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm+    tot = T.dropAround (== '"')+        . T.decodeLatin1+        . L.toStrict+        . E.encodingToLazyByteString+        . e++instance Contravariant ToJSONKeyFunction where+    contramap = contramapToJSONKeyFunction++-- | Contravariant map, as 'ToJSONKeyFunction' is a contravariant functor.+contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b+contramapToJSONKeyFunction h x = case x of+    ToJSONKeyText  f g -> ToJSONKeyText (f . h) (g . h)+    ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)++-- 'toJSONKey' for 'Generic' types.+-- Deriving is supported for enumeration types, i.e. the sums of nullary+-- constructors. The names of constructors will be used as keys for JSON+-- objects.+--+-- See also 'genericFromJSONKey'.+--+-- === __Example__+--+-- @+-- data Color = Red | Green | Blue+--   deriving 'Generic'+--+-- instance 'ToJSONKey' Color where+--   'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'+-- @+genericToJSONKey :: (Generic a, GToJSONKey (Rep a))+           => JSONKeyOptions -> ToJSONKeyFunction a+genericToJSONKey opts = toJSONKeyText (pack . keyModifier opts . getConName . from)++class    GetConName f => GToJSONKey f+instance GetConName f => GToJSONKey f++-------------------------------------------------------------------------------+-- Lifings of FromJSON and ToJSON to unary and binary type constructors+-------------------------------------------------------------------------------+++-- | Lifting of the 'ToJSON' class to unary type constructors.+--+-- Instead of manually writing your 'ToJSON1' instance, there are two options+-- to do it automatically:+--+-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an+-- instance at compile time. The generated instance is optimized for your type+-- so it will probably be more efficient than the following option.+--+-- * The compiler can provide a default generic implementation for+-- 'toJSON1'.+--+-- To use the second, simply add a @deriving 'Generic1'@ clause to your+-- datatype and declare a 'ToJSON1' instance for your datatype without giving+-- definitions for 'liftToJSON' or 'liftToEncoding'.+--+-- For example:+--+-- @+-- {-\# LANGUAGE DeriveGeneric \#-}+--+-- import "GHC.Generics"+--+-- data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'+--+-- instance 'ToJSON' a => 'ToJSON1' (Pair a)+-- @+--+-- If the default implementation doesn't give exactly the results you want,+-- you can customize the generic encoding with only a tiny amount of+-- effort, using 'genericLiftToJSON' and 'genericLiftToEncoding' with+-- your preferred 'Options':+--+-- @+-- customOptions = 'defaultOptions'+--                 { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'+--                 }+--+-- instance 'ToJSON' a => 'ToJSON1' (Pair a) where+--     'liftToJSON'     = 'genericLiftToJSON' customOptions+--     'liftToEncoding' = 'genericLiftToEncoding' customOptions+-- @+--+-- See also 'ToJSON'.+class ToJSON1 f where+    liftToJSON :: (a -> Value) -> ([a] -> Value) -> f a -> Value++    default liftToJSON :: (Generic1 f, GToJSON' Value One (Rep1 f))+                       => (a -> Value) -> ([a] -> Value) -> f a -> Value+    liftToJSON = genericLiftToJSON defaultOptions++    liftToJSONList :: (a -> Value) -> ([a] -> Value) -> [f a] -> Value+    liftToJSONList f g = listValue (liftToJSON f g)++    liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> f a -> Encoding++    default liftToEncoding :: (Generic1 f, GToJSON' Encoding One (Rep1 f))+                           => (a -> Encoding) -> ([a] -> Encoding)+                           -> f a -> Encoding+    liftToEncoding = genericLiftToEncoding defaultOptions++    liftToEncodingList :: (a -> Encoding) -> ([a] -> Encoding) -> [f a] -> Encoding+    liftToEncodingList f g = listEncoding (liftToEncoding f g)++-- | Lift the standard 'toJSON' function through the type constructor.+toJSON1 :: (ToJSON1 f, ToJSON a) => f a -> Value+toJSON1 = liftToJSON toJSON toJSONList+{-# INLINE toJSON1 #-}++-- | Lift the standard 'toEncoding' function through the type constructor.+toEncoding1 :: (ToJSON1 f, ToJSON a) => f a -> Encoding+toEncoding1 = liftToEncoding toEncoding toEncodingList+{-# INLINE toEncoding1 #-}++-- | Lifting of the 'ToJSON' class to binary type constructors.+--+-- Instead of manually writing your 'ToJSON2' instance, "Data.Aeson.TH"+-- provides Template Haskell functions which will derive an instance at compile time.+--+-- The compiler cannot provide a default generic implementation for 'liftToJSON2',+-- unlike 'toJSON' and 'liftToJSON'.+class ToJSON2 f where+    liftToJSON2 :: (a -> Value) -> ([a] -> Value) -> (b -> Value) -> ([b] -> Value) -> f a b -> Value+    liftToJSONList2 :: (a -> Value) -> ([a] -> Value) -> (b -> Value) -> ([b] -> Value) -> [f a b] -> Value+    liftToJSONList2 fa ga fb gb = listValue (liftToJSON2 fa ga fb gb)++    liftToEncoding2 :: (a -> Encoding) -> ([a] -> Encoding) -> (b -> Encoding) -> ([b] -> Encoding) -> f a b -> Encoding+    liftToEncodingList2 :: (a -> Encoding) -> ([a] -> Encoding) -> (b -> Encoding) -> ([b] -> Encoding) -> [f a b] -> Encoding+    liftToEncodingList2 fa ga fb gb = listEncoding (liftToEncoding2 fa ga fb gb)++-- | Lift the standard 'toJSON' function through the type constructor.+toJSON2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Value+toJSON2 = liftToJSON2 toJSON toJSONList toJSON toJSONList+{-# INLINE toJSON2 #-}++-- | Lift the standard 'toEncoding' function through the type constructor.+toEncoding2 :: (ToJSON2 f, ToJSON a, ToJSON b) => f a b -> Encoding+toEncoding2 = liftToEncoding2 toEncoding toEncodingList toEncoding toEncodingList+{-# INLINE toEncoding2 #-}++-------------------------------------------------------------------------------+-- Encoding functions+-------------------------------------------------------------------------------++-- | Helper function to use with 'liftToEncoding'.+-- Useful when writing own 'ToJSON1' instances.+--+-- @+-- newtype F a = F [a]+--+-- -- This instance encodes 'String' as an array of chars+-- instance 'ToJSON1' F where+--     'liftToJSON'     tj _ (F xs) = 'liftToJSON'     tj ('listValue'    tj) xs+--     'liftToEncoding' te _ (F xs) = 'liftToEncoding' te ('listEncoding' te) xs+--+-- instance 'Data.Aeson.FromJSON.FromJSON1' F where+--     'Data.Aeson.FromJSON.liftParseJSON' p _ v = F \<$\> 'Data.Aeson.FromJSON.liftParseJSON' p ('Data.Aeson.FromJSON.listParser' p) v+-- @+listEncoding :: (a -> Encoding) -> [a] -> Encoding+listEncoding = E.list+{-# INLINE listEncoding #-}++-- | Helper function to use with 'liftToJSON', see 'listEncoding'.+listValue :: (a -> Value) -> [a] -> Value+listValue f = Array . V.fromList . map f+{-# INLINE listValue #-}++-------------------------------------------------------------------------------+-- [] instances+-------------------------------------------------------------------------------++-- These are needed for key-class default definitions++instance ToJSON1 [] where+    liftToJSON _ to' = to'+    {-# INLINE liftToJSON #-}++    liftToEncoding _ to' = to'+    {-# INLINE liftToEncoding #-}++instance (ToJSON a) => ToJSON [a] where+    {-# SPECIALIZE instance ToJSON String #-}+    {-# SPECIALIZE instance ToJSON [String] #-}+    {-# SPECIALIZE instance ToJSON [Array] #-}+    {-# SPECIALIZE instance ToJSON [Object] #-}++    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++-------------------------------------------------------------------------------+-- Generic toJSON / toEncoding+-------------------------------------------------------------------------------++instance OVERLAPPABLE_ (GToJSON' enc arity a) => GToJSON' enc arity (M1 i c a) where+    -- Meta-information, which is not handled elsewhere, is ignored:+    gToJSON opts targs = gToJSON opts targs . unM1+    {-# INLINE gToJSON #-}++instance GToJSON' enc One Par1 where+    -- Direct occurrences of the last type parameter are encoded with the+    -- function passed in as an argument:+    gToJSON _opts (To1Args tj _) = tj . unPar1+    {-# INLINE gToJSON #-}++instance ( ConsToJSON enc arity a+         , AllNullary          (C1 c a) allNullary+         , SumToJSON enc arity (C1 c a) allNullary+         ) => GToJSON' enc arity (D1 d (C1 c a)) where+    -- The option 'tagSingleConstructors' determines whether to wrap+    -- a single-constructor type.+    gToJSON opts targs+        | tagSingleConstructors opts = (unTagged :: Tagged allNullary enc -> enc)+                                     . sumToJSON opts targs+                                     . unM1+        | otherwise = consToJSON opts targs . unM1 . unM1+    {-# INLINE gToJSON #-}++instance (ConsToJSON enc arity a) => GToJSON' enc arity (C1 c a) where+    -- Constructors need to be encoded differently depending on whether they're+    -- a record or not. This distinction is made by 'consToJSON':+    gToJSON opts targs = consToJSON opts targs . unM1+    {-# INLINE gToJSON #-}++instance ( AllNullary       (a :+: b) allNullary+         , SumToJSON  enc arity (a :+: b) allNullary+         ) => GToJSON' enc arity (a :+: b)+  where+    -- If all constructors of a sum datatype are nullary and the+    -- 'allNullaryToStringTag' option is set they are encoded to+    -- strings.  This distinction is made by 'sumToJSON':+    gToJSON opts targs = (unTagged :: Tagged allNullary enc -> enc)+                       . sumToJSON opts targs+    {-# INLINE gToJSON #-}++--------------------------------------------------------------------------------+-- Generic toJSON++-- Note: Refactoring 'ToJSON a' to 'ToJSON enc a' (and 'ToJSON1' similarly) is+-- possible but makes error messages a bit harder to understand for missing+-- instances.++instance GToJSON' Value arity V1 where+    -- Empty values do not exist, which makes the job of formatting them+    -- rather easy:+    gToJSON _ _ x = x `seq` error "case: V1"+    {-# INLINE gToJSON #-}++instance ToJSON a => GToJSON' Value arity (K1 i a) where+    -- Constant values are encoded using their ToJSON instance:+    gToJSON _opts _ = toJSON . unK1+    {-# INLINE gToJSON #-}++instance ToJSON1 f => GToJSON' Value One (Rec1 f) where+    -- Recursive occurrences of the last type parameter are encoded using their+    -- ToJSON1 instance:+    gToJSON _opts (To1Args tj tjl) = liftToJSON tj tjl . unRec1+    {-# INLINE gToJSON #-}++instance GToJSON' Value arity U1 where+    -- Empty constructors are encoded to an empty array:+    gToJSON _opts _ _ = emptyArray+    {-# INLINE gToJSON #-}++instance ( WriteProduct arity a, WriteProduct arity b+         , ProductSize        a, ProductSize        b+         ) => GToJSON' Value arity (a :*: b)+  where+    -- Products are encoded to an array. Here we allocate a mutable vector of+    -- the same size as the product and write the product's elements to it using+    -- 'writeProduct':+    gToJSON opts targs p =+        Array $ V.create $ do+          mv <- VM.unsafeNew lenProduct+          writeProduct opts targs mv 0 lenProduct p+          return mv+        where+          lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)+                       productSize+    {-# INLINE gToJSON #-}++instance ( ToJSON1 f+         , GToJSON' Value One g+         ) => GToJSON' Value One (f :.: g)+  where+    -- If an occurrence of the last type parameter is nested inside two+    -- composed types, it is encoded by using the outermost type's ToJSON1+    -- instance to generically encode the innermost type:+    gToJSON opts targs =+      let gtj = gToJSON opts targs in+      liftToJSON gtj (listValue gtj) . unComp1+    {-# INLINE gToJSON #-}++--------------------------------------------------------------------------------+-- Generic toEncoding++instance ToJSON a => GToJSON' Encoding arity (K1 i a) where+    -- Constant values are encoded using their ToJSON instance:+    gToJSON _opts _ = toEncoding . unK1+    {-# INLINE gToJSON #-}++instance ToJSON1 f => GToJSON' Encoding One (Rec1 f) where+    -- Recursive occurrences of the last type parameter are encoded using their+    -- ToEncoding1 instance:+    gToJSON _opts (To1Args te tel) = liftToEncoding te tel . unRec1+    {-# INLINE gToJSON #-}++instance GToJSON' Encoding arity U1 where+    -- Empty constructors are encoded to an empty array:+    gToJSON _opts _ _ = E.emptyArray_+    {-# INLINE gToJSON #-}++instance ( EncodeProduct  arity a+         , EncodeProduct  arity b+         ) => GToJSON' Encoding arity (a :*: b)+  where+    -- Products are encoded to an array. Here we allocate a mutable vector of+    -- the same size as the product and write the product's elements to it using+    -- 'encodeProduct':+    gToJSON opts targs p = E.list E.retagEncoding [encodeProduct opts targs p]+    {-# INLINE gToJSON #-}++instance ( ToJSON1 f+         , GToJSON' Encoding One g+         ) => GToJSON' Encoding One (f :.: g)+  where+    -- If an occurrence of the last type parameter is nested inside two+    -- composed types, it is encoded by using the outermost type's ToJSON1+    -- instance to generically encode the innermost type:+    gToJSON opts targs =+      let gte = gToJSON opts targs in+      liftToEncoding gte (listEncoding gte) . unComp1+    {-# INLINE gToJSON #-}++--------------------------------------------------------------------------------++class SumToJSON enc arity f allNullary where+    sumToJSON :: Options -> ToArgs enc arity a+              -> f a -> Tagged allNullary enc++instance ( GetConName f+         , FromString enc+         , TaggedObject                     enc arity f+         , SumToJSON' ObjectWithSingleField enc arity f+         , SumToJSON' TwoElemArray          enc arity f+         , SumToJSON' UntaggedValue         enc arity f+         ) => SumToJSON enc arity f True+  where+    sumToJSON opts targs+        | allNullaryToStringTag opts = Tagged . fromString+                                     . constructorTagModifier opts . getConName+        | otherwise = Tagged . nonAllNullarySumToJSON opts targs++instance ( TaggedObject                     enc arity f+         , SumToJSON' ObjectWithSingleField enc arity f+         , SumToJSON' TwoElemArray          enc arity f+         , SumToJSON' UntaggedValue         enc arity f+         ) => SumToJSON enc arity f False+  where+    sumToJSON opts targs = Tagged . nonAllNullarySumToJSON opts targs++nonAllNullarySumToJSON :: ( TaggedObject                     enc arity f+                          , SumToJSON' ObjectWithSingleField enc arity f+                          , SumToJSON' TwoElemArray          enc arity f+                          , SumToJSON' UntaggedValue         enc arity f+                          ) => Options -> ToArgs enc arity a+                            -> f a -> enc+nonAllNullarySumToJSON opts targs =+    case sumEncoding opts of++      TaggedObject{..}      ->+        taggedObject opts targs tagFieldName contentsFieldName++      ObjectWithSingleField ->+        (unTagged :: Tagged ObjectWithSingleField enc -> enc)+          . sumToJSON' opts targs++      TwoElemArray          ->+        (unTagged :: Tagged TwoElemArray enc -> enc)+          . sumToJSON' opts targs++      UntaggedValue         ->+        (unTagged :: Tagged UntaggedValue enc -> enc)+          . sumToJSON' opts targs++--------------------------------------------------------------------------------++class FromString enc where+  fromString :: String -> enc++instance FromString Encoding where+  fromString = toEncoding++instance FromString Value where+  fromString = String . pack++--------------------------------------------------------------------------------++class TaggedObject enc arity f where+    taggedObject :: Options -> ToArgs enc arity a+                 -> String -> String+                 -> f a -> enc++instance ( TaggedObject enc arity a+         , TaggedObject enc arity b+         ) => TaggedObject enc arity (a :+: b)+  where+    taggedObject opts targs tagFieldName contentsFieldName (L1 x) =+        taggedObject opts targs tagFieldName contentsFieldName x+    taggedObject opts targs tagFieldName contentsFieldName (R1 x) =+        taggedObject opts targs tagFieldName contentsFieldName x++instance ( IsRecord                      a isRecord+         , TaggedObject' enc pairs arity a isRecord+         , FromPairs enc pairs+         , FromString enc+         , KeyValuePair enc pairs+         , Constructor c+         ) => TaggedObject enc arity (C1 c a)+  where+    taggedObject opts targs tagFieldName contentsFieldName =+      fromPairs . mappend tag . contents+      where+        tag = tagFieldName `pair`+          (fromString (constructorTagModifier opts (conName (undefined :: t c a p)))+            :: enc)+        contents =+          (unTagged :: Tagged isRecord pairs -> pairs) .+            taggedObject' opts targs contentsFieldName . unM1++class TaggedObject' enc pairs arity f isRecord where+    taggedObject' :: Options -> ToArgs enc arity a+                  -> String -> f a -> Tagged isRecord pairs++instance ( GToJSON' enc arity f+         , KeyValuePair enc pairs+         ) => TaggedObject' enc pairs arity f False+  where+    taggedObject' opts targs contentsFieldName =+        Tagged . (contentsFieldName `pair`) . gToJSON opts targs++instance OVERLAPPING_ Monoid pairs => TaggedObject' enc pairs arity U1 False where+    taggedObject' _ _ _ _ = Tagged mempty++instance ( RecordToPairs enc pairs arity f+         ) => TaggedObject' enc pairs arity f True+  where+    taggedObject' opts targs _ = Tagged . recordToPairs opts targs++--------------------------------------------------------------------------------++-- | Get the name of the constructor of a sum datatype.+class GetConName f where+    getConName :: f a -> String++instance (GetConName a, GetConName b) => GetConName (a :+: b) where+    getConName (L1 x) = getConName x+    getConName (R1 x) = getConName x++instance (Constructor c) => GetConName (C1 c a) where+    getConName = conName++-- For genericToJSONKey+instance GetConName a => GetConName (D1 d a) where+    getConName (M1 x) = getConName x++--------------------------------------------------------------------------------++-- Reflection of SumEncoding variants++data ObjectWithSingleField+data TwoElemArray+data UntaggedValue++--------------------------------------------------------------------------------++class SumToJSON' s enc arity f where+    sumToJSON' :: Options -> ToArgs enc arity a+                    -> f a -> Tagged s enc++instance ( SumToJSON' s enc arity a+         , SumToJSON' s enc arity b+         ) => SumToJSON' s enc arity (a :+: b)+  where+    sumToJSON' opts targs (L1 x) = sumToJSON' opts targs x+    sumToJSON' opts targs (R1 x) = sumToJSON' opts targs x++--------------------------------------------------------------------------------++instance ( GToJSON'    Value arity a+         , ConsToJSON Value arity a+         , Constructor c+         ) => SumToJSON' TwoElemArray Value arity (C1 c a) where+    sumToJSON' opts targs x = Tagged $ Array $ V.create $ do+      mv <- VM.unsafeNew 2+      VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts+                                   $ conName (undefined :: t c a p)+      VM.unsafeWrite mv 1 $ gToJSON opts targs x+      return mv++--------------------------------------------------------------------------------++instance ( GToJSON'    Encoding arity a+         , ConsToJSON Encoding arity a+         , Constructor c+         ) => SumToJSON' TwoElemArray Encoding arity (C1 c a)+  where+    sumToJSON' opts targs x = Tagged $ E.list id+      [ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))+      , gToJSON opts targs x+      ]++--------------------------------------------------------------------------------++class ConsToJSON enc arity f where+    consToJSON :: Options -> ToArgs enc arity a+               -> f a -> enc++class ConsToJSON' enc arity f isRecord where+    consToJSON'     :: Options -> ToArgs enc arity a+                    -> f a -> Tagged isRecord enc++instance ( IsRecord                f isRecord+         , ConsToJSON'   enc arity f isRecord+         ) => ConsToJSON enc arity f+  where+    consToJSON opts targs =+        (unTagged :: Tagged isRecord enc -> enc)+      . consToJSON' opts targs+    {-# INLINE consToJSON #-}++instance OVERLAPPING_+         ( RecordToPairs enc pairs arity (S1 s f)+         , FromPairs enc pairs+         , GToJSON' enc arity f+         ) => ConsToJSON' enc arity (S1 s f) True+  where+    consToJSON' opts targs+      | unwrapUnaryRecords opts = Tagged . gToJSON opts targs+      | otherwise = Tagged . fromPairs . recordToPairs opts targs+    {-# INLINE consToJSON' #-}++instance ( RecordToPairs enc pairs arity f+         , FromPairs enc pairs+         ) => ConsToJSON' enc arity f True+  where+    consToJSON' opts targs = Tagged . fromPairs . recordToPairs opts targs+    {-# INLINE consToJSON' #-}++instance GToJSON' enc arity f => ConsToJSON' enc arity f False where+    consToJSON' opts targs = Tagged . gToJSON opts targs+    {-# INLINE consToJSON' #-}++--------------------------------------------------------------------------------++class RecordToPairs enc pairs arity f where+    -- 1st element: whole thing+    -- 2nd element: in case the record has only 1 field, just the value+    --              of the field (without the key); 'Nothing' otherwise+    recordToPairs :: Options -> ToArgs enc arity a+                  -> f a -> pairs++instance ( Monoid pairs+         , RecordToPairs enc pairs arity a+         , RecordToPairs enc pairs arity b+         ) => RecordToPairs enc pairs arity (a :*: b)+  where+    recordToPairs opts (targs :: ToArgs enc arity p) (a :*: b) =+        pairsOf a `mappend` pairsOf b+      where+        pairsOf :: (RecordToPairs enc pairs arity f) => f p -> pairs+        pairsOf = recordToPairs opts targs+    {-# INLINE recordToPairs #-}++instance ( Selector s+         , GToJSON' enc arity a+         , KeyValuePair enc pairs+         ) => RecordToPairs enc pairs arity (S1 s a)+  where+    recordToPairs = fieldToPair+    {-# INLINE recordToPairs #-}++instance INCOHERENT_+    ( Selector s+    , GToJSON' enc arity (K1 i (Maybe a))+    , KeyValuePair enc pairs+    , Monoid pairs+    ) => RecordToPairs enc pairs arity (S1 s (K1 i (Maybe a)))+  where+    recordToPairs opts _ (M1 k1) | omitNothingFields opts+                                 , K1 Nothing <- k1 = mempty+    recordToPairs opts targs m1 = fieldToPair opts targs m1+    {-# INLINE recordToPairs #-}++instance INCOHERENT_+    ( Selector s+    , GToJSON' enc arity (K1 i (Maybe a))+    , KeyValuePair enc pairs+    , Monoid pairs+    ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))+  where+    recordToPairs opts targs = recordToPairs opts targs . unwrap+      where+        unwrap :: S1 s (K1 i (Semigroup.Option a)) p -> S1 s (K1 i (Maybe a)) p+        unwrap (M1 (K1 (Semigroup.Option a))) = M1 (K1 a)+    {-# INLINE recordToPairs #-}++fieldToPair :: (Selector s+               , GToJSON' enc arity a+               , KeyValuePair enc pairs)+            => Options -> ToArgs enc arity p+            -> S1 s a p -> pairs+fieldToPair opts targs m1 =+  let key   = fieldLabelModifier opts (selName m1)+      value = gToJSON opts targs (unM1 m1)+  in key `pair` value+{-# INLINE fieldToPair #-}++--------------------------------------------------------------------------------++class WriteProduct arity f where+    writeProduct :: Options+                 -> ToArgs Value arity a+                 -> VM.MVector s Value+                 -> Int -- ^ index+                 -> Int -- ^ length+                 -> f a+                 -> ST s ()++instance ( WriteProduct arity a+         , WriteProduct arity b+         ) => WriteProduct arity (a :*: b) where+    writeProduct opts targs mv ix len (a :*: b) = do+      writeProduct opts targs mv ix  lenL a+      writeProduct opts targs mv ixR lenR b+        where+          lenL = len `unsafeShiftR` 1+          lenR = len - lenL+          ixR  = ix  + lenL+    {-# INLINE writeProduct #-}++instance OVERLAPPABLE_ (GToJSON' Value arity a) => WriteProduct arity a where+    writeProduct opts targs mv ix _ =+      VM.unsafeWrite mv ix . gToJSON opts targs+    {-# INLINE writeProduct #-}++--------------------------------------------------------------------------------++class EncodeProduct arity f where+    encodeProduct :: Options -> ToArgs Encoding arity a+                  -> f a -> Encoding' E.InArray++instance ( EncodeProduct    arity a+         , EncodeProduct    arity b+         ) => EncodeProduct arity (a :*: b) where+    encodeProduct opts targs (a :*: b) | omitNothingFields opts =+        E.econcat $ intersperse E.comma $+        filter (not . E.nullEncoding)+        [encodeProduct opts targs a, encodeProduct opts targs b]+    encodeProduct opts targs (a :*: b) =+      encodeProduct opts targs a >*<+      encodeProduct opts targs b+    {-# INLINE encodeProduct #-}++instance OVERLAPPABLE_ (GToJSON' Encoding arity a) => EncodeProduct arity a where+    encodeProduct opts targs a = E.retagEncoding $ gToJSON opts targs a+    {-# INLINE encodeProduct #-}++--------------------------------------------------------------------------------++instance ( GToJSON'   enc arity a+         , ConsToJSON enc arity a+         , FromPairs  enc pairs+         , KeyValuePair  enc pairs+         , Constructor c+         ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a)+  where+    sumToJSON' opts targs =+      Tagged . fromPairs . (typ `pair`) . gToJSON opts targs+        where+          typ = constructorTagModifier opts $+                         conName (undefined :: t c a p)++--------------------------------------------------------------------------------++instance OVERLAPPABLE_+    ( ConsToJSON enc arity a+    ) => SumToJSON' UntaggedValue enc arity (C1 c a)+  where+    sumToJSON' opts targs = Tagged . gToJSON opts targs++instance OVERLAPPING_+    ( Constructor c+    , FromString enc+    ) => SumToJSON' UntaggedValue enc arity (C1 c U1)+  where+    sumToJSON' opts _ _ = Tagged . fromString $+        constructorTagModifier opts $ conName (undefined :: t c U1 p)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- base+-------------------------------------------------------------------------------++instance ToJSON2 Const where+    liftToJSON2 t _ _ _ (Const x) = t x+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 t _ _ _ (Const x) = t x+    {-# INLINE liftToEncoding2 #-}++instance ToJSON a => ToJSON1 (Const a) where+    liftToJSON _ _ (Const x) = toJSON x+    {-# INLINE liftToJSON #-}++    liftToEncoding _ _ (Const x) = toEncoding x+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Const a b) where+    toJSON (Const x) = toJSON x+    {-# INLINE toJSON #-}++    toEncoding (Const x) = toEncoding x+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSONKey a) => ToJSONKey (Const a b) where+    toJSONKey = contramap getConst toJSONKey+++instance ToJSON1 Maybe where+    liftToJSON t _ (Just a) = t a+    liftToJSON _  _ Nothing  = Null+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ (Just a) = t a+    liftToEncoding _  _ Nothing  = E.null_+    {-# INLINE liftToEncoding #-}++instance (ToJSON a) => ToJSON (Maybe a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON2 Either where+    liftToJSON2  toA _ _toB _ (Left a)  = Object $ H.singleton "Left"  (toA a)+    liftToJSON2 _toA _  toB _ (Right b) = Object $ H.singleton "Right" (toB b)+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2  toA _ _toB _ (Left a) = E.pairs $ E.pair "Left" $ toA a++    liftToEncoding2 _toA _ toB _ (Right b) = E.pairs $ E.pair "Right" $ toB b+    {-# INLINE liftToEncoding2 #-}++instance (ToJSON a) => ToJSON1 (Either a) where+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}++    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}++    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance ToJSON Void where+    toJSON = absurd+    {-# INLINE toJSON #-}++    toEncoding = absurd+    {-# INLINE toEncoding #-}+++instance ToJSON Bool where+    toJSON = Bool+    {-# INLINE toJSON #-}++    toEncoding = E.bool+    {-# INLINE toEncoding #-}++instance ToJSONKey Bool where+    toJSONKey = toJSONKeyText $ \x -> if x then "true" else "false"+++instance ToJSON Ordering where+  toJSON     = toJSON     . orderingToText+  toEncoding = toEncoding . orderingToText++orderingToText :: Ordering -> T.Text+orderingToText o = case o of+                     LT -> "LT"+                     EQ -> "EQ"+                     GT -> "GT"++instance ToJSON () where+    toJSON _ = emptyArray+    {-# INLINE toJSON #-}++    toEncoding _ = emptyArray_+    {-# INLINE toEncoding #-}+++instance ToJSON Char where+    toJSON = String . T.singleton+    {-# INLINE toJSON #-}++    toJSONList = String . T.pack+    {-# INLINE toJSONList #-}++    toEncoding = E.string . (:[])+    {-# INLINE toEncoding #-}++    toEncodingList = E.string+    {-# INLINE toEncodingList #-}+++instance ToJSON Double where+    toJSON = realFloatToJSON+    {-# INLINE toJSON #-}++    toEncoding = E.double+    {-# INLINE toEncoding #-}++instance ToJSONKey Double where+    toJSONKey = toJSONKeyTextEnc E.doubleText+    {-# INLINE toJSONKey #-}+++instance ToJSON Number where+    toJSON (D d) = toJSON d+    toJSON (I i) = toJSON i+    {-# INLINE toJSON #-}++    toEncoding (D d) = toEncoding d+    toEncoding (I i) = toEncoding i+    {-# INLINE toEncoding #-}+++instance ToJSON Float where+    toJSON = realFloatToJSON+    {-# INLINE toJSON #-}++    toEncoding = E.float+    {-# INLINE toEncoding #-}++instance ToJSONKey Float where+    toJSONKey = toJSONKeyTextEnc E.floatText+    {-# INLINE toJSONKey #-}+++instance (ToJSON a, Integral a) => ToJSON (Ratio a) where+    toJSON r = object [ "numerator"   .= numerator   r+                      , "denominator" .= denominator r+                      ]+    {-# INLINE toJSON #-}++    toEncoding r = E.pairs $+        "numerator" .= numerator r <>+        "denominator" .= denominator r+    {-# INLINE toEncoding #-}+++instance HasResolution a => ToJSON (Fixed a) where+    toJSON = Number . realToFrac+    {-# INLINE toJSON #-}++    toEncoding = E.scientific . realToFrac+    {-# INLINE toEncoding #-}++instance HasResolution a => ToJSONKey (Fixed a) where+    toJSONKey = toJSONKeyTextEnc (E.scientificText . realToFrac)+    {-# INLINE toJSONKey #-}+++instance ToJSON Int where+    toJSON = Number . fromIntegral+    {-# INLINE toJSON #-}++    toEncoding = E.int+    {-# INLINE toEncoding #-}++instance ToJSONKey Int where+    toJSONKey = toJSONKeyTextEnc E.intText+    {-# INLINE toJSONKey #-}+++instance ToJSON Integer where+    toJSON = Number . fromInteger+    {-# INLINE toJSON #-}++    toEncoding = E.integer+    {-# INLINE toEncoding #-}++instance ToJSONKey Integer where+    toJSONKey = toJSONKeyTextEnc E.integerText+    {-# INLINE toJSONKey #-}+++instance ToJSON Natural where+    toJSON = toJSON . toInteger+    {-# INLINE toJSON #-}++    toEncoding = toEncoding . toInteger+    {-# INLINE toEncoding #-}++instance ToJSONKey Natural where+    toJSONKey = toJSONKeyTextEnc (E.integerText . toInteger)+    {-# INLINE toJSONKey #-}+++instance ToJSON Int8 where+    toJSON = Number . fromIntegral+    {-# INLINE toJSON #-}++    toEncoding = E.int8+    {-# INLINE toEncoding #-}++instance ToJSONKey Int8 where+    toJSONKey = toJSONKeyTextEnc E.int8Text+    {-# INLINE toJSONKey #-}+++instance ToJSON Int16 where+    toJSON = Number . fromIntegral+    {-# INLINE toJSON #-}++    toEncoding = E.int16+    {-# INLINE toEncoding #-}++instance ToJSONKey Int16 where+    toJSONKey = toJSONKeyTextEnc E.int16Text+    {-# INLINE toJSONKey #-}+++instance ToJSON Int32 where+    toJSON = Number . fromIntegral+    {-# INLINE toJSON #-}++    toEncoding = E.int32+    {-# INLINE toEncoding #-}++instance ToJSONKey Int32 where+    toJSONKey = toJSONKeyTextEnc E.int32Text+    {-# INLINE toJSONKey #-}+++instance ToJSON Int64 where+    toJSON = Number . fromIntegral+    {-# INLINE toJSON #-}++    toEncoding = E.int64+    {-# INLINE toEncoding #-}++instance ToJSONKey Int64 where+    toJSONKey = toJSONKeyTextEnc E.int64Text+    {-# INLINE toJSONKey #-}++instance ToJSON Word where+    toJSON = Number . fromIntegral+    {-# INLINE toJSON #-}++    toEncoding = E.word+    {-# INLINE toEncoding #-}++instance ToJSONKey Word where+    toJSONKey = toJSONKeyTextEnc E.wordText+    {-# INLINE toJSONKey #-}+++instance ToJSON Word8 where+    toJSON = Number . fromIntegral+    {-# INLINE toJSON #-}++    toEncoding = E.word8+    {-# INLINE toEncoding #-}++instance ToJSONKey Word8 where+    toJSONKey = toJSONKeyTextEnc E.word8Text+    {-# INLINE toJSONKey #-}+++instance ToJSON Word16 where+    toJSON = Number . fromIntegral+    {-# INLINE toJSON #-}++    toEncoding = E.word16+    {-# INLINE toEncoding #-}++instance ToJSONKey Word16 where+    toJSONKey = toJSONKeyTextEnc E.word16Text+    {-# INLINE toJSONKey #-}+++instance ToJSON Word32 where+    toJSON = Number . fromIntegral+    {-# INLINE toJSON #-}++    toEncoding = E.word32+    {-# INLINE toEncoding #-}++instance ToJSONKey Word32 where+    toJSONKey = toJSONKeyTextEnc E.word32Text+    {-# INLINE toJSONKey #-}+++instance ToJSON Word64 where+    toJSON = Number . fromIntegral+    {-# INLINE toJSON #-}++    toEncoding = E.word64+    {-# INLINE toEncoding #-}++instance ToJSONKey Word64 where+    toJSONKey = toJSONKeyTextEnc E.word64Text+    {-# INLINE toJSONKey #-}++instance ToJSON CTime where+    toJSON (CTime i) = toJSON i+    {-# INLINE toJSON #-}++    toEncoding (CTime i) = toEncoding i+    {-# INLINE toEncoding #-}++instance ToJSON Text where+    toJSON = String+    {-# INLINE toJSON #-}++    toEncoding = E.text+    {-# INLINE toEncoding #-}++instance ToJSONKey Text where+    toJSONKey = toJSONKeyText id+    {-# INLINE toJSONKey #-}+++instance ToJSON LT.Text where+    toJSON = String . LT.toStrict+    {-# INLINE toJSON #-}++    toEncoding = E.lazyText+    {-# INLINE toEncoding #-}++instance ToJSONKey LT.Text where+    toJSONKey = toJSONKeyText LT.toStrict+++instance ToJSON Version where+    toJSON = toJSON . showVersion+    {-# INLINE toJSON #-}++    toEncoding = toEncoding . showVersion+    {-# INLINE toEncoding #-}++instance ToJSONKey Version where+    toJSONKey = toJSONKeyText (T.pack . showVersion)++-------------------------------------------------------------------------------+-- semigroups NonEmpty+-------------------------------------------------------------------------------++instance ToJSON1 NonEmpty where+    liftToJSON t _ = listValue t . NE.toList+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ = listEncoding t . NE.toList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a) => ToJSON (NonEmpty a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++-------------------------------------------------------------------------------+-- scientific+-------------------------------------------------------------------------------++instance ToJSON Scientific where+    toJSON = Number+    {-# INLINE toJSON #-}++    toEncoding = E.scientific+    {-# INLINE toEncoding #-}++instance ToJSONKey Scientific where+    toJSONKey = toJSONKeyTextEnc E.scientificText++-------------------------------------------------------------------------------+-- DList+-------------------------------------------------------------------------------++instance ToJSON1 DList.DList where+    liftToJSON t _ = listValue t . toList+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ = listEncoding t . toList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a) => ToJSON (DList.DList a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++#if MIN_VERSION_dlist(1,0,0) && __GLASGOW_HASKELL__ >=800+-- | @since 1.5.3.0+instance ToJSON1 DNE.DNonEmpty where+    liftToJSON t _ = listValue t . DNE.toList+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ = listEncoding t . DNE.toList+    {-# INLINE liftToEncoding #-}++-- | @since 1.5.3.0+instance (ToJSON a) => ToJSON (DNE.DNonEmpty a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+#endif++-------------------------------------------------------------------------------+-- transformers - Functors+-------------------------------------------------------------------------------++instance ToJSON1 Identity where+    liftToJSON t _ (Identity a) = t a+    {-# INLINE liftToJSON #-}++    liftToJSONList _ tl xs = tl (map runIdentity xs)+    {-# INLINE liftToJSONList #-}++    liftToEncoding t _ (Identity a) = t a+    {-# INLINE liftToEncoding #-}++    liftToEncodingList _ tl xs = tl (map runIdentity xs)+    {-# INLINE liftToEncodingList #-}++instance (ToJSON a) => ToJSON (Identity a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toJSONList = liftToJSONList toJSON toJSONList+    {-# INLINE toJSONList #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++    toEncodingList = liftToEncodingList toEncoding toEncodingList+    {-# INLINE toEncodingList #-}++instance (ToJSONKey a) => ToJSONKey (Identity a) where+    toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey+    toJSONKeyList = contramapToJSONKeyFunction (map runIdentity) toJSONKeyList+++instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where+    liftToJSON tv tvl (Compose x) = liftToJSON g gl x+      where+        g = liftToJSON tv tvl+        gl = liftToJSONList tv tvl+    {-# INLINE liftToJSON #-}++    liftToJSONList te tel xs = liftToJSONList g gl (map getCompose xs)+      where+        g = liftToJSON te tel+        gl = liftToJSONList te tel+    {-# INLINE liftToJSONList #-}++    liftToEncoding te tel (Compose x) = liftToEncoding g gl x+      where+        g = liftToEncoding te tel+        gl = liftToEncodingList te tel+    {-# INLINE liftToEncoding #-}++    liftToEncodingList te tel xs = liftToEncodingList g gl (map getCompose xs)+      where+        g = liftToEncoding te tel+        gl = liftToEncodingList te tel+    {-# INLINE liftToEncodingList #-}++instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Compose f g a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toJSONList = liftToJSONList toJSON toJSONList+    {-# INLINE toJSONList #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++    toEncodingList = liftToEncodingList toEncoding toEncodingList+    {-# INLINE toEncodingList #-}+++instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Product f g) where+    liftToJSON tv tvl (Pair x y) = liftToJSON2 tx txl ty tyl (x, y)+      where+        tx = liftToJSON tv tvl+        txl = liftToJSONList tv tvl+        ty = liftToJSON tv tvl+        tyl = liftToJSONList tv tvl++    liftToEncoding te tel (Pair x y) = liftToEncoding2 tx txl ty tyl (x, y)+      where+        tx = liftToEncoding te tel+        txl = liftToEncodingList te tel+        ty = liftToEncoding te tel+        tyl = liftToEncodingList te tel++instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Product f g a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Sum f g) where+    liftToJSON tv tvl (InL x) = Object $ H.singleton "InL" (liftToJSON tv tvl x)+    liftToJSON tv tvl (InR y) = Object $ H.singleton "InR" (liftToJSON tv tvl y)++    liftToEncoding te tel (InL x) = E.pairs $ E.pair "InL" $ liftToEncoding te tel x+    liftToEncoding te tel (InR y) = E.pairs $ E.pair "InR" $ liftToEncoding te tel y++instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Sum f g a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++-------------------------------------------------------------------------------+-- containers+-------------------------------------------------------------------------------++instance ToJSON1 Seq.Seq where+    liftToJSON t _ = listValue t . toList+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ = listEncoding t . toList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a) => ToJSON (Seq.Seq a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON1 Set.Set where+    liftToJSON t _ = listValue t . Set.toList+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ = listEncoding t . Set.toList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a) => ToJSON (Set.Set a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON IntSet.IntSet where+    toJSON = toJSON . IntSet.toList+    {-# INLINE toJSON #-}++    toEncoding = toEncoding . IntSet.toList+    {-# INLINE toEncoding #-}+++instance ToJSON1 IntMap.IntMap where+    liftToJSON t tol = liftToJSON to' tol' . IntMap.toList+      where+        to'  = liftToJSON2     toJSON toJSONList t tol+        tol' = liftToJSONList2 toJSON toJSONList t tol+    {-# INLINE liftToJSON #-}++    liftToEncoding t tol = liftToEncoding to' tol' . IntMap.toList+      where+        to'  = liftToEncoding2     toEncoding toEncodingList t tol+        tol' = liftToEncodingList2 toEncoding toEncodingList t tol+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (IntMap.IntMap a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSONKey k => ToJSON1 (M.Map k) where+    liftToJSON g _ = case toJSONKey of+        ToJSONKeyText f _ -> Object . mapHashKeyVal f g+        ToJSONKeyValue  f _ -> Array . V.fromList . map (toJSONPair f g) . M.toList+    {-# INLINE liftToJSON #-}++    liftToEncoding g _ = case toJSONKey of+        ToJSONKeyText _ f -> dict f g M.foldrWithKey+        ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . M.toList+      where+        pairEncoding f (a, b) = E.list id [f a, g b]+    {-# INLINE liftToEncoding #-}+++instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON1 Tree.Tree where+    liftToJSON t tol = go+      where+        go (Tree.Node root branches) =+            liftToJSON2 t tol to' tol' (root, branches)++        to' = liftToJSON go (listValue go)+        tol' = liftToJSONList go (listValue go)+    {-# INLINE liftToJSON #-}++    liftToEncoding t tol = go+      where+        go (Tree.Node root branches) =+            liftToEncoding2 t tol to' tol' (root, branches)++        to' = liftToEncoding go (listEncoding go)+        tol' = liftToEncodingList go (listEncoding go)+    {-# INLINE liftToEncoding #-}++instance (ToJSON v) => ToJSON (Tree.Tree v) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++-------------------------------------------------------------------------------+-- uuid+-------------------------------------------------------------------------------++instance ToJSON UUID.UUID where+    toJSON = toJSON . UUID.toText+    toEncoding = E.unsafeToEncoding . EB.quote . B.byteString . UUID.toASCIIBytes++instance ToJSONKey UUID.UUID where+    toJSONKey = ToJSONKeyText UUID.toText $+        E.unsafeToEncoding . EB.quote . B.byteString . UUID.toASCIIBytes++-------------------------------------------------------------------------------+-- vector+-------------------------------------------------------------------------------++instance ToJSON1 Vector where+    liftToJSON t _ = Array . V.map t+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ =  listEncoding t . V.toList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a) => ToJSON (Vector a) where+    {-# SPECIALIZE instance ToJSON Array #-}++    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++encodeVector :: (ToJSON a, VG.Vector v a) => v a -> Encoding+encodeVector = listEncoding toEncoding . VG.toList+{-# INLINE encodeVector #-}++vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value+vectorToJSON = Array . V.map toJSON . V.convert+{-# INLINE vectorToJSON #-}++instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where+    toJSON = vectorToJSON+    {-# INLINE toJSON #-}++    toEncoding = encodeVector+    {-# INLINE toEncoding #-}+++instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where+    toJSON = vectorToJSON+    {-# INLINE toJSON #-}++    toEncoding = encodeVector+    {-# INLINE toEncoding #-}+++instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where+    toJSON = vectorToJSON+    {-# INLINE toJSON #-}++    toEncoding = encodeVector+    {-# INLINE toEncoding #-}++-------------------------------------------------------------------------------+-- unordered-containers+-------------------------------------------------------------------------------++instance ToJSON1 HashSet.HashSet where+    liftToJSON t _ = listValue t . HashSet.toList+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ = listEncoding t . HashSet.toList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a) => ToJSON (HashSet.HashSet a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSONKey k => ToJSON1 (H.HashMap k) where+    liftToJSON g _ = case toJSONKey of+        ToJSONKeyText f _ -> Object . mapKeyVal f g+        ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . H.toList+    {-# INLINE liftToJSON #-}++    -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding+    liftToEncoding g _ = case toJSONKey of+        ToJSONKeyText _ f -> dict f g H.foldrWithKey+        ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . H.toList+      where+        pairEncoding f (a, b) = E.list id [f a, g b]+    {-# INLINE liftToEncoding #-}++instance (ToJSON v, ToJSONKey k) => ToJSON (H.HashMap k v) where+    {-# SPECIALIZE instance ToJSON Object #-}++    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++-------------------------------------------------------------------------------+-- aeson+-------------------------------------------------------------------------------++instance ToJSON Value where+    toJSON a = a+    {-# INLINE toJSON #-}++    toEncoding = E.value+    {-# INLINE toEncoding #-}++instance ToJSON DotNetTime where+    toJSON = toJSON . dotNetTime++    toEncoding = toEncoding . dotNetTime++dotNetTime :: DotNetTime -> String+dotNetTime (DotNetTime t) = secs ++ formatMillis t ++ ")/"+  where secs  = formatTime defaultTimeLocale "/Date(%s" t++formatMillis :: (FormatTime t) => t -> String+formatMillis = take 3 . formatTime defaultTimeLocale "%q"++-------------------------------------------------------------------------------+-- primitive+-------------------------------------------------------------------------------++instance ToJSON a => ToJSON (PM.Array a) where+  -- note: we could do better than this if vector exposed the data+  -- constructor in Data.Vector.+  toJSON = toJSON . Exts.toList+  toEncoding = toEncoding . Exts.toList++instance ToJSON a => ToJSON (PM.SmallArray a) where+  toJSON = toJSON . Exts.toList+  toEncoding = toEncoding . Exts.toList++instance (PM.Prim a,ToJSON a) => ToJSON (PM.PrimArray a) where+  toJSON = toJSON . Exts.toList+  toEncoding = toEncoding . Exts.toList++-------------------------------------------------------------------------------+-- time+-------------------------------------------------------------------------------++instance ToJSON Day where+    toJSON     = stringEncoding . E.day+    toEncoding = E.day++instance ToJSONKey Day where+    toJSONKey = toJSONKeyTextEnc E.day++instance ToJSON Month where+    toJSON     = stringEncoding . E.month+    toEncoding = E.month++instance ToJSONKey Month where+    toJSONKey = toJSONKeyTextEnc E.month++instance ToJSON Quarter where+    toJSON     = stringEncoding . E.quarter+    toEncoding = E.quarter++instance ToJSONKey Quarter where+    toJSONKey = toJSONKeyTextEnc E.quarter++instance ToJSON TimeOfDay where+    toJSON     = stringEncoding . E.timeOfDay+    toEncoding = E.timeOfDay++instance ToJSONKey TimeOfDay where+    toJSONKey = toJSONKeyTextEnc E.timeOfDay+++instance ToJSON LocalTime where+    toJSON     = stringEncoding . E.localTime+    toEncoding = E.localTime++instance ToJSONKey LocalTime where+    toJSONKey = toJSONKeyTextEnc E.localTime+++instance ToJSON ZonedTime where+    toJSON     = stringEncoding . E.zonedTime+    toEncoding = E.zonedTime++instance ToJSONKey ZonedTime where+    toJSONKey = toJSONKeyTextEnc E.zonedTime+++instance ToJSON UTCTime where+    toJSON     = stringEncoding . E.utcTime+    toEncoding = E.utcTime++instance ToJSONKey UTCTime where+    toJSONKey = toJSONKeyTextEnc E.utcTime++-- | Encode something t a JSON string.+stringEncoding :: Encoding' Text -> Value+stringEncoding = String+    . T.dropAround (== '"')+    . T.decodeLatin1+    . L.toStrict+    . E.encodingToLazyByteString+{-# INLINE stringEncoding #-}+++instance ToJSON NominalDiffTime where+    toJSON = Number . realToFrac+    {-# INLINE toJSON #-}++    toEncoding = E.scientific . realToFrac+    {-# INLINE toEncoding #-}+++instance ToJSON DiffTime where+    toJSON = Number . realToFrac+    {-# INLINE toJSON #-}++    toEncoding = E.scientific . realToFrac+    {-# INLINE toEncoding #-}++-- | Encoded as number+instance ToJSON SystemTime where+    toJSON (MkSystemTime secs nsecs) =+        toJSON (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)+    toEncoding (MkSystemTime secs nsecs) =+        toEncoding (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)++instance ToJSON CalendarDiffTime where+    toJSON (CalendarDiffTime m nt) = object+        [ "months" .= m+        , "time" .= nt+        ]+    toEncoding (CalendarDiffTime m nt) = E.pairs+        ("months" .= m <> "time" .= nt)++instance ToJSON CalendarDiffDays where+    toJSON (CalendarDiffDays m d) = object+        [ "months" .= m+        , "days" .= d+        ]+    toEncoding (CalendarDiffDays m d) = E.pairs+        ("months" .= m <> "days" .= d)++instance ToJSON DayOfWeek where+    toJSON Monday    = "monday"+    toJSON Tuesday   = "tuesday"+    toJSON Wednesday = "wednesday"+    toJSON Thursday  = "thursday"+    toJSON Friday    = "friday"+    toJSON Saturday  = "saturday"+    toJSON Sunday    = "sunday"++    toEncoding = toEncodingDayOfWeek++toEncodingDayOfWeek :: DayOfWeek -> E.Encoding' a+toEncodingDayOfWeek Monday    = E.unsafeToEncoding "\"monday\""+toEncodingDayOfWeek Tuesday   = E.unsafeToEncoding "\"tuesday\""+toEncodingDayOfWeek Wednesday = E.unsafeToEncoding "\"wednesday\""+toEncodingDayOfWeek Thursday  = E.unsafeToEncoding "\"thursday\""+toEncodingDayOfWeek Friday    = E.unsafeToEncoding "\"friday\""+toEncodingDayOfWeek Saturday  = E.unsafeToEncoding "\"saturday\""+toEncodingDayOfWeek Sunday    = E.unsafeToEncoding "\"sunday\""++instance ToJSONKey DayOfWeek where+    toJSONKey = toJSONKeyTextEnc toEncodingDayOfWeek++instance ToJSON QuarterOfYear where+    toJSON Q1 = "q1"+    toJSON Q2 = "q2"+    toJSON Q3 = "q3"+    toJSON Q4 = "q4"++toEncodingQuarterOfYear :: QuarterOfYear -> E.Encoding' a+toEncodingQuarterOfYear Q1 = E.unsafeToEncoding "\"q1\""+toEncodingQuarterOfYear Q2 = E.unsafeToEncoding "\"q2\""+toEncodingQuarterOfYear Q3 = E.unsafeToEncoding "\"q3\""+toEncodingQuarterOfYear Q4 = E.unsafeToEncoding "\"q4\""++instance ToJSONKey QuarterOfYear where+    toJSONKey = toJSONKeyTextEnc toEncodingQuarterOfYear++-------------------------------------------------------------------------------+-- base Monoid/Semigroup+-------------------------------------------------------------------------------++instance ToJSON1 Monoid.Dual where+    liftToJSON t _ = t . Monoid.getDual+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ = t . Monoid.getDual+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Monoid.Dual a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON1 Monoid.First where+    liftToJSON t to' = liftToJSON t to' . Monoid.getFirst+    {-# INLINE liftToJSON #-}++    liftToEncoding t to' = liftToEncoding t to' . Monoid.getFirst+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Monoid.First a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON1 Monoid.Last where+    liftToJSON t to' = liftToJSON t to' . Monoid.getLast+    {-# INLINE liftToJSON #-}++    liftToEncoding t to' = liftToEncoding t to' . Monoid.getLast+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Monoid.Last a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON1 Semigroup.Min where+    liftToJSON t _ (Semigroup.Min x) = t x+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ (Semigroup.Min x) = t x+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.Min a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON1 Semigroup.Max where+    liftToJSON t _ (Semigroup.Max x) = t x+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ (Semigroup.Max x) = t x+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.Max a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++instance ToJSON1 Semigroup.First where+    liftToJSON t _ (Semigroup.First x) = t x+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ (Semigroup.First x) = t x+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.First a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON1 Semigroup.Last where+    liftToJSON t _ (Semigroup.Last x) = t x+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ (Semigroup.Last x) = t x+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.Last a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON1 Semigroup.WrappedMonoid where+    liftToJSON t _ (Semigroup.WrapMonoid x) = t x+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ (Semigroup.WrapMonoid x) = t x+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.WrappedMonoid a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}+++instance ToJSON1 Semigroup.Option where+    liftToJSON t to' = liftToJSON t to' . Semigroup.getOption+    {-# INLINE liftToJSON #-}++    liftToEncoding t to' = liftToEncoding t to' . Semigroup.getOption+    {-# INLINE liftToEncoding #-}++instance ToJSON a => ToJSON (Semigroup.Option a) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++-------------------------------------------------------------------------------+-- data-fix+-------------------------------------------------------------------------------++-- | @since 1.5.3.0+instance ToJSON1 f => ToJSON (F.Fix f) where+    toJSON     = go where go (F.Fix f) = liftToJSON go toJSONList f+    toEncoding = go where go (F.Fix f) = liftToEncoding go toEncodingList f++-- | @since 1.5.3.0+instance (ToJSON1 f, Functor f) => ToJSON (F.Mu f) where+    toJSON     = F.foldMu (liftToJSON id (listValue id))+    toEncoding = F.foldMu (liftToEncoding id (listEncoding id))++-- | @since 1.5.3.0+instance (ToJSON1 f, Functor f) => ToJSON (F.Nu f) where+    toJSON     = F.foldNu (liftToJSON id (listValue id))+    toEncoding = F.foldNu (liftToEncoding id (listEncoding id))++-------------------------------------------------------------------------------+-- strict+-------------------------------------------------------------------------------++-- | @since 1.5.3.0+instance (ToJSON a, ToJSON b) => ToJSON (S.These a b) where+    toJSON = toJSON . S.toLazy+    toEncoding = toEncoding . S.toLazy++-- | @since 1.5.3.0+instance ToJSON2 S.These where+    liftToJSON2 toa toas tob tobs = liftToJSON2 toa toas tob tobs . S.toLazy+    liftToEncoding2 toa toas tob tobs = liftToEncoding2 toa toas tob tobs . S.toLazy++-- | @since 1.5.3.0+instance ToJSON a => ToJSON1 (S.These a) where+    liftToJSON toa tos = liftToJSON toa tos . S.toLazy+    liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy++-- | @since 1.5.3.0+instance (ToJSON a, ToJSON b) => ToJSON (S.Pair a b) where+    toJSON = toJSON . S.toLazy+    toEncoding = toEncoding . S.toLazy++-- | @since 1.5.3.0+instance ToJSON2 S.Pair where+    liftToJSON2 toa toas tob tobs = liftToJSON2 toa toas tob tobs . S.toLazy+    liftToEncoding2 toa toas tob tobs = liftToEncoding2 toa toas tob tobs . S.toLazy++-- | @since 1.5.3.0+instance ToJSON a => ToJSON1 (S.Pair a) where+    liftToJSON toa tos = liftToJSON toa tos . S.toLazy+    liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy++-- | @since 1.5.3.0+instance (ToJSON a, ToJSON b) => ToJSON (S.Either a b) where+    toJSON = toJSON . S.toLazy+    toEncoding = toEncoding . S.toLazy++-- | @since 1.5.3.0+instance ToJSON2 S.Either where+    liftToJSON2 toa toas tob tobs = liftToJSON2 toa toas tob tobs . S.toLazy+    liftToEncoding2 toa toas tob tobs = liftToEncoding2 toa toas tob tobs . S.toLazy++-- | @since 1.5.3.0+instance ToJSON a => ToJSON1 (S.Either a) where+    liftToJSON toa tos = liftToJSON toa tos . S.toLazy+    liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy++-- | @since 1.5.3.0+instance ToJSON a => ToJSON (S.Maybe a) where+    toJSON = toJSON . S.toLazy+    toEncoding = toEncoding . S.toLazy++-- | @since 1.5.3.0+instance ToJSON1 S.Maybe where+    liftToJSON toa tos = liftToJSON toa tos . S.toLazy+    liftToEncoding toa tos = liftToEncoding toa tos . S.toLazy++-------------------------------------------------------------------------------+-- tagged+-------------------------------------------------------------------------------++instance ToJSON1 Proxy where+    liftToJSON _ _ _ = Null+    {-# INLINE liftToJSON #-}++    liftToEncoding _ _ _ = E.null_+    {-# INLINE liftToEncoding #-}++instance ToJSON (Proxy a) where+    toJSON _ = Null+    {-# INLINE toJSON #-}++    toEncoding _ = E.null_+    {-# INLINE toEncoding #-}+++instance ToJSON2 Tagged where+    liftToJSON2 _ _ t _ (Tagged x) = t x+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 _ _ t _ (Tagged x) = t x+    {-# INLINE liftToEncoding2 #-}++instance ToJSON1 (Tagged a) where+    liftToJSON t _ (Tagged x) = t x+    {-# INLINE liftToJSON #-}++    liftToEncoding t _ (Tagged x) = t x+    {-# INLINE liftToEncoding #-}++instance ToJSON b => ToJSON (Tagged a b) where+    toJSON = toJSON1+    {-# INLINE toJSON #-}++    toEncoding = toEncoding1+    {-# INLINE toEncoding #-}++instance ToJSONKey b => ToJSONKey (Tagged a b) where+    toJSONKey = contramapToJSONKeyFunction unTagged toJSONKey+    toJSONKeyList = contramapToJSONKeyFunction (fmap unTagged) toJSONKeyList++-------------------------------------------------------------------------------+-- these+-------------------------------------------------------------------------------++-- | @since 1.5.1.0+instance (ToJSON a, ToJSON b) => ToJSON (These a b) where+    toJSON (This a)    = object [ "This" .= a ]+    toJSON (That b)    = object [ "That" .= b ]+    toJSON (These a b) = object [ "This" .= a, "That" .= b ]++    toEncoding (This a)    = E.pairs $ "This" .= a+    toEncoding (That b)    = E.pairs $ "That" .= b+    toEncoding (These a b) = E.pairs $ "This" .= a <> "That" .= b++-- | @since 1.5.1.0+instance ToJSON2 These where+    liftToJSON2  toa _ _tob _ (This a)    = object [ "This" .= toa a ]+    liftToJSON2 _toa _  tob _ (That b)    = object [ "That" .= tob b ]+    liftToJSON2  toa _  tob _ (These a b) = object [ "This" .= toa a, "That" .= tob b ]++    liftToEncoding2  toa _ _tob _ (This a)    = E.pairs $ E.pair "This" (toa a)+    liftToEncoding2 _toa _  tob _ (That b)    = E.pairs $ E.pair "That" (tob b)+    liftToEncoding2  toa _  tob _ (These a b) = E.pairs $ E.pair "This" (toa a) <> E.pair "That" (tob b)++-- | @since 1.5.1.0+instance ToJSON a => ToJSON1 (These a) where+    liftToJSON _tob _ (This a)    = object [ "This" .= a ]+    liftToJSON  tob _ (That b)    = object [ "That" .= tob b ]+    liftToJSON  tob _ (These a b) = object [ "This" .= a, "That" .= tob b ]++    liftToEncoding _tob _ (This a)    = E.pairs $ "This" .= a+    liftToEncoding  tob _ (That b)    = E.pairs $ E.pair "That" (tob b)+    liftToEncoding  tob _ (These a b) = E.pairs $ "This" .= a <> E.pair "That" (tob b)++-- | @since 1.5.1.0+instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (These1 f g) where+    liftToJSON tx tl (This1 a)    = object [ "This" .= liftToJSON tx tl a ]+    liftToJSON tx tl (That1 b)    = object [ "That" .= liftToJSON tx tl b ]+    liftToJSON tx tl (These1 a b) = object [ "This" .= liftToJSON tx tl a, "That" .= liftToJSON tx tl b ]++    liftToEncoding tx tl (This1 a)    = E.pairs $ E.pair "This" (liftToEncoding tx tl a)+    liftToEncoding tx tl (That1 b)    = E.pairs $ E.pair "That" (liftToEncoding tx tl b)+    liftToEncoding tx tl (These1 a b) = E.pairs $+        pair "This" (liftToEncoding tx tl a) `mappend`+        pair "That" (liftToEncoding tx tl b)++-- | @since 1.5.1.0+instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (These1 f g a) where+    toJSON     = toJSON1+    toEncoding = toEncoding1++-------------------------------------------------------------------------------+-- Instances for converting t map keys+-------------------------------------------------------------------------------++instance (ToJSON a, ToJSON b) => ToJSONKey (a,b)+instance (ToJSON a, ToJSON b, ToJSON c) => ToJSONKey (a,b,c)+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSONKey (a,b,c,d)++instance ToJSONKey Char where+    toJSONKey = ToJSONKeyText T.singleton (E.string . (:[]))+    toJSONKeyList = toJSONKeyText T.pack++instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where+    toJSONKey = toJSONKeyList++-------------------------------------------------------------------------------+-- Tuple instances+-------------------------------------------------------------------------------++instance ToJSON2 (,) where+    liftToJSON2 toA _ toB _ (a, b) = Array $ V.create $ do+        mv <- VM.unsafeNew 2+        VM.unsafeWrite mv 0 (toA a)+        VM.unsafeWrite mv 1 (toB b)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toA _ toB _ (a, b) = E.list id [toA a, toB b]+    {-# INLINE liftToEncoding2 #-}++instance (ToJSON a) => ToJSON1 ((,) a) where+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b) => ToJSON (a, b) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a) => ToJSON2 ((,,) a) where+    liftToJSON2 toB _ toC _ (a, b, c) = Array $ V.create $ do+        mv <- VM.unsafeNew 3+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toB b)+        VM.unsafeWrite mv 2 (toC c)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toB _ toC _ (a, b, c) = E.list id+      [ toEncoding a+      , toB b+      , toC c+      ]+    {-# INLINE liftToEncoding2 #-}++instance (ToJSON a, ToJSON b) => ToJSON1 ((,,) a b) where+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a, b, c) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b) => ToJSON2 ((,,,) a b) where+    liftToJSON2 toC _ toD _ (a, b, c, d) = Array $ V.create $ do+        mv <- VM.unsafeNew 4+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toC c)+        VM.unsafeWrite mv 3 (toD d)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toC _ toD _ (a, b, c, d) = E.list id+      [ toEncoding a+      , toEncoding b+      , toC c+      , toD d+      ]+    {-# INLINE liftToEncoding2 #-}++instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON1 ((,,,) a b c) where+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a, b, c, d) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON2 ((,,,,) a b c) where+    liftToJSON2 toD _ toE _ (a, b, c, d, e) = Array $ V.create $ do+        mv <- VM.unsafeNew 5+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toD d)+        VM.unsafeWrite mv 4 (toE e)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toD _ toE _ (a, b, c, d, e) = E.list id+      [ toEncoding a+      , toEncoding b+      , toEncoding c+      , toD d+      , toE e+      ]+    {-# INLINE liftToEncoding2 #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON1 ((,,,,) a b c d) where+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON (a, b, c, d, e) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON2 ((,,,,,) a b c d) where+    liftToJSON2 toE _ toF _ (a, b, c, d, e, f) = Array $ V.create $ do+        mv <- VM.unsafeNew 6+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toJSON d)+        VM.unsafeWrite mv 4 (toE e)+        VM.unsafeWrite mv 5 (toF f)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toE _ toF _ (a, b, c, d, e, f) = E.list id+      [ toEncoding a+      , toEncoding b+      , toEncoding c+      , toEncoding d+      , toE e+      , toF f+      ]+    {-# INLINE liftToEncoding2 #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON1 ((,,,,,) a b c d e) where+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON (a, b, c, d, e, f) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON2 ((,,,,,,) a b c d e) where+    liftToJSON2 toF _ toG _ (a, b, c, d, e, f, g) = Array $ V.create $ do+        mv <- VM.unsafeNew 7+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toJSON d)+        VM.unsafeWrite mv 4 (toJSON e)+        VM.unsafeWrite mv 5 (toF f)+        VM.unsafeWrite mv 6 (toG g)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toF _ toG _ (a, b, c, d, e, f, g) = E.list id+        [ toEncoding a+        , toEncoding b+        , toEncoding c+        , toEncoding d+        , toEncoding e+        , toF f+        , toG g+        ]+    {-# INLINE liftToEncoding2 #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON1 ((,,,,,,) a b c d e f) where+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON (a, b, c, d, e, f, g) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON2 ((,,,,,,,) a b c d e f) where+    liftToJSON2 toG _ toH _ (a, b, c, d, e, f, g, h) = Array $ V.create $ do+        mv <- VM.unsafeNew 8+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toJSON d)+        VM.unsafeWrite mv 4 (toJSON e)+        VM.unsafeWrite mv 5 (toJSON f)+        VM.unsafeWrite mv 6 (toG g)+        VM.unsafeWrite mv 7 (toH h)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toG _ toH _ (a, b, c, d, e, f, g, h) = E.list id+        [ toEncoding a+        , toEncoding b+        , toEncoding c+        , toEncoding d+        , toEncoding e+        , toEncoding f+        , toG g+        , toH h+        ]+    {-# INLINE liftToEncoding2 #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON1 ((,,,,,,,) a b c d e f g) where+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h) => ToJSON (a, b, c, d, e, f, g, h) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON2 ((,,,,,,,,) a b c d e f g) where+    liftToJSON2 toH _ toI _ (a, b, c, d, e, f, g, h, i) = Array $ V.create $ do+        mv <- VM.unsafeNew 9+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toJSON d)+        VM.unsafeWrite mv 4 (toJSON e)+        VM.unsafeWrite mv 5 (toJSON f)+        VM.unsafeWrite mv 6 (toJSON g)+        VM.unsafeWrite mv 7 (toH h)+        VM.unsafeWrite mv 8 (toI i)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toH _ toI _ (a, b, c, d, e, f, g, h, i) = E.list id+        [ toEncoding a+        , toEncoding b+        , toEncoding c+        , toEncoding d+        , toEncoding e+        , toEncoding f+        , toEncoding g+        , toH h+        , toI i+        ]+    {-# INLINE liftToEncoding2 #-}++instance (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+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i) => ToJSON (a, b, c, d, e, f, g, h, i) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h) => ToJSON2 ((,,,,,,,,,) a b c d e f g h) where+    liftToJSON2 toI _ toJ _ (a, b, c, d, e, f, g, h, i, j) = Array $ V.create $ do+        mv <- VM.unsafeNew 10+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toJSON d)+        VM.unsafeWrite mv 4 (toJSON e)+        VM.unsafeWrite mv 5 (toJSON f)+        VM.unsafeWrite mv 6 (toJSON g)+        VM.unsafeWrite mv 7 (toJSON h)+        VM.unsafeWrite mv 8 (toI i)+        VM.unsafeWrite mv 9 (toJ j)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toI _ toJ _ (a, b, c, d, e, f, g, h, i, j) = E.list id+        [ toEncoding a+        , toEncoding b+        , toEncoding c+        , toEncoding d+        , toEncoding e+        , toEncoding f+        , toEncoding g+        , toEncoding h+        , toI i+        , toJ j+        ]+    {-# INLINE liftToEncoding2 #-}++instance (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+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j) => ToJSON (a, b, c, d, e, f, g, h, i, j) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i) => ToJSON2 ((,,,,,,,,,,) a b c d e f g h i) where+    liftToJSON2 toJ _ toK _ (a, b, c, d, e, f, g, h, i, j, k) = Array $ V.create $ do+        mv <- VM.unsafeNew 11+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toJSON d)+        VM.unsafeWrite mv 4 (toJSON e)+        VM.unsafeWrite mv 5 (toJSON f)+        VM.unsafeWrite mv 6 (toJSON g)+        VM.unsafeWrite mv 7 (toJSON h)+        VM.unsafeWrite mv 8 (toJSON i)+        VM.unsafeWrite mv 9 (toJ j)+        VM.unsafeWrite mv 10 (toK k)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toJ _ toK _ (a, b, c, d, e, f, g, h, i, j, k) = E.list id+        [ toEncoding a+        , toEncoding b+        , toEncoding c+        , toEncoding d+        , toEncoding e+        , toEncoding f+        , toEncoding g+        , toEncoding h+        , toEncoding i+        , toJ j+        , toK k+        ]+    {-# INLINE liftToEncoding2 #-}++instance (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+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k) => ToJSON (a, b, c, d, e, f, g, h, i, j, k) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j) => ToJSON2 ((,,,,,,,,,,,) a b c d e f g h i j) where+    liftToJSON2 toK _ toL _ (a, b, c, d, e, f, g, h, i, j, k, l) = Array $ V.create $ do+        mv <- VM.unsafeNew 12+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toJSON d)+        VM.unsafeWrite mv 4 (toJSON e)+        VM.unsafeWrite mv 5 (toJSON f)+        VM.unsafeWrite mv 6 (toJSON g)+        VM.unsafeWrite mv 7 (toJSON h)+        VM.unsafeWrite mv 8 (toJSON i)+        VM.unsafeWrite mv 9 (toJSON j)+        VM.unsafeWrite mv 10 (toK k)+        VM.unsafeWrite mv 11 (toL l)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toK _ toL _ (a, b, c, d, e, f, g, h, i, j, k, l) = E.list id+        [ toEncoding a+        , toEncoding b+        , toEncoding c+        , toEncoding d+        , toEncoding e+        , toEncoding f+        , toEncoding g+        , toEncoding h+        , toEncoding i+        , toEncoding j+        , toK k+        , toL l+        ]+    {-# INLINE liftToEncoding2 #-}++instance (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+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (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 (a, b, c, d, e, f, g, h, i, j, k, l) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k) => ToJSON2 ((,,,,,,,,,,,,) a b c d e f g h i j k) where+    liftToJSON2 toL _ toM _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = Array $ V.create $ do+        mv <- VM.unsafeNew 13+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toJSON d)+        VM.unsafeWrite mv 4 (toJSON e)+        VM.unsafeWrite mv 5 (toJSON f)+        VM.unsafeWrite mv 6 (toJSON g)+        VM.unsafeWrite mv 7 (toJSON h)+        VM.unsafeWrite mv 8 (toJSON i)+        VM.unsafeWrite mv 9 (toJSON j)+        VM.unsafeWrite mv 10 (toJSON k)+        VM.unsafeWrite mv 11 (toL l)+        VM.unsafeWrite mv 12 (toM m)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toL _ toM _ (a, b, c, d, e, f, g, h, i, j, k, l, m) = E.list id+        [ toEncoding a+        , toEncoding b+        , toEncoding c+        , toEncoding d+        , toEncoding e+        , toEncoding f+        , toEncoding g+        , toEncoding h+        , toEncoding i+        , toEncoding j+        , toEncoding k+        , toL l+        , toM m+        ]+    {-# INLINE liftToEncoding2 #-}++instance (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+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (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 (a, b, c, d, e, f, g, h, i, j, k, l, m) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g, ToJSON h, ToJSON i, ToJSON j, ToJSON k, ToJSON l) => ToJSON2 ((,,,,,,,,,,,,,) a b c d e f g h i j k l) where+    liftToJSON2 toM _ toN _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = Array $ V.create $ do+        mv <- VM.unsafeNew 14+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toJSON d)+        VM.unsafeWrite mv 4 (toJSON e)+        VM.unsafeWrite mv 5 (toJSON f)+        VM.unsafeWrite mv 6 (toJSON g)+        VM.unsafeWrite mv 7 (toJSON h)+        VM.unsafeWrite mv 8 (toJSON i)+        VM.unsafeWrite mv 9 (toJSON j)+        VM.unsafeWrite mv 10 (toJSON k)+        VM.unsafeWrite mv 11 (toJSON l)+        VM.unsafeWrite mv 12 (toM m)+        VM.unsafeWrite mv 13 (toN n)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toM _ toN _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = E.list id+        [ toEncoding a+        , toEncoding b+        , toEncoding c+        , toEncoding d+        , toEncoding e+        , toEncoding f+        , toEncoding g+        , toEncoding h+        , toEncoding i+        , toEncoding j+        , toEncoding k+        , toEncoding l+        , toM m+        , toN n+        ]+    {-# INLINE liftToEncoding2 #-}++instance (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+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (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) => ToJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++instance (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) => ToJSON2 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m) where+    liftToJSON2 toN _ toO _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = Array $ V.create $ do+        mv <- VM.unsafeNew 15+        VM.unsafeWrite mv 0 (toJSON a)+        VM.unsafeWrite mv 1 (toJSON b)+        VM.unsafeWrite mv 2 (toJSON c)+        VM.unsafeWrite mv 3 (toJSON d)+        VM.unsafeWrite mv 4 (toJSON e)+        VM.unsafeWrite mv 5 (toJSON f)+        VM.unsafeWrite mv 6 (toJSON g)+        VM.unsafeWrite mv 7 (toJSON h)+        VM.unsafeWrite mv 8 (toJSON i)+        VM.unsafeWrite mv 9 (toJSON j)+        VM.unsafeWrite mv 10 (toJSON k)+        VM.unsafeWrite mv 11 (toJSON l)+        VM.unsafeWrite mv 12 (toJSON m)+        VM.unsafeWrite mv 13 (toN n)+        VM.unsafeWrite mv 14 (toO o)+        return mv+    {-# INLINE liftToJSON2 #-}++    liftToEncoding2 toN _ toO _ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = E.list id+        [ toEncoding a+        , toEncoding b+        , toEncoding c+        , toEncoding d+        , toEncoding e+        , toEncoding f+        , toEncoding g+        , toEncoding h+        , toEncoding i+        , toEncoding j+        , toEncoding k+        , toEncoding l+        , toEncoding m+        , toN n+        , toO o+        ]+    {-# INLINE liftToEncoding2 #-}++instance (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+    liftToJSON = liftToJSON2 toJSON toJSONList+    {-# INLINE liftToJSON #-}+    liftToEncoding = liftToEncoding2 toEncoding toEncodingList+    {-# INLINE liftToEncoding #-}++instance (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, ToJSON o) => ToJSON (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+    toJSON = toJSON2+    {-# INLINE toJSON #-}+    toEncoding = toEncoding2+    {-# INLINE toEncoding #-}++--------------------------------------------------------------------------------++-- | Wrap a list of pairs as an object.+class Monoid pairs => FromPairs enc pairs | enc -> pairs where+  fromPairs :: pairs -> enc++instance (a ~ Value) => FromPairs (Encoding' a) Series where+  fromPairs = E.pairs++instance FromPairs Value (DList Pair) where+  fromPairs = object . toList++-- | Like 'KeyValue' but the value is already converted to JSON+-- ('Value' or 'Encoding'), and the result actually represents lists of pairs+-- so it can be readily concatenated.+class Monoid kv => KeyValuePair v kv where+    pair :: String -> v -> kv++instance (v ~ Value) => KeyValuePair v (DList Pair) where+    pair k v = DList.singleton (pack k .= v)++instance (e ~ Encoding) => KeyValuePair e Series where+    pair = E.pairStr
− stack.yaml 
@@ -1,15 +0,0 @@-resolver: lts-12.26-packages:-- '.'-- attoparsec-iso8601-flags:-  aeson:-    fast: true-    cffi: true-extra-deps:-- base-orphans-0.8.1-- hashable-time-0.2.0.1-- QuickCheck-2.13.1-- quickcheck-instances-0.3.21-- splitmix-0.0.2-- time-compat-1.9.2.2
tests/Instances.hs view
@@ -17,9 +17,10 @@ import Data.Time (ZonedTime(..), TimeZone(..)) import Data.Time.Clock (UTCTime(..)) import Functions-import Test.QuickCheck (Arbitrary(..), elements,  oneof)+import Test.QuickCheck (Arbitrary(..), elements,  oneof, sized, Gen, chooseInt, shuffle) import Types import qualified Data.DList as DList+import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM  import Data.Orphans ()@@ -165,3 +166,38 @@  instance Arbitrary a => Arbitrary (DList.DList a) where     arbitrary = DList.fromList <$> arbitrary++instance Arbitrary Value where+    arbitrary = sized arb where+        arb :: Int -> Gen Value+        arb n+            | n <= 1 = oneof+                [ return Null+                , fmap Bool arbitrary+                , fmap String arbitrary+                , fmap Number arbitrary+                ]++            | otherwise = oneof [arr n, obj n]++        arr n = do+            pars <- arbPartition (n - 1)+            fmap (Array . V.fromList) (traverse arb pars)++        obj n = do+            pars <- arbPartition (n - 1)+            fmap (Object . HM.fromList) (traverse pair pars)++        pair n = do+            k <- arbitrary+            v <- arb n+            return (k, v)++        arbPartition :: Int -> Gen [Int]+        arbPartition k = case compare k 1 of+            LT -> pure []+            EQ -> pure [1]+            GT -> do+                first <- chooseInt (1, k)+                rest <- arbPartition $ k - first+                shuffle (first : rest)
tests/PropUtils.hs view
@@ -21,6 +21,7 @@ import Instances () import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample) import Types+import Text.Read (readMaybe) import qualified Data.Attoparsec.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.HashMap.Strict as H@@ -73,6 +74,9 @@  roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y++roundtripReadShow :: Value -> Property+roundtripReadShow v = readMaybe (show v) === Just v  -- We test keys by encoding HashMap and Map with it roundTripKey
tests/Properties.hs view
@@ -21,6 +21,7 @@       testProperty "encodeDouble" encodeDouble     , testProperty "encodeInteger" encodeInteger     ]+  , testProperty "read . show = id" roundtripReadShow   , roundTripTests   , keysTests   , testGroup "toFromJSON" [
tests/PropertyKeys.hs view
@@ -35,11 +35,10 @@     , testProperty "Float" $ roundTripKey (undefined :: Float)     , testProperty "Double" $ roundTripKey (undefined :: Double)     , testProperty "Day" $ roundTripKey (undefined :: Day)-    -- TODO: needs https://github.com/w3rs/hashable-time/pull/12-    -- , testProperty "DayOfWeek" $ roundTripKey (undefined :: DayOfWeek)-    -- , testProperty "Month" $ roundTripKey (undefined :: Month)-    -- , testProperty "Quarter" $ roundTripKey (undefined :: Quarter)-    -- , testProperty "QuarterOfYear" $ roundTripKey (undefined :: QuarterOfYear)+    , testProperty "DayOfWeek" $ roundTripKey (undefined :: DayOfWeek)+    , testProperty "Month" $ roundTripKey (undefined :: Month)+    , testProperty "Quarter" $ roundTripKey (undefined :: Quarter)+    , testProperty "QuarterOfYear" $ roundTripKey (undefined :: QuarterOfYear)     , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime)     , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)     , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)
tests/PropertyRoundTrip.hs view
@@ -37,7 +37,8 @@ roundTripTests :: TestTree roundTripTests =   testGroup "roundTrip" [-      testProperty "Bool" $ roundTripEq True+      testProperty "Value" $ roundTripEq (undefined :: Value)+    , testProperty "Bool" $ roundTripEq True     , testProperty "Double" $ roundTripEq (1 :: Approx Double)     , testProperty "Int" $ roundTripEq (1 :: Int)     , testProperty "NonEmpty Char" $ roundTripEq (undefined :: NonEmpty Char)