{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
#include "incoherent-compat.h"
#include "overlapping-compat.h"
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Data.Aeson.Types.FromJSON
(
FromJSON(..)
, FromJSON1(..)
, parseJSON1
, FromJSON2(..)
, parseJSON2
, GFromJSON(..)
, FromArgs(..)
, genericParseJSON
, genericLiftParseJSON
, FromJSONKey(..)
, FromJSONKeyFunction(..)
, fromJSONKeyCoerce
, coerceFromJSONKeyFunction
, mapFromJSONKeyFunction
, GFromJSONKey()
, genericFromJSONKey
, listParser
, withObject
, withText
, withArray
, withScientific
, withBool
, withEmbeddedJSON
, fromJSON
, ifromJSON
, typeMismatch
, unexpected
, parseField
, parseFieldMaybe
, parseFieldMaybe'
, explicitParseField
, explicitParseFieldMaybe
, explicitParseFieldMaybe'
, parseIndexedJSON
, (.:)
, (.:?)
, (.:!)
, (.!=)
, parseOptionalFieldWith
) where
import Prelude.Compat
import Control.Applicative ((<|>), Const(..), liftA2)
import Control.Monad (zipWithM)
import Data.Aeson.Internal.Functions (mapKey)
import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
import Data.Aeson.Types.Generic
import Data.Aeson.Types.Internal
import Data.Bits (unsafeShiftR)
import Data.Fixed (Fixed, HasResolution (resolution), Nano)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Identity (Identity(..))
import Data.Functor.Product (Product(..))
import Data.Functor.Sum (Sum(..))
import Data.Functor.These (These1 (..))
import Data.Hashable (Hashable(..))
import Data.Int (Int16, Int32, Int64, Int8)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy(..))
import Data.Ratio ((%), Ratio)
import Data.Scientific (Scientific, base10Exponent)
import Data.Tagged (Tagged(..))
import Data.Text (Text, pack, unpack)
import Data.These (These (..))
import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
import Data.Time.Clock.System.Compat (SystemTime (..))
import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
import Data.Traversable as Tr (sequence)
import Data.Vector (Vector)
import Data.Version (Version, parseVersion)
import Data.Void (Void)
import Data.Word (Word16, Word32, Word64, Word8)
import Foreign.Storable (Storable)
import Foreign.C.Types (CTime (..))
import GHC.Generics
import Numeric.Natural (Natural)
import Text.ParserCombinators.ReadP (readP_to_S)
import Unsafe.Coerce (unsafeCoerce)
import qualified Data.Aeson.Parser.Time as Time
import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
import qualified Data.ByteString.Lazy as L
import qualified Data.DList as DList
import qualified Data.HashMap.Strict as H
import qualified Data.HashSet as HashSet
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as M
import qualified Data.Monoid as Monoid
import qualified Data.Scientific as Scientific
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Tree as Tree
import qualified Data.UUID.Types as UUID
import qualified Data.Vector as V
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
import qualified GHC.Exts as Exts
import qualified Data.Primitive.Array as PM
import qualified Data.Primitive.SmallArray as PM
import qualified Data.Primitive.Types as PM
#if MIN_VERSION_primitive(0,6,4)
#if !MIN_VERSION_primitive(0,7,0)
import qualified Data.Primitive.UnliftedArray as PM
#endif
import qualified Data.Primitive.PrimArray as PM
#endif
import Data.Coerce (Coercible, coerce)
parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
parseIndexedJSON p idx value = p value <?> Index idx
{-# INLINE parseIndexedJSON #-}
parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)
parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
where
p = withArray "(k, v)" $ \ab ->
let n = V.length ab
in if n == 2
then (,) <$> parseJSONElemAtIndex keyParser 0 ab
<*> parseJSONElemAtIndex valParser 1 ab
else fail $ "cannot unpack array of length " ++
show n ++ " into a pair"
{-# INLINE parseIndexedJSONPair #-}
parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a
parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx
parseRealFloat :: RealFloat a => String -> Value -> Parser a
parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s
parseRealFloat _ Null = pure (0/0)
parseRealFloat name v = prependContext name (unexpected v)
{-# INLINE parseRealFloat #-}
parseIntegralFromScientific :: forall a. Integral a => Scientific -> Parser a
parseIntegralFromScientific s =
case Scientific.floatingOrInteger s :: Either Double a of
Right x -> pure x
Left _ -> fail $ "unexpected floating number " ++ show s
{-# INLINE parseIntegralFromScientific #-}
parseIntegral :: Integral a => String -> Value -> Parser a
parseIntegral name =
prependContext name . withBoundedScientific' parseIntegralFromScientific
{-# INLINE parseIntegral #-}
parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => Scientific -> Parser a
parseBoundedIntegralFromScientific s = maybe
(fail $ "value is either floating or will cause over or underflow " ++ show s)
pure
(Scientific.toBoundedInteger s)
{-# INLINE parseBoundedIntegralFromScientific #-}
parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a
parseBoundedIntegral name =
prependContext name . withScientific' parseBoundedIntegralFromScientific
{-# INLINE parseBoundedIntegral #-}
parseScientificText :: Text -> Parser Scientific
parseScientificText
= either fail pure
. A.parseOnly (A.scientific <* A.endOfInput)
. T.encodeUtf8
parseIntegralText :: Integral a => String -> Text -> Parser a
parseIntegralText name t =
prependContext name $
parseScientificText t
>>= rejectLargeExponent
>>= parseIntegralFromScientific
where
rejectLargeExponent :: Scientific -> Parser Scientific
rejectLargeExponent s = withBoundedScientific' pure (Number s)
{-# INLINE parseIntegralText #-}
parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a
parseBoundedIntegralText name t =
prependContext name $
parseScientificText t >>= parseBoundedIntegralFromScientific
parseOptionalFieldWith :: (Value -> Parser (Maybe a))
-> Object -> Text -> Parser (Maybe a)
parseOptionalFieldWith pj obj key =
case H.lookup key obj of
Nothing -> pure Nothing
Just v -> pj v <?> Key key
{-# INLINE parseOptionalFieldWith #-}
class GFromJSON arity f where
gParseJSON :: Options -> FromArgs arity a -> Value -> Parser (f a)
data FromArgs arity a where
NoFromArgs :: FromArgs Zero a
From1Args :: (Value -> Parser a) -> (Value -> Parser [a]) -> FromArgs One a
genericParseJSON :: (Generic a, GFromJSON Zero (Rep a))
=> Options -> Value -> Parser a
genericParseJSON opts = fmap to . gParseJSON opts NoFromArgs
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 FromJSON a where
parseJSON :: Value -> Parser a
default parseJSON :: (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a
parseJSON = genericParseJSON defaultOptions
parseJSONList :: Value -> Parser [a]
parseJSONList = withArray "[]" $ \a ->
zipWithM (parseIndexedJSON parseJSON) [0..]
. V.toList
$ a
class FromJSONKey a where
fromJSONKey :: FromJSONKeyFunction a
default fromJSONKey :: FromJSON a => FromJSONKeyFunction a
fromJSONKey = FromJSONKeyValue parseJSON
fromJSONKeyList :: FromJSONKeyFunction [a]
default fromJSONKeyList :: FromJSON a => FromJSONKeyFunction [a]
fromJSONKeyList = FromJSONKeyValue parseJSON
data FromJSONKeyFunction a where
FromJSONKeyCoerce :: Coercible Text a => FromJSONKeyFunction a
FromJSONKeyText :: !(Text -> a) -> FromJSONKeyFunction a
FromJSONKeyTextParser :: !(Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyValue :: !(Value -> Parser a) -> FromJSONKeyFunction a
instance Functor FromJSONKeyFunction where
fmap h FromJSONKeyCoerce = FromJSONKeyText (h . coerce)
fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
fromJSONKeyCoerce ::
Coercible Text a =>
FromJSONKeyFunction a
fromJSONKeyCoerce = FromJSONKeyCoerce
coerceFromJSONKeyFunction ::
Coercible a b =>
FromJSONKeyFunction a -> FromJSONKeyFunction b
coerceFromJSONKeyFunction = coerce
{-# RULES
"FromJSONKeyCoerce: fmap coerce" forall x .
fmap coerce x = coerceFromJSONKeyFunction x
#-}
mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
mapFromJSONKeyFunction = fmap
genericFromJSONKey :: forall a. (Generic a, GFromJSONKey (Rep a))
=> JSONKeyOptions
-> FromJSONKeyFunction a
genericFromJSONKey opts = FromJSONKeyTextParser $ \t ->
case parseSumFromString (keyModifier opts) t of
Nothing -> fail $
"invalid key " ++ show t ++ ", expected one of " ++ show cnames
Just k -> pure (to k)
where
cnames = unTagged2 (constructorTags (keyModifier opts) :: Tagged2 (Rep a) [String])
class (ConstructorNames f, SumFromString f) => GFromJSONKey f where
instance (ConstructorNames f, SumFromString f) => GFromJSONKey f where
typeMismatch :: String
-> Value
-> Parser a
typeMismatch expected actual =
fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual
unexpected :: Value -> Parser a
unexpected actual = fail $ "unexpected " ++ typeOf actual
typeOf :: Value -> String
typeOf v = case v of
Object _ -> "Object"
Array _ -> "Array"
String _ -> "String"
Number _ -> "Number"
Bool _ -> "Boolean"
Null -> "Null"
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
parseJSON1 :: (FromJSON1 f, FromJSON a) => Value -> Parser (f a)
parseJSON1 = liftParseJSON parseJSON parseJSONList
{-# INLINE parseJSON1 #-}
class FromJSON2 f where
liftParseJSON2
:: (Value -> Parser a)
-> (Value -> Parser [a])
-> (Value -> Parser b)
-> (Value -> Parser [b])
-> Value -> Parser (f a b)
liftParseJSONList2
:: (Value -> Parser a)
-> (Value -> Parser [a])
-> (Value -> Parser b)
-> (Value -> Parser [b])
-> Value -> Parser [f a b]
liftParseJSONList2 fa ga fb gb = withArray "[]" $ \vals ->
fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)
parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
{-# INLINE parseJSON2 #-}
listParser :: (Value -> Parser a) -> Value -> Parser [a]
listParser f (Array xs) = fmap V.toList (V.mapM f xs)
listParser _ v = typeMismatch "Array" v
{-# INLINE listParser #-}
instance FromJSON1 [] where
liftParseJSON _ p' = p'
{-# INLINE liftParseJSON #-}
instance (FromJSON a) => FromJSON [a] where
parseJSON = parseJSON1
prependContext :: String -> Parser a -> Parser a
prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")
withObject :: String -> (Object -> Parser a) -> Value -> Parser a
withObject _ f (Object obj) = f obj
withObject name _ v = prependContext name (typeMismatch "Object" v)
{-# INLINE withObject #-}
withText :: String -> (Text -> Parser a) -> Value -> Parser a
withText _ f (String txt) = f txt
withText name _ v = prependContext name (typeMismatch "String" v)
{-# INLINE withText #-}
withArray :: String -> (Array -> Parser a) -> Value -> Parser a
withArray _ f (Array arr) = f arr
withArray name _ v = prependContext name (typeMismatch "Array" v)
{-# INLINE withArray #-}
withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
withScientific _ f (Number scientific) = f scientific
withScientific name _ v = prependContext name (typeMismatch "Number" v)
{-# INLINE withScientific #-}
withScientific' :: (Scientific -> Parser a) -> Value -> Parser a
withScientific' f v = case v of
Number n -> f n
_ -> typeMismatch "Number" v
{-# INLINE withScientific' #-}
withBoundedScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
withBoundedScientific name f v = withBoundedScientific_ (prependContext name) f v
{-# INLINE withBoundedScientific #-}
withBoundedScientific' :: (Scientific -> Parser a) -> Value -> Parser a
withBoundedScientific' f v = withBoundedScientific_ id f v
{-# INLINE withBoundedScientific' #-}
withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
withBoundedScientific_ whenFail f (Number scientific) =
if exp10 > 1024
then whenFail (fail msg)
else f scientific
where
exp10 = base10Exponent scientific
msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"
withBoundedScientific_ whenFail _ v =
whenFail (typeMismatch "Number" v)
{-# INLINE withBoundedScientific_ #-}
withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
withBool _ f (Bool arr) = f arr
withBool name _ v = prependContext name (typeMismatch "Boolean" v)
{-# INLINE withBool #-}
withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
withEmbeddedJSON _ innerParser (String txt) =
either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
where
eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
eitherFormatError = either (Left . uncurry formatError) Right
withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v)
{-# INLINE withEmbeddedJSON #-}
fromJSON :: (FromJSON a) => Value -> Result a
fromJSON = parse parseJSON
{-# INLINE fromJSON #-}
ifromJSON :: (FromJSON a) => Value -> IResult a
ifromJSON = iparse parseJSON
{-# INLINE ifromJSON #-}
(.:) :: (FromJSON a) => Object -> Text -> Parser a
(.:) = explicitParseField parseJSON
{-# INLINE (.:) #-}
(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
(.:?) = explicitParseFieldMaybe parseJSON
{-# INLINE (.:?) #-}
(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
(.:!) = explicitParseFieldMaybe' parseJSON
{-# INLINE (.:!) #-}
parseField :: (FromJSON a) => Object -> Text -> Parser a
parseField = (.:)
{-# INLINE parseField #-}
parseFieldMaybe :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
parseFieldMaybe = (.:?)
{-# INLINE parseFieldMaybe #-}
parseFieldMaybe' :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
parseFieldMaybe' = (.:!)
{-# INLINE parseFieldMaybe' #-}
explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
explicitParseField p obj key = case H.lookup key obj of
Nothing -> fail $ "key " ++ show key ++ " not found"
Just v -> p v <?> Key key
{-# INLINE explicitParseField #-}
explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)
explicitParseFieldMaybe p obj key = case H.lookup key obj of
Nothing -> pure Nothing
Just v -> liftParseJSON p (listParser p) v <?> Key key
{-# INLINE explicitParseFieldMaybe #-}
explicitParseFieldMaybe' :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)
explicitParseFieldMaybe' p obj key = case H.lookup key obj of
Nothing -> pure Nothing
Just v -> Just <$> p v <?> Key key
{-# INLINE explicitParseFieldMaybe' #-}
(.!=) :: Parser (Maybe a) -> a -> Parser a
pmval .!= val = fromMaybe val <$> pmval
{-# INLINE (.!=) #-}
instance GFromJSON arity V1 where
gParseJSON _ _ _ = fail "Attempted to parse empty type"
instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where
gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs
type TypeName = String
type ConName = String
contextType :: TypeName -> Parser a -> Parser a
contextType = prependContext
contextTag :: Text -> [String] -> Parser a -> Parser a
contextTag tagKey cnames = prependFailure
("expected Object with key \"" ++ unpack tagKey ++ "\"" ++
" containing one of " ++ show cnames ++ ", ")
contextCons :: ConName -> TypeName -> Parser a -> Parser a
contextCons cname tname = prependContext (showCons cname tname)
showCons :: ConName -> TypeName -> String
showCons cname tname = tname ++ "(" ++ cname ++ ")"
instance (FromJSON a) => GFromJSON arity (K1 i a) where
gParseJSON _opts _ = fmap K1 . parseJSON
instance GFromJSON One Par1 where
gParseJSON _opts (From1Args pj _) = fmap Par1 . pj
instance (FromJSON1 f) => GFromJSON One (Rec1 f) where
gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl
instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
gParseJSON opts fargs =
let gpj = gParseJSON opts fargs in
fmap Comp1 . liftParseJSON gpj (listParser gpj)
instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where
gParseJSON opts fargs = fmap M1 . gParseJSON' (tname :* opts :* fargs)
where
tname = moduleName proxy ++ "." ++ datatypeName proxy
proxy = undefined :: M1 _i d _f _p
class GFromJSON' arity f where
gParseJSON' :: TypeName :* Options :* FromArgs arity a
-> Value
-> Parser (f a)
instance ( ConsFromJSON arity a
, AllNullary (C1 c a) allNullary
, ParseSum arity (C1 c a) allNullary
, Constructor c
) => GFromJSON' arity (C1 c a) where
gParseJSON' p@(_ :* opts :* _)
| tagSingleConstructors opts
= (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))
. parseSum p
| otherwise = fmap M1 . consParseJSON (cname :* p)
where
cname = conName (undefined :: M1 _i c _f _p)
instance ( AllNullary (a :+: b) allNullary
, ParseSum arity (a :+: b) allNullary
) => GFromJSON' arity (a :+: b) where
gParseJSON' p =
(unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->
Parser ((a :+: b) _d))
. parseSum p
class ParseSum arity f allNullary where
parseSum :: TypeName :* Options :* FromArgs arity a
-> Value
-> Tagged allNullary (Parser (f a))
instance ( ConstructorNames f
, SumFromString f
, FromPair arity f
, FromTaggedObject arity f
, FromUntaggedValue arity f
) => ParseSum arity f True where
parseSum p@(tname :* opts :* _)
| allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts
| otherwise = Tagged . parseNonAllNullarySum p
instance ( ConstructorNames f
, FromPair arity f
, FromTaggedObject arity f
, FromUntaggedValue arity f
) => ParseSum arity f False where
parseSum p = Tagged . parseNonAllNullarySum p
parseAllNullarySum :: (SumFromString f, ConstructorNames f)
=> TypeName -> Options -> Value -> Parser (f a)
parseAllNullarySum tname opts =
withText tname $ \tag ->
maybe (badTag tag) return $
parseSumFromString modifier tag
where
badTag tag = failWithCTags tname modifier $ \cnames ->
"expected one of the tags " ++ show cnames ++
", but found tag " ++ show tag
modifier = constructorTagModifier opts
failWithCTags
:: forall f a t. ConstructorNames f
=> TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)
failWithCTags tname modifier f =
contextType tname . fail $ f cnames
where
cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])
class SumFromString f where
parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
(R1 <$> parseSumFromString opts key)
instance (Constructor c) => SumFromString (C1 c U1) where
parseSumFromString modifier key
| key == name = Just $ M1 U1
| otherwise = Nothing
where
name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)
instance SumFromString a => SumFromString (D1 d a) where
parseSumFromString modifier key = M1 <$> parseSumFromString modifier key
constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]
constructorTags modifier =
fmap DList.toList (constructorNames' modifier)
class ConstructorNames a where
constructorNames' :: (String -> t) -> Tagged2 a (DList.DList t)
instance (ConstructorNames a, ConstructorNames b) => ConstructorNames (a :+: b) where
constructorNames' = liftA2 append constructorNames' constructorNames'
where
append
:: Tagged2 a (DList.DList t)
-> Tagged2 b (DList.DList t)
-> Tagged2 (a :+: b) (DList.DList t)
append (Tagged2 xs) (Tagged2 ys) = Tagged2 (DList.append xs ys)
instance Constructor c => ConstructorNames (C1 c a) where
constructorNames' f = Tagged2 (pure (f cname))
where
cname = conName (undefined :: M1 _i c _f _p)
instance ConstructorNames a => ConstructorNames (D1 d a) where
constructorNames' = retag . constructorNames'
where
retag :: Tagged2 a u -> Tagged2 (D1 d a) u
retag (Tagged2 x) = Tagged2 x
parseNonAllNullarySum :: forall f c arity.
( FromPair arity f
, FromTaggedObject arity f
, FromUntaggedValue arity f
, ConstructorNames f
) => TypeName :* Options :* FromArgs arity c
-> Value -> Parser (f c)
parseNonAllNullarySum p@(tname :* opts :* _) =
case sumEncoding opts of
TaggedObject{..} ->
withObject tname $ \obj -> do
tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
fromMaybe (badTag tag <?> Key tagKey) $
parseFromTaggedObject (tag :* contentsFieldName :* p) obj
where
tagKey = pack tagFieldName
badTag tag = failWith_ $ \cnames ->
"expected tag field to be one of " ++ show cnames ++
", but found tag " ++ show tag
cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
ObjectWithSingleField ->
withObject tname $ \obj -> case H.toList obj of
[(tag, v)] -> maybe (badTag tag) (<?> Key tag) $
parsePair (tag :* p) v
_ -> contextType tname . fail $
"expected an Object with a single pair, but found " ++
show (H.size obj) ++ " pairs"
where
badTag tag = failWith_ $ \cnames ->
"expected an Object with a single pair where the tag is one of " ++
show cnames ++ ", but found tag " ++ show tag
TwoElemArray ->
withArray tname $ \arr -> case V.length arr of
2 | String tag <- V.unsafeIndex arr 0 ->
maybe (badTag tag <?> Index 0) (<?> Index 1) $
parsePair (tag :* p) (V.unsafeIndex arr 1)
| otherwise ->
contextType tname $
fail "tag element is not a String" <?> Index 0
len -> contextType tname . fail $
"expected a 2-element Array, but encountered an Array of length " ++
show len
where
badTag tag = failWith_ $ \cnames ->
"expected tag of the 2-element Array to be one of " ++
show cnames ++ ", but found tag " ++ show tag
UntaggedValue -> parseUntaggedValue p
where
failWith_ = failWithCTags tname (constructorTagModifier opts)
class FromTaggedObject arity f where
parseFromTaggedObject
:: Text :* String :* TypeName :* Options :* FromArgs arity a
-> Object
-> Maybe (Parser (f a))
instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
FromTaggedObject arity (a :+: b) where
parseFromTaggedObject p obj =
(fmap L1 <$> parseFromTaggedObject p obj) <|>
(fmap R1 <$> parseFromTaggedObject p obj)
instance ( IsRecord f isRecord
, FromTaggedObject' arity f isRecord
, Constructor c
) => FromTaggedObject arity (C1 c f) where
parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))
| tag == tag'
= Just . fmap M1 .
(unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
parseFromTaggedObject' (contentsFieldName :* cname :* p)
| otherwise = const Nothing
where
tag' = pack $ constructorTagModifier opts cname
cname = conName (undefined :: M1 _i c _f _p)
class FromTaggedObject' arity f isRecord where
parseFromTaggedObject'
:: String :* ConName :* TypeName :* Options :* FromArgs arity a
-> Object -> Tagged isRecord (Parser (f a))
instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
parseFromTaggedObject' p obj = Tagged $ do
contents <- contextCons cname tname (obj .: key)
consParseJSON p' contents <?> Key key
where
key = pack contentsFieldName
contentsFieldName :* p'@(cname :* tname :* _) = p
instance OVERLAPPING_ FromTaggedObject' arity U1 False where
parseFromTaggedObject' _ _ = Tagged (pure U1)
class ConsFromJSON arity f where
consParseJSON
:: ConName :* TypeName :* Options :* FromArgs arity a
-> Value -> Parser (f a)
class ConsFromJSON' arity f isRecord where
consParseJSON'
:: ConName :* TypeName :* Options :* FromArgs arity a
-> Value -> Tagged isRecord (Parser (f a))
instance ( IsRecord f isRecord
, ConsFromJSON' arity f isRecord
) => ConsFromJSON arity f where
consParseJSON p =
(unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
. consParseJSON' p
instance OVERLAPPING_
( GFromJSON arity a, RecordFromJSON arity (S1 s a)
) => ConsFromJSON' arity (S1 s a) True where
consParseJSON' p@(cname :* tname :* opts :* fargs)
| unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
| otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
instance RecordFromJSON arity f => ConsFromJSON' arity f True where
consParseJSON' p@(cname :* tname :* _) =
Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
instance OVERLAPPING_
ConsFromJSON' arity U1 False where
consParseJSON' (cname :* tname :* _) v =
Tagged . contextCons cname tname $ case v of
Array a | V.null a -> pure U1
| otherwise -> fail_ a
_ -> typeMismatch "Array" v
where
fail_ a = fail $
"expected an empty Array, but encountered an Array of length " ++
show (V.length a)
instance OVERLAPPING_
GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where
consParseJSON' (_ :* _ :* opts :* fargs) =
Tagged . fmap M1 . gParseJSON opts fargs
instance (ProductFromJSON arity f, ProductSize f
) => ConsFromJSON' arity f False where
consParseJSON' p = Tagged . productParseJSON0 p
class FieldNames f where
fieldNames :: f a -> [String] -> [String]
instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where
fieldNames _ =
fieldNames (undefined :: a x) .
fieldNames (undefined :: b y)
instance (Selector s) => FieldNames (S1 s f) where
fieldNames _ = (selName (undefined :: M1 _i s _f _p) :)
class RecordFromJSON arity f where
recordParseJSON
:: Bool :* ConName :* TypeName :* Options :* FromArgs arity a
-> Object -> Parser (f a)
instance ( FieldNames f
, RecordFromJSON' arity f
) => RecordFromJSON arity f where
recordParseJSON (fromTaggedSum :* p@(cname :* tname :* opts :* _)) =
\obj -> checkUnknown obj >> recordParseJSON' p obj
where
knownFields :: H.HashMap Text ()
knownFields = H.fromList $ map ((,()) . pack) $
[tagFieldName (sumEncoding opts) | fromTaggedSum] <>
(fieldLabelModifier opts <$> fieldNames (undefined :: f a) [])
checkUnknown =
if not (rejectUnknownFields opts)
then \_ -> return ()
else \obj -> case H.keys (H.difference obj knownFields) of
[] -> return ()
unknownFields -> contextCons cname tname $
fail ("unknown fields: " ++ show unknownFields)
class RecordFromJSON' arity f where
recordParseJSON'
:: ConName :* TypeName :* Options :* FromArgs arity a
-> Object -> Parser (f a)
instance ( RecordFromJSON' arity a
, RecordFromJSON' arity b
) => RecordFromJSON' arity (a :*: b) where
recordParseJSON' p obj =
(:*:) <$> recordParseJSON' p obj
<*> recordParseJSON' p obj
instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
RecordFromJSON' arity (S1 s a) where
recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
fv <- contextCons cname tname (obj .: label)
M1 <$> gParseJSON opts fargs fv <?> Key label
where
label = pack $ fieldLabelModifier opts sname
sname = selName (undefined :: M1 _i s _f _p)
instance INCOHERENT_ (Selector s, FromJSON a) =>
RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
where
label = fieldLabelModifier opts sname
sname = selName (undefined :: M1 _i s _f _p)
instance INCOHERENT_ (Selector s, FromJSON a) =>
RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
where
wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
productParseJSON0
:: forall f arity a. (ProductFromJSON arity f, ProductSize f)
=> ConName :* TypeName :* Options :* FromArgs arity a
-> Value -> Parser (f a)
productParseJSON0 p@(cname :* tname :* _ :* _) =
withArray (showCons cname tname) $ \arr ->
let lenArray = V.length arr
lenProduct = (unTagged2 :: Tagged2 f Int -> Int)
productSize in
if lenArray == lenProduct
then productParseJSON p arr 0 lenProduct
else contextCons cname tname $
fail $ "expected an Array of length " ++ show lenProduct ++
", but encountered an Array of length " ++ show lenArray
class ProductFromJSON arity f where
productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a
-> Array -> Int -> Int
-> Parser (f a)
instance ( ProductFromJSON arity a
, ProductFromJSON arity b
) => ProductFromJSON arity (a :*: b) where
productParseJSON p arr ix len =
(:*:) <$> productParseJSON p arr ix lenL
<*> productParseJSON p arr ixR lenR
where
lenL = len `unsafeShiftR` 1
ixR = ix + lenL
lenR = len - lenL
instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where
productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =
M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix
class FromPair arity f where
parsePair :: Text :* TypeName :* Options :* FromArgs arity a
-> Value
-> Maybe (Parser (f a))
instance ( FromPair arity a
, FromPair arity b
) => FromPair arity (a :+: b) where
parsePair p pair =
(fmap L1 <$> parsePair p pair) <|>
(fmap R1 <$> parsePair p pair)
instance ( Constructor c
, ConsFromJSON arity a
) => FromPair arity (C1 c a) where
parsePair (tag :* p@(_ :* opts :* _)) v
| tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v
| otherwise = Nothing
where
tag' = pack $ constructorTagModifier opts cname
cname = conName (undefined :: M1 _i c _a _p)
class FromUntaggedValue arity f where
parseUntaggedValue :: TypeName :* Options :* FromArgs arity a
-> Value
-> Parser (f a)
instance
( FromUntaggedValue arity a
, FromUntaggedValue arity b
) => FromUntaggedValue arity (a :+: b)
where
parseUntaggedValue p value =
L1 <$> parseUntaggedValue p value <|>
R1 <$> parseUntaggedValue p value
instance OVERLAPPABLE_
( ConsFromJSON arity a
, Constructor c
) => FromUntaggedValue arity (C1 c a)
where
parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)
where
cname = conName (undefined :: M1 _i c _f _p)
instance OVERLAPPING_
( Constructor c )
=> FromUntaggedValue arity (C1 c U1)
where
parseUntaggedValue (tname :* opts :* _) v =
contextCons cname tname $ case v of
String tag
| tag == tag' -> pure $ M1 U1
| otherwise -> fail_ tag
_ -> typeMismatch "String" v
where
tag' = pack $ constructorTagModifier opts cname
cname = conName (undefined :: M1 _i c _f _p)
fail_ tag = fail $
"expected tag " ++ show tag' ++ ", but found tag " ++ show tag
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 Void where
parseJSON _ = fail "Cannot parse Void"
{-# INLINE parseJSON #-}
instance FromJSON Bool where
parseJSON (Bool b) = pure b
parseJSON v = typeMismatch "Bool" v
{-# INLINE parseJSON #-}
instance FromJSONKey Bool where
fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
"true" -> pure True
"false" -> pure False
_ -> fail $ "cannot parse key " ++ show t ++ " into Bool"
instance FromJSON Ordering where
parseJSON = withText "Ordering" $ \s ->
case s of
"LT" -> return LT
"EQ" -> return EQ
"GT" -> return GT
_ -> fail $ "parsing Ordering failed, unexpected " ++ show s ++
" (expected \"LT\", \"EQ\", or \"GT\")"
instance FromJSON () where
parseJSON = withArray "()" $ \v ->
if V.null v
then pure ()
else prependContext "()" $ fail "expected an empty array"
{-# INLINE parseJSON #-}
instance FromJSON Char where
parseJSON = withText "Char" parseChar
{-# INLINE parseJSON #-}
parseJSONList (String s) = pure (T.unpack s)
parseJSONList v = typeMismatch "String" v
{-# INLINE parseJSONList #-}
parseChar :: Text -> Parser Char
parseChar t =
if T.compareLength t 1 == EQ
then pure $ T.head t
else prependContext "Char" $ fail "expected a string of length 1"
instance FromJSON Double where
parseJSON = parseRealFloat "Double"
{-# INLINE parseJSON #-}
instance FromJSONKey Double where
fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
"NaN" -> pure (0/0)
"Infinity" -> pure (1/0)
"-Infinity" -> pure (negate 1/0)
_ -> Scientific.toRealFloat <$> parseScientificText t
instance FromJSON Float where
parseJSON = parseRealFloat "Float"
{-# INLINE parseJSON #-}
instance FromJSONKey Float where
fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
"NaN" -> pure (0/0)
"Infinity" -> pure (1/0)
"-Infinity" -> pure (negate 1/0)
_ -> Scientific.toRealFloat <$> parseScientificText t
instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
parseJSON (Number x)
| exp10 <= 1024
, exp10 >= -1024 = return $! realToFrac x
| otherwise = prependContext "Ratio" $ fail msg
where
exp10 = base10Exponent x
msg = "found a number with exponent " ++ show exp10
++ ", but it must not be greater than 1024 or less than -1024"
parseJSON o = objParser o
where
objParser = withObject "Rational" $ \obj -> do
numerator <- obj .: "numerator"
denominator <- obj .: "denominator"
if denominator == 0
then fail "Ratio denominator was 0"
else pure $ numerator % denominator
{-# INLINE parseJSON #-}
instance HasResolution a => FromJSON (Fixed a) where
parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac)
{-# INLINE parseJSON #-}
instance FromJSON Int where
parseJSON = parseBoundedIntegral "Int"
{-# INLINE parseJSON #-}
instance FromJSONKey Int where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"
instance FromJSON Integer where
parseJSON = parseIntegral "Integer"
{-# INLINE parseJSON #-}
instance FromJSONKey Integer where
fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer"
instance FromJSON Natural where
parseJSON value = do
integer <- parseIntegral "Natural" value
parseNatural integer
instance FromJSONKey Natural where
fromJSONKey = FromJSONKeyTextParser $ \text -> do
integer <- parseIntegralText "Natural" text
parseNatural integer
parseNatural :: Integer -> Parser Natural
parseNatural integer =
if integer < 0 then
fail $ "parsing Natural failed, unexpected negative number " <> show integer
else
pure $ fromIntegral integer
instance FromJSON Int8 where
parseJSON = parseBoundedIntegral "Int8"
{-# INLINE parseJSON #-}
instance FromJSONKey Int8 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int8"
instance FromJSON Int16 where
parseJSON = parseBoundedIntegral "Int16"
{-# INLINE parseJSON #-}
instance FromJSONKey Int16 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int16"
instance FromJSON Int32 where
parseJSON = parseBoundedIntegral "Int32"
{-# INLINE parseJSON #-}
instance FromJSONKey Int32 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int32"
instance FromJSON Int64 where
parseJSON = parseBoundedIntegral "Int64"
{-# INLINE parseJSON #-}
instance FromJSONKey Int64 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int64"
instance FromJSON Word where
parseJSON = parseBoundedIntegral "Word"
{-# INLINE parseJSON #-}
instance FromJSONKey Word where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word"
instance FromJSON Word8 where
parseJSON = parseBoundedIntegral "Word8"
{-# INLINE parseJSON #-}
instance FromJSONKey Word8 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word8"
instance FromJSON Word16 where
parseJSON = parseBoundedIntegral "Word16"
{-# INLINE parseJSON #-}
instance FromJSONKey Word16 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word16"
instance FromJSON Word32 where
parseJSON = parseBoundedIntegral "Word32"
{-# INLINE parseJSON #-}
instance FromJSONKey Word32 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word32"
instance FromJSON Word64 where
parseJSON = parseBoundedIntegral "Word64"
{-# INLINE parseJSON #-}
instance FromJSONKey Word64 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64"
instance FromJSON CTime where
parseJSON = fmap CTime . parseJSON
{-# INLINE parseJSON #-}
instance FromJSON Text where
parseJSON = withText "Text" pure
{-# INLINE parseJSON #-}
instance FromJSONKey Text where
fromJSONKey = fromJSONKeyCoerce
instance FromJSON LT.Text where
parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
{-# INLINE parseJSON #-}
instance FromJSONKey LT.Text where
fromJSONKey = FromJSONKeyText LT.fromStrict
instance FromJSON Version where
parseJSON = withText "Version" parseVersionText
{-# INLINE parseJSON #-}
instance FromJSONKey Version where
fromJSONKey = FromJSONKeyTextParser parseVersionText
parseVersionText :: Text -> Parser Version
parseVersionText = go . readP_to_S parseVersion . unpack
where
go [(v,[])] = return v
go (_ : xs) = go xs
go _ = fail "parsing Version failed"
instance FromJSON1 NonEmpty where
liftParseJSON p _ = withArray "NonEmpty" $
(>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
where
ne [] = fail "parsing NonEmpty failed, unexpected empty list"
ne (x:xs) = pure (x :| xs)
{-# INLINE liftParseJSON #-}
instance (FromJSON a) => FromJSON (NonEmpty a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSON Scientific where
parseJSON = withScientific "Scientific" pure
{-# INLINE parseJSON #-}
instance FromJSON1 DList.DList where
liftParseJSON p _ = withArray "DList" $
fmap DList.fromList .
Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
{-# INLINE liftParseJSON #-}
instance (FromJSON a) => FromJSON (DList.DList a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSON1 Identity where
liftParseJSON p _ a = Identity <$> p a
{-# INLINE liftParseJSON #-}
liftParseJSONList _ p a = fmap Identity <$> p a
{-# INLINE liftParseJSONList #-}
instance (FromJSON a) => FromJSON (Identity a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
parseJSONList = liftParseJSONList parseJSON parseJSONList
{-# INLINE parseJSONList #-}
instance (FromJSONKey a) => FromJSONKey (Identity a) where
fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a)
fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])
instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Compose f g) where
liftParseJSON p pl a = Compose <$> liftParseJSON g gl a
where
g = liftParseJSON p pl
gl = liftParseJSONList p pl
{-# INLINE liftParseJSON #-}
liftParseJSONList p pl a = map Compose <$> liftParseJSONList g gl a
where
g = liftParseJSON p pl
gl = liftParseJSONList p pl
{-# INLINE liftParseJSONList #-}
instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Compose f g a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
parseJSONList = liftParseJSONList parseJSON parseJSONList
{-# INLINE parseJSONList #-}
instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Product f g) where
liftParseJSON p pl a = uncurry Pair <$> liftParseJSON2 px pxl py pyl a
where
px = liftParseJSON p pl
pxl = liftParseJSONList p pl
py = liftParseJSON p pl
pyl = liftParseJSONList p pl
{-# INLINE liftParseJSON #-}
instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Product f g a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where
liftParseJSON p pl (Object (H.toList -> [(key, value)]))
| key == inl = InL <$> liftParseJSON p pl value <?> Key inl
| key == inr = InR <$> liftParseJSON p pl value <?> Key inl
where
inl, inr :: Text
inl = "InL"
inr = "InR"
liftParseJSON _ _ _ = fail $
"parsing Sum failed, expected an object with a single property " ++
"where the property key should be either " ++
"\"InL\" or \"InR\""
{-# INLINE liftParseJSON #-}
instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSON1 Seq.Seq where
liftParseJSON p _ = withArray "Seq" $
fmap Seq.fromList .
Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
{-# INLINE liftParseJSON #-}
instance (FromJSON a) => FromJSON (Seq.Seq a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
parseJSON = fmap Set.fromList . parseJSON
{-# INLINE parseJSON #-}
instance FromJSON IntSet.IntSet where
parseJSON = fmap IntSet.fromList . parseJSON
{-# INLINE parseJSON #-}
instance FromJSON1 IntMap.IntMap where
liftParseJSON p pl = fmap IntMap.fromList . liftParseJSON p' pl'
where
p' = liftParseJSON2 parseJSON parseJSONList p pl
pl' = liftParseJSONList2 parseJSON parseJSONList p pl
{-# INLINE liftParseJSON #-}
instance FromJSON a => FromJSON (IntMap.IntMap a) where
parseJSON = fmap IntMap.fromList . parseJSON
{-# INLINE parseJSON #-}
instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
liftParseJSON p _ = case fromJSONKey of
FromJSONKeyCoerce -> withObject "Map" $
fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
FromJSONKeyText f -> withObject "Map" $
fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
FromJSONKeyTextParser f -> withObject "Map" $
H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)
FromJSONKeyValue f -> withArray "Map" $ \arr ->
fmap M.fromList . Tr.sequence .
zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
{-# INLINE liftParseJSON #-}
instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (M.Map k v) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSON1 Tree.Tree where
liftParseJSON p pl = go
where
go v = uncurry Tree.Node <$> liftParseJSON2 p pl p' pl' v
p' = liftParseJSON go (listParser go)
pl'= liftParseJSONList go (listParser go)
instance (FromJSON v) => FromJSON (Tree.Tree v) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSON UUID.UUID where
parseJSON = withText "UUID" $
maybe (fail "invalid UUID") pure . UUID.fromText
instance FromJSONKey UUID.UUID where
fromJSONKey = FromJSONKeyTextParser $
maybe (fail "invalid UUID") pure . UUID.fromText
instance FromJSON1 Vector where
liftParseJSON p _ = withArray "Vector" $
V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
{-# INLINE liftParseJSON #-}
instance (FromJSON a) => FromJSON (Vector a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry $ parseIndexedJSON parseJSON) . V.indexed
{-# INLINE vectorParseJSON #-}
instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
parseJSON = vectorParseJSON "Data.Vector.Storable.Vector"
instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector"
{-# INLINE parseJSON #-}
instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector"
{-# INLINE parseJSON #-}
instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
parseJSON = fmap HashSet.fromList . parseJSON
{-# INLINE parseJSON #-}
instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
liftParseJSON p _ = case fromJSONKey of
FromJSONKeyCoerce -> withObject "HashMap ~Text" $
uc . H.traverseWithKey (\k v -> p v <?> Key k)
FromJSONKeyText f -> withObject "HashMap" $
fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)
FromJSONKeyTextParser f -> withObject "HashMap" $
H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)
FromJSONKeyValue f -> withArray "Map" $ \arr ->
fmap H.fromList . Tr.sequence .
zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
where
uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v)
uc = unsafeCoerce
instance (FromJSON v, FromJSONKey k, Eq k, Hashable k) => FromJSON (H.HashMap k v) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSON Value where
parseJSON = pure
{-# INLINE parseJSON #-}
instance FromJSON DotNetTime where
parseJSON = withText "DotNetTime" $ \t ->
let (s,m) = T.splitAt (T.length t - 5) t
t' = T.concat [s,".",m]
in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
Just d -> pure (DotNetTime d)
_ -> fail "could not parse .NET time"
{-# INLINE parseJSON #-}
instance FromJSON a => FromJSON (PM.Array a) where
parseJSON = fmap Exts.fromList . parseJSON
instance FromJSON a => FromJSON (PM.SmallArray a) where
parseJSON = fmap Exts.fromList . parseJSON
#if MIN_VERSION_primitive(0,6,4)
instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where
parseJSON = fmap Exts.fromList . parseJSON
#if !MIN_VERSION_primitive(0,7,0)
instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
parseJSON = fmap Exts.fromList . parseJSON
#endif
#endif
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)
instance FromJSON NominalDiffTime where
parseJSON = withBoundedScientific "NominalDiffTime" $ pure . realToFrac
{-# INLINE parseJSON #-}
instance FromJSON DiffTime where
parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
{-# INLINE parseJSON #-}
instance FromJSON SystemTime where
parseJSON v = prependContext "SystemTime" $ do
n <- parseJSON v
let n' = floor (n * fromInteger (resolution n) :: Nano)
let (secs, nano) = n' `divMod` resolution n
return (MkSystemTime (fromInteger secs) (fromInteger nano))
instance FromJSON CalendarDiffTime where
parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime
<$> obj .: "months"
<*> obj .: "time"
instance FromJSON CalendarDiffDays where
parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays
<$> obj .: "months"
<*> obj .: "days"
instance FromJSON DayOfWeek where
parseJSON = withText "DaysOfWeek" parseDayOfWeek
parseDayOfWeek :: T.Text -> Parser DayOfWeek
parseDayOfWeek t = case T.toLower t of
"monday" -> return Monday
"tuesday" -> return Tuesday
"wednesday" -> return Wednesday
"thursday" -> return Thursday
"friday" -> return Friday
"saturday" -> return Saturday
"sunday" -> return Sunday
_ -> fail "Invalid week day"
instance FromJSONKey DayOfWeek where
fromJSONKey = FromJSONKeyTextParser parseDayOfWeek
instance FromJSON1 Monoid.Dual where
liftParseJSON p _ = fmap Monoid.Dual . p
{-# INLINE liftParseJSON #-}
instance FromJSON a => FromJSON (Monoid.Dual a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSON1 Monoid.First where
liftParseJSON p p' = fmap Monoid.First . liftParseJSON p p'
{-# INLINE liftParseJSON #-}
instance FromJSON a => FromJSON (Monoid.First a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSON1 Monoid.Last where
liftParseJSON p p' = fmap Monoid.Last . liftParseJSON p p'
{-# INLINE liftParseJSON #-}
instance FromJSON a => FromJSON (Monoid.Last a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSON1 Semigroup.Min where
liftParseJSON p _ a = Semigroup.Min <$> p a
{-# INLINE liftParseJSON #-}
liftParseJSONList _ p a = fmap Semigroup.Min <$> p a
{-# INLINE liftParseJSONList #-}
instance (FromJSON a) => FromJSON (Semigroup.Min a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
parseJSONList = liftParseJSONList parseJSON parseJSONList
{-# INLINE parseJSONList #-}
instance FromJSON1 Semigroup.Max where
liftParseJSON p _ a = Semigroup.Max <$> p a
{-# INLINE liftParseJSON #-}
liftParseJSONList _ p a = fmap Semigroup.Max <$> p a
{-# INLINE liftParseJSONList #-}
instance (FromJSON a) => FromJSON (Semigroup.Max a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
parseJSONList = liftParseJSONList parseJSON parseJSONList
{-# INLINE parseJSONList #-}
instance FromJSON1 Semigroup.First where
liftParseJSON p _ a = Semigroup.First <$> p a
{-# INLINE liftParseJSON #-}
liftParseJSONList _ p a = fmap Semigroup.First <$> p a
{-# INLINE liftParseJSONList #-}
instance (FromJSON a) => FromJSON (Semigroup.First a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
parseJSONList = liftParseJSONList parseJSON parseJSONList
{-# INLINE parseJSONList #-}
instance FromJSON1 Semigroup.Last where
liftParseJSON p _ a = Semigroup.Last <$> p a
{-# INLINE liftParseJSON #-}
liftParseJSONList _ p a = fmap Semigroup.Last <$> p a
{-# INLINE liftParseJSONList #-}
instance (FromJSON a) => FromJSON (Semigroup.Last a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
parseJSONList = liftParseJSONList parseJSON parseJSONList
{-# INLINE parseJSONList #-}
instance FromJSON1 Semigroup.WrappedMonoid where
liftParseJSON p _ a = Semigroup.WrapMonoid <$> p a
{-# INLINE liftParseJSON #-}
liftParseJSONList _ p a = fmap Semigroup.WrapMonoid <$> p a
{-# INLINE liftParseJSONList #-}
instance (FromJSON a) => FromJSON (Semigroup.WrappedMonoid a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
parseJSONList = liftParseJSONList parseJSON parseJSONList
{-# INLINE parseJSONList #-}
instance FromJSON1 Semigroup.Option where
liftParseJSON p p' = fmap Semigroup.Option . liftParseJSON p p'
{-# INLINE liftParseJSON #-}
instance FromJSON a => FromJSON (Semigroup.Option a) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSON1 Proxy where
{-# INLINE liftParseJSON #-}
liftParseJSON _ _ = fromNull "Proxy" Proxy
instance FromJSON (Proxy a) where
{-# INLINE parseJSON #-}
parseJSON = fromNull "Proxy" Proxy
fromNull :: String -> a -> Value -> Parser a
fromNull _ a Null = pure a
fromNull c _ v = prependContext c (typeMismatch "Null" v)
instance FromJSON2 Tagged where
liftParseJSON2 _ _ p _ = fmap Tagged . p
{-# INLINE liftParseJSON2 #-}
instance FromJSON1 (Tagged a) where
liftParseJSON p _ = fmap Tagged . p
{-# INLINE liftParseJSON #-}
instance FromJSON b => FromJSON (Tagged a b) where
parseJSON = parseJSON1
{-# INLINE parseJSON #-}
instance FromJSONKey b => FromJSONKey (Tagged a b) where
fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b)
fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList
instance (FromJSON a, FromJSON b) => FromJSON (These a b) where
parseJSON = withObject "These a b" (p . H.toList)
where
p [("This", a), ("That", b)] = These <$> parseJSON a <*> parseJSON b
p [("That", b), ("This", a)] = These <$> parseJSON a <*> parseJSON b
p [("This", a)] = This <$> parseJSON a
p [("That", b)] = That <$> parseJSON b
p _ = fail "Expected object with 'This' and 'That' keys only"
instance FromJSON a => FromJSON1 (These a) where
liftParseJSON pb _ = withObject "These a b" (p . H.toList)
where
p [("This", a), ("That", b)] = These <$> parseJSON a <*> pb b
p [("That", b), ("This", a)] = These <$> parseJSON a <*> pb b
p [("This", a)] = This <$> parseJSON a
p [("That", b)] = That <$> pb b
p _ = fail "Expected object with 'This' and 'That' keys only"
instance FromJSON2 These where
liftParseJSON2 pa _ pb _ = withObject "These a b" (p . H.toList)
where
p [("This", a), ("That", b)] = These <$> pa a <*> pb b
p [("That", b), ("This", a)] = These <$> pa a <*> pb b
p [("This", a)] = This <$> pa a
p [("That", b)] = That <$> pb b
p _ = fail "Expected object with 'This' and 'That' keys only"
instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (These1 f g) where
liftParseJSON px pl = withObject "These1" (p . H.toList)
where
p [("This", a), ("That", b)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b
p [("That", b), ("This", a)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b
p [("This", a)] = This1 <$> liftParseJSON px pl a
p [("That", b)] = That1 <$> liftParseJSON px pl b
p _ = fail "Expected object with 'This' and 'That' keys only"
instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (These1 f g a) where
parseJSON = parseJSON1
instance (FromJSON a, FromJSON b) => FromJSONKey (a,b)
instance (FromJSON a, FromJSON b, FromJSON c) => FromJSONKey (a,b,c)
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)
instance FromJSONKey Char where
fromJSONKey = FromJSONKeyTextParser parseChar
fromJSONKeyList = FromJSONKeyText T.unpack
instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where
fromJSONKey = fromJSONKeyList
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 #-}