aeson 0.11.3.0 → 1.0.0.0

raw patch · 69 files changed

+10310/−5015 lines, 69 filesdep +base-compatdep +bytestring-builderdep +generic-derivingdep −mtldep −old-localedep −sybdep ~QuickCheckdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: base-compat, bytestring-builder, generic-deriving, hashable-time, time-locale-compat, transformers-compat

Dependencies removed: mtl, old-locale, syb

Dependency ranges changed: QuickCheck, base, bytestring, containers, deepseq, dlist, hashable, scientific, semigroups, template-haskell, time, transformers

API changes (from Hackage documentation)

Files

• Data/Aeson.hs +36/−6
• Data/Aeson/Encode.hs +15/−85
• Data/Aeson/Encode/Builder.hs +0/−260
• Data/Aeson/Encode/Functions.hs +0/−59
• Data/Aeson/Encoding.hs +52/−0
• Data/Aeson/Encoding/Builder.hs +330/−0
• Data/Aeson/Encoding/Internal.hs +360/−0
• Data/Aeson/Functions.hs +0/−42
• Data/Aeson/Internal.hs +3/−1
• Data/Aeson/Internal/Functions.hs +39/−0
• Data/Aeson/Internal/Time.hs +3/−0
• Data/Aeson/Parser.hs +9/−2
• Data/Aeson/Parser/Internal.hs +11/−11
• Data/Aeson/Parser/Time.hs +6/−6
• Data/Aeson/TH.hs +2441/−1512
• Data/Aeson/Text.hs +101/−0
• Data/Aeson/Types.hs +45/−3
• Data/Aeson/Types/Class.hs +59/−243
• Data/Aeson/Types/FromJSON.hs +2032/−0
• Data/Aeson/Types/Generic.hs +47/−719
• Data/Aeson/Types/Instances.hs +0/−1738
• Data/Aeson/Types/Internal.hs +27/−62
• Data/Aeson/Types/ToJSON.hs +2689/−0
• aeson.cabal +72/−40
• benchmarks/AesonCompareAutoInstances.hs +12/−14
• benchmarks/AesonEncode.hs +9/−2
• benchmarks/AesonFoldable.hs +114/−0
• benchmarks/AesonMap.hs +231/−0
• benchmarks/AesonParse.hs +9/−2
• benchmarks/AesonTuples.hs +5/−2
• benchmarks/Compare.hs +5/−1
• benchmarks/Compare/BufferBuilder.hs +9/−3
• benchmarks/Compare/JsonBench.hs +8/−2
• benchmarks/Compare/JsonBuilder.hs +6/−1
• benchmarks/CompareWithJSON.hs +7/−2
• benchmarks/Dates.hs +5/−1
• benchmarks/JsonParse.hs +8/−2
• benchmarks/Micro.hs +4/−2
• benchmarks/Options.hs +4/−1
• benchmarks/ReadFile.hs +7/−1
• benchmarks/Typed.hs +3/−0
• benchmarks/Typed/Common.hs +16/−3
• benchmarks/Typed/Generic.hs +24/−11
• benchmarks/Typed/Manual.hs +24/−11
• benchmarks/Typed/TH.hs +24/−11
• benchmarks/aeson-benchmarks.cabal +82/−22
• changelog.md +74/−2
• examples/Generic.hs +7/−5
• examples/Simplest.hs +8/−2
• examples/TemplateHaskell.hs +6/−3
• examples/Twitter.hs +9/−5
• examples/Twitter/Generic.hs +26/−2
• examples/Twitter/Manual.hs +142/−4
• examples/Twitter/TH.hs +18/−1
• examples/aeson-examples.cabal +3/−0
• include/overlapping-compat.h +0/−7
• tests/DataFamilies/Encoders.hs +102/−1
• tests/DataFamilies/Instances.hs +5/−3
• tests/DataFamilies/Properties.hs +74/−14
• tests/DataFamilies/Types.hs +19/−1
• tests/Encoders.hs +131/−6
• tests/Functions.hs +8/−1
• tests/Instances.hs +56/−18
• tests/Options.hs +13/−0
• tests/Properties.hs +248/−15
• tests/Tests.hs +3/−0
• tests/Types.hs +26/−2
• tests/UnitTests.hs +276/−40
• tests/UnitTests/NullaryConstructors.hs +63/−0

@@ -57,13 +57,36 @@     , fromJSON     , ToJSON(..)     , KeyValue(..)+    -- ** Keys for maps+    , ToJSONKey(..)+    , ToJSONKeyFunction(..)+    , FromJSONKey(..)+    , FromJSONKeyFunction(..)+    -- ** 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(..)+    , ToArgs(..)+    , Zero+    , One     , genericToJSON+    , genericLiftToJSON     , genericToEncoding+    , genericLiftToEncoding     , genericParseJSON+    , genericLiftParseJSON     , defaultOptions      -- * Inspecting @'Value's@@@ -87,16 +110,23 @@     , json'     ) where -import Data.Aeson.Encode (encode)-import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith,-                                   eitherDecodeWith, eitherDecodeStrictWith,-                                   jsonEOF, json, jsonEOF', json')+import Prelude ()+import Prelude.Compat++import Data.Aeson.Types.FromJSON (ifromJSON)+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.Instances (ifromJSON) import Data.Aeson.Types.Internal (JSONPath, 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 deserialize a JSON value from a lazy 'L.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned.@@ -136,7 +166,7 @@ decode' = decodeWith jsonEOF' fromJSON {-# INLINE decode' #-} --- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.+-- | Efficiently deserialize a JSON value from a strict 'B.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. --

@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}- -- | -- Module:      Data.Aeson.Encode -- Copyright:   (c) 2012-2016 Bryan O'Sullivan@@ -9,92 +7,24 @@ -- Stability:   experimental -- Portability: portable ----- Efficiently serialize a JSON value.------ 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.Encode-    ( encode--    -- * Encoding to Builders-    , encodeToBuilder+-- This module is left to supply limited backwards-compatibility.+module Data.Aeson.Encode {-# DEPRECATED "Use Data.Aeson or Data.Aeson.Text instead" #-}+    (+      encode     , encodeToTextBuilder--    -- * Deprecated-    , fromValue     ) where -import Data.Aeson.Encode.Builder (encodeToBuilder)-import Data.Aeson.Encode.Functions (encode)-import Data.Aeson.Types (Value(..))-import Data.Monoid ((<>))-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.Vector as V---- | 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 'encodeToBuilder'--- instead.-encodeToTextBuilder :: Value -> Builder-encodeToTextBuilder =-    go-  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--{-# DEPRECATED fromValue "Use 'encodeToTextBuilder' instead" #-}-fromValue :: Value -> Builder-fromValue = encodeToTextBuilder+import Prelude () -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"+import Data.ByteString.Lazy (ByteString)+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Aeson as A+import qualified Data.Aeson.Text as A -    escape c-        | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h-        | otherwise  = singleton c-        where h = showHex (fromEnum c) ""+encode :: A.ToJSON a => a -> ByteString+encode = A.encode+{-# DEPRECATED encode "Use encode from Data.Aeson" #-} -fromScientific :: Scientific -> Builder-fromScientific s = formatScientificBuilder format prec s-  where-    (format, prec)-      | base10Exponent s < 0 = (Generic, Nothing)-      | otherwise            = (Fixed,   Just 0)+encodeToTextBuilder :: A.Value -> Builder+encodeToTextBuilder = A.encodeToTextBuilder+{-# DEPRECATED encodeToTextBuilder "Use encodeTotextBuilder from Data.Aeson.Text" #-}

@@ -1,260 +0,0 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}---- |--- Module:      Data.Aeson.Encode.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.Encode.Builder-    (-      encodeToBuilder-    , null_-    , bool-    , array-    , emptyArray_-    , emptyObject_-    , object-    , text-    , string-    , unquoted-    , quote-    , number-    , day-    , localTime-    , utcTime-    , timeOfDay-    , zonedTime-    , ascii2-    , ascii4-    , ascii5-    ) where--import Data.Aeson.Internal.Time-import Data.Aeson.Types.Internal (Encoding(..), 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.Monoid ((<>))-import Data.Scientific (Scientific, base10Exponent, coefficient)-import Data.Time (UTCTime(..))-import Data.Time.Calendar (Day(..), toGregorian)-import Data.Time.LocalTime-import Data.Word (Word8)-import qualified Data.HashMap.Strict as HMS-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-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) = number 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 t = TE.encodeUtf8BuilderEscaped escapeAscii t---- | 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.-number :: Scientific -> Builder-number s-    | e < 0     = scientificBuilder s-    | otherwise = B.integerDec (coefficient s * 10 ^ e)-  where-    e = base10Exponent s--emptyArray_ :: Encoding-emptyArray_ = Encoding emptyArray__--emptyArray__ :: Builder-emptyArray__ = BP.primBounded (ascii2 ('[',']')) ()--emptyObject_ :: Encoding-emptyObject_ = Encoding emptyObject__--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 #-}--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-        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-        padYear y =-            let (ab,c) = fromIntegral y `quotRem` 10-                (a,b)  = ab `quotRem` 10-            in ('0',(digit a,(digit b,digit c)))-{-# INLINE day #-}--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 = (\x -> ('.', x)) >$< (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-{-# INLINE timeOfDay64 #-}--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)

@@ -1,59 +0,0 @@-{-# LANGUAGE CPP #-}--module Data.Aeson.Encode.Functions-    (-      brackets-    , builder-    , char7-    , encode-    , foldable-    , list-    , pairs-    ) where--import Data.Aeson.Encode.Builder-import Data.Aeson.Types.Class-import Data.Aeson.Types.Internal-import Data.ByteString.Builder (Builder, char7)-import Data.ByteString.Builder.Prim (primBounded)-import Data.Monoid ((<>))-import qualified Data.ByteString.Builder as B-import qualified Data.ByteString.Lazy as L--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable, foldMap)-import Data.Monoid (mempty)-#endif--builder :: ToJSON a => a -> Builder-builder = fromEncoding . toEncoding-{-# INLINE builder #-}---- | 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 = B.toLazyByteString . builder-{-# INLINE encode #-}---- | Encode a 'Foldable' as a JSON array.-foldable :: (Foldable t, ToJSON a) => t a -> Encoding-foldable = brackets '[' ']' . foldMap (Value . toEncoding)-{-# INLINE foldable #-}--list :: (ToJSON a) => [a] -> Encoding-list []     = emptyArray_-list (x:xs) = Encoding $-              char7 '[' <> builder x <> commas xs <> char7 ']'-      where commas = foldr (\v vs -> char7 ',' <> builder v <> vs) mempty-{-# INLINE list #-}--brackets :: Char -> Char -> Series -> Encoding-brackets begin end (Value v) = Encoding $-                               char7 begin <> fromEncoding v <> char7 end-brackets begin end Empty     = Encoding (primBounded (ascii2 (begin,end)) ())---- | Encode a series of key/value pairs, separated by commas.-pairs :: Series -> Encoding-pairs s = brackets '{' '}' s-{-# INLINE pairs #-}

@@ -0,0 +1,52 @@+-- |+--+-- 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+    -- * 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+    , localTime+    , utcTime+    , timeOfDay+    , zonedTime++    -- ** value+    , value+    ) where++import Prelude ()++import Data.Aeson.Encoding.Internal

@@ -0,0 +1,330 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- 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+    , localTime+    , utcTime+    , timeOfDay+    , zonedTime+    , ascii2+    , ascii4+    , ascii5+    ) where++import Prelude ()+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.Monoid ((<>))+import Data.Scientific (Scientific, base10Exponent, coefficient)+import Data.Time (UTCTime(..))+import Data.Time.Calendar (Day(..), toGregorian)+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++#if MIN_VERSION_bytestring(0,10,4)+import Data.Text.Encoding (encodeUtf8BuilderEscaped)+#else+import Data.Bits ((.&.))+import Data.Text.Internal (Text(..))+import Data.Text.Internal.Unsafe.Shift (shiftR)+import Foreign.Ptr (minusPtr, plusPtr)+import Foreign.Storable (poke)+import qualified Data.ByteString.Builder.Internal as B+import qualified Data.ByteString.Builder.Prim.Internal as BP+import qualified Data.Text.Array as A+import qualified Data.Text.Internal.Encoding.Utf16 as U16+#endif++-- | 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     = 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 #-}++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+        encodeYear y+            | y >= 1000 = B.integerDec y+            | y > 0 =+                let (ab,c) = fromIntegral y `quotRem` 10+                    (a,b)  = ab `quotRem` 10+                in BP.primBounded (ascii4 ('0',(digit a,(digit b,digit c)))) ()+            | otherwise =+                error "Data.Aeson.Encode.Builder.day:  years BCE not supported"+{-# INLINE day #-}++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 = (\x -> ('.', x)) >$< (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+{-# INLINE timeOfDay64 #-}++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)++#if !(MIN_VERSION_bytestring(0,10,4))+-- | Encode text using UTF-8 encoding and escape the ASCII characters using+-- a 'BP.BoundedPrim'.+--+-- Use this function is to implement efficient encoders for text-based formats+-- like JSON or HTML.+{-# INLINE encodeUtf8BuilderEscaped #-}+-- TODO: Extend documentation with references to source code in @blaze-html@+-- or @aeson@ that uses this function.+encodeUtf8BuilderEscaped :: BP.BoundedPrim Word8 -> Text -> B.Builder+encodeUtf8BuilderEscaped be =+    -- manual eta-expansion to ensure inlining works as expected+    \txt -> B.builder (mkBuildstep txt)+  where+    bound = max 4 $ BP.sizeBound be++    mkBuildstep (Text arr off len) !k =+        outerLoop off+      where+        iend = off + len++        outerLoop !i0 !br@(B.BufferRange op0 ope)+          | i0 >= iend       = k br+          | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)+          -- TODO: Use a loop with an integrated bound's check if outRemaining+          -- is smaller than 8, as this will save on divisions.+          | otherwise        = return $ B.bufferFull bound op0 (outerLoop i0)+          where+            outRemaining = (ope `minusPtr` op0) `div` bound+            inpRemaining = iend - i0++            goPartial !iendTmp = go i0 op0+              where+                go !i !op+                  | i < iendTmp = case A.unsafeIndex arr i of+                      w | w <= 0x7F -> do+                            BP.runB be (fromIntegral w) op >>= go (i + 1)+                        | w <= 0x7FF -> do+                            poke8 0 $ (w `shiftR` 6) + 0xC0+                            poke8 1 $ (w .&. 0x3f) + 0x80+                            go (i + 1) (op `plusPtr` 2)+                        | 0xD800 <= w && w <= 0xDBFF -> do+                            let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1))+                            poke8 0 $ (c `shiftR` 18) + 0xF0+                            poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80+                            poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80+                            poke8 3 $ (c .&. 0x3F) + 0x80+                            go (i + 2) (op `plusPtr` 4)+                        | otherwise -> do+                            poke8 0 $ (w `shiftR` 12) + 0xE0+                            poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80+                            poke8 2 $ (w .&. 0x3F) + 0x80+                            go (i + 1) (op `plusPtr` 3)+                  | otherwise =+                      outerLoop i (B.BufferRange op ope)+                  where+                    poke8 j v = poke (op `plusPtr` j) (fromIntegral v :: Word8)+#endif

@@ -0,0 +1,360 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+module Data.Aeson.Encoding.Internal+    (+    -- * Encoding+      Encoding' (..)+    , Encoding+    , encodingToLazyByteString+    , unsafeToEncoding+    , retagEncoding+    , Series (..)+    , pairs+    , 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+    , localTime+    , utcTime+    , timeOfDay+    , zonedTime+    -- ** value+    , value+    -- ** JSON tokens+    , comma, colon, openBracket, closeBracket, openCurly, closeCurly+    ) where++import Prelude ()+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.Semigroup (Semigroup ((<>)))+import Data.Text (Text)+import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime)+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 synonnym 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 = Value $ retagEncoding $ text 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++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

@@ -1,42 +0,0 @@--- |--- 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.Functions-    ( mapHashKeyVal-    , hashMapKey-    , mapKeyVal-    , mapKey-    ) where--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 a 'M.Map' into a 'H.HashMap' while transforming the keys.-hashMapKey :: (Ord k2) => (k1 -> k2)-           -> H.HashMap k1 v -> M.Map k2 v-hashMapKey kv = H.foldrWithKey (M.insert . kv) M.empty-{-# INLINE hashMapKey #-}---- | 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 #-}

@@ -22,5 +22,7 @@     , iparse     ) where -import Data.Aeson.Types.Instances (ifromJSON)+import Prelude ()+ import Data.Aeson.Types.Internal+import Data.Aeson.Types.FromJSON (ifromJSON)

@@ -0,0 +1,39 @@+-- |+-- 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 ()+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 #-}

@@ -17,6 +17,9 @@     , toTimeOfDay64     ) where +import Prelude ()+import Prelude.Compat+ import Data.Fixed (Pico) import Data.Int (Int64) import Data.Time

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}  -- | -- Module:      Data.Aeson.Parser@@ -39,9 +39,16 @@     -- $strict     , json'     , value'+    -- * Decoding without FromJSON instances+    , decodeWith+    , decodeStrictWith+    , eitherDecodeWith+    , eitherDecodeStrictWith     ) where -import Data.Aeson.Parser.Internal (json, json', jstring, value, value')+import Prelude ()++import Data.Aeson.Parser.Internal (decodeStrictWith, decodeWith, eitherDecodeStrictWith, eitherDecodeWith, json, json', jstring, value, value')  -- $lazy --

@@ -1,4 +1,6 @@-{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} #if MIN_VERSION_ghc_prim(0,3,1) {-# LANGUAGE MagicHash #-} #endif@@ -31,10 +33,12 @@     , eitherDecodeStrictWith     ) where +import Prelude ()+import Prelude.Compat+ import Control.Monad.IO.Class (liftIO) import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))-import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,-                                         skipSpace, string)+import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific, skipSpace, string) import Data.Bits ((.|.), shiftL) import Data.ByteString.Internal (ByteString(..)) import Data.Char (chr)@@ -45,8 +49,8 @@ import Data.Vector as Vector (Vector, empty, fromList, reverse) import Data.Word (Word8) import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (Ptr, plusPtr)-import Foreign.Ptr (minusPtr)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.Ptr (Ptr, minusPtr, plusPtr) import Foreign.Storable (poke) import System.IO.Unsafe (unsafePerformIO) import qualified Data.Attoparsec.ByteString as A@@ -58,10 +62,6 @@ import qualified Data.ByteString.Unsafe as B import qualified Data.HashMap.Strict as H -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((*>), (<$>), (<*), pure)-#endif- #if MIN_VERSION_ghc_prim(0,3,1) import GHC.Base (Int#, (==#), isTrue#, orI#, word2Int#) import GHC.Word (Word8(W8#))@@ -263,7 +263,7 @@         let newlen = p `minusPtr` ptr             slop = len - newlen         Right <$> if slop >= 128 && slop >= len `quot` 4-                  then B.create newlen $ \np -> B.memcpy np ptr newlen+                  then B.create newlen $ \np -> copyBytes np ptr newlen                   else return (PS fp 0 newlen)  where   go ptr = do@@ -382,7 +382,7 @@ copy :: ByteString -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8) copy (PS fp off len) ptr =   liftIO . withForeignPtr fp $ \src -> do-    B.memcpy ptr (src `plusPtr` off) len+    copyBytes ptr (src `plusPtr` off) len     return $! ptr `plusPtr` len  charUtf8 :: Char -> Ptr Word8 -> Z.ZeptoT IO (Ptr Word8)

@@ -1,4 +1,5 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | -- Module:      Data.Aeson.Parser.Time@@ -21,7 +22,10 @@     , zonedTime     ) where -import Control.Monad (when, void)+import Prelude ()+import Prelude.Compat++import Control.Monad (void, when) import Data.Aeson.Internal.Time (toPico) import Data.Attoparsec.Text as A import Data.Bits ((.&.))@@ -35,10 +39,6 @@ import qualified Data.Aeson.Types.Internal as Aeson import qualified Data.Text as T import qualified Data.Time.LocalTime as Local--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>), (<*), (*>))-#endif  -- | Run an attoparsec parser as an aeson parser. run :: Parser a -> Text -> Aeson.Parser a

@@ -1,1512 +1,2441 @@-{-# LANGUAGE CPP, FlexibleInstances, NamedFieldPuns,-    NoImplicitPrelude, 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 "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--    , deriveToJSON-    , deriveFromJSON--    , mkToJSON-    , mkToEncoding-    , mkParseJSON-    ) where--import Control.Applicative ( pure, (<$>), (<*>) )-import Data.Aeson ( toJSON, Object, (.=), (.:), (.:?)-                  , ToJSON, toEncoding, toJSON-                  , FromJSON, parseJSON-                  )-import Data.Aeson.Types ( Value(..), Parser-                        , Options(..)-                        , SumEncoding(..)-                        , defaultOptions-                        , defaultTaggedObject-                        )-import Data.Aeson.Types.Internal (Encoding(..))-import Control.Monad       ( liftM2, return, mapM, fail )-import Data.Bool           ( Bool(False, True), otherwise, (&&), not )-import Data.Either         ( Either(Left, Right) )-import Data.Eq             ( (==) )-import Data.Function       ( ($), (.), flip )-import Data.Functor        ( fmap )-import Data.Int            ( Int )-import Data.List           ( (++), all, any, find, foldl, foldl'-                           , genericLength , intercalate , intersperse, length, map-                           , partition, zip-                           )-import Data.Map            ( Map )-import Data.Maybe          ( Maybe(Nothing, Just), catMaybes )-import Data.Monoid         ( (<>), mconcat )-import Language.Haskell.TH-import Language.Haskell.TH.Syntax ( VarStrictType )-import Prelude             ( String, (-), Integer, error, foldr1, fromIntegral-                           , splitAt, zipWith-                           )-#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))-import Data.Foldable              ( foldr' )-import qualified Data.Map as M    ( singleton )-import Data.List                  ( nub )-import Language.Haskell.TH.Syntax ( mkNameG_tc )-import Prelude                    ( concatMap, uncurry )-#endif-#if MIN_VERSION_template_haskell(2,11,0)-import Prelude             ( head )-#endif-import Text.Printf         ( printf )-import Text.Show           ( show )-import qualified Data.Aeson as A-import qualified Data.Aeson.Encode.Builder as E-import qualified Data.Aeson.Encode.Functions as E-import qualified Data.HashMap.Strict as H ( lookup, toList )-import qualified Data.Map as M ( fromList, findWithDefault )-import qualified Data.Text as T ( Text, pack, unpack )-import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList )-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 opts name =-    liftM2 (++)-           (deriveToJSON   opts name)-           (deriveFromJSON opts name)-------------------------------------------------------------------------------------- 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 opts name =-    withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys-  where-    fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec-    fromCons name' tvbs cons mbTys = do-        (instanceCxt, instanceType) <- buildTypeInstance name' ''ToJSON tvbs mbTys-        instanceD (return instanceCxt)-                  (return instanceType)-                  [ funD 'toJSON-                         [ clause []-                                  (normalB $ consToValue opts cons)-                                  []-                         ]-                  , funD 'toEncoding-                         [ clause []-                                  (normalB $ consToEncoding opts cons)-                                  []-                         ]-                  ]---- | 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 opts name = withType name (\_ _ cons _ -> consToValue opts cons)---- | 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 opts name = withType name (\_ _ cons _ -> consToEncoding opts cons)---- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates--- code to generate a 'Value' of a number of constructors. All constructors--- must be from the same type.-consToValue :: Options-           -- ^ Encoding options.-           -> [Con]-           -- ^ Constructors for which to generate JSON generating code.-           -> Q Exp--consToValue _ [] = error $ "Data.Aeson.TH.consToValue: "-                          ++ "Not a single constructor given!"---- A single constructor is directly encoded. The constructor itself may be--- forgotten.-consToValue opts [con] = do-    value <- newName "value"-    lam1E (varP value) $ caseE (varE value) [argsToValue opts False con]--consToValue opts cons = do-    value <- newName "value"-    lam1E (varP value) $ caseE (varE value) matches-  where-    matches-        | allNullaryToStringTag opts && all isNullary cons =-              [ match (conP conName []) (normalB $ conStr opts conName) []-              | con <- cons-              , let conName = getConName con-              ]-        | otherwise = [argsToValue opts True con | con <- cons]--conStr :: Options -> Name -> Q Exp-conStr opts = appE [|String|] . conTxt opts--conTxt :: Options -> Name -> Q Exp-conTxt opts = appE [|T.pack|] . conStringE opts--conStringE :: Options -> Name -> Q Exp-conStringE opts = stringE . constructorTagModifier opts . nameBase---- | Helper function used by both 'deriveToJSON' and 'mkToEncoding'. Generates--- code to write out a value for a number of constructors. All constructors--- must be from the same type.-consToEncoding :: Options-                  -- ^ Encoding options.-               -> [Con]-               -- ^ Constructors for which to generate JSON generating code.-               -> Q Exp--consToEncoding _ [] = error $ "Data.Aeson.TH.consToEncoding: "-                      ++ "Not a single constructor given!"---- A single constructor is directly encoded. The constructor itself may be--- forgotten.-consToEncoding opts [con] = do-    value <- newName "value"-    lam1E (varP value) $ caseE (varE value) [argsToEncoding opts False con]---- Encode just the name of the constructor of a sum type iff all the--- constructors are nullary.-consToEncoding opts cons = do-    value <- newName "value"-    lam1E (varP value) $ caseE (varE value) matches-  where-    matches-        | allNullaryToStringTag opts && all isNullary cons =-              [ match (conP conName [])-                (normalB $ [|Encoding|] `appE` encStr opts conName) []-              | con <- cons-              , let conName = getConName con-              ]-        | otherwise = [argsToEncoding opts True con | con <- cons]--encStr :: Options -> Name -> Q Exp-encStr opts = appE [|E.text|] . conTxt opts---- | If constructor is nullary.-isNullary :: Con -> Bool-isNullary (NormalC _ []) = True-isNullary _ = False--sumToValue :: Options -> Bool -> Name -> Q Exp -> Q Exp-sumToValue opts multiCons conName exp-    | multiCons =-        case sumEncoding opts of-          TwoElemArray ->-              [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])-          TaggedObject{tagFieldName, contentsFieldName} ->-              [|A.object|] `appE` listE-                [ infixApp [|T.pack tagFieldName|]     [|(.=)|] (conStr opts conName)-                , infixApp [|T.pack contentsFieldName|] [|(.=)|] exp-                ]-          ObjectWithSingleField ->-              [|A.object|] `appE` listE-                [ infixApp (conTxt opts conName) [|(.=)|] exp-                ]--    | otherwise = exp---- | Generates code to generate the JSON encoding of a single constructor.-argsToValue :: Options -> Bool -> Con -> Q Match--- Nullary constructors. Generates code that explicitly matches against the--- constructor even though it doesn't contain data. This is useful to prevent--- type errors.-argsToValue  opts multiCons (NormalC conName []) =-    match (conP conName [])-          (normalB (sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]))-          []---- Polyadic constructors with special case for unary constructors.-argsToValue opts multiCons (NormalC conName ts) = do-    let len = length ts-    args <- mapM newName ["arg" ++ show n | n <- [1..len]]-    js <- case [[|toJSON|] `appE` varE arg | arg <- args] of-            -- Single argument is directly converted.-            [e] -> return e-            -- Multiple arguments are converted to a JSON array.-            es  -> do-              mv <- newName "mv"-              let newMV = bindS (varP mv)-                                ([|VM.unsafeNew|] `appE`-                                  litE (integerL $ fromIntegral len))-                  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-              return $ [|Array|] `appE`-                         (varE 'V.create `appE`-                           doE (newMV:stmts++[ret]))-    match (conP conName $ map varP args)-          (normalB $ sumToValue opts multiCons conName js)-          []---- Records.-argsToValue opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of-  (True,True,[(_,st,ty)]) -> argsToValue opts multiCons (NormalC conName [(st,ty)])-  _ -> do-    args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]-    let exp = [|A.object|] `appE` pairs--        pairs | omitNothingFields opts = infixApp maybeFields-                                                  [|(++)|]-                                                  restFields-              | otherwise = listE $ map toPair argCons--        argCons = zip args ts--        maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)--        restFields = listE $ map toPair rest--        (maybes, rest) = partition isMaybe argCons--        maybeToPair (arg, (field, _, _)) =-            infixApp (infixE (Just $ toFieldName field)-                             [|(.=)|]-                             Nothing)-                     [|(<$>)|]-                     (varE arg)--        toPair (arg, (field, _, _)) =-            infixApp (toFieldName field)-                     [|(.=)|]-                     (varE arg)--        toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field--    match (conP conName $ map varP args)-          ( normalB-          $ if multiCons-            then case sumEncoding opts of-                   TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]-                   TaggedObject{tagFieldName} ->-                       [|A.object|] `appE`-                         -- TODO: Maybe throw an error in case-                         -- tagFieldName overwrites a field in pairs.-                         infixApp (infixApp [|T.pack tagFieldName|]-                                            [|(.=)|]-                                            (conStr opts conName))-                                  [|(:)|]-                                  pairs-                   ObjectWithSingleField ->-                       [|A.object|] `appE` listE-                         [ infixApp (conTxt opts conName) [|(.=)|] exp ]-            else exp-          ) []---- Infix constructors.-argsToValue opts multiCons (InfixC _ conName _) = do-    al <- newName "argL"-    ar <- newName "argR"-    match (infixP (varP al) conName (varP ar))-          ( normalB-          $ sumToValue opts multiCons conName-          $ [|toJSON|] `appE` listE [ [|toJSON|] `appE` varE a-                                    | a <- [al,ar]-                                    ]-          )-          []--- Existentially quantified constructors.-argsToValue opts multiCons (ForallC _ _ con) =-    argsToValue opts multiCons con--#if MIN_VERSION_template_haskell(2,11,0)--- GADTs.-argsToValue opts multiCons (GadtC conNames ts _) =-    argsToValue opts multiCons $ NormalC (head conNames) ts--argsToValue opts multiCons (RecGadtC conNames ts _) =-    argsToValue opts multiCons $ RecC (head conNames) ts-#endif--isMaybe :: (a, (b, c, Type)) -> Bool-isMaybe (_, (_, _, AppT (ConT t) _)) = t == ''Maybe-isMaybe _                            = False--(<^>) :: ExpQ -> ExpQ -> ExpQ-(<^>) a b = infixApp a [|(<>)|] b-infixr 6 <^>--(<:>) :: ExpQ -> ExpQ -> ExpQ-(<:>) a b = a <^> [|E.char7 ':'|] <^> b-infixr 5 <:>--(<%>) :: ExpQ -> ExpQ -> ExpQ-(<%>) a b = a <^> [|E.char7 ','|] <^> b-infixr 4 <%>--array :: ExpQ -> ExpQ-array exp = [|Encoding|] `appE` ([|E.char7 '['|] <^> exp <^> [|E.char7 ']'|])--object :: ExpQ -> ExpQ-object exp = [|Encoding|] `appE` ([|E.char7 '{'|] <^> exp <^> [|E.char7 '}'|])--sumToEncoding :: Options -> Bool -> Name -> Q Exp -> Q Exp-sumToEncoding opts multiCons conName exp-    | multiCons =-        let fexp = [|fromEncoding|] `appE` exp in-        case sumEncoding opts of-          TwoElemArray ->-            array (encStr opts conName <%> fexp)-          TaggedObject{tagFieldName, contentsFieldName} ->-            object $-            ([|E.text (T.pack tagFieldName)|] <:> encStr opts conName) <%>-            ([|E.text (T.pack contentsFieldName)|] <:> fexp)-          ObjectWithSingleField ->-            object (encStr opts conName <:> fexp)--    | otherwise = exp---- | Generates code to generate the JSON encoding of a single constructor.-argsToEncoding :: Options -> Bool -> Con -> Q Match--- Nullary constructors. Generates code that explicitly matches against the--- constructor even though it doesn't contain data. This is useful to prevent--- type errors.-argsToEncoding  opts multiCons (NormalC conName []) =-    match (conP conName [])-          (normalB (sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]))-          []---- Polyadic constructors with special case for unary constructors.-argsToEncoding opts multiCons (NormalC conName ts) = do-    let len = length ts-    args <- mapM newName ["arg" ++ show n | n <- [1..len]]-    js <- case args of-            -- Single argument is directly converted.-            [e] -> return ([|toEncoding|] `appE` varE e)-            -- Multiple arguments are converted to a JSON array.-            es  ->-              return (array (foldr1 (<%>) [[|E.builder|] `appE` varE x | x <- es]))-    match (conP conName $ map varP args)-          (normalB $ sumToEncoding opts multiCons conName js)-          []---- Records.-argsToEncoding opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of-  (True,True,[(_,st,ty)]) -> argsToEncoding opts multiCons (NormalC conName [(st,ty)])-  _ -> do-    args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]--    let exp = object objBody--        objBody = [|mconcat|] `appE`-                  ([|intersperse (E.char7 ',')|] `appE` pairs)-        pairs | omitNothingFields opts = infixApp maybeFields-                                                  [|(<>)|]-                                                  restFields-              | otherwise = listE (map toPair argCons)--        argCons = zip args ts--        maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)--        restFields = listE (map toPair rest)--        (maybes, rest) = partition isMaybe argCons--        maybeToPair (arg, (field, _, _)) =-            infixApp-              (infixApp-                (infixE-                  (Just $ toFieldName field <^> [|E.char7 ':'|])-                  [|(<>)|]-                  Nothing)-                [|(.)|]-                [|E.builder|])-              [|(<$>)|]-              (varE arg)--        toPair (arg, (field, _, _)) =-          toFieldName field <:> [|E.builder|] `appE` varE arg--        toFieldName field = [|E.text|] `appE`-                            ([|T.pack|] `appE` fieldLabelExp opts field)--    match (conP conName $ map varP args)-          ( normalB-          $ if multiCons-            then case sumEncoding opts of-                   TwoElemArray -> array $-                     encStr opts conName <%> [|fromEncoding|] `appE` exp-                   TaggedObject{tagFieldName} -> object $-                     ([|E.text (T.pack tagFieldName)|] <:>-                      encStr opts conName) <%>-                     objBody-                   ObjectWithSingleField -> object $-                     encStr opts conName <:> [|fromEncoding|] `appE` exp-            else exp-          ) []---- Infix constructors.-argsToEncoding opts multiCons (InfixC _ conName _) = do-    al <- newName "argL"-    ar <- newName "argR"-    match (infixP (varP al) conName (varP ar))-          ( normalB-          $ sumToEncoding opts multiCons conName-          $ [|toEncoding|] `appE` listE [ [|toJSON|] `appE` varE a-                                        | a <- [al,ar]-                                        ]-          )-          []--- Existentially quantified constructors.-argsToEncoding opts multiCons (ForallC _ _ con) =-    argsToEncoding opts multiCons con--#if MIN_VERSION_template_haskell(2,11,0)--- GADTs.-argsToEncoding opts multiCons (GadtC conNames ts _) =-    argsToEncoding opts multiCons $ NormalC (head conNames) ts--argsToEncoding opts multiCons (RecGadtC conNames ts _) =-    argsToEncoding opts multiCons $ RecC (head conNames) ts-#endif------------------------------------------------------------------------------------- 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 opts name =-    withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys-  where-    fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec-    fromCons name' tvbs cons mbTys = do-        (instanceCxt, instanceType) <- buildTypeInstance name' ''FromJSON tvbs mbTys-        instanceD (return instanceCxt)-                  (return instanceType)-                  [ funD 'parseJSON-                         [ clause []-                                  (normalB $ consFromJSON name' opts cons)-                                  []-                         ]-                  ]---- | 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 opts name =-    withType name (\name' _ cons _ -> consFromJSON name' opts cons)---- | 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 :: Name-             -- ^ Name of the type to which the constructors belong.-             -> Options-             -- ^ Encoding options-             -> [Con]-             -- ^ Constructors for which to generate JSON parsing code.-             -> Q Exp--consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "-                              ++ "Not a single constructor given!"--consFromJSON tName opts [con] = do-  value <- newName "value"-  lam1E (varP value) (parseArgs tName opts con (Right value))--consFromJSON tName opts cons = do-  value <- newName "value"-  lam1E (varP value) $ caseE (varE value) $-    if allNullaryToStringTag opts && all isNullary cons-    then allNullaryMatches-    else mixedMatches--  where-    allNullaryMatches =-      [ do txt <- newName "txt"-           match (conP 'String [varP txt])-                 (guardedB $-                  [ liftM2 (,) (normalG $-                                  infixApp (varE txt)-                                           [|(==)|]-                                           ([|T.pack|] `appE`-                                              conStringE opts conName)-                               )-                               ([|pure|] `appE` conE conName)-                  | con <- cons-                  , let conName = getConName 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 =-        case sumEncoding opts of-          TaggedObject {tagFieldName, contentsFieldName} ->-            parseObject $ parseTaggedObject tagFieldName contentsFieldName-          ObjectWithSingleField ->-            parseObject $ parseObjectWithSingleField-          TwoElemArray ->-            [ do arr <- newName "array"-                 match (conP 'Array [varP arr])-                       (guardedB $-                        [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)-                                                         [|(==)|]-                                                         (litE $ integerL 2))-                                     (parse2ElemArray 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 typFieldName valFieldName obj = do-      conKey <- newName "conKey"-      doE [ bindS (varP conKey)-                  (infixApp (varE obj)-                            [|(.:)|]-                            ([|T.pack|] `appE` stringE typFieldName))-          , noBindS $ parseContents conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject-          ]--    parse2ElemArray 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 txt-                                                      (Right conVal)-                                                      'conNotFoundFail2ElemArray-                             )-                             []-                  , do other <- newName "other"-                       match (varP other)-                             ( normalB-                               $ [|firstElemNoStringFail|]-                                     `appE` (litE $ stringL $ show tName)-                                     `appE` ([|valueConName|] `appE` varE other)-                             )-                             []-                  ]-           )--    parseObjectWithSingleField obj = do-      conKey <- newName "conKey"-      conVal <- newName "conVal"-      caseE ([e|H.toList|] `appE` varE obj)-            [ match (listP [tupP [varP conKey, varP conVal]])-                    (normalB $ parseContents 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 conKey contents errorFun =-        caseE (varE conKey)-              [ match wildP-                      ( guardedB $-                        [ do g <- normalG $ infixApp (varE conKey)-                                                     [|(==)|]-                                                     ([|T.pack|] `appE`-                                                        conNameExp opts con)-                             e <- parseArgs 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-                                                     . getConName-                                                     ) 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 :: Name -> [Q Match]-parseUnaryMatches conName =-    [ do arg <- newName "arg"-         match (varP arg)-               ( normalB $ infixApp (conE conName)-                                    [|(<$>)|]-                                    ([|parseJSON|] `appE` varE arg)-               )-               []-    ]--parseRecord :: Options -> Name -> Name -> [VarStrictType] -> Name -> ExpQ-parseRecord opts tName conName ts obj =-    foldl' (\a b -> infixApp a [|(<*>)|] b)-           (infixApp (conE conName) [|(<$>)|] x)-           xs-    where-      x:xs = [ [|lookupField|]-               `appE` (litE $ stringL $ show tName)-               `appE` (litE $ stringL $ constructorTagModifier opts $ nameBase conName)-               `appE` (varE obj)-               `appE` ( [|T.pack|] `appE` fieldLabelExp opts field-                      )-             | (field, _, _) <- ts-             ]--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-      ]---- | Generates code to parse the JSON encoding of a single constructor.-parseArgs :: Name -- ^ Name of the type to which the constructor belongs.-          -> Options -- ^ Encoding options.-          -> Con -- ^ Constructor for which to generate JSON parsing code.-          -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or-                                        --   Right valName-          -> Q Exp--- Nullary constructors.-parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) =-  getValField obj valFieldName $ parseNullaryMatches tName conName-parseArgs tName _ (NormalC conName []) (Right valName) =-  caseE (varE valName) $ parseNullaryMatches tName conName---- Unary constructors.-parseArgs _ _ (NormalC conName [_]) (Left (valFieldName, obj)) =-  getValField obj valFieldName $ parseUnaryMatches conName-parseArgs _ _ (NormalC conName [_]) (Right valName) =-  caseE (varE valName) $ parseUnaryMatches conName---- Polyadic constructors.-parseArgs tName _ (NormalC conName ts) (Left (valFieldName, obj)) =-    getValField obj valFieldName $ parseProduct tName conName $ genericLength ts-parseArgs tName _ (NormalC conName ts) (Right valName) =-    caseE (varE valName) $ parseProduct tName conName $ genericLength ts---- Records.-parseArgs tName opts (RecC conName ts) (Left (_, obj)) =-    parseRecord opts tName conName ts obj-parseArgs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of-  (True,[(_,st,ty)])-> parseArgs tName opts (NormalC conName [(st,ty)]) (Right valName)-  _ -> do-    obj <- newName "recObj"-    caseE (varE valName)-      [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []-      , matchFailed tName conName "Object"-      ]---- Infix constructors. Apart from syntax these are the same as--- polyadic constructors.-parseArgs tName _ (InfixC _ conName _) (Left (valFieldName, obj)) =-    getValField obj valFieldName $ parseProduct tName conName 2-parseArgs tName _ (InfixC _ conName _) (Right valName) =-    caseE (varE valName) $ parseProduct tName conName 2---- Existentially quantified constructors. We ignore the quantifiers--- and proceed with the contained constructor.-parseArgs tName opts (ForallC _ _ con) contents =-    parseArgs tName opts con contents--#if MIN_VERSION_template_haskell(2,11,0)--- GADTs. We ignore the refined return type and proceed as if it were a--- NormalC or RecC.-parseArgs tName opts (GadtC conNames ts _) contents =-    parseArgs tName opts (NormalC (head conNames) ts) contents--parseArgs tName opts (RecGadtC conNames ts _) contents =-    parseArgs tName opts (RecC (head conNames) ts) contents-#endif---- | Generates code to parse the JSON encoding of an n-ary--- constructor.-parseProduct :: Name -- ^ Name of the type to which the constructor belongs.-             -> Name -- ^ 'Con'structor name.-             -> Integer -- ^ 'Con'structor arity.-             -> [Q Match]-parseProduct tName conName numArgs =-    [ do arr <- newName "arr"-         -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"-         let x:xs = [ [|parseJSON|]-                      `appE`-                      infixApp (varE arr)-                               [|V.unsafeIndex|]-                               (litE $ integerL ix)-                    | ix <- [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 (FromJSON a) => LookupField a where-    lookupField :: String -> String -> Object -> T.Text -> Parser a--instance OVERLAPPABLE_ (FromJSON a) => LookupField a where-    lookupField tName rec obj key =-        case H.lookup key obj of-          Nothing -> unknownFieldFail tName rec (T.unpack key)-          Just v  -> parseJSON v--instance (FromJSON a) => LookupField (Maybe a) where-    lookupField _ _ = (.:?)--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-------------------------------------------------------------------------------------- Utility functions------------------------------------------------------------------------------------- | Boilerplate for top level splices.------ The given 'Name' must meet one of two criteria:------ 1. It must be the name of a type constructor of a plain data type or newtype.--- 2. It must be the name of a data family instance or newtype instance constructor.---- Any other value will result in an exception.-withType :: Name-         -> (Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)-         -- ^ Function that generates the actual code. Will be applied-         -- to the datatype/data family 'Name', type variable binders and-         -- constructors extracted from the given 'Name'. If the 'Name' is-         -- from a data family instance constructor, it will also have its-         -- instantiated types; otherwise, it will be 'Nothing'.-         -> Q a-         -- ^ Resulting value in the 'Q'uasi monad.-withType name f = do-    info <- reify name-    case info of-      TyConI dec ->-        case dec of-#if MIN_VERSION_template_haskell(2,11,0)-          DataD    _ _ tvbs _ cons _ -> f name tvbs cons Nothing-          NewtypeD _ _ tvbs _ con  _ -> f name tvbs [con] Nothing-#else-          DataD    _ _ tvbs   cons _ -> f name tvbs cons Nothing-          NewtypeD _ _ tvbs   con  _ -> f name tvbs [con] Nothing-#endif-          other -> error $ ns ++ "Unsupported type: " ++ show other-#if MIN_VERSION_template_haskell(2,11,0)-      DataConI _ _ parentName   -> do-#else-      DataConI _ _ parentName _ -> do-#endif-        parentInfo <- reify parentName-        case parentInfo of-#if MIN_VERSION_template_haskell(2,11,0)-          FamilyI (DataFamilyD _ tvbs _) decs ->-#else-          FamilyI (FamilyD DataFam _ tvbs _) decs ->-#endif-            let instDec = flip find decs $ \dec -> case dec of-#if MIN_VERSION_template_haskell(2,11,0)-                  DataInstD    _ _ _ _ cons _ -> any ((name ==) . getConName) cons-                  NewtypeInstD _ _ _ _ con  _ -> name == getConName con-#else-                  DataInstD    _ _ _   cons _ -> any ((name ==) . getConName) cons-                  NewtypeInstD _ _ _   con  _ -> name == getConName con-#endif-                  _ -> error $ ns ++ "Must be a data or newtype instance."-             in case instDec of-#if MIN_VERSION_template_haskell(2,11,0)-                  Just (DataInstD    _ _ instTys _ cons _) -> f parentName tvbs cons $ Just instTys-                  Just (NewtypeInstD _ _ instTys _ con  _) -> f parentName tvbs [con] $ Just instTys-#else-                  Just (DataInstD    _ _ instTys   cons _) -> f parentName tvbs cons $ Just instTys-                  Just (NewtypeInstD _ _ instTys   con  _) -> f parentName tvbs [con] $ Just instTys-#endif-                  _ -> error $ ns ++-                    "Could not find data or newtype instance constructor."-          _ -> error $ ns ++ "Data constructor " ++ show name ++-            " is not from a data family instance constructor."-#if MIN_VERSION_template_haskell(2,11,0)-      FamilyI DataFamilyD{} _ ->-#else-      FamilyI (FamilyD DataFam _ _ _) _ ->-#endif-        error $ ns ++-          "Cannot use a data family name. Use a data family instance constructor instead."-      _ -> error $ ns ++ "I need the name of a plain data type constructor, "-                      ++ "or a data family instance constructor."-  where-    ns :: String-    ns = "Data.Aeson.TH.withType: "---- | Infer the context and instance head needed for a FromJSON or ToJSON instance.-buildTypeInstance :: Name-                  -- ^ The type constructor or data family name-                  -> Name-                  -- ^ The typeclass name ('ToJSON' or 'FromJSON')-                  -> [TyVarBndr]-                  -- ^ The type variables from the data type/data family declaration-                  -> Maybe [Type]-                  -- ^ 'Just' the types used to instantiate a data family instance,-                  -- or 'Nothing' if it's a plain data type-                  -> Q (Cxt, Type)-                  -- ^ The resulting 'Cxt' and 'Type' to use in a class instance--- Plain data type/newtype case-buildTypeInstance tyConName constraint tvbs Nothing =-    let varTys :: [Type]-        varTys = map tvbToType tvbs-    in buildTypeInstanceFromTys tyConName constraint varTys False--- Data family instance case------ The CPP is present to work around a couple of annoying old GHC bugs.--- See Note [Polykinded data families in Template Haskell]-buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) = do-#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)-    let instTys :: [Type]-        instTys = zipWith stealKindForType tvbs instTysAndKinds-#else-    let kindVarNames :: [Name]-        kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs--        -- Gets all of the type/kind variable names mentioned somewhere in a Type.-        tyVarNamesOfType :: Type -> [Name]-        tyVarNamesOfType = go-          where-            go :: Type -> [Name]-            go (AppT t1 t2) = go t1 ++ go t2-            go (SigT t k)   = go t  ++ go k-            go (VarT n)     = [n]-            go _            = []--        numKindVars :: Int-        numKindVars = length kindVarNames--        givenKinds, givenKinds' :: [Kind]-        givenTys                :: [Type]-        (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds-        givenKinds' = map sanitizeStars givenKinds--        -- A GHC 7.6-specific bug requires us to replace all occurrences of-        -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.-        -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.-        sanitizeStars :: Kind -> Kind-        sanitizeStars = go-          where-            go :: Kind -> Kind-            go (AppT t1 t2)                 = AppT (go t1) (go t2)-            go (SigT t k)                   = SigT (go t) (go k)-            go (ConT n) | n == starKindName = StarT-            go t                            = t--            -- It's quite awkward to import * from GHC.Prim, so we'll just-            -- hack our way around it.-            starKindName :: Name-            starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"--        -- Generate a list of fresh names with a common prefix, and numbered suffixes.-        newNameList :: String -> Int -> Q [Name]-        newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]--    -- If we run this code with GHC 7.8, we might have to generate extra type-    -- variables to compensate for any type variables that Template Haskell-    -- eta-reduced away.-    -- See Note [Polykinded data families in Template Haskell]-    xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)--    let xTys   :: [Type]-        xTys = map VarT xTypeNames-        -- ^ Because these type variables were eta-reduced away, we can only-        --   determine their kind by using stealKindForType. Therefore, we mark-        --   them as VarT to ensure they will be given an explicit kind annotation-        --   (and so the kind inference machinery has the right information).--        substNameWithKind :: Name -> Kind -> Type -> Type-        substNameWithKind n k = substType (M.singleton n k)--        substNamesWithKinds :: [(Name, Kind)] -> Type -> Type-        substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks--        -- The types from the data family instance might not have explicit kind-        -- annotations, which the kind machinery needs to work correctly. To-        -- compensate, we use stealKindForType to explicitly annotate any-        -- types without kind annotations.-        instTys :: [Type]-        instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))-                  -- Note that due to a GHC 7.8-specific bug-                  -- (see Note [Polykinded data families in Template Haskell]),-                  -- there may be more kind variable names than there are kinds-                  -- to substitute. But this is OK! If a kind is eta-reduced, it-                  -- means that is was not instantiated to something more specific,-                  -- so we need not substitute it. Using stealKindForType will-                  -- grab the correct kind.-                $ zipWith stealKindForType tvbs (givenTys ++ xTys)-#endif-    buildTypeInstanceFromTys dataFamName constraint instTys True---- For the given Types, generate an instance context and head.-buildTypeInstanceFromTys :: Name-                         -- ^ The type constructor or data family name-                         -> Name-                         -- ^ The typeclass name ('ToJSON' or 'FromJSON')-                         -> [Type]-                         -- ^ The types to instantiate the instance with-                         -> Bool-                         -- ^ True if it's a data family, False otherwise-                         -> Q (Cxt, Type)-buildTypeInstanceFromTys tyConName constraint varTysOrig isDataFamily = do-    -- Make sure to expand through type/kind synonyms! Otherwise, we won't-    -- be able to infer constraints as accurately.-    varTysExp <- mapM expandSyn varTysOrig--    let preds    :: [Maybe Pred]-        -- Derive instance constraints for type variables of kind *-        preds = map (deriveConstraint constraint) varTysExp--        varTys :: [Type]-        -- See Note [Kind signatures in derived instances] for an explanation-        -- of the isDataFamily check.-        varTys =-          if isDataFamily-             then varTysOrig-             else map unSigT varTysOrig--        instanceCxt :: Cxt-        instanceCxt = catMaybes preds--        instanceType :: Type-        instanceType = AppT (ConT constraint)-                     $ applyTyCon tyConName varTys--    return (instanceCxt, instanceType)---- | Attempt to derive a constraint on a Type. If it's of kind *,--- we give it Just a ToJSON/FromJSON constraint. Otherwise, return Nothing.-deriveConstraint :: Name -> Type -> Maybe Pred-deriveConstraint constraint t-  | isTyVar t && hasKindStar t = Just $ applyCon constraint $ varTToName t-  | otherwise                  = Nothing--{--Note [Polykinded data families in Template Haskell]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In order to come up with the correct instance context and head for an instance, e.g.,--  instance C a => C (Data a) where ...--We need to know the exact types and kinds used to instantiate the instance. For-plain old datatypes, this is simple: every type must be a type variable, and-Template Haskell reliably tells us the type variables and their kinds.--Doing the same for data families proves to be much harder for three reasons:--1. On any version of Template Haskell, it may not tell you what an instantiated-   type's kind is. For instance, in the following data family instance:--     data family Fam (f :: * -> *) (a :: *)-     data instance Fam f a--   Then if we use TH's reify function, it would tell us the TyVarBndrs of the-   data family declaration are:--     [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]--   and the instantiated types of the data family instance are:--     [VarT f1,VarT a1]--   We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we-   have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the-   kind is in case an instantiated type isn't a SigT, so we use the stealKindForType-   function to ensure all of the instantiated types are SigTs before passing them-   to buildTypeInstanceFromTys.-2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of-   the specified kinds of a data family instance efore any of the instantiated-   types. Fortunately, this is easy to deal with: you simply count the number of-   distinct kind variables in the data family declaration, take that many elements-   from the front of the  Types list of the data family instance, substitute the-   kind variables with their respective instantiated kinds (which you took earlier),-   and proceed as normal.-3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template-   Haskell might not even list all of the Types of a data family instance, since-   they are eta-reduced away! And yes, kinds can be eta-reduced too.--   The simplest workaround is to count how many instantiated types are missing from-   the list and generate extra type variables to use in their place. Luckily, we-   needn't worry much if its kind was eta-reduced away, since using stealKindForType-   will get it back.--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.--}---- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.-stealKindForType :: TyVarBndr -> Type -> Type-stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)-stealKindForType _   t        = t---- | Extracts the kind from a type variable binder.-tvbKind :: TyVarBndr -> Kind-#if MIN_VERSION_template_haskell(2,8,0)-tvbKind (PlainTV  _  ) = StarT-#else-tvbKind (PlainTV  _  ) = StarK-#endif-tvbKind (KindedTV _ k) = k--tvbToType :: TyVarBndr -> Type-tvbToType (PlainTV n)    = VarT n-tvbToType (KindedTV n k) = SigT (VarT n) k---- | Returns True if a Type has kind *.-hasKindStar :: Type -> Bool-hasKindStar VarT{}         = True-#if MIN_VERSION_template_haskell(2,8,0)-hasKindStar (SigT _ StarT) = True-#else-hasKindStar (SigT _ StarK) = True-#endif-hasKindStar _              = False---- | Extract the Name from a type variable. If the argument Type is not a--- type variable, throw an error.-varTToName :: Type -> Name-varTToName (VarT n)   = n-varTToName (SigT t _) = varTToName t-varTToName _          = error "Not a type variable!"---- | Extracts the name from a constructor.-getConName :: Con -> Name-getConName (NormalC name _)  = name-getConName (RecC name _)     = name-getConName (InfixC _ name _) = name-getConName (ForallC _ _ con) = getConName con-#if MIN_VERSION_template_haskell(2,11,0)-getConName (GadtC    names _ _) = head names-getConName (RecGadtC names _ _) = head names-#endif---- | 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---- | Peel off a kind signature from a Type (if it has one).-unSigT :: Type -> Type-unSigT (SigT t _) = t-unSigT t          = t---- | Makes a string literal expression from a constructor's name.-conNameExp :: Options -> Con -> Q Exp-conNameExp opts = litE-                . stringL-                . constructorTagModifier opts-                . nameBase-                . getConName---- | Creates a string literal expression from a record field label.-fieldLabelExp :: Options -- ^ Encoding options-              -> Name-              -> Q Exp-fieldLabelExp opts = litE . stringL . 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------------------------------------------------------------------------------------ Expanding type synonyms------------------------------------------------------------------------------------ | Expands all type synonyms in a type. Written by Dan Rosén in the--- @genifunctors@ package (licensed under BSD3).-expandSyn :: Type -> Q Type-expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t-expandSyn t@AppT{}            = expandSynApp t []-expandSyn t@ConT{}            = expandSynApp t []-expandSyn (SigT t k)          = do t' <- expandSyn t-                                   k' <- expandSynKind k-                                   return (SigT t' k')-expandSyn t                   = return t--expandSynKind :: Kind -> Q Kind-#if MIN_VERSION_template_haskell(2,8,0)-expandSynKind = expandSyn-#else-expandSynKind = return -- There are no kind synonyms to deal with-#endif--expandSynApp :: Type -> [Type] -> Q Type-expandSynApp (AppT t1 t2) ts = do-    t2' <- expandSyn t2-    expandSynApp t1 (t2':ts)-expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts-expandSynApp t@(ConT n) ts = do-    info <- reify n-    case info of-        TyConI (TySynD _ tvs rhs) ->-            let (ts', ts'') = splitAt (length tvs) ts-                subs = mkSubst tvs ts'-                rhs' = substType subs rhs-             in expandSynApp rhs' ts''-        _ -> return $ foldl' AppT t ts-expandSynApp t ts = do-    t' <- expandSyn t-    return $ foldl' AppT t' ts--type TypeSubst = Map Name Type--mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst-mkSubst vs ts =-   let vs' = map un vs-       un (PlainTV v)    = v-       un (KindedTV v _) = v-   in M.fromList $ zip vs' ts--substType :: TypeSubst -> Type -> Type-substType subs (ForallT v c t) = ForallT v c $ substType subs t-substType subs t@(VarT n)      = M.findWithDefault t n subs-substType subs (AppT t1 t2)    = AppT (substType subs t1) (substType subs t2)-substType subs (SigT t k)      = SigT (substType subs t)-#if MIN_VERSION_template_haskell(2,8,0)-                                      (substType subs k)-#else-                                      k-#endif-substType _ t                  = t+{-# 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 "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 ()+import Prelude.Compat hiding (exp)++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 ((<?>), Pair, JSONPathElement(Key))+import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)+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 (find, foldl', genericLength , intercalate , intersperse, partition, union)+import Data.List.NonEmpty ((<|), NonEmpty((:|)))+import Data.Map (Map)+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)+import Data.Set (Set)+#if MIN_VERSION_template_haskell(2,8,0)+import Language.Haskell.TH hiding (Arity)+#else+import Language.Haskell.TH+#endif+import Language.Haskell.TH.Syntax (VarStrictType)+#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))+import Language.Haskell.TH.Lib (starK)+#endif+#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 as A+import qualified Data.Aeson.Encoding.Internal as E+import qualified Data.Foldable as F (all)+import qualified Data.HashMap.Strict as H (lookup, toList)+import qualified Data.List.NonEmpty as NE (drop, length, reverse, splitAt)+import qualified Data.Map as M (fromList, findWithDefault, keys, lookup , singleton, size)+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, fromList)+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    jc)+                                     , (ToEncoding, \jc _ -> consToEncoding 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 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 _ -> consToEncoding jc)++-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates+-- code to generate a 'Value' of a number of constructors. All constructors+-- must be from the same type.+consToValue :: JSONClass+            -- ^ The ToJSON variant being derived.+            -> Options+            -- ^ Encoding options.+            -> [Con]+            -- ^ Constructors for which to generate JSON generating code.+            -> Q Exp++consToValue _ _ [] = error $ "Data.Aeson.TH.consToValue: "+                            ++ "Not a single constructor given!"++consToValue jc opts cons = do+    value <- newName "value"+    tjs   <- newNameList "_tj"  $ arityInt jc+    tjls  <- newNameList "_tjl" $ arityInt jc+    let zippedTJs      = zip tjs tjls+        interleavedTJs = interleave tjs tjls+    lamE (map varP $ interleavedTJs ++ [value]) $+        caseE (varE value) (matches zippedTJs)+  where+    matches tjs = case cons of+      -- A single constructor is directly encoded. The constructor itself may be+      -- forgotten.+      [con] -> [argsToValue jc tjs opts False con]+      _ | allNullaryToStringTag opts && all isNullary cons ->+              [ match (conP conName []) (normalB $ conStr opts conName) []+              | con <- cons+              , let conName = getConName con+              ]+        | otherwise -> [argsToValue jc tjs opts True con | con <- cons]++conStr :: Options -> Name -> Q Exp+conStr opts = appE [|String|] . conTxt opts++conTxt :: Options -> Name -> Q Exp+conTxt opts = appE [|T.pack|] . conStringE opts++conStringE :: Options -> Name -> Q Exp+conStringE opts = stringE . constructorTagModifier opts . nameBase++-- | Helper function used by both 'deriveToJSON' and 'mkToEncoding'. Generates+-- code to write out a value for a number of constructors. All constructors+-- must be from the same type.+consToEncoding :: JSONClass+               -- ^ The ToJSON variant being derived.+               -> Options+               -- ^ Encoding options.+               -> [Con]+               -- ^ Constructors for which to generate JSON generating code.+               -> Q Exp++consToEncoding _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "+                        ++ "Not a single constructor given!"++consToEncoding jc opts cons = do+    value <- newName "value"+    tes   <- newNameList "_te"  $ arityInt jc+    tels  <- newNameList "_tel" $ arityInt jc+    let zippedTEs      = zip tes tels+        interleavedTEs = interleave tes tels+    lamE (map varP $ interleavedTEs ++ [value]) $+        caseE (varE value) (matches zippedTEs)+  where+    matches tes = case cons of+      -- A single constructor is directly encoded. The constructor itself may be+      -- forgotten.+      [con] -> [argsToEncoding jc tes opts False con]+      -- Encode just the name of the constructor of a sum type iff all the+      -- constructors are nullary.+      _ | allNullaryToStringTag opts && all isNullary cons ->+              [ match (conP conName [])+                (normalB $ encStr opts conName) []+              | con <- cons+              , let conName = getConName con+              ]+        | otherwise -> [argsToEncoding jc tes opts True con | con <- cons]++encStr :: Options -> Name -> Q Exp+encStr opts = appE [|E.text|] . conTxt opts++-- | If constructor is nullary.+isNullary :: Con -> Bool+isNullary (NormalC _ []) = True+isNullary _ = False++sumToValue :: Options -> Bool -> Name -> Q Exp -> Q Exp+sumToValue opts multiCons conName exp+    | multiCons =+        case sumEncoding opts of+          TwoElemArray ->+              [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])+          TaggedObject{tagFieldName, contentsFieldName} ->+              [|A.object|] `appE` listE+                [ infixApp [|T.pack tagFieldName|]     [|(.=)|] (conStr opts conName)+                , infixApp [|T.pack contentsFieldName|] [|(.=)|] exp+                ]+          ObjectWithSingleField ->+              [|A.object|] `appE` listE+                [ infixApp (conTxt opts conName) [|(.=)|] exp+                ]+          UntaggedValue -> exp+    | otherwise = exp++nullarySumToValue :: Options -> Bool -> Name -> Q Exp+nullarySumToValue opts multiCons conName =+    case sumEncoding opts of+      TaggedObject{tagFieldName} ->+          [|A.object|] `appE` listE+            [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)+            ]+      UntaggedValue -> conStr opts conName+      _ -> sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]++-- | Generates code to generate the JSON encoding of a single constructor.+argsToValue :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match+-- Nullary constructors. Generates code that explicitly matches against the+-- constructor even though it doesn't contain data. This is useful to prevent+-- type errors.+argsToValue jc tjs opts multiCons (NormalC conName []) = do+    ([], _) <- reifyConTys jc tjs conName+    match (conP conName [])+          (normalB (nullarySumToValue opts multiCons conName))+          []++-- Polyadic constructors with special case for unary constructors.+argsToValue jc tjs opts multiCons (NormalC conName ts) = do+    (argTys, tvMap) <- reifyConTys jc tjs conName+    let len = length ts+    args <- newNameList "arg" len+    js <- case [ dispatchToJSON jc conName tvMap argTy+                   `appE` varE arg+               | (arg, argTy) <- zip args argTys+               ] of+            -- Single argument is directly converted.+            [e] -> return e+            -- Multiple arguments are converted to a JSON array.+            es  -> do+              mv <- newName "mv"+              let newMV = bindS (varP mv)+                                ([|VM.unsafeNew|] `appE`+                                  litE (integerL $ fromIntegral len))+                  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+              return $ [|Array|] `appE`+                         (varE 'V.create `appE`+                           doE (newMV:stmts++[ret]))+    match (conP conName $ map varP args)+          (normalB $ sumToValue opts multiCons conName js)+          []++-- Records.+argsToValue jc tjs opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of+  (True,True,[(_,st,ty)]) -> argsToValue jc tjs opts multiCons (NormalC conName [(st,ty)])+  _ -> do+    (argTys, tvMap) <- reifyConTys jc tjs conName+    args <- newNameList "arg" $ length ts+    let exp = [|A.object|] `appE` pairs++        pairs | omitNothingFields opts = infixApp maybeFields+                                                  [|(++)|]+                                                  restFields+              | otherwise = listE $ map toPair argCons++        argCons = zip3 args argTys ts++        maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)++        restFields = listE $ map toPair rest++        (maybes, rest) = partition isMaybe argCons++        maybeToPair (arg, argTy, (field, _, _)) =+            infixApp ([|keyValuePairWith|]+                        `appE` dispatchToJSON jc conName tvMap argTy+                        `appE` toFieldName field)+                     [|(<$>)|]+                     (varE arg)++        toPair (arg, argTy, (field, _, _)) =+            [|keyValuePairWith|]+              `appE` dispatchToJSON jc conName tvMap argTy+              `appE` toFieldName field+              `appE` varE arg++        toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field++    match (conP conName $ map varP args)+          ( normalB+          $ if multiCons+            then case sumEncoding opts of+                   TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]+                   TaggedObject{tagFieldName} ->+                       [|A.object|] `appE`+                         -- TODO: Maybe throw an error in case+                         -- tagFieldName overwrites a field in pairs.+                         infixApp (infixApp [|T.pack tagFieldName|]+                                            [|(.=)|]+                                            (conStr opts conName))+                                  [|(:)|]+                                  pairs+                   ObjectWithSingleField ->+                       [|A.object|] `appE` listE+                         [ infixApp (conTxt opts conName) [|(.=)|] exp ]+                   UntaggedValue -> exp+            else exp+          ) []++-- Infix constructors.+argsToValue jc tjs opts multiCons (InfixC _ conName _) = do+    ([alTy, arTy], tvMap) <- reifyConTys jc tjs conName+    al <- newName "argL"+    ar <- newName "argR"+    match (infixP (varP al) conName (varP ar))+          ( normalB+          $ sumToValue opts multiCons conName+          $ [|toJSON|] `appE` listE [ dispatchToJSON jc conName tvMap aTy+                                        `appE` varE a+                                    | (a, aTy) <- [(al,alTy), (ar,arTy)]+                                    ]+          )+          []+-- Existentially quantified constructors.+argsToValue jc tjs opts multiCons (ForallC _ _ con) =+    argsToValue jc tjs opts multiCons con++#if MIN_VERSION_template_haskell(2,11,0)+-- GADTs.+argsToValue jc tjs opts multiCons (GadtC conNames ts _) =+    argsToValue jc tjs opts multiCons $ NormalC (head conNames) ts++argsToValue jc tjs opts multiCons (RecGadtC conNames ts _) =+    argsToValue jc tjs opts multiCons $ RecC (head conNames) ts+#endif++isMaybe :: (a, b, (c, d, Type)) -> Bool+isMaybe (_, _, (_, _, AppT (ConT t) _)) = t == ''Maybe+isMaybe _                               = False++(<^>) :: ExpQ -> ExpQ -> ExpQ+(<^>) a b = infixApp a [|(E.><)|] b+infixr 6 <^>++(<:>) :: ExpQ -> ExpQ -> ExpQ+(<:>) a b = a <^> [|E.colon|] <^> b+infixr 5 <:>++(<%>) :: ExpQ -> ExpQ -> ExpQ+(<%>) a b = a <^> [|E.comma|] <^> b+infixr 4 <%>++array :: ExpQ -> ExpQ+array exp = [|E.wrapArray|] `appE` exp++object :: ExpQ -> ExpQ+object exp = [|E.wrapObject|] `appE` exp++sumToEncoding :: Options -> Bool -> Name -> Q Exp -> Q Exp+sumToEncoding opts multiCons conName exp+    | multiCons =+        let fexp = exp in+        case sumEncoding opts of+          TwoElemArray ->+            array (encStr opts conName <%> fexp)+          TaggedObject{tagFieldName, contentsFieldName} ->+            object $+            ([|E.text (T.pack tagFieldName)|] <:> encStr opts conName) <%>+            ([|E.text (T.pack contentsFieldName)|] <:> fexp)+          ObjectWithSingleField ->+            object (encStr opts conName <:> fexp)+          UntaggedValue -> exp+    | otherwise = exp++nullarySumToEncoding :: Options -> Bool -> Name -> Q Exp+nullarySumToEncoding opts multiCons conName =+    case sumEncoding opts of+      TaggedObject{tagFieldName} ->+          object $+            [|E.text (T.pack tagFieldName)|] <:> encStr opts conName+      UntaggedValue -> encStr opts conName+      _ -> sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]++-- | Generates code to generate the JSON encoding of a single constructor.+argsToEncoding :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match+-- Nullary constructors. Generates code that explicitly matches against the+-- constructor even though it doesn't contain data. This is useful to prevent+-- type errors.+argsToEncoding jc tes opts multiCons (NormalC conName []) = do+    ([], _) <- reifyConTys jc tes conName+    match (conP conName [])+          (normalB (nullarySumToEncoding opts multiCons conName))+          []++-- Polyadic constructors with special case for unary constructors.+argsToEncoding jc tes opts multiCons (NormalC conName ts) = do+    (argTys, tvMap) <- reifyConTys jc tes conName+    let len = length ts+    args <- newNameList "arg" len+    js <- case zip args argTys of+            -- Single argument is directly converted.+            [(e,eTy)] -> return (dispatchToEncoding jc conName tvMap eTy+                                   `appE` varE e)+            -- Multiple arguments are converted to a JSON array.+            es  ->+              return (array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap xTy+                                              `appE` varE x+                                          | (x,xTy) <- es+                                          ]))+    match (conP conName $ map varP args)+          (normalB $ sumToEncoding opts multiCons conName js)+          []++-- Records.+argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of+  (True,True,[(_,st,ty)]) -> argsToEncoding jc tes opts multiCons (NormalC conName [(st,ty)])+  _ -> do+    args <- newNameList "arg" $ length ts+    (argTys, tvMap) <- reifyConTys jc tes conName+    let exp = object objBody++        objBody = [|E.econcat|] `appE`+                  ([|intersperse E.comma|] `appE` pairs)+        pairs | omitNothingFields opts = infixApp maybeFields+                                                  [|(++)|]+                                                  restFields+              | otherwise = listE (map toPair argCons)++        argCons = zip3 args argTys ts++        maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)++        restFields = listE (map toPair rest)++        (maybes, rest) = partition isMaybe argCons++        maybeToPair (arg, argTy, (field, _, _)) =+            infixApp+              (infixApp+                (infixE+                  (Just $ toFieldName field <^> [|E.colon|])+                  [|(E.><)|]+                  Nothing)+                [|(.)|]+                (dispatchToEncoding jc conName tvMap argTy))+              [|(<$>)|]+              (varE arg)++        toPair (arg, argTy, (field, _, _)) =+          toFieldName field+            <:> dispatchToEncoding jc conName tvMap argTy+                  `appE` varE arg++        toFieldName field = [|E.text|] `appE`+                            ([|T.pack|] `appE` fieldLabelExp opts field)++    match (conP conName $ map varP args)+          ( normalB+          $ if multiCons+            then case sumEncoding opts of+                   TwoElemArray -> array $+                     encStr opts conName <%>  exp+                   TaggedObject{tagFieldName} -> object $+                     ([|E.text (T.pack tagFieldName)|] <:>+                      encStr opts conName) <%>+                     objBody+                   ObjectWithSingleField -> object $+                     encStr opts conName <:> exp+                   UntaggedValue -> exp+            else exp+          ) []++-- Infix constructors.+argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do+    al <- newName "argL"+    ar <- newName "argR"+    ([alTy,arTy], tvMap) <- reifyConTys jc tes conName+    match (infixP (varP al) conName (varP ar))+          ( normalB+          $ sumToEncoding opts multiCons conName+          $ array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap aTy+                                    `appE` varE a+                                | (a,aTy) <- [(al,alTy), (ar,arTy)]+                                ])+          )+          []+-- Existentially quantified constructors.+argsToEncoding jc tes opts multiCons (ForallC _ _ con) =+    argsToEncoding jc tes opts multiCons con++#if MIN_VERSION_template_haskell(2,11,0)+-- GADTs.+argsToEncoding jc tes opts multiCons (GadtC conNames ts _) =+    argsToEncoding jc tes opts multiCons $ NormalC (head conNames) ts++argsToEncoding jc tes opts multiCons (RecGadtC conNames ts _) =+    argsToEncoding jc tes opts multiCons $ RecC (head conNames) ts+#endif++--------------------------------------------------------------------------------+-- 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+             -> [Con]+             -- ^ 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 cons = do+  value <- newName "value"+  pjs   <- newNameList "_pj"  $ arityInt jc+  pjls  <- newNameList "_pjl" $ arityInt jc+  let zippedPJs      = zip pjs pjls+      interleavedPJs = interleave pjs pjls+  lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value zippedPJs++  where+    lamExpr value pjs = case cons of+      [con] -> parseArgs jc pjs tName opts con (Right value)+      _ | sumEncoding opts == UntaggedValue+            -> parseUntaggedValue pjs cons value+        | otherwise+            -> caseE (varE value) $+                   if allNullaryToStringTag opts && all isNullary cons+                   then allNullaryMatches+                   else mixedMatches pjs++    allNullaryMatches =+      [ do txt <- newName "txt"+           match (conP 'String [varP txt])+                 (guardedB $+                  [ liftM2 (,) (normalG $+                                  infixApp (varE txt)+                                           [|(==)|]+                                           ([|T.pack|] `appE`+                                              conStringE opts conName)+                               )+                               ([|pure|] `appE` conE conName)+                  | con <- cons+                  , let conName = getConName 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 pjs =+        case sumEncoding opts of+          TaggedObject {tagFieldName, contentsFieldName} ->+            parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName+          UntaggedValue -> error "UntaggedValue: Should be handled already"+          ObjectWithSingleField ->+            parseObject $ parseObjectWithSingleField pjs+          TwoElemArray ->+            [ do arr <- newName "array"+                 match (conP 'Array [varP arr])+                       (guardedB+                        [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)+                                                         [|(==)|]+                                                         (litE $ integerL 2))+                                     (parse2ElemArray pjs 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 pjs typFieldName valFieldName obj = do+      conKey <- newName "conKey"+      doE [ bindS (varP conKey)+                  (infixApp (varE obj)+                            [|(.:)|]+                            ([|T.pack|] `appE` stringE typFieldName))+          , noBindS $ parseContents pjs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject+          ]++    parseUntaggedValue pjs cons' conVal =+        foldr1 (\e e' -> infixApp e [|(<|>)|] e')+               (map (\x -> parseValue pjs x conVal) cons')++    parseValue _pjs (NormalC conName []) conVal = do+      str <- newName "str"+      caseE (varE conVal)+        [ match (conP 'String [varP str])+                (guardedB+                  [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] ([|T.pack|] `appE` conStringE opts conName)+                               )+                               ([|pure|] `appE` conE conName)+                  ]+                )+                []+        , matchFailed tName conName "String"+        ]+    parseValue pjs con conVal =+      parseArgs jc pjs tName opts con (Right conVal)+++    parse2ElemArray pjs 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 pjs+                                                      txt+                                                      (Right conVal)+                                                      'conNotFoundFail2ElemArray+                             )+                             []+                  , do other <- newName "other"+                       match (varP other)+                             ( normalB+                               $ [|firstElemNoStringFail|]+                                     `appE` litE (stringL $ show tName)+                                     `appE` ([|valueConName|] `appE` varE other)+                             )+                             []+                  ]+           )++    parseObjectWithSingleField pjs obj = do+      conKey <- newName "conKey"+      conVal <- newName "conVal"+      caseE ([e|H.toList|] `appE` varE obj)+            [ match (listP [tupP [varP conKey, varP conVal]])+                    (normalB $ parseContents pjs 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 pjs conKey contents errorFun =+        caseE (varE conKey)+              [ match wildP+                      ( guardedB $+                        [ do g <- normalG $ infixApp (varE conKey)+                                                     [|(==)|]+                                                     ([|T.pack|] `appE`+                                                        conNameExp opts con)+                             e <- parseArgs jc pjs 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+                                                     . getConName+                                                     ) 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+            -> [VarStrictType]+            -> Name+            -> ExpQ+parseRecord jc tvMap argTys opts tName conName ts obj =+    foldl' (\a b -> infixApp a [|(<*>)|] b)+           (infixApp (conE conName) [|(<$>)|] x)+           xs+    where+      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` fieldLabelExp opts field+                      )+             | ((field, _, _), argTy) <- zip ts 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.+          -> [(Name, Name)] -- ^ The names of the encoding/decoding function arguments.+          -> Name -- ^ Name of the type to which the constructor belongs.+          -> Options -- ^ Encoding options.+          -> Con -- ^ Constructor for which to generate JSON parsing code.+          -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or+                                        --   Right valName+          -> Q Exp+-- Nullary constructors.+parseArgs jc pjs _ _ (NormalC conName []) (Left _) = do+  ([], _) <- reifyConTys jc pjs conName+  [|pure|] `appE` conE conName+parseArgs jc pjs tName _ (NormalC conName []) (Right valName) = do+  ([], _) <- reifyConTys jc pjs conName+  caseE (varE valName) $ parseNullaryMatches tName conName++-- Unary constructors.+parseArgs jc pjs _ _ (NormalC conName [_]) contents = do+  ([argTy], tvMap) <- reifyConTys jc pjs conName+  matchCases contents $ parseUnaryMatches jc tvMap argTy conName++-- Polyadic constructors.+parseArgs jc pjs tName _ (NormalC conName ts) contents = do+    (argTys, tvMap) <- reifyConTys jc pjs conName+    let len = genericLength ts+    matchCases contents $ parseProduct jc tvMap argTys tName conName len++-- Records.+parseArgs jc pjs tName opts (RecC conName ts) (Left (_, obj)) = do+    (argTys, tvMap) <- reifyConTys jc pjs conName+    parseRecord jc tvMap argTys opts tName conName ts obj+parseArgs jc pjs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of+  (True,[(_,st,ty)])-> parseArgs jc pjs tName opts (NormalC conName [(st,ty)]) (Right valName)+  _ -> do+    obj <- newName "recObj"+    (argTys, tvMap) <- reifyConTys jc pjs conName+    caseE (varE valName)+      [ match (conP 'Object [varP obj]) (normalB $+          parseRecord jc tvMap argTys opts tName conName ts obj) []+      , matchFailed tName conName "Object"+      ]++-- Infix constructors. Apart from syntax these are the same as+-- polyadic constructors.+parseArgs jc pjs tName _ (InfixC _ conName _) contents = do+    (argTys, tvMap) <- reifyConTys jc pjs conName+    matchCases contents $ parseProduct jc tvMap argTys tName conName 2++-- Existentially quantified constructors. We ignore the quantifiers+-- and proceed with the contained constructor.+parseArgs jc pjs tName opts (ForallC _ _ con) contents =+    parseArgs jc pjs tName opts con contents++#if MIN_VERSION_template_haskell(2,11,0)+-- GADTs. We ignore the refined return type and proceed as if it were a+-- NormalC or RecC.+parseArgs jc pjs tName opts (GadtC conNames ts _) contents =+    parseArgs jc pjs tName opts (NormalC (head conNames) ts) contents++parseArgs jc pjs tName opts (RecGadtC conNames ts _) contents =+    parseArgs jc pjs tName opts (RecC (head conNames) ts) contents+#endif++-- | 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 LookupField (Maybe a) where+    lookupField pj _ _ = parseOptionalFieldWith pj++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++keyValuePairWith :: (v -> Value) -> T.Text -> v -> Pair+keyValuePairWith tj name value = (name, tj value)++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 -> [Con] -> 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 =+    withType name $ \name' ctxt tvbs cons mbTys ->+        (:[]) <$> fromCons name' ctxt tvbs cons mbTys+  where+    fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec+    fromCons name' ctxt tvbs cons mbTys = do+      (instanceCxt, instanceType)+        <- buildTypeInstance name' jc ctxt tvbs mbTys+      instanceD (return instanceCxt)+                (return instanceType)+                (methodDecs name' cons)++    methodDecs :: Name -> [Con] -> [Q Dec]+    methodDecs name' cons = flip map consFuns $ \(jf, jfMaker) ->+      funD (jsonFunValName jf (arity jc))+           [ clause []+                    (normalB $ jfMaker jc name' opts cons)+                    []+           ]++mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> 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 = withType name fromCons+  where+    fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp+    fromCons name' ctxt tvbs cons mbTys = 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 name' jc ctxt tvbs mbTys+        consFun jc name' opts 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 <- isTyFamily tyCon+    if any (`mentionsName` tyVarNames) lhsArgs+          || itf && any (`mentionsName` tyVarNames) tyArgs+       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, dispatchToEncoding, dispatchParseJSON+  :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp+dispatchToJSON     jc n tvMap = dispatchFunByType jc ToJSON     n tvMap False+dispatchToEncoding jc n tvMap = dispatchFunByType jc ToEncoding n tvMap False+dispatchParseJSON  jc n tvMap = dispatchFunByType jc ParseJSON  n tvMap False++--------------------------------------------------------------------------------+-- Utility functions+--------------------------------------------------------------------------------++-- | Boilerplate for top level splices.+--+-- The given 'Name' must meet one of two criteria:+--+-- 1. It must be the name of a type constructor of a plain data type or newtype.+-- 2. It must be the name of a data family instance or newtype instance constructor.++-- Any other value will result in an exception.+withType :: Name+         -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)+         -- ^ Function that generates the actual code. Will be applied+         -- to the datatype/data family 'Name', datatype context, type+         -- variable binders and constructors extracted from the given+         -- 'Name'. If the 'Name' is from a data family instance+         -- constructor, it will also have its instantiated types;+         -- otherwise, it will be 'Nothing'.+         -> Q a+         -- ^ Resulting value in the 'Q'uasi monad.+withType name f = do+    info <- reify name+    case info of+      TyConI dec ->+        case dec of+#if MIN_VERSION_template_haskell(2,11,0)+          DataD    ctxt _ tvbs _ cons _ -> f name ctxt tvbs cons Nothing+          NewtypeD ctxt _ tvbs _ con  _ -> f name ctxt tvbs [con] Nothing+#else+          DataD    ctxt _ tvbs   cons _ -> f name ctxt tvbs cons Nothing+          NewtypeD ctxt _ tvbs   con  _ -> f name ctxt tvbs [con] Nothing+#endif+          other -> fail $ ns ++ "Unsupported type: " ++ show other+#if MIN_VERSION_template_haskell(2,11,0)+      DataConI _ _ parentName   -> do+#else+      DataConI _ _ parentName _ -> do+#endif+        parentInfo <- reify parentName+        case parentInfo of+#if MIN_VERSION_template_haskell(2,11,0)+          FamilyI (DataFamilyD _ tvbs _) decs ->+#else+          FamilyI (FamilyD DataFam _ tvbs _) decs ->+#endif+            let instDec = flip find decs $ \dec -> case dec of+#if MIN_VERSION_template_haskell(2,11,0)+                  DataInstD    _ _ _ _ cons _ -> any ((name ==) . getConName) cons+                  NewtypeInstD _ _ _ _ con  _ -> name == getConName con+#else+                  DataInstD    _ _ _   cons _ -> any ((name ==) . getConName) cons+                  NewtypeInstD _ _ _   con  _ -> name == getConName con+#endif+                  _ -> error $ ns ++ "Must be a data or newtype instance."+             in case instDec of+#if MIN_VERSION_template_haskell(2,11,0)+                  Just (DataInstD    ctxt _ instTys _ cons _) -> f parentName ctxt tvbs cons $ Just instTys+                  Just (NewtypeInstD ctxt _ instTys _ con  _) -> f parentName ctxt tvbs [con] $ Just instTys+#else+                  Just (DataInstD    ctxt _ instTys   cons _) -> f parentName ctxt tvbs cons $ Just instTys+                  Just (NewtypeInstD ctxt _ instTys   con  _) -> f parentName ctxt tvbs [con] $ Just instTys+#endif+                  _ -> fail $ ns +++                    "Could not find data or newtype instance constructor."+          _ -> fail $ ns ++ "Data constructor " ++ show name +++            " is not from a data family instance constructor."+#if MIN_VERSION_template_haskell(2,11,0)+      FamilyI DataFamilyD{} _ ->+#else+      FamilyI (FamilyD DataFam _ _ _) _ ->+#endif+        fail $ ns +++          "Cannot use a data family name. Use a data family instance constructor instead."+      _ -> fail $ ns ++ "I need the name of a plain data type constructor, "+                      ++ "or a data family instance constructor."+  where+    ns :: String+    ns = "Data.Aeson.TH.withType: "++-- | Infer the context and instance head needed for a FromJSON or ToJSON instance.+buildTypeInstance :: Name+                  -- ^ The type constructor or data family name+                  -> JSONClass+                  -- ^ The typeclass to derive+                  -> Cxt+                  -- ^ The datatype context+                  -> [TyVarBndr]+                  -- ^ The type variables from the data type/data family declaration+                  -> Maybe [Type]+                  -- ^ 'Just' the types used to instantiate a data family instance,+                  -- or 'Nothing' if it's a plain data type+                  -> Q (Cxt, Type)+                  -- ^ The resulting 'Cxt' and 'Type' to use in a class instance+-- Plain data type/newtype case+buildTypeInstance tyConName jc dataCxt tvbs Nothing =+    let varTys :: [Type]+        varTys = map tvbToType tvbs+    in buildTypeInstanceFromTys tyConName jc dataCxt varTys False+-- Data family instance case+--+-- The CPP is present to work around a couple of annoying old GHC bugs.+-- See Note [Polykinded data families in Template Haskell]+buildTypeInstance dataFamName jc dataCxt tvbs (Just instTysAndKinds) = do+#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)+    let instTys :: [Type]+        instTys = zipWith stealKindForType tvbs instTysAndKinds+#else+    let kindVarNames :: [Name]+        kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs++        numKindVars :: Int+        numKindVars = length kindVarNames++        givenKinds, givenKinds' :: [Kind]+        givenTys                :: [Type]+        (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds+        givenKinds' = map sanitizeStars givenKinds++        -- A GHC 7.6-specific bug requires us to replace all occurrences of+        -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.+        -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.+        sanitizeStars :: Kind -> Kind+        sanitizeStars = go+          where+            go :: Kind -> Kind+            go (AppT t1 t2)                 = AppT (go t1) (go t2)+            go (SigT t k)                   = SigT (go t) (go k)+            go (ConT n) | n == starKindName = StarT+            go t                            = t++            -- It's quite awkward to import * from GHC.Prim, so we'll just+            -- hack our way around it.+            starKindName :: Name+            starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"++    -- If we run this code with GHC 7.8, we might have to generate extra type+    -- variables to compensate for any type variables that Template Haskell+    -- eta-reduced away.+    -- See Note [Polykinded data families in Template Haskell]+    xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)++    let xTys   :: [Type]+        xTys = map VarT xTypeNames+        -- ^ Because these type variables were eta-reduced away, we can only+        --   determine their kind by using stealKindForType. Therefore, we mark+        --   them as VarT to ensure they will be given an explicit kind annotation+        --   (and so the kind inference machinery has the right information).++        substNamesWithKinds :: [(Name, Kind)] -> Type -> Type+        substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks++        -- The types from the data family instance might not have explicit kind+        -- annotations, which the kind machinery needs to work correctly. To+        -- compensate, we use stealKindForType to explicitly annotate any+        -- types without kind annotations.+        instTys :: [Type]+        instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))+                  -- Note that due to a GHC 7.8-specific bug+                  -- (see Note [Polykinded data families in Template Haskell]),+                  -- there may be more kind variable names than there are kinds+                  -- to substitute. But this is OK! If a kind is eta-reduced, it+                  -- means that is was not instantiated to something more specific,+                  -- so we need not substitute it. Using stealKindForType will+                  -- grab the correct kind.+                $ zipWith stealKindForType tvbs (givenTys ++ xTys)+#endif+    buildTypeInstanceFromTys dataFamName jc dataCxt instTys True++-- For the given Types, generate an instance context and head.+buildTypeInstanceFromTys :: 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+                         -> Bool+                         -- ^ True if it's a data family, False otherwise+                         -> Q (Cxt, Type)+buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = 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 expandSyn 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 = concatMap tyVarNamesOfType 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 (union droppedKindVarNames kvNames'))+            $ take remainingLength varTysOrig++        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 [Polykinded data families in Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In order to come up with the correct instance context and head for an instance, e.g.,++  instance C a => C (Data a) where ...++We need to know the exact types and kinds used to instantiate the instance. For+plain old datatypes, this is simple: every type must be a type variable, and+Template Haskell reliably tells us the type variables and their kinds.++Doing the same for data families proves to be much harder for three reasons:++1. On any version of Template Haskell, it may not tell you what an instantiated+   type's kind is. For instance, in the following data family instance:++     data family Fam (f :: * -> *) (a :: *)+     data instance Fam f a++   Then if we use TH's reify function, it would tell us the TyVarBndrs of the+   data family declaration are:++     [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]++   and the instantiated types of the data family instance are:++     [VarT f1,VarT a1]++   We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we+   have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the+   kind is in case an instantiated type isn't a SigT, so we use the stealKindForType+   function to ensure all of the instantiated types are SigTs before passing them+   to buildTypeInstanceFromTys.+2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of+   the specified kinds of a data family instance efore any of the instantiated+   types. Fortunately, this is easy to deal with: you simply count the number of+   distinct kind variables in the data family declaration, take that many elements+   from the front of the  Types list of the data family instance, substitute the+   kind variables with their respective instantiated kinds (which you took earlier),+   and proceed as normal.+3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template+   Haskell might not even list all of the Types of a data family instance, since+   they are eta-reduced away! And yes, kinds can be eta-reduced too.++   The simplest workaround is to count how many instantiated types are missing from+   the list and generate extra type variables to use in their place. Luckily, we+   needn't worry much if its kind was eta-reduced away, since using stealKindForType+   will get it back.++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.+-}++-- Determines the types of a constructor's arguments as well as the last type+-- parameters (mapped to their encoding/decoding functions), expanding through+-- any type synonyms.+--+-- The type parameters are determined on a constructor-by-constructor basis since+-- they may be refined to be particular types in a GADT.+reifyConTys :: JSONClass+            -> [(Name, Name)]+            -> Name+            -> Q ([Type], TyVarMap)+reifyConTys jc tpjs conName = do+    info  <- reify conName+    (ctxt, uncTy) <- case info of+        DataConI _ ty _+#if !(MIN_VERSION_template_haskell(2,11,0))+                _+#endif+                -> fmap uncurryTy (expandSyn ty)+        _ -> error "Must be a data constructor"+    let (argTys, [resTy]) = NE.splitAt (NE.length uncTy - 1) uncTy+        unapResTy = unapplyTy resTy+        -- If one of the last type variables is refined to a particular type+        -- (i.e., not truly polymorphic), we mark it with Nothing and filter+        -- it out later, since we only apply encoding/decoding functions to+        -- arguments of a type that it (1) one of the last type variables,+        -- and (2) of a truly polymorphic type.+        jArity = arityInt jc+        mbTvNames = map varTToNameMaybe $+                        NE.drop (NE.length unapResTy - jArity) unapResTy+        -- We use M.fromList to ensure that if there are any duplicate type+        -- variables (as can happen in a GADT), the rightmost type variable gets+        -- associated with the show function.+        --+        -- See Note [Matching functions with GADT type variables]+        tvMap = M.fromList+                    . catMaybes -- Drop refined types+                    $ zipWith (\mbTvName tpj ->+                                  fmap (\tvName -> (tvName, tpj)) mbTvName)+                              mbTvNames tpjs+    if (any (`predMentionsName` M.keys tvMap) ctxt+         || M.size tvMap < jArity)+         && not (allowExQuant jc)+       then existentialContextError conName+       else return (argTys, tvMap)++{-+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)++-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.+stealKindForType :: TyVarBndr -> Type -> Type+stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)+stealKindForType _   t        = t++-- | Extracts the kind from a type variable binder.+tvbKind :: TyVarBndr -> Kind+#if MIN_VERSION_template_haskell(2,8,0)+tvbKind (PlainTV  _  ) = StarT+#else+tvbKind (PlainTV  _  ) = StarK+#endif+tvbKind (KindedTV _ k) = k++tvbToType :: TyVarBndr -> Type+tvbToType (PlainTV n)    = VarT n+tvbToType (KindedTV n k) = SigT (VarT n) k++-- | Returns True if a Type has kind *.+hasKindStar :: Type -> Bool+hasKindStar VarT{}         = True+#if MIN_VERSION_template_haskell(2,8,0)+hasKindStar (SigT _ StarT) = True+#else+hasKindStar (SigT _ StarK) = True+#endif+hasKindStar _              = False++-- Returns True is a kind is equal to *, or if it is a kind variable.+isStarOrVar :: Kind -> Bool+#if MIN_VERSION_template_haskell(2,8,0)+isStarOrVar StarT  = True+isStarOrVar VarT{} = True+#else+isStarOrVar StarK  = True+#endif+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]]++-- Gets all of the type/kind variable names mentioned somewhere in a Type.+tyVarNamesOfType :: Type -> [Name]+tyVarNamesOfType = go+  where+    go :: Type -> [Name]+    go (AppT t1 t2) = go t1 ++ go t2+    go (SigT t _k)  = go t+#if MIN_VERSION_template_haskell(2,8,0)+                           ++ go _k+#endif+    go (VarT n)     = [n]+    go _            = []++-- | Gets all of the type/kind variable names mentioned somewhere in a Kind.+tyVarNamesOfKind :: Kind -> [Name]+#if MIN_VERSION_template_haskell(2,8,0)+tyVarNamesOfKind = tyVarNamesOfType+#else+tyVarNamesOfKind _ = [] -- There are no kind variables+#endif++-- | @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 tyVarNamesOfKind 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++-- | Extracts the name from a constructor.+getConName :: Con -> Name+getConName (NormalC name _)  = name+getConName (RecC name _)     = name+getConName (InfixC _ name _) = name+getConName (ForallC _ _ con) = getConName con+#if MIN_VERSION_template_haskell(2,11,0)+getConName (GadtC    names _ _) = head names+getConName (RecGadtC names _ _) = head names+#endif++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++-- | Is the given type a type family constructor (and not a data family constructor)?+isTyFamily :: Type -> Q Bool+isTyFamily (ConT n) = do+    info <- reify n+    return $ case info of+#if MIN_VERSION_template_haskell(2,11,0)+         FamilyI OpenTypeFamilyD{} _       -> True+#else+         FamilyI (FamilyD TypeFam _ _ _) _ -> True+#endif+#if MIN_VERSION_template_haskell(2,9,0)+         FamilyI ClosedTypeFamilyD{} _     -> True+#endif+         _ -> False+isTyFamily _ = return False++-- | 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+#if MIN_VERSION_template_haskell(2,8,0)+                              || go _k names+#endif+    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+#if MIN_VERSION_template_haskell(2,8,0)+uncurryKind = snd . uncurryTy+#else+uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2+uncurryKind k              = k :| []+#endif++createKindChain :: Int -> Kind+createKindChain = go starK+  where+    go :: Kind -> Int -> Kind+    go k !0 = k+#if MIN_VERSION_template_haskell(2,8,0)+    go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)+#else+    go k !n = go (ArrowK StarK k) (n - 1)+#endif++-- | Makes a string literal expression from a constructor's name.+conNameExp :: Options -> Con -> Q Exp+conNameExp opts = litE+                . stringL+                . constructorTagModifier opts+                . nameBase+                . getConName++-- | Creates a string literal expression from a record field label.+fieldLabelExp :: Options -- ^ Encoding options+              -> Name+              -> Q Exp+fieldLabelExp opts = litE . stringL . 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+-------------------------------------------------------------------------------++-- | Expands all type synonyms in a type. Written by Dan Rosén in the+-- @genifunctors@ package (licensed under BSD3).+expandSyn :: Type -> Q Type+expandSyn (ForallT tvs ctx t) = ForallT tvs ctx <$> expandSyn t+expandSyn t@AppT{}            = expandSynApp t []+expandSyn t@ConT{}            = expandSynApp t []+expandSyn (SigT t k)          = do t' <- expandSyn t+                                   k' <- expandSynKind k+                                   return (SigT t' k')+expandSyn t                   = return t++expandSynKind :: Kind -> Q Kind+#if MIN_VERSION_template_haskell(2,8,0)+expandSynKind = expandSyn+#else+expandSynKind = return -- There are no kind synonyms to deal with+#endif++expandSynApp :: Type -> [Type] -> Q Type+expandSynApp (AppT t1 t2) ts = do+    t2' <- expandSyn t2+    expandSynApp t1 (t2':ts)+expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts+expandSynApp t@(ConT n) ts = do+    info <- reify n+    case info of+        TyConI (TySynD _ tvs rhs) ->+            let (ts', ts'') = splitAt (length tvs) ts+                subs = mkSubst tvs ts'+                rhs' = substType subs rhs+             in expandSynApp rhs' ts''+        _ -> return $ foldl' AppT t ts+expandSynApp t ts = do+    t' <- expandSyn t+    return $ foldl' AppT t' ts++type TypeSubst = Map Name Type+type KindSubst = Map Name Kind++mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst+mkSubst vs ts =+   let vs' = map un vs+       un (PlainTV v)    = v+       un (KindedTV v _) = v+   in M.fromList $ zip vs' ts++substType :: TypeSubst -> Type -> Type+substType subs (ForallT v c t) = ForallT v c $ substType subs t+substType subs t@(VarT n)      = M.findWithDefault t n subs+substType subs (AppT t1 t2)    = AppT (substType subs t1) (substType subs t2)+substType subs (SigT t k)      = SigT (substType subs t)+#if MIN_VERSION_template_haskell(2,8,0)+                                      (substType subs k)+#else+                                      k+#endif+substType _ t                  = t++substKind :: KindSubst -> Type -> Type+#if MIN_VERSION_template_haskell(2,8,0)+substKind = substType+#else+substKind _ t = t -- There are no kind variables!+#endif++substNameWithKind :: Name -> Kind -> Type -> Type+substNameWithKind n k = substKind (M.singleton n k)++substNamesWithKindStar :: [Name] -> Type -> Type+substNamesWithKindStar ns t = foldr' (flip 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 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+  | hasKindStar t = KindStar+  | otherwise = case t of+#if MIN_VERSION_template_haskell(2,8,0)+                     SigT _ (VarT k) -> IsKindVar k+#endif+                     _               -> 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

@@ -0,0 +1,101 @@+{-# LANGUAGE BangPatterns #-}+{-# 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 ()+import Prelude.Compat++import Data.Aeson.Types (Value(..), ToJSON(..))+import Data.Aeson.Encoding (encodingToLazyByteString)+import Data.Monoid ((<>))+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 'encodeToBuilder'+-- 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)

@@ -37,13 +37,43 @@     , KeyValue(..)     , modifyFailure +    -- ** Keys for maps+    , ToJSONKey(..)+    , ToJSONKeyFunction(..)+    , toJSONKeyText+    , contramapToJSONKeyFunction+    , FromJSONKey(..)+    , FromJSONKeyFunction(..)+    , fromJSONKeyCoerce+    , coerceFromJSONKeyFunction+    , mapFromJSONKeyFunction++    -- ** Liftings to unary and binary type constructors+    , FromJSON1(..)+    , parseJSON1+    , FromJSON2(..)+    , parseJSON2+    , ToJSON1(..)+    , toJSON1+    , toEncoding1+    , ToJSON2(..)+    , toJSON2+    , toEncoding2+     -- ** Generic JSON classes     , GFromJSON(..)+    , FromArgs(..)     , GToJSON(..)     , GToEncoding(..)+    , ToArgs(..)+    , Zero+    , One     , genericToJSON+    , genericLiftToJSON     , genericToEncoding+    , genericLiftToEncoding     , genericParseJSON+    , genericLiftParseJSON      -- * Inspecting @'Value's@     , withObject@@ -61,6 +91,10 @@     , (.!=)     , object +    , listEncoding+    , listValue+    , listParser+     -- * Generic and TH encoding configuration     , Options(..)     , SumEncoding(..)@@ -70,7 +104,15 @@     , defaultTaggedObject     ) where -import Data.Aeson.Encode.Functions (foldable, pairs)-import Data.Aeson.Types.Generic ()-import Data.Aeson.Types.Instances+import Prelude ()+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 #-}

@@ -1,4 +1,10 @@-{-# LANGUAGE CPP, DefaultSignatures, FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}  -- | -- Module:      Data.Aeson.Types.Class@@ -16,259 +22,69 @@     -- * 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(..)+    , ToArgs(..)+    , Zero+    , One     , genericToJSON+    , genericLiftToJSON     , genericToEncoding+    , genericLiftToEncoding     , genericParseJSON+    , genericLiftParseJSON+    -- * Classes and types for map keys+    , ToJSONKey(..)+    , ToJSONKeyFunction(..)+    , toJSONKeyText+    , contramapToJSONKeyFunction+    , FromJSONKey(..)+    , FromJSONKeyFunction(..)+    , fromJSONKeyCoerce+    , coerceFromJSONKeyFunction+    , mapFromJSONKeyFunction     -- * Object key-value pairs     , KeyValue(..)-    -- * Functions needed for documentation-    , typeMismatch-    ) where -import Data.Aeson.Types.Internal-import Data.Text (Text)-import GHC.Generics (Generic, Rep, from, to)-import qualified Data.Aeson.Encode.Builder as E---- | Class of generic representation types ('Rep') that can be converted to--- JSON.-class GToJSON f where-    -- | This method (applied to 'defaultOptions') is used as the-    -- default generic implementation of 'toJSON'.-    gToJSON :: Options -> f a -> Value---- | Class of generic representation types ('Rep') that can be converted to--- a JSON 'Encoding'.-class GToEncoding f where-    -- | This method (applied to 'defaultOptions') can be used as the-    -- default generic implementation of 'toEncoding'.-    gToEncoding :: Options -> f a -> Encoding---- | Class of generic representation types ('Rep') that can be converted from JSON.-class GFromJSON f where-    -- | This method (applied to 'defaultOptions') is used as the-    -- default generic implementation of 'parseJSON'.-    gParseJSON :: Options -> Value -> Parser (f 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 (Rep a)) => Options -> a -> Value-genericToJSON opts = gToJSON opts . from---- | 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, GToEncoding (Rep a)) => Options -> a -> Encoding-genericToEncoding opts = gToEncoding opts . from---- | 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 (Rep a)) => Options -> Value -> Parser a-genericParseJSON opts = fmap to . gParseJSON opts---- | A type that can be converted to JSON.------ 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 will probably be more efficient than the following two options:------ * 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 for your datatype without giving--- definitions for 'toJSON' or 'toEncoding'.------ For example, the previous example can be simplified to a more--- minimal instance:------ @--- {-\# LANGUAGE DeriveGeneric \#-}------ import "GHC.Generics"------ data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'------ instance ToJSON Coord where---     toEncoding = 'genericToEncoding' 'defaultOptions'--- @------ Why do we provide an implementation for 'toEncoding' here?  The--- 'toEncoding' function is a relatively new addition to this class.--- To allow users of older versions of this library to upgrade without--- having to edit all of their instances or encounter surprising--- incompatibilities, the default implementation of 'toEncoding' uses--- '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'.  Our one-liner definition of--- 'toEncoding' above bypasses the intermediate 'Value'.------ If @DefaultSignatures@ doesn't give exactly the results you want,--- you can customize the generic encoding with only a tiny amount of--- effort, using 'genericToJSON' and 'genericToEncoding' with your--- preferred 'Options':------ @--- instance ToJSON Coord where---     toJSON     = 'genericToJSON' 'defaultOptions'---     toEncoding = 'genericToEncoding' 'defaultOptions'--- @-class ToJSON a where-    -- | Convert a Haskell value to a JSON-friendly intermediate type.-    toJSON     :: a -> Value--    default toJSON :: (Generic a, GToJSON (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 = Encoding . E.encodeToBuilder . toJSON-    {-# INLINE toEncoding #-}---- | 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:------ * 'empty' and 'mzero' work, but are terse and uninformative------ * 'fail' yields a custom error message------ * 'typeMismatch' produces an informative message for cases when the--- value encountered is not of the expected type------ An example type and instance:------ @--- \-- 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 'mzero' to fail, but 'typeMismatch'---   \-- gives a much more informative error message.---   parseJSON invalid    = 'typeMismatch' \"Coord\" invalid--- @------ 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 will probably be more efficient than the following two options:------ * 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--- @------ If @DefaultSignatures@ doesn't give exactly the results you want,--- you can customize the generic decoding with only a tiny amount of--- effort, using 'genericParseJSON' with your preferred 'Options':------ @--- instance FromJSON Coord where---     parseJSON = 'genericParseJSON' 'defaultOptions'--- @+    -- * List functions+    , listEncoding+    , listValue+    , listParser -class FromJSON a where-    parseJSON :: Value -> Parser a+      -- * Inspecting @'Value's@+    , withObject+    , withText+    , withArray+    , withNumber+    , withScientific+    , withBool -    default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a-    parseJSON = genericParseJSON defaultOptions+    -- * Functions+    , fromJSON+    , ifromJSON+    , (.:)+    , (.:?)+    , (.:!)+    , (.!=)+    , typeMismatch+    ) where --- | A key-value pair for encoding a JSON object.-class KeyValue kv where-    (.=) :: ToJSON v => Text -> v -> kv-    infixr 8 .=+import Prelude () --- | Fail parsing due to a type mismatch, with a descriptive message.------ Example usage:------ @--- instance FromJSON Coord where---   parseJSON ('Object' v) = {- type matches, life is good -}---   parseJSON wat        = 'typeMismatch' \"Coord\" wat--- @-typeMismatch :: String -- ^ The name of the type you are trying to parse.-             -> Value  -- ^ The actual value encountered.-             -> Parser a-typeMismatch expected actual =-    fail $ "expected " ++ expected ++ ", encountered " ++ name-  where-    name = case actual of-             Object _ -> "Object"-             Array _  -> "Array"-             String _ -> "String"-             Number _ -> "Number"-             Bool _   -> "Boolean"-             Null     -> "Null"+import Data.Aeson.Types.FromJSON+import Data.Aeson.Types.Generic (One, Zero)+import Data.Aeson.Types.ToJSON

@@ -0,0 +1,2032 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-}+#endif++#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++    -- * List functions+    , listParser++    -- * Inspecting @'Value's@+    , withObject+    , withText+    , withArray+    , withNumber+    , withScientific+    , withBool++    -- * Functions+    , fromJSON+    , ifromJSON+    , (.:)+    , (.:?)+    , (.:!)+    , (.!=)+    , typeMismatch++    -- * Internal+    , parseOptionalFieldWith+    ) where++import Prelude ()+import Prelude.Compat++import Control.Applicative ((<|>), Const(..))+import Control.Monad ((<=<), zipWithM)+import Data.Aeson.Internal.Functions (mapKey)+import Data.Aeson.Types.Generic+import Data.Aeson.Types.Internal+import Data.Attoparsec.Number (Number(..))+import Data.Bits (unsafeShiftR)+import Data.Fixed (Fixed, HasResolution)+import Data.Functor.Compose (Compose(..))+import Data.Functor.Identity (Identity(..))+import Data.Functor.Product (Product(..))+import Data.Functor.Sum (Sum(..))+import Data.Hashable (Hashable(..))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>), Dual(..), First (..), Last (..))+import Data.Proxy (Proxy(..))+import Data.Ratio ((%), Ratio)+import Data.Scientific (Scientific)+import Data.Tagged (Tagged(..))+import Data.Text (Text, pack, unpack)+import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)+import Data.Time.Format (parseTime)+import Data.Time.Locale.Compat (defaultTimeLocale)+import Data.Traversable as Tr (sequence)+import Data.Vector (Vector)+import Data.Version (Version, parseVersion)+import Data.Word (Word16, Word32, Word64, Word8)+import Foreign.Storable (Storable)+import GHC.Generics+import Numeric.Natural (Natural)+import Text.ParserCombinators.ReadP (readP_to_S)+import qualified Data.Aeson.Parser.Time as Time+import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)+import qualified Data.DList as DList+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.Scientific as Scientific+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+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.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 Unsafe.Coerce (unsafeCoerce)++#ifndef HAS_COERCIBLE+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)+#endif++#if HAS_COERCIBLE+import Data.Coerce (Coercible, coerce)+coerce' :: Coercible a b => a -> b+coerce' = coerce+#else+coerce' :: a -> b+coerce' = unsafeCoerce+#endif++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++scientificToNumber :: Scientific -> Number+scientificToNumber s+    | e < 0     = D $ Scientific.toRealFloat s+    | otherwise = I $ c * 10 ^ e+  where+    e = Scientific.base10Exponent s+    c = Scientific.coefficient s+{-# INLINE scientificToNumber #-}++parseRealFloat :: RealFloat a => String -> Value -> Parser a+parseRealFloat _        (Number s) = pure $ Scientific.toRealFloat s+parseRealFloat _        Null       = pure (0/0)+parseRealFloat expected v          = typeMismatch expected v+{-# INLINE parseRealFloat #-}++parseIntegralFromScientific :: forall a. Integral a => String -> Scientific -> Parser a+parseIntegralFromScientific expected s =+    case Scientific.floatingOrInteger s :: Either Double a of+        Right x -> pure x+        Left _  -> fail $ "Floating number specified for " ++ expected ++ ": " ++ show s+{-# INLINE parseIntegralFromScientific #-}++parseIntegral :: Integral a => String -> Value -> Parser a+parseIntegral expected =+    withScientific expected $ parseIntegralFromScientific expected+{-# INLINE parseIntegral #-}++parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => String -> Scientific -> Parser a+parseBoundedIntegralFromScientific expected s = maybe+    (fail $ expected ++ " 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 expected =+    withScientific expected $ parseBoundedIntegralFromScientific expected+{-# 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 expected t =+    parseScientificText t >>= parseIntegralFromScientific expected+{-# INLINE parseIntegralText #-}++parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a+parseBoundedIntegralText expected t =+    parseScientificText t >>= parseBoundedIntegralFromScientific expected++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:+--+-- * 'empty' and 'mzero' work, but are terse and uninformative+--+-- * 'fail' yields a custom error message+--+-- * 'typeMismatch' produces an informative message for cases when the+-- value encountered is not of the expected type+--+-- An example type and instance:+--+-- @+-- \-- 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 'mzero' to fail, but 'typeMismatch'+--   \-- gives a much more informative error message.+--   parseJSON invalid    = 'typeMismatch' \"Coord\" invalid+-- @+--+-- 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 will probably be more efficient than the following two options:+--+-- * 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+-- @+--+-- If @DefaultSignatures@ doesn't give exactly the results you want,+-- you can customize the generic decoding with only a tiny amount of+-- effort, using 'genericParseJSON' with your preferred 'Options':+--+-- @+-- instance FromJSON Coord where+--     parseJSON = 'genericParseJSON' 'defaultOptions'+-- @++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 (Array a)+        = zipWithM (parseIndexedJSON parseJSON) [0..]+        . V.toList+        $ a++    parseJSONList v = typeMismatch "[a]" v++-------------------------------------------------------------------------------+--  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)+--+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++-- | With GHC 7.8+ we carry around @'Coercible' 'Text' a@ dictionary,+-- to give us an assurance that the program will not segfault.+-- Unfortunately we cannot enforce that the 'Eq' instances or the+-- 'Hashable' instances for 'Text' and @a@ agree.+--+-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'+-- can be inspected, but cannot be constructed.+data CoerceText a where+#if HAS_COERCIBLE+    CoerceText :: Coercible Text a => CoerceText a+#else+    CoerceText :: CoerceText a+#endif++-- | 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+    = FromJSONKeyCoerce !(CoerceText a)+      -- ^ uses 'coerce' ('unsafeCoerce' in older GHCs)+    | FromJSONKeyText !(Text -> a)+      -- ^ conversion from 'Text' that always succeeds+    | FromJSONKeyTextParser !(Text -> Parser a)+      -- ^ conversion from 'Text' that may fail+    | FromJSONKeyValue !(Value -> Parser a)+      -- ^ conversion for non-textual keys++-- | Only law abiding up to interpretation+instance Functor FromJSONKeyFunction where+    fmap h (FromJSONKeyCoerce CoerceText) = 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 ::+#if HAS_COERCIBLE+    Coercible Text a =>+#endif+    FromJSONKeyFunction a+fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText++-- | Semantically the same as @coerceFromJSONKeyFunction = fmap coerce = coerce@.+--+-- See note on 'fromJSONKeyCoerce'.+coerceFromJSONKeyFunction ::+#if HAS_COERCIBLE+    Coercible a b =>+#endif+    FromJSONKeyFunction a -> FromJSONKeyFunction b+#if HAS_COERCIBLE+coerceFromJSONKeyFunction = coerce+#else+coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText+coerceFromJSONKeyFunction (FromJSONKeyText f)            = FromJSONKeyText (coerce' . f)+coerceFromJSONKeyFunction (FromJSONKeyTextParser f)      = FromJSONKeyTextParser (fmap coerce' . f)+coerceFromJSONKeyFunction (FromJSONKeyValue f)           = FromJSONKeyValue (fmap coerce' . f)+#endif++{-# RULES+  "FromJSONKeyCoerce: fmap id"     forall (x :: FromJSONKeyFunction a).+                                   fmap id x = x+  #-}+#if HAS_COERCIBLE+{-# RULES+  "FromJSONKeyCoerce: fmap coerce" forall x .+                                   fmap coerce x = coerceFromJSONKeyFunction x+  #-}+#endif++-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.+mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b+mapFromJSONKeyFunction = fmap++-------------------------------------------------------------------------------+-- Functions needed for documentation+-------------------------------------------------------------------------------++-- | Fail parsing due to a type mismatch, with a descriptive message.+--+-- Example usage:+--+-- @+-- instance FromJSON Coord where+--   parseJSON ('Object' v) = {- type matches, life is good -}+--   parseJSON wat        = 'typeMismatch' \"Coord\" wat+-- @+typeMismatch :: String -- ^ The name of the type you are trying to parse.+             -> Value  -- ^ The actual value encountered.+             -> Parser a+typeMismatch expected actual =+    fail $ "expected " ++ expected ++ ", encountered " ++ name+  where+    name = case actual 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 will probably be more efficient than the following two options:+--+-- * 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 @DefaultSignatures@ 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':+--+-- @+-- instance FromJSON a => FromJSON1 (Pair a) where+--     liftParseJSON = 'genericLiftParseJSON' 'defaultOptions'+-- @+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 v = case v of+        Array vals -> fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)+        _ -> typeMismatch "[a]" v++-- | 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 "[a]" v+{-# INLINE listParser #-}++-------------------------------------------------------------------------------+-- [] instances+-------------------------------------------------------------------------------++instance FromJSON1 [] where+    liftParseJSON _ p' = p'+    {-# INLINE liftParseJSON #-}++instance (FromJSON a) => FromJSON [a] where+    parseJSON = parseJSON1++-------------------------------------------------------------------------------+-- Functions+-------------------------------------------------------------------------------++-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@+--   and fails using @'typeMismatch' expected@ otherwise.+withObject :: String -> (Object -> Parser a) -> Value -> Parser a+withObject _        f (Object obj) = f obj+withObject expected _ v            = typeMismatch expected v+{-# INLINE withObject #-}++-- | @withText expected f value@ applies @f@ to the 'Text' when @value@ is a @String@+--   and fails using @'typeMismatch' expected@ otherwise.+withText :: String -> (Text -> Parser a) -> Value -> Parser a+withText _        f (String txt) = f txt+withText expected _ v            = typeMismatch expected v+{-# INLINE withText #-}++-- | @withArray expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@+--   and fails using @'typeMismatch' expected@ otherwise.+withArray :: String -> (Array -> Parser a) -> Value -> Parser a+withArray _        f (Array arr) = f arr+withArray expected _ v           = typeMismatch expected v+{-# INLINE withArray #-}++-- | @withNumber expected f value@ applies @f@ to the 'Number' when @value@ is a 'Number'.+--   and fails using @'typeMismatch' expected@ otherwise.+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a+withNumber expected f = withScientific expected (f . scientificToNumber)+{-# INLINE withNumber #-}+{-# DEPRECATED withNumber "Use withScientific instead" #-}++-- | @withScientific expected f value@ applies @f@ to the 'Scientific' number when @value@ is a 'Number'.+--   and fails using @'typeMismatch' expected@ otherwise.+withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a+withScientific _        f (Number scientific) = f scientific+withScientific expected _ v                   = typeMismatch expected v+{-# INLINE withScientific #-}++-- | @withBool expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@+--   and fails using @'typeMismatch' expected@ otherwise.+withBool :: String -> (Bool -> Parser a) -> Value -> Parser a+withBool _        f (Bool arr) = f arr+withBool expected _ v          = typeMismatch expected v+{-# INLINE withBool #-}++-- | 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+obj .: key = case H.lookup key obj of+               Nothing -> fail $ "key " ++ show key ++ " not present"+               Just v  -> parseJSON v <?> Key key+{-# INLINE (.:) #-}++-- | Retrieve the value associated with the given key of an 'Object'.  The+-- result is 'Nothing' if the key is not present or 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)+obj .:? key = case H.lookup key obj of+               Nothing -> pure Nothing+               Just v  -> parseJSON v <?> Key key+{-# INLINE (.:?) #-}++-- | Like '.:?', but the resulting parser will fail,+-- if the key is present but is 'Null'.+(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)+obj .:! key = case H.lookup key obj of+               Nothing -> pure Nothing+               Just v  -> Just <$> parseJSON v <?> Key key+{-# INLINE (.:!) #-}++-- | 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 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++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 GFromJSON arity U1 where+    -- Empty constructors are expected to be encoded as an empty array:+    gParseJSON _opts _ v+        | isEmptyArray v = pure U1+        | otherwise      = typeMismatch "unit constructor (U1)" v++instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where+    -- Constructors need to be decoded differently depending on whether they're+    -- a record or not. This distinction is made by consParseJSON:+    gParseJSON opts fargs = fmap M1 . consParseJSON opts fargs++instance ( FromProduct arity a, FromProduct arity b+         , ProductSize       a, ProductSize       b+         ) => GFromJSON arity (a :*: b) where+    -- 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 parseProduct:+    gParseJSON opts fargs = withArray "product (:*:)" $ \arr ->+      let lenArray = V.length arr+          lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)+                       productSize in+      if lenArray == lenProduct+      then parseProduct opts fargs arr 0 lenProduct+      else fail $ "When expecting a product of " ++ show lenProduct +++                  " values, encountered an Array of " ++ show lenArray +++                  " elements instead"++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 opts fargs =+      (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->+                                     Parser ((a :+: b) d))+                 . parseSum opts fargs++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)++--------------------------------------------------------------------------------++class ParseSum arity f allNullary where+    parseSum :: Options -> FromArgs arity a+             -> Value -> Tagged allNullary (Parser (f a))++instance ( SumFromString           (a :+: b)+         , FromPair          arity (a :+: b)+         , FromTaggedObject  arity (a :+: b)+         , FromUntaggedValue arity (a :+: b)+         ) => ParseSum       arity (a :+: b) True where+    parseSum opts fargs+        | allNullaryToStringTag opts = Tagged . parseAllNullarySum    opts+        | otherwise                  = Tagged . parseNonAllNullarySum opts fargs++instance ( FromPair          arity (a :+: b)+         , FromTaggedObject  arity (a :+: b)+         , FromUntaggedValue arity (a :+: b)+         ) => ParseSum       arity (a :+: b) False where+    parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs++--------------------------------------------------------------------------------++parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)+parseAllNullarySum opts = withText "Text" $ \key ->+                            maybe (notFound key) return $+                              parseSumFromString opts key++class SumFromString f where+    parseSumFromString :: Options -> 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 opts key | key == name = Just $ M1 U1+                                | otherwise   = Nothing+        where+          name = pack $ constructorTagModifier opts $+                          conName (undefined :: t c U1 p)++--------------------------------------------------------------------------------++parseNonAllNullarySum :: ( FromPair          arity (a :+: b)+                         , FromTaggedObject  arity (a :+: b)+                         , FromUntaggedValue arity (a :+: b)+                         ) => Options -> FromArgs arity c+                           -> Value -> Parser ((a :+: b) c)+parseNonAllNullarySum opts fargs =+    case sumEncoding opts of+      TaggedObject{..} ->+          withObject "Object" $ \obj -> do+            tag <- obj .: pack tagFieldName+            fromMaybe (notFound tag) $+              parseFromTaggedObject opts fargs contentsFieldName obj tag++      ObjectWithSingleField ->+          withObject "Object" $ \obj ->+            case H.toList obj of+              [pair@(tag, _)] -> fromMaybe (notFound tag) $+                                   parsePair opts fargs pair+              _ -> fail "Object doesn't have a single field"++      TwoElemArray ->+          withArray "Array" $ \arr ->+            if V.length arr == 2+            then case V.unsafeIndex arr 0 of+                   String tag -> fromMaybe (notFound tag) $+                                   parsePair opts fargs (tag, V.unsafeIndex arr 1)+                   _ -> fail "First element is not a String"+            else fail "Array doesn't have 2 elements"++      UntaggedValue -> parseUntaggedValue opts fargs++--------------------------------------------------------------------------------++class FromTaggedObject arity f where+    parseFromTaggedObject :: Options -> FromArgs arity a+                          -> String -> Object+                          -> Text -> Maybe (Parser (f a))++instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>+    FromTaggedObject arity (a :+: b) where+        parseFromTaggedObject opts fargs contentsFieldName obj tag =+            (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>+            (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)++instance ( FromTaggedObject' arity f+         , Constructor c+         ) => FromTaggedObject arity (C1 c f) where+    parseFromTaggedObject opts fargs contentsFieldName obj tag+        | tag == name = Just $ M1 <$> parseFromTaggedObject'+                                        opts fargs contentsFieldName obj+        | otherwise = Nothing+        where+          name = pack $ constructorTagModifier opts $+                          conName (undefined :: t c f p)++--------------------------------------------------------------------------------++class FromTaggedObject' arity f where+    parseFromTaggedObject' :: Options -> FromArgs arity a -> String+                           -> Object -> Parser (f a)++class FromTaggedObject'' arity f isRecord where+    parseFromTaggedObject'' :: Options -> FromArgs arity a -> String+                            -> Object -> Tagged isRecord (Parser (f a))++instance ( IsRecord                   f isRecord+         , FromTaggedObject''   arity f isRecord+         ) => FromTaggedObject' arity f where+    parseFromTaggedObject' opts fargs contentsFieldName =+        (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .+        parseFromTaggedObject'' opts fargs contentsFieldName++instance (FromRecord arity f) => FromTaggedObject'' arity f True where+    parseFromTaggedObject'' opts fargs _ =+      Tagged . parseRecord opts fargs Nothing++instance (GFromJSON arity f) => FromTaggedObject'' arity f False where+    parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .+      (gParseJSON opts fargs <=< (.: pack contentsFieldName))++instance OVERLAPPING_ FromTaggedObject'' arity U1 False where+    parseFromTaggedObject'' _ _ _ _ = Tagged (pure U1)++--------------------------------------------------------------------------------++class ConsFromJSON arity f where+    consParseJSON  :: Options -> FromArgs arity a+                   -> Value -> Parser (f a)++class ConsFromJSON' arity f isRecord where+    consParseJSON' :: Options -> FromArgs arity a+                   -> Maybe Text -- ^ A dummy label+                                 --   (Nothing to use proper label)+                   -> Value -> Tagged isRecord (Parser (f a))++instance ( IsRecord            f isRecord+         , ConsFromJSON' arity f isRecord+         ) => ConsFromJSON arity f where+    consParseJSON opts fargs v = let+      (v2,lab) = case (unwrapUnaryRecords opts,isUnary (undefined :: f a)) of+                       -- use a dummy object with a dummy label+        (True,True) -> (object [(pack "dummy",v)], Just $ pack "dummy")+        _ ->(v,Nothing)+      in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))+                       $ consParseJSON' opts fargs lab v2+++instance (FromRecord arity f) => ConsFromJSON' arity f True where+    consParseJSON' opts fargs mlab = Tagged . withObject "record (:*:)"+                                        (parseRecord opts fargs mlab)++instance (GFromJSON arity f) => ConsFromJSON' arity f False where+    consParseJSON' opts fargs _ = Tagged . gParseJSON opts fargs++--------------------------------------------------------------------------------++class FromRecord arity f where+    parseRecord :: Options -> FromArgs arity a+                -> Maybe Text -- ^ A dummy label+                              --   (Nothing to use proper label)+                -> Object -> Parser (f a)++instance ( FromRecord arity a+         , FromRecord arity b+         ) => FromRecord arity (a :*: b) where+    parseRecord opts fargs _ obj =+      (:*:) <$> parseRecord opts fargs Nothing obj+            <*> parseRecord opts fargs Nothing obj++instance ( Selector s+         , GFromJSON arity a+         ) => FromRecord arity (S1 s a) where+    parseRecord opts fargs lab =+      (<?> Key label) . gParseJSON opts fargs <=< (.: label)+        where+          label = fromMaybe defLabel lab+          defLabel = pack . fieldLabelModifier opts $+                       selName (undefined :: t s a p)++instance OVERLAPPING_ (Selector s, FromJSON a) =>+  FromRecord arity (S1 s (K1 i (Maybe a))) where+    parseRecord _ _ (Just lab) obj = (M1 . K1) <$> obj .:? lab+    parseRecord opts _ Nothing obj = (M1 . K1) <$> obj .:? pack label+        where+          label = fieldLabelModifier opts $+                    selName (undefined :: t s (K1 i (Maybe a)) p)++--------------------------------------------------------------------------------++class FromProduct arity f where+    parseProduct :: Options -> FromArgs arity a+                 -> Array -> Int -> Int+                 -> Parser (f a)++instance ( FromProduct    arity a+         , FromProduct    arity b+         ) => FromProduct arity (a :*: b) where+    parseProduct opts fargs arr ix len =+        (:*:) <$> parseProduct opts fargs arr ix  lenL+              <*> parseProduct opts fargs arr ixR lenR+        where+          lenL = len `unsafeShiftR` 1+          ixR  = ix + lenL+          lenR = len - lenL++instance (GFromJSON arity a) => FromProduct arity (S1 s a) where+    parseProduct opts fargs arr ix _ =+      gParseJSON opts fargs $ V.unsafeIndex arr ix++--------------------------------------------------------------------------------++class FromPair arity f where+    parsePair :: Options -> FromArgs arity a+              -> Pair -> Maybe (Parser (f a))++instance ( FromPair arity a+         , FromPair arity b+         ) => FromPair arity (a :+: b) where+    parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>+                                (fmap R1 <$> parsePair opts fargs pair)++instance ( Constructor c+         , GFromJSON    arity a+         , ConsFromJSON arity a+         ) => FromPair arity (C1 c a) where+    parsePair opts fargs (tag, value)+        | tag == tag' = Just $ gParseJSON opts fargs value+        | otherwise   = Nothing+        where+          tag' = pack $ constructorTagModifier opts $+                          conName (undefined :: t c a p)++--------------------------------------------------------------------------------++class FromUntaggedValue arity f where+    parseUntaggedValue :: Options -> FromArgs arity a+                       -> Value -> Parser (f a)++instance+    ( FromUntaggedValue    arity a+    , FromUntaggedValue    arity b+    ) => FromUntaggedValue arity (a :+: b)+  where+    parseUntaggedValue opts fargs value =+        L1 <$> parseUntaggedValue opts fargs value <|>+        R1 <$> parseUntaggedValue opts fargs value++instance OVERLAPPABLE_+    ( GFromJSON            arity a+    , ConsFromJSON         arity a+    ) => FromUntaggedValue arity (C1 c a)+  where+    parseUntaggedValue = gParseJSON++instance OVERLAPPING_+    ( Constructor c )+    => FromUntaggedValue arity (C1 c U1)+  where+    parseUntaggedValue opts _ (String s)+        | s == pack (constructorTagModifier opts (conName (undefined :: t c U1 p))) =+            pure $ M1 U1+        | otherwise =+            fail $ "Invalid tag: " ++ unpack s+    parseUntaggedValue _ _ v = typeMismatch (conName (undefined :: t c U1 p)) v+++--------------------------------------------------------------------------------++notFound :: Text -> Parser a+notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"+{-# INLINE notFound #-}++-------------------------------------------------------------------------------+-- 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 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 Bool where+    parseJSON = withBool "Bool" pure+    {-# INLINE parseJSON #-}++instance FromJSONKey Bool where+    fromJSONKey = FromJSONKeyTextParser $ \t -> case t of+        "true"  -> pure True+        "false" -> pure False+        _       -> fail $ "Cannot parse key into Bool: " ++ T.unpack t++instance FromJSON Ordering where+  parseJSON = withText "Ordering" $ \s ->+    case s of+      "LT" -> return LT+      "EQ" -> return EQ+      "GT" -> return GT+      _ -> fail "Parsing Ordering value failed: expected \"LT\", \"EQ\", or \"GT\""++instance FromJSON () where+    parseJSON = withArray "()" $ \v ->+                  if V.null v+                    then pure ()+                    else fail "Expected an empty array"+    {-# INLINE parseJSON #-}++instance FromJSON Char where+    parseJSON = withText "Char" $ \t ->+                  if T.compareLength t 1 == EQ+                    then pure $ T.head t+                    else fail "Expected a string of length 1"+    {-# INLINE parseJSON #-}++    parseJSONList = withText "String" $ pure . T.unpack+    {-# INLINE parseJSONList #-}++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 Number where+    parseJSON (Number s) = pure $ scientificToNumber s+    parseJSON Null       = pure (D (0/0))+    parseJSON v          = typeMismatch "Number" v+    {-# INLINE parseJSON #-}++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 = withObject "Rational" $ \obj ->+                  (%) <$> obj .: "numerator"+                      <*> obj .: "denominator"+    {-# INLINE parseJSON #-}++-- | /WARNING:/ Only parse fixed-precision numbers from trusted input+-- since an attacker could easily fill up the memory of the target+-- system by specifying a scientific number with a big exponent like+-- @1e1000000000@.+instance HasResolution a => FromJSON (Fixed a) where+    parseJSON = withScientific "Fixed" $ pure . realToFrac+    {-# INLINE parseJSON #-}++instance FromJSON Int where+    parseJSON = parseBoundedIntegral "Int"+    {-# INLINE parseJSON #-}++instance FromJSONKey Int where+    fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"++-- | /WARNING:/ Only parse Integers from trusted input since an+-- attacker could easily fill up the memory of the target system by+-- specifying a scientific number with a big exponent like+-- @1e1000000000@.+instance FromJSON Integer where+    parseJSON = parseIntegral "Integer"+    {-# INLINE parseJSON #-}++instance FromJSONKey Integer where+    fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer"++instance FromJSON Natural where+    parseJSON = withScientific "Natural" $ \s ->+      if Scientific.coefficient s < 0+        then fail $ "Expected a Natural number but got the negative number: " <> show s+        else pure $ truncate s++instance FromJSONKey Natural where+    fromJSONKey = FromJSONKeyTextParser $ \t -> parseScientificText t >>= \s ->+      if Scientific.coefficient s < 0+        then fail $ "Expected a Natural number but got the negative number: " <> show s+        else pure $ truncate s++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 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 "could not parse Version"++-------------------------------------------------------------------------------+-- semigroups NonEmpty+-------------------------------------------------------------------------------++instance FromJSON1 NonEmpty where+    liftParseJSON p _ = withArray "NonEmpty a" $+        (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList+      where+        ne []     = fail "Expected a NonEmpty but got an 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 a" $+      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 #-}++-------------------------------------------------------------------------------+-- tranformers - 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, FromJSON 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 $+        "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 a" $+      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 k v" $+            fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)+        FromJSONKeyText f -> withObject "Map k v" $+            fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)+        FromJSONKeyTextParser f -> withObject "Map k v" $+            H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)+        FromJSONKeyValue f -> withArray "Map k v" $ \arr ->+            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 #-}++-------------------------------------------------------------------------------+-- vector+-------------------------------------------------------------------------------++instance FromJSON1 Vector where+    liftParseJSON p _ = withArray "Vector a" $+        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 a"++instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where+    parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"+    {-# INLINE parseJSON #-}++instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where+    parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"+    {-# 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 v" $+            uc . H.traverseWithKey (\k v -> p v <?> Key k)+        FromJSONKeyText f -> withObject "HashMap k v" $+            fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)+        FromJSONKeyTextParser f -> withObject "HashMap k v" $+            H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)+        FromJSONKeyValue f -> withArray "Map k v" $ \arr ->+            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 parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of+             Just d -> pure (DotNetTime d)+             _      -> fail "could not parse .NET time"+    {-# INLINE 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)+++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)+++-- | /WARNING:/ Only parse lengths of time from trusted input+-- since an attacker could easily fill up the memory of the target+-- system by specifying a scientific number with a big exponent like+-- @1e1000000000@.+instance FromJSON NominalDiffTime where+    parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac+    {-# INLINE parseJSON #-}++-------------------------------------------------------------------------------+-- base Monoid/Semigroup+-------------------------------------------------------------------------------++instance FromJSON1 Dual where+    liftParseJSON p _ = fmap Dual . p+    {-# INLINE liftParseJSON #-}++instance FromJSON a => FromJSON (Dual a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}+++instance FromJSON1 First where+    liftParseJSON p p' = fmap First . liftParseJSON p p'+    {-# INLINE liftParseJSON #-}++instance FromJSON a => FromJSON (First a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}+++instance FromJSON1 Last where+    liftParseJSON p p' = fmap Last . liftParseJSON p p'+    {-# INLINE liftParseJSON #-}++instance FromJSON a => FromJSON (Last a) where+    parseJSON = parseJSON1+    {-# INLINE parseJSON #-}++-------------------------------------------------------------------------------+-- tagged+-------------------------------------------------------------------------------++instance FromJSON (Proxy a) where+    {-# INLINE parseJSON #-}+    parseJSON Null = pure Proxy+    parseJSON v    = typeMismatch "Proxy" v+++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++-------------------------------------------------------------------------------+-- 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 $ \t ->+        if T.length t == 1+            then return (T.index t 0)+            else typeMismatch "Expected Char but String didn't contain exactly one character" (String t)+    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 #-}