aeson-2.0.2.0: src/Data/Aeson/Types/FromJSON.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE InstanceSigs #-}
{-# 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 #-}
-- TODO: Drop this when we remove support for Data.Attoparsec.Number
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Data.Aeson.Types.FromJSON
(
-- * Core JSON classes
FromJSON(..)
-- * Liftings to unary and binary type constructors
, FromJSON1(..)
, parseJSON1
, FromJSON2(..)
, parseJSON2
-- * Generic JSON classes
, GFromJSON(..)
, FromArgs(..)
, genericParseJSON
, genericLiftParseJSON
-- * Classes and types for map keys
, FromJSONKey(..)
, FromJSONKeyFunction(..)
, fromJSONKeyCoerce
, coerceFromJSONKeyFunction
, mapFromJSONKeyFunction
, GFromJSONKey()
, genericFromJSONKey
-- * List functions
, listParser
-- * Inspecting @'Value's@
, withObject
, withText
, withArray
, withScientific
, withBool
, withEmbeddedJSON
-- * Functions
, fromJSON
, ifromJSON
, typeMismatch
, unexpected
, parseField
, parseFieldMaybe
, parseFieldMaybe'
, explicitParseField
, explicitParseFieldMaybe
, explicitParseFieldMaybe'
, parseIndexedJSON
-- ** Operators
, (.:)
, (.:?)
, (.:!)
, (.!=)
-- * Internal
, parseOptionalFieldWith
) where
import Prelude.Compat
import Control.Applicative ((<|>), Const(..), liftA2)
import Control.Monad (zipWithM)
import Data.Aeson.Internal.Functions (mapKey, mapKeyO)
import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
import Data.Aeson.Types.Generic
import Data.Aeson.Types.Internal
import Data.Bits (unsafeShiftR)
import Data.Fixed (Fixed, HasResolution (resolution), Nano)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Identity (Identity(..))
import Data.Functor.Product (Product(..))
import Data.Functor.Sum (Sum(..))
import Data.Functor.These (These1 (..))
import Data.Hashable (Hashable(..))
import Data.Int (Int16, Int32, Int64, Int8)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy(..))
import Data.Ratio ((%), Ratio)
import Data.Scientific (Scientific, base10Exponent)
import Data.Tagged (Tagged(..))
import Data.Text (Text, pack, unpack)
import Data.These (These (..))
import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
import Data.Time.Calendar.Month.Compat (Month)
import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))
import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
import Data.Time.Clock.System.Compat (SystemTime (..))
import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
import Data.Traversable as Tr (sequence)
import Data.Tuple.Solo (Solo (..))
import Data.Type.Coercion (Coercion (..))
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.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
import qualified Data.ByteString.Lazy as L
import qualified Data.DList as DList
#if MIN_VERSION_dlist(1,0,0)
import qualified Data.DList.DNonEmpty as DNE
#endif
import qualified Data.Fix as F
import qualified Data.HashMap.Strict as H
import qualified Data.HashSet as HashSet
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as M
import qualified Data.Monoid as Monoid
import qualified Data.Scientific as Scientific
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Strict as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Short as ST
import qualified Data.Tree as Tree
import qualified Data.UUID.Types as UUID
import qualified Data.Vector as V
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
import qualified GHC.Exts as Exts
import qualified Data.Primitive.Array as PM
import qualified Data.Primitive.SmallArray as PM
import qualified Data.Primitive.Types as PM
import qualified Data.Primitive.PrimArray as PM
import Data.Coerce (Coercible, coerce)
#if __GLASGOW_HASKELL__ < 804
import qualified Data.Type.Coercion
#endif
parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
parseIndexedJSON p idx value = p value <?> Index idx
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"
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 _ (String "-inf") = pure (negate 1/0)
parseRealFloat _ (String "+inf") = pure (1/0)
parseRealFloat name v = prependContext name (unexpected v)
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
parseIntegral :: Integral a => String -> Value -> Parser a
parseIntegral name =
prependContext name . withBoundedScientific' parseIntegralFromScientific
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)
parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a
parseBoundedIntegral name =
prependContext name . withScientific' parseBoundedIntegralFromScientific
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)
parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a
parseBoundedIntegralText name t =
prependContext name $
parseScientificText t >>= parseBoundedIntegralFromScientific
parseOptionalFieldWith :: (Value -> Parser (Maybe a))
-> Object -> Key -> Parser (Maybe a)
parseOptionalFieldWith pj obj key =
case KM.lookup key obj of
Nothing -> pure Nothing
Just v -> pj v <?> Key key
-------------------------------------------------------------------------------
-- Generics
-------------------------------------------------------------------------------
-- | Class of generic representation types that can be converted from JSON.
class GFromJSON arity f where
-- | This method (applied to 'defaultOptions') is used as the
-- default generic implementation of 'parseJSON' (if the @arity@ is 'Zero')
-- or 'liftParseJSON' (if the @arity@ is 'One').
gParseJSON :: Options -> FromArgs arity a -> Value -> Parser (f a)
-- | A 'FromArgs' value either stores nothing (for 'FromJSON') or it stores the
-- two function arguments that decode occurrences of the type parameter (for
-- 'FromJSON1').
data FromArgs arity a where
NoFromArgs :: FromArgs Zero a
From1Args :: (Value -> Parser a) -> (Value -> Parser [a]) -> FromArgs One a
-- | A configurable generic JSON decoder. This function applied to
-- 'defaultOptions' is used as the default for 'parseJSON' when the
-- type is an instance of 'Generic'.
genericParseJSON :: (Generic a, GFromJSON Zero (Rep a))
=> Options -> Value -> Parser a
genericParseJSON opts = fmap to . gParseJSON opts NoFromArgs
-- | A configurable generic JSON decoder. This function applied to
-- 'defaultOptions' is used as the default for 'liftParseJSON' when the
-- type is an instance of 'Generic1'.
genericLiftParseJSON :: (Generic1 f, GFromJSON One (Rep1 f))
=> Options -> (Value -> Parser a) -> (Value -> Parser [a])
-> Value -> Parser (f a)
genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
-------------------------------------------------------------------------------
-- Class
-------------------------------------------------------------------------------
-- | A type that can be converted from JSON, with the possibility of
-- failure.
--
-- In many cases, you can get the compiler to generate parsing code
-- for you (see below). To begin, let's cover writing an instance by
-- hand.
--
-- There are various reasons a conversion could fail. For example, an
-- 'Object' could be missing a required key, an 'Array' could be of
-- the wrong size, or a value could be of an incompatible type.
--
-- The basic ways to signal a failed conversion are as follows:
--
-- * 'fail' yields a custom error message: it is the recommended way of
-- reporting a failure;
--
-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:
-- use it when the error is meant to be caught by some @('<|>')@;
--
-- * 'typeMismatch' can be used to report a failure when the encountered value
-- is not of the expected JSON type; 'unexpected' is an appropriate alternative
-- when more than one type may be expected, or to keep the expected type
-- implicit.
--
-- 'prependFailure' (or 'modifyFailure') add more information to a parser's
-- error messages.
--
-- An example type and instance using 'typeMismatch' and 'prependFailure':
--
-- @
-- \-- Allow ourselves to write 'Text' literals.
-- {-\# LANGUAGE OverloadedStrings #-}
--
-- data Coord = Coord { x :: Double, y :: Double }
--
-- instance 'FromJSON' Coord where
-- 'parseJSON' ('Object' v) = Coord
-- '<$>' v '.:' \"x\"
-- '<*>' v '.:' \"y\"
--
-- \-- We do not expect a non-'Object' value here.
-- \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'
-- \-- gives a much more informative error message.
-- 'parseJSON' invalid =
-- 'prependFailure' "parsing Coord failed, "
-- ('typeMismatch' \"Object\" invalid)
-- @
--
-- For this common case of only being concerned with a single
-- type of JSON value, the functions 'withObject', 'withScientific', etc.
-- are provided. Their use is to be preferred when possible, since
-- they are more terse. Using 'withObject', we can rewrite the above instance
-- (assuming the same language extension and data type) as:
--
-- @
-- instance 'FromJSON' Coord where
-- 'parseJSON' = 'withObject' \"Coord\" $ \\v -> Coord
-- '<$>' v '.:' \"x\"
-- '<*>' v '.:' \"y\"
-- @
--
-- Instead of manually writing your 'FromJSON' instance, there are two options
-- to do it automatically:
--
-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
-- instance at compile time. The generated instance is optimized for your type
-- so it will probably be more efficient than the following option.
--
-- * The compiler can provide a default generic implementation for
-- 'parseJSON'.
--
-- To use the second, simply add a @deriving 'Generic'@ clause to your
-- datatype and declare a 'FromJSON' instance for your datatype without giving
-- a definition for 'parseJSON'.
--
-- For example, the previous example can be simplified to just:
--
-- @
-- {-\# LANGUAGE DeriveGeneric \#-}
--
-- import "GHC.Generics"
--
-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'
--
-- instance 'FromJSON' Coord
-- @
--
-- The default implementation will be equivalent to
-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different
-- options, you can customize the generic decoding by defining:
--
-- @
-- customOptions = 'defaultOptions'
-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'
-- }
--
-- instance 'FromJSON' Coord where
-- 'parseJSON' = 'genericParseJSON' customOptions
-- @
class FromJSON a where
parseJSON :: Value -> Parser a
default parseJSON :: (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a
parseJSON = genericParseJSON defaultOptions
parseJSONList :: Value -> Parser [a]
parseJSONList = withArray "[]" $ \a ->
zipWithM (parseIndexedJSON parseJSON) [0..]
. V.toList
$ a
-------------------------------------------------------------------------------
-- Classes and types for map keys
-------------------------------------------------------------------------------
-- | Read the docs for 'ToJSONKey' first. This class is a conversion
-- in the opposite direction. If you have a newtype wrapper around 'Text',
-- the recommended way to define instances is with generalized newtype deriving:
--
-- > newtype SomeId = SomeId { getSomeId :: Text }
-- > deriving (Eq,Ord,Hashable,FromJSONKey)
--
-- If you have a sum of nullary constructors, you may use the generic
-- implementation:
--
-- @
-- data Color = Red | Green | Blue
-- deriving Generic
--
-- instance 'FromJSONKey' Color where
-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'
-- @
class FromJSONKey a where
-- | Strategy for parsing the key of a map-like container.
fromJSONKey :: FromJSONKeyFunction a
default fromJSONKey :: FromJSON a => FromJSONKeyFunction a
fromJSONKey = FromJSONKeyValue parseJSON
-- | This is similar in spirit to the 'readList' method of 'Read'.
-- It makes it possible to give 'String' keys special treatment
-- without using @OverlappingInstances@. End users should always
-- be able to use the default implementation of this method.
fromJSONKeyList :: FromJSONKeyFunction [a]
default fromJSONKeyList :: FromJSON a => FromJSONKeyFunction [a]
fromJSONKeyList = FromJSONKeyValue parseJSON
-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
-- instance. The other three data constructors for this type all correspond to
-- 'ToJSONKeyText'. Strictly speaking, 'FromJSONKeyTextParser' is more powerful than
-- 'FromJSONKeyText', which is in turn more powerful than 'FromJSONKeyCoerce'.
-- For performance reasons, these exist as three options instead of one.
data FromJSONKeyFunction a where
FromJSONKeyCoerce :: Coercible Text a => FromJSONKeyFunction a
-- ^ uses 'coerce', we expect that 'Hashable' and 'Ord' instance are compatible.
FromJSONKeyText :: !(Text -> a) -> FromJSONKeyFunction a
-- ^ conversion from 'Text' that always succeeds
FromJSONKeyTextParser :: !(Text -> Parser a) -> FromJSONKeyFunction a
-- ^ conversion from 'Text' that may fail
FromJSONKeyValue :: !(Value -> Parser a) -> FromJSONKeyFunction a
-- ^ conversion for non-textual keys
-- | Only law abiding up to interpretation
instance Functor FromJSONKeyFunction where
fmap h FromJSONKeyCoerce = FromJSONKeyText (h . coerce)
fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
-- | Construct 'FromJSONKeyFunction' for types coercible from 'Text'. This
-- conversion is still unsafe, as 'Hashable' and 'Eq' instances of @a@ should be
-- compatible with 'Text' i.e. hash values should be equal for wrapped values as well.
-- This property will always be maintained if the 'Hashable' and 'Eq' instances
-- are derived with generalized newtype deriving.
-- compatible with 'Text' i.e. hash values be equal for wrapped values as well.
--
-- On pre GHC 7.8 this is unconstrainted function.
fromJSONKeyCoerce ::
Coercible Text a =>
FromJSONKeyFunction a
fromJSONKeyCoerce = FromJSONKeyCoerce
-- | Semantically the same as @coerceFromJSONKeyFunction = fmap coerce = coerce@.
--
-- See note on 'fromJSONKeyCoerce'.
coerceFromJSONKeyFunction ::
Coercible a b =>
FromJSONKeyFunction a -> FromJSONKeyFunction b
coerceFromJSONKeyFunction = coerce
{-# RULES
"FromJSONKeyCoerce: fmap coerce" forall x .
fmap coerce x = coerceFromJSONKeyFunction x
#-}
-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
mapFromJSONKeyFunction = fmap
-- | 'fromJSONKey' for 'Generic' types.
-- These types must be sums of nullary constructors, whose names will be used
-- as keys for JSON objects.
--
-- See also 'genericToJSONKey'.
--
-- === __Example__
--
-- @
-- data Color = Red | Green | Blue
-- deriving 'Generic'
--
-- instance 'FromJSONKey' Color where
-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'
-- @
genericFromJSONKey :: forall a. (Generic a, GFromJSONKey (Rep a))
=> JSONKeyOptions
-> FromJSONKeyFunction a
genericFromJSONKey opts = FromJSONKeyTextParser $ \t ->
case parseSumFromString (keyModifier opts) t of
Nothing -> fail $
"invalid key " ++ show t ++ ", expected one of " ++ show cnames
Just k -> pure (to k)
where
cnames = unTagged2 (constructorTags (keyModifier opts) :: Tagged2 (Rep a) [String])
class (ConstructorNames f, SumFromString f) => GFromJSONKey f where
instance (ConstructorNames f, SumFromString f) => GFromJSONKey f where
-------------------------------------------------------------------------------
-- Functions needed for documentation
-------------------------------------------------------------------------------
-- | Fail parsing due to a type mismatch, with a descriptive message.
--
-- The following wrappers should generally be prefered:
-- 'withObject', 'withArray', 'withText', 'withBool'.
--
-- ==== Error message example
--
-- > typeMismatch "Object" (String "oops")
-- > -- Error: "expected Object, but encountered String"
typeMismatch :: String -- ^ The name of the JSON type being parsed
-- (@\"Object\"@, @\"Array\"@, @\"String\"@, @\"Number\"@,
-- @\"Boolean\"@, or @\"Null\"@).
-> Value -- ^ The actual value encountered.
-> Parser a
typeMismatch expected actual =
fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual
-- | Fail parsing due to a type mismatch, when the expected types are implicit.
--
-- ==== Error message example
--
-- > unexpected (String "oops")
-- > -- Error: "unexpected String"
unexpected :: Value -> Parser a
unexpected actual = fail $ "unexpected " ++ typeOf actual
-- | JSON type of a value, name of the head constructor.
typeOf :: Value -> String
typeOf v = case v of
Object _ -> "Object"
Array _ -> "Array"
String _ -> "String"
Number _ -> "Number"
Bool _ -> "Boolean"
Null -> "Null"
-------------------------------------------------------------------------------
-- Lifings of FromJSON and ToJSON to unary and binary type constructors
-------------------------------------------------------------------------------
-- | Lifting of the 'FromJSON' class to unary type constructors.
--
-- Instead of manually writing your 'FromJSON1' instance, there are two options
-- to do it automatically:
--
-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
-- instance at compile time. The generated instance is optimized for your type
-- so it will probably be more efficient than the following option.
--
-- * The compiler can provide a default generic implementation for
-- 'liftParseJSON'.
--
-- To use the second, simply add a @deriving 'Generic1'@ clause to your
-- datatype and declare a 'FromJSON1' instance for your datatype without giving
-- a definition for 'liftParseJSON'.
--
-- For example:
--
-- @
-- {-\# LANGUAGE DeriveGeneric \#-}
--
-- import "GHC.Generics"
--
-- data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'
--
-- instance 'FromJSON' a => 'FromJSON1' (Pair a)
-- @
--
-- If the default implementation doesn't give exactly the results you want,
-- you can customize the generic decoding with only a tiny amount of
-- effort, using 'genericLiftParseJSON' with your preferred 'Options':
--
-- @
-- customOptions = 'defaultOptions'
-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'
-- }
--
-- instance 'FromJSON' a => 'FromJSON1' (Pair a) where
-- 'liftParseJSON' = 'genericLiftParseJSON' customOptions
-- @
class FromJSON1 f where
liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)
default liftParseJSON :: (Generic1 f, GFromJSON One (Rep1 f))
=> (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)
liftParseJSON = genericLiftParseJSON defaultOptions
liftParseJSONList :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser [f a]
liftParseJSONList f g v = listParser (liftParseJSON f g) v
-- | Lift the standard 'parseJSON' function through the type constructor.
parseJSON1 :: (FromJSON1 f, FromJSON a) => Value -> Parser (f a)
parseJSON1 = liftParseJSON parseJSON parseJSONList
{-# INLINE parseJSON1 #-}
-- | Lifting of the 'FromJSON' class to binary type constructors.
--
-- Instead of manually writing your 'FromJSON2' instance, "Data.Aeson.TH"
-- provides Template Haskell functions which will derive an instance at compile time.
-- The compiler cannot provide a default generic implementation for 'liftParseJSON2',
-- unlike 'parseJSON' and 'liftParseJSON'.
class FromJSON2 f where
liftParseJSON2
:: (Value -> Parser a)
-> (Value -> Parser [a])
-> (Value -> Parser b)
-> (Value -> Parser [b])
-> Value -> Parser (f a b)
liftParseJSONList2
:: (Value -> Parser a)
-> (Value -> Parser [a])
-> (Value -> Parser b)
-> (Value -> Parser [b])
-> Value -> Parser [f a b]
liftParseJSONList2 fa ga fb gb = withArray "[]" $ \vals ->
fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)
-- | Lift the standard 'parseJSON' function through the type constructor.
parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
{-# INLINE parseJSON2 #-}
-------------------------------------------------------------------------------
-- List functions
-------------------------------------------------------------------------------
-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
listParser :: (Value -> Parser a) -> Value -> Parser [a]
listParser f (Array xs) = fmap V.toList (V.mapM f xs)
listParser _ v = typeMismatch "Array" v
{-# INLINE listParser #-}
-------------------------------------------------------------------------------
-- [] instances
-------------------------------------------------------------------------------
instance FromJSON1 [] where
liftParseJSON _ p' = p'
instance (FromJSON a) => FromJSON [a] where
parseJSON = parseJSON1
-------------------------------------------------------------------------------
-- Functions
-------------------------------------------------------------------------------
-- | Add context to a failure message, indicating the name of the structure
-- being parsed.
--
-- > prependContext "MyType" (fail "[error message]")
-- > -- Error: "parsing MyType failed, [error message]"
prependContext :: String -> Parser a -> Parser a
prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")
-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@
-- is an 'Data.Aeson.Object' and fails otherwise.
--
-- ==== Error message example
--
-- > withObject "MyType" f (String "oops")
-- > -- Error: "parsing MyType failed, expected Object, but encountered String"
withObject :: String -> (Object -> Parser a) -> Value -> Parser a
withObject _ f (Object obj) = f obj
withObject name _ v = prependContext name (typeMismatch "Object" v)
-- | @'withText' name f value@ applies @f@ to the 'Text' when @value@ is a
-- 'Data.Aeson.String' and fails otherwise.
--
-- ==== Error message example
--
-- > withText "MyType" f Null
-- > -- Error: "parsing MyType failed, expected String, but encountered Null"
withText :: String -> (Text -> Parser a) -> Value -> Parser a
withText _ f (String txt) = f txt
withText name _ v = prependContext name (typeMismatch "String" v)
-- | @'withArray' expected f value@ applies @f@ to the 'Array' when @value@ is
-- an 'Data.Aeson.Array' and fails otherwise.
--
-- ==== Error message example
--
-- > withArray "MyType" f (String "oops")
-- > -- Error: "parsing MyType failed, expected Array, but encountered String"
withArray :: String -> (Array -> Parser a) -> Value -> Parser a
withArray _ f (Array arr) = f arr
withArray name _ v = prependContext name (typeMismatch "Array" v)
-- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number
-- when @value@ is a 'Data.Aeson.Number' and fails using 'typeMismatch'
-- otherwise.
--
-- /Warning/: If you are converting from a scientific to an unbounded
-- type such as 'Integer' you may want to add a restriction on the
-- size of the exponent (see 'withBoundedScientific') to prevent
-- malicious input from filling up the memory of the target system.
--
-- ==== Error message example
--
-- > withScientific "MyType" f (String "oops")
-- > -- Error: "parsing MyType failed, expected Number, but encountered String"
withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
withScientific _ f (Number scientific) = f scientific
withScientific name _ v = prependContext name (typeMismatch "Number" v)
-- | A variant of 'withScientific' which doesn't use 'prependContext', so that
-- such context can be added separately in a way that also applies when the
-- continuation @f :: Scientific -> Parser a@ fails.
--
-- /Warning/: If you are converting from a scientific to an unbounded
-- type such as 'Integer' you may want to add a restriction on the
-- size of the exponent (see 'withBoundedScientific') to prevent
-- malicious input from filling up the memory of the target system.
--
-- ==== Error message examples
--
-- > withScientific' f (String "oops")
-- > -- Error: "unexpected String"
-- >
-- > prependContext "MyType" (withScientific' f (String "oops"))
-- > -- Error: "parsing MyType failed, unexpected String"
withScientific' :: (Scientific -> Parser a) -> Value -> Parser a
withScientific' f v = case v of
Number n -> f n
_ -> typeMismatch "Number" v
-- | @'withBoundedScientific' name f value@ applies @f@ to the 'Scientific' number
-- when @value@ is a 'Number' with exponent less than or equal to 1024.
withBoundedScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
withBoundedScientific name f v = withBoundedScientific_ (prependContext name) f v
-- | A variant of 'withBoundedScientific' which doesn't use 'prependContext',
-- so that such context can be added separately in a way that also applies
-- when the continuation @f :: Scientific -> Parser a@ fails.
withBoundedScientific' :: (Scientific -> Parser a) -> Value -> Parser a
withBoundedScientific' f v = withBoundedScientific_ id f v
-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
-- to the 'Parser' in case of failure.
withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
withBoundedScientific_ whenFail f (Number scientific) =
if exp10 > 1024
then whenFail (fail msg)
else f scientific
where
exp10 = base10Exponent scientific
msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"
withBoundedScientific_ whenFail _ v =
whenFail (typeMismatch "Number" v)
-- | @'withBool' expected f value@ applies @f@ to the 'Bool' when @value@ is a
-- 'Boolean' and fails otherwise.
--
-- ==== Error message example
--
-- > withBool "MyType" f (String "oops")
-- > -- Error: "parsing MyType failed, expected Boolean, but encountered String"
withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
withBool _ f (Bool arr) = f arr
withBool name _ v = prependContext name (typeMismatch "Boolean" v)
-- | Decode a nested JSON-encoded string.
withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
withEmbeddedJSON _ innerParser (String txt) =
either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
where
eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
eitherFormatError = either (Left . uncurry formatError) Right
withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v)
-- | Convert a value from JSON, failing if the types do not match.
fromJSON :: (FromJSON a) => Value -> Result a
fromJSON = parse parseJSON
-- | Convert a value from JSON, failing if the types do not match.
ifromJSON :: (FromJSON a) => Value -> IResult a
ifromJSON = iparse parseJSON
-- | 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 -> Key -> Parser a
(.:) = explicitParseField parseJSON
-- | Retrieve the value associated with the given key of an 'Object'. The
-- result is 'Nothing' if the key is not present or if its value is 'Null',
-- or 'empty' if the value cannot be converted to the desired type.
--
-- This accessor is most useful if the key and value can be absent
-- from an object without affecting its validity. If the key and
-- value are mandatory, use '.:' instead.
(.:?) :: (FromJSON a) => Object -> Key -> Parser (Maybe a)
(.:?) = explicitParseFieldMaybe parseJSON
-- | Retrieve the value associated with the given key of an 'Object'.
-- The result is 'Nothing' if the key is not present or 'empty' if the
-- value cannot be converted to the desired type.
--
-- This differs from '.:?' by attempting to parse 'Null' the same as any
-- other JSON value, instead of interpreting it as 'Nothing'.
(.:!) :: (FromJSON a) => Object -> Key -> Parser (Maybe a)
(.:!) = explicitParseFieldMaybe' parseJSON
-- | Function variant of '.:'.
parseField :: (FromJSON a) => Object -> Key -> Parser a
parseField = (.:)
-- | Function variant of '.:?'.
parseFieldMaybe :: (FromJSON a) => Object -> Key -> Parser (Maybe a)
parseFieldMaybe = (.:?)
-- | Function variant of '.:!'.
parseFieldMaybe' :: (FromJSON a) => Object -> Key -> Parser (Maybe a)
parseFieldMaybe' = (.:!)
-- | Variant of '.:' with explicit parser function.
--
-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
explicitParseField :: (Value -> Parser a) -> Object -> Key -> Parser a
explicitParseField p obj key = case KM.lookup key obj of
Nothing -> fail $ "key " ++ show key ++ " not found"
Just v -> p v <?> Key key
-- | Variant of '.:?' with explicit parser function.
explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
explicitParseFieldMaybe p obj key = case KM.lookup key obj of
Nothing -> pure Nothing
Just v -> liftParseJSON p (listParser p) v <?> Key key -- listParser isn't used by maybe instance.
-- | Variant of '.:!' with explicit parser function.
explicitParseFieldMaybe' :: (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
explicitParseFieldMaybe' p obj key = case KM.lookup key obj of
Nothing -> pure Nothing
Just v -> Just <$> p v <?> Key key
-- | 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
--------------------------------------------------------------------------------
-- Generic parseJSON
-------------------------------------------------------------------------------
instance GFromJSON arity V1 where
-- Whereof we cannot format, thereof we cannot parse:
gParseJSON _ _ _ = fail "Attempted to parse empty type"
{-# INLINE gParseJSON #-}
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
{-# INLINE gParseJSON #-}
-- Information for error messages
type TypeName = String
type ConName = String
-- | Add the name of the type being parsed to a parser's error messages.
contextType :: TypeName -> Parser a -> Parser a
contextType = prependContext
-- | Add the tagKey that will be looked up while building an ADT
-- | Produce the error equivalent to
-- | Left "Error in $: parsing T failed, expected an object with keys "tag" and
-- | "contents", where "tag" i-- |s associated to one of ["Foo", "Bar"],
-- | The parser returned error was: could not find key "tag"
contextTag :: Key -> [String] -> Parser a -> Parser a
contextTag tagKey cnames = prependFailure
("expected Object with key \"" ++ Key.toString tagKey ++ "\"" ++
" containing one of " ++ show cnames ++ ", ")
-- | Add the name of the constructor being parsed to a parser's error messages.
contextCons :: ConName -> TypeName -> Parser a -> Parser a
contextCons cname tname = prependContext (showCons cname tname)
-- | Render a constructor as @\"MyType(MyConstructor)\"@.
showCons :: ConName -> TypeName -> String
showCons cname tname = tname ++ "(" ++ cname ++ ")"
--------------------------------------------------------------------------------
-- Parsing single fields
instance (FromJSON a) => GFromJSON arity (K1 i a) where
-- Constant values are decoded using their FromJSON instance:
gParseJSON _opts _ = fmap K1 . parseJSON
{-# INLINE gParseJSON #-}
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
{-# INLINE gParseJSON #-}
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
{-# INLINE gParseJSON #-}
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)
{-# INLINE gParseJSON #-}
--------------------------------------------------------------------------------
instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where
-- Meta-information, which is not handled elsewhere, is just added to the
-- parsed value:
gParseJSON opts fargs = fmap M1 . gParseJSON' (tname :* opts :* fargs)
where
tname = moduleName proxy ++ "." ++ datatypeName proxy
proxy = undefined :: M1 _i d _f _p
{-# INLINE gParseJSON #-}
-- | 'GFromJSON', after unwrapping the 'D1' constructor, now carrying the data
-- type's name.
class GFromJSON' arity f where
gParseJSON' :: TypeName :* Options :* FromArgs arity a
-> Value
-> Parser (f a)
-- | Single constructor.
instance ( ConsFromJSON arity a
, AllNullary (C1 c a) allNullary
, ParseSum arity (C1 c a) allNullary
, Constructor c
) => GFromJSON' arity (C1 c a) where
-- The option 'tagSingleConstructors' determines whether to wrap
-- a single-constructor type.
gParseJSON' p@(_ :* opts :* _)
| tagSingleConstructors opts
= (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))
. parseSum p
| otherwise = fmap M1 . consParseJSON (cname :* p)
where
cname = conName (undefined :: M1 _i c _f _p)
{-# INLINE gParseJSON' #-}
-- | Multiple constructors.
instance ( AllNullary (a :+: b) allNullary
, ParseSum arity (a :+: b) allNullary
) => GFromJSON' arity (a :+: b) where
-- If all constructors of a sum datatype are nullary and the
-- 'allNullaryToStringTag' option is set they are expected to be
-- encoded as strings. This distinction is made by 'parseSum':
gParseJSON' p =
(unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->
Parser ((a :+: b) _d))
. parseSum p
{-# INLINE gParseJSON' #-}
--------------------------------------------------------------------------------
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
{-# INLINE parseSum #-}
instance ( ConstructorNames f
, FromPair arity f
, FromTaggedObject arity f
, FromUntaggedValue arity f
) => ParseSum arity f False where
parseSum p = Tagged . parseNonAllNullarySum p
{-# INLINE parseSum #-}
--------------------------------------------------------------------------------
parseAllNullarySum :: (SumFromString f, ConstructorNames f)
=> TypeName -> Options -> Value -> Parser (f a)
parseAllNullarySum tname opts =
withText tname $ \tag ->
maybe (badTag tag) return $
parseSumFromString modifier tag
where
badTag tag = failWithCTags tname modifier $ \cnames ->
"expected one of the tags " ++ show cnames ++
", but found tag " ++ show tag
modifier = constructorTagModifier opts
-- | Fail with an informative error message about a mismatched tag.
-- The error message is parameterized by the list of expected tags,
-- to be inferred from the result type of the parser.
failWithCTags
:: forall f a t. ConstructorNames f
=> TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)
failWithCTags tname modifier f =
contextType tname . fail $ f cnames
where
cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])
class SumFromString f where
parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
(R1 <$> parseSumFromString opts key)
{-# INLINE parseSumFromString #-}
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)
{-# INLINE parseSumFromString #-}
-- For genericFromJSONKey
instance SumFromString a => SumFromString (D1 d a) where
parseSumFromString modifier key = M1 <$> parseSumFromString modifier key
{-# INLINE parseSumFromString #-}
-- | List of all constructor tags.
constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]
constructorTags modifier =
fmap DList.toList (constructorNames' modifier)
-- | List of all constructor names of an ADT, after a given conversion
-- function. (Better inlining.)
class ConstructorNames a where
constructorNames' :: (String -> t) -> Tagged2 a (DList.DList t)
instance (ConstructorNames a, ConstructorNames b) => ConstructorNames (a :+: b) where
constructorNames' = liftA2 append constructorNames' constructorNames'
where
append
:: Tagged2 a (DList.DList t)
-> Tagged2 b (DList.DList t)
-> Tagged2 (a :+: b) (DList.DList t)
append (Tagged2 xs) (Tagged2 ys) = Tagged2 (DList.append xs ys)
{-# INLINE constructorNames' #-}
instance Constructor c => ConstructorNames (C1 c a) where
constructorNames' f = Tagged2 (pure (f cname))
where
cname = conName (undefined :: M1 _i c _f _p)
{-# INLINE constructorNames' #-}
-- For genericFromJSONKey
instance ConstructorNames a => ConstructorNames (D1 d a) where
constructorNames' = retag . constructorNames'
where
retag :: Tagged2 a u -> Tagged2 (D1 d a) u
retag (Tagged2 x) = Tagged2 x
{-# INLINE constructorNames' #-}
--------------------------------------------------------------------------------
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 = Key.fromString 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 KM.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 (KM.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 (Key.fromText tag :* p) (V.unsafeIndex arr 1)
| otherwise ->
contextType tname $
fail "tag element is not a String" <?> Index 0
len -> contextType tname . fail $
"expected a 2-element Array, but encountered an Array of length " ++
show len
where
badTag tag = failWith_ $ \cnames ->
"expected tag of the 2-element Array to be one of " ++
show cnames ++ ", but found tag " ++ show tag
UntaggedValue -> parseUntaggedValue p
where
failWith_ = failWithCTags tname (constructorTagModifier opts)
--------------------------------------------------------------------------------
class FromTaggedObject arity f where
-- The first two components of the parameter tuple are: the constructor tag
-- to match against, and the contents field name.
parseFromTaggedObject
:: Text :* String :* TypeName :* Options :* FromArgs arity a
-> Object
-> Maybe (Parser (f a))
instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
FromTaggedObject arity (a :+: b) where
parseFromTaggedObject p obj =
(fmap L1 <$> parseFromTaggedObject p obj) <|>
(fmap R1 <$> parseFromTaggedObject p obj)
{-# INLINE parseFromTaggedObject #-}
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)
{-# INLINE parseFromTaggedObject #-}
--------------------------------------------------------------------------------
class FromTaggedObject' arity f isRecord where
-- The first component of the parameter tuple is the contents field name.
parseFromTaggedObject'
:: String :* ConName :* TypeName :* Options :* FromArgs arity a
-> Object -> Tagged isRecord (Parser (f a))
instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
-- Records are unpacked in the tagged object
parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
{-# INLINE parseFromTaggedObject' #-}
instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
-- Nonnullary nonrecords are encoded in the contents field
parseFromTaggedObject' p obj = Tagged $ do
contents <- contextCons cname tname (obj .: key)
consParseJSON p' contents <?> Key key
where
key = Key.fromString contentsFieldName
contentsFieldName :* p'@(cname :* tname :* _) = p
{-# INLINE parseFromTaggedObject' #-}
instance {-# OVERLAPPING #-} FromTaggedObject' arity U1 False where
-- Nullary constructors don't need a contents field
parseFromTaggedObject' _ _ = Tagged (pure U1)
{-# INLINE parseFromTaggedObject' #-}
--------------------------------------------------------------------------------
-- | Constructors need to be decoded differently depending on whether they're
-- a record or not. This distinction is made by 'ConsParseJSON'.
class ConsFromJSON arity f where
consParseJSON
:: ConName :* TypeName :* Options :* FromArgs arity a
-> Value -> Parser (f a)
class ConsFromJSON' arity f isRecord where
consParseJSON'
:: ConName :* TypeName :* Options :* FromArgs arity a
-> Value -> Tagged isRecord (Parser (f a))
instance ( IsRecord f isRecord
, ConsFromJSON' arity f isRecord
) => ConsFromJSON arity f where
consParseJSON p =
(unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
. consParseJSON' p
{-# INLINE consParseJSON #-}
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))
{-# INLINE consParseJSON' #-}
instance RecordFromJSON arity f => ConsFromJSON' arity f True where
consParseJSON' p@(cname :* tname :* _) =
Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
{-# INLINE consParseJSON' #-}
instance {-# OVERLAPPING #-}
ConsFromJSON' arity U1 False where
-- Empty constructors are expected to be encoded as an empty array:
consParseJSON' (cname :* tname :* _) v =
Tagged . contextCons cname tname $ case v of
Array a | V.null a -> pure U1
| otherwise -> fail_ a
_ -> typeMismatch "Array" v
where
fail_ a = fail $
"expected an empty Array, but encountered an Array of length " ++
show (V.length a)
{-# INLINE consParseJSON' #-}
instance {-# OVERLAPPING #-}
GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where
consParseJSON' (_ :* _ :* opts :* fargs) =
Tagged . fmap M1 . gParseJSON opts fargs
{-# INLINE consParseJSON' #-}
instance (ProductFromJSON arity f, ProductSize f
) => ConsFromJSON' arity f False where
consParseJSON' p = Tagged . productParseJSON0 p
{-# INLINE consParseJSON' #-}
--------------------------------------------------------------------------------
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)
{-# INLINE fieldNames #-}
instance (Selector s) => FieldNames (S1 s f) where
fieldNames _ = (selName (undefined :: M1 _i s _f _p) :)
{-# INLINE fieldNames #-}
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 :: KM.KeyMap ()
knownFields = KM.fromList $ map ((,()) . Key.fromString) $
[tagFieldName (sumEncoding opts) | fromTaggedSum] <>
(fieldLabelModifier opts <$> fieldNames (undefined :: f a) [])
checkUnknown =
if not (rejectUnknownFields opts)
then \_ -> return ()
else \obj -> case KM.keys (KM.difference obj knownFields) of
[] -> return ()
unknownFields -> contextCons cname tname $
fail ("unknown fields: " ++ show unknownFields)
{-# INLINE recordParseJSON #-}
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
{-# INLINE recordParseJSON' #-}
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 = Key.fromString $ fieldLabelModifier opts sname
sname = selName (undefined :: M1 _i s _f _p)
{-# INLINE recordParseJSON' #-}
instance {-# INCOHERENT #-} (Selector s, FromJSON a) =>
RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? label
where
label = Key.fromString $ fieldLabelModifier opts sname
sname = selName (undefined :: M1 _i s _f _p)
{-# INLINE recordParseJSON' #-}
#if !MIN_VERSION_base(4,16,0)
-- Parse an Option like a Maybe.
instance {-# INCOHERENT #-} (Selector s, FromJSON a) =>
RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
where
wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
{-# INLINE recordParseJSON' #-}
#endif
--------------------------------------------------------------------------------
productParseJSON0
:: forall f arity a. (ProductFromJSON arity f, ProductSize f)
=> ConName :* TypeName :* Options :* FromArgs arity a
-> Value -> Parser (f a)
-- Products are expected to be encoded to an array. Here we check whether we
-- got an array of the same size as the product, then parse each of the
-- product's elements using productParseJSON:
productParseJSON0 p@(cname :* tname :* _ :* _) =
withArray (showCons cname tname) $ \arr ->
let lenArray = V.length arr
lenProduct = (unTagged2 :: Tagged2 f Int -> Int)
productSize in
if lenArray == lenProduct
then productParseJSON p arr 0 lenProduct
else contextCons cname tname $
fail $ "expected an Array of length " ++ show lenProduct ++
", but encountered an Array of length " ++ show lenArray
--
class ProductFromJSON arity f where
productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a
-> Array -> Int -> Int
-> Parser (f a)
instance ( ProductFromJSON arity a
, ProductFromJSON arity b
) => ProductFromJSON arity (a :*: b) where
productParseJSON p arr ix len =
(:*:) <$> productParseJSON p arr ix lenL
<*> productParseJSON p arr ixR lenR
where
lenL = len `unsafeShiftR` 1
ixR = ix + lenL
lenR = len - lenL
instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where
productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =
M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix
{-# INLINE productParseJSON #-}
--------------------------------------------------------------------------------
class FromPair arity f where
-- The first component of the parameter tuple is the tag to match.
parsePair :: Key :* 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)
{-# INLINE parsePair #-}
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' = Key.fromString $ constructorTagModifier opts cname
cname = conName (undefined :: M1 _i c _a _p)
{-# INLINE parsePair #-}
--------------------------------------------------------------------------------
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
{-# INLINE parseUntaggedValue #-}
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)
{-# INLINE parseUntaggedValue #-}
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
{-# INLINE parseUntaggedValue #-}
-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- base
-------------------------------------------------------------------------------
instance FromJSON2 Const where
liftParseJSON2 p _ _ _ = fmap Const . p
instance FromJSON a => FromJSON1 (Const a) where
liftParseJSON _ _ = fmap Const . parseJSON
instance FromJSON a => FromJSON (Const a b) where
parseJSON = fmap Const . parseJSON
instance (FromJSON a, FromJSONKey a) => FromJSONKey (Const a b) where
fromJSONKey = fmap Const fromJSONKey
instance FromJSON1 Maybe where
liftParseJSON _ _ Null = pure Nothing
liftParseJSON p _ a = Just <$> p a
instance (FromJSON a) => FromJSON (Maybe a) where
parseJSON = parseJSON1
instance FromJSON2 Either where
liftParseJSON2 pA _ pB _ (Object (KM.toList -> [(key, value)]))
| key == left = Left <$> pA value <?> Key left
| key == right = Right <$> pB value <?> Key right
where
left, right :: Key
left = "Left"
right = "Right"
liftParseJSON2 _ _ _ _ _ = fail $
"expected an object with a single property " ++
"where the property key should be either " ++
"\"Left\" or \"Right\""
instance (FromJSON a) => FromJSON1 (Either a) where
liftParseJSON = liftParseJSON2 parseJSON parseJSONList
instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
parseJSON = parseJSON2
instance FromJSON Void where
parseJSON _ = fail "Cannot parse Void"
instance FromJSON Bool where
parseJSON (Bool b) = pure b
parseJSON v = typeMismatch "Bool" v
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 _ = pure ()
instance FromJSON Char where
parseJSON = withText "Char" parseChar
parseJSONList (String s) = pure (T.unpack s)
parseJSONList v = typeMismatch "String" v
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"
instance FromJSONKey Double where
fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
"NaN" -> pure (0/0)
"-inf" -> pure (1/0)
"+inf" -> pure (negate 1/0)
_ -> Scientific.toRealFloat <$> parseScientificText t
instance FromJSON Float where
parseJSON = parseRealFloat "Float"
instance FromJSONKey Float where
fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
"NaN" -> pure (0/0)
"+inf" -> pure (1/0)
"-inf" -> 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
-- | This instance includes a bounds check to prevent maliciously
-- large inputs to fill up the memory of the target system. You can
-- newtype 'Scientific' and provide your own instance using
-- 'withScientific' if you want to allow larger inputs.
instance HasResolution a => FromJSON (Fixed a) where
parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac)
instance FromJSON Int where
parseJSON = parseBoundedIntegral "Int"
instance FromJSONKey Int where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"
-- | This instance includes a bounds check to prevent maliciously
-- large inputs to fill up the memory of the target system. You can
-- newtype 'Scientific' and provide your own instance using
-- 'withScientific' if you want to allow larger inputs.
instance FromJSON Integer where
parseJSON = parseIntegral "Integer"
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"
instance FromJSONKey Int8 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int8"
instance FromJSON Int16 where
parseJSON = parseBoundedIntegral "Int16"
instance FromJSONKey Int16 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int16"
instance FromJSON Int32 where
parseJSON = parseBoundedIntegral "Int32"
instance FromJSONKey Int32 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int32"
instance FromJSON Int64 where
parseJSON = parseBoundedIntegral "Int64"
instance FromJSONKey Int64 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int64"
instance FromJSON Word where
parseJSON = parseBoundedIntegral "Word"
instance FromJSONKey Word where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word"
instance FromJSON Word8 where
parseJSON = parseBoundedIntegral "Word8"
instance FromJSONKey Word8 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word8"
instance FromJSON Word16 where
parseJSON = parseBoundedIntegral "Word16"
instance FromJSONKey Word16 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word16"
instance FromJSON Word32 where
parseJSON = parseBoundedIntegral "Word32"
instance FromJSONKey Word32 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word32"
instance FromJSON Word64 where
parseJSON = parseBoundedIntegral "Word64"
instance FromJSONKey Word64 where
fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64"
instance FromJSON CTime where
parseJSON = fmap CTime . parseJSON
instance FromJSON Text where
parseJSON = withText "Text" pure
instance FromJSONKey Text where
fromJSONKey = fromJSONKeyCoerce
instance FromJSON LT.Text where
parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
instance FromJSONKey LT.Text where
fromJSONKey = FromJSONKeyText LT.fromStrict
-- | @since 2.0.2.0
instance FromJSON ST.ShortText where
parseJSON = withText "Lazy Text" $ pure . ST.fromText
-- | @since 2.0.2.0
instance FromJSONKey ST.ShortText where
fromJSONKey = FromJSONKeyText ST.fromText
instance FromJSON Version where
parseJSON = withText "Version" parseVersionText
instance FromJSONKey Version where
fromJSONKey = FromJSONKeyTextParser parseVersionText
parseVersionText :: Text -> Parser Version
parseVersionText = go . readP_to_S parseVersion . unpack
where
go [(v,[])] = return v
go (_ : xs) = go xs
go _ = fail "parsing Version failed"
-------------------------------------------------------------------------------
-- semigroups NonEmpty
-------------------------------------------------------------------------------
instance FromJSON1 NonEmpty where
liftParseJSON p _ = withArray "NonEmpty" $
(>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
where
ne [] = fail "parsing NonEmpty failed, unexpected empty list"
ne (x:xs) = pure (x :| xs)
instance (FromJSON a) => FromJSON (NonEmpty a) where
parseJSON = parseJSON1
-------------------------------------------------------------------------------
-- scientific
-------------------------------------------------------------------------------
instance FromJSON Scientific where
parseJSON = withScientific "Scientific" pure
-------------------------------------------------------------------------------
-- DList
-------------------------------------------------------------------------------
instance FromJSON1 DList.DList where
liftParseJSON p _ = withArray "DList" $
fmap DList.fromList .
Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
instance (FromJSON a) => FromJSON (DList.DList a) where
parseJSON = parseJSON1
#if MIN_VERSION_dlist(1,0,0)
-- | @since 1.5.3.0
instance FromJSON1 DNE.DNonEmpty where
liftParseJSON p _ = withArray "DNonEmpty" $
(>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
where
ne [] = fail "parsing DNonEmpty failed, unexpected empty list"
ne (x:xs) = pure (DNE.fromNonEmpty (x :| xs))
-- | @since 1.5.3.0
instance (FromJSON a) => FromJSON (DNE.DNonEmpty a) where
parseJSON = parseJSON1
#endif
-------------------------------------------------------------------------------
-- OneTuple
-------------------------------------------------------------------------------
-- | @since 2.0.2.0
instance FromJSON1 Solo where
liftParseJSON p _ a = Solo <$> p a
liftParseJSONList _ p a = fmap Solo <$> p a
-- | @since 2.0.2.0
instance (FromJSON a) => FromJSON (Solo a) where
parseJSON = parseJSON1
parseJSONList = liftParseJSONList parseJSON parseJSONList
-- | @since 2.0.2.0
instance (FromJSONKey a) => FromJSONKey (Solo a) where
fromJSONKey = fmap Solo fromJSONKey
fromJSONKeyList = fmap (map Solo) fromJSONKeyList
-------------------------------------------------------------------------------
-- transformers - Functors
-------------------------------------------------------------------------------
instance FromJSON1 Identity where
liftParseJSON p _ a = Identity <$> p a
liftParseJSONList _ p a = fmap Identity <$> p a
instance (FromJSON a) => FromJSON (Identity a) where
parseJSON = parseJSON1
parseJSONList = liftParseJSONList parseJSON 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
liftParseJSONList p pl a = map Compose <$> liftParseJSONList g gl a
where
g = liftParseJSON p pl
gl = liftParseJSONList p pl
instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Compose f g a) where
parseJSON = parseJSON1
parseJSONList = liftParseJSONList parseJSON 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
instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Product f g a) where
parseJSON = parseJSON1
instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where
liftParseJSON p pl (Object (KM.toList -> [(key, value)]))
| key == inl = InL <$> liftParseJSON p pl value <?> Key inl
| key == inr = InR <$> liftParseJSON p pl value <?> Key inr
where
inl, inr :: Key
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\""
instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where
parseJSON = parseJSON1
-------------------------------------------------------------------------------
-- containers
-------------------------------------------------------------------------------
instance FromJSON1 Seq.Seq where
liftParseJSON p _ = withArray "Seq" $
fmap Seq.fromList .
Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
instance (FromJSON a) => FromJSON (Seq.Seq a) where
parseJSON = parseJSON1
instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
parseJSON = fmap Set.fromList . parseJSON
instance FromJSON IntSet.IntSet where
parseJSON = fmap IntSet.fromList . 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
instance FromJSON a => FromJSON (IntMap.IntMap a) where
parseJSON = fmap IntMap.fromList . parseJSON
instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
liftParseJSON :: forall a. (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (M.Map k a)
liftParseJSON p _ = case fromJSONKey of
FromJSONKeyCoerce -> withObject "Map ~Text" $ case Key.coercionToText of
Nothing -> text coerce
Just Coercion -> case KM.coercionToMap of
Nothing -> text coerce
Just Coercion -> uc . M.traverseWithKey (\k v -> p v <?> Key k) . KM.toMap
FromJSONKeyText f -> withObject "Map" (text f)
FromJSONKeyTextParser f -> withObject "Map" $
KM.foldrWithKey
(\k v m -> M.insert <$> f (Key.toText 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
where
uc :: Coercible Key k => Parser (M.Map Key a) -> Parser (M.Map k a)
uc = unsafeCoerce
text f = case KM.coercionToMap of
Nothing -> basic f
Just Coercion -> fmap (mapKeyO (f . Key.toText)) . M.traverseWithKey (\k v -> p v <?> Key k) . KM.toMap
{-# INLINE text #-}
basic f = fmap (KM.foldrWithKey (M.insert . f . Key.toText) M.empty) . KM.traverseWithKey (\k v -> p v <?> Key k)
{-# INLINE basic #-}
instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (M.Map k v) where
parseJSON = parseJSON1
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
-------------------------------------------------------------------------------
-- uuid
-------------------------------------------------------------------------------
instance FromJSON UUID.UUID where
parseJSON = withText "UUID" $
maybe (fail "invalid UUID") pure . UUID.fromText
instance FromJSONKey UUID.UUID where
fromJSONKey = FromJSONKeyTextParser $
maybe (fail "invalid UUID") pure . UUID.fromText
-------------------------------------------------------------------------------
-- vector
-------------------------------------------------------------------------------
instance FromJSON1 Vector where
liftParseJSON p _ = withArray "Vector" $
V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
instance (FromJSON a) => FromJSON (Vector a) where
parseJSON = parseJSON1
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
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"
instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector"
-------------------------------------------------------------------------------
-- unordered-containers
-------------------------------------------------------------------------------
instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
parseJSON = fmap HashSet.fromList . parseJSON
instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
liftParseJSON :: forall a. (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (H.HashMap k a)
liftParseJSON p _ = case fromJSONKey of
FromJSONKeyCoerce -> withObject "HashMap ~Text" $ case Key.coercionToText of
Nothing -> text coerce
Just Coercion -> case KM.coercionToHashMap of
Nothing -> text coerce
Just Coercion -> uc . H.traverseWithKey (\k v -> p v <?> Key k) . KM.toHashMap
FromJSONKeyText f -> withObject "HashMap" (text f)
FromJSONKeyTextParser f -> withObject "HashMap" $
KM.foldrWithKey
(\k v m -> H.insert <$> f (Key.toText 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 :: Coercible Key k => Parser (H.HashMap Key a) -> Parser (H.HashMap k a)
uc = unsafeCoerce
text f = case KM.coercionToHashMap of
Nothing -> basic f
Just Coercion -> fmap (mapKey (f . Key.toText)) . H.traverseWithKey (\k v -> p v <?> Key k) . KM.toHashMap
{-# INLINE text #-}
basic f = fmap (KM.foldrWithKey (H.insert . f . Key.toText) H.empty) . KM.traverseWithKey (\k v -> p v <?> Key k)
{-# INLINE basic #-}
instance (FromJSON v, FromJSONKey k, Eq k, Hashable k) => FromJSON (H.HashMap k v) where
parseJSON = parseJSON1
-------------------------------------------------------------------------------
-- aeson
-------------------------------------------------------------------------------
instance FromJSON Key where
parseJSON = withText "Key" (pure . Key.fromText)
instance FromJSONKey Key where
fromJSONKey = case oldGHC Key.coercionToText of
Just Coercion -> FromJSONKeyCoerce
Nothing -> FromJSONKeyText Key.fromText
where
#if __GLASGOW_HASKELL__ < 804
-- for some reason GHC-8.0 and 8.2 cannot apply the sym without help
oldGHC = fmap Data.Type.Coercion.sym
#else
oldGHC = id
#endif
-- | @since 2.0.1.0
instance FromJSON1 KM.KeyMap where
liftParseJSON p _ = withObject "KeyMap" $ \obj ->
traverse p obj
-- | @since 2.0.1.0
instance FromJSON v => FromJSON (KM.KeyMap v) where
parseJSON = parseJSON1
instance FromJSON Value where
parseJSON = pure
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"
-------------------------------------------------------------------------------
-- primitive
-------------------------------------------------------------------------------
instance FromJSON a => FromJSON (PM.Array a) where
-- note: we could do better than this if vector exposed the data
-- constructor in Data.Vector.
parseJSON = fmap Exts.fromList . parseJSON
instance FromJSON a => FromJSON (PM.SmallArray a) where
parseJSON = fmap Exts.fromList . parseJSON
instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where
parseJSON = fmap Exts.fromList . parseJSON
-------------------------------------------------------------------------------
-- time
-------------------------------------------------------------------------------
instance FromJSON Day where
parseJSON = withText "Day" (Time.run Time.day)
instance FromJSONKey Day where
fromJSONKey = FromJSONKeyTextParser (Time.run Time.day)
instance FromJSON TimeOfDay where
parseJSON = withText "TimeOfDay" (Time.run Time.timeOfDay)
instance FromJSONKey TimeOfDay where
fromJSONKey = FromJSONKeyTextParser (Time.run Time.timeOfDay)
instance FromJSON LocalTime where
parseJSON = withText "LocalTime" (Time.run Time.localTime)
instance FromJSONKey LocalTime where
fromJSONKey = FromJSONKeyTextParser (Time.run Time.localTime)
-- | Supported string formats:
--
-- @YYYY-MM-DD HH:MM Z@
-- @YYYY-MM-DD HH:MM:SS Z@
-- @YYYY-MM-DD HH:MM:SS.SSS Z@
--
-- The first space may instead be a @T@, and the second space is
-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a
-- time zone offset of the form @+0000@ or @-08:00@, where the first
-- two digits are hours, the @:@ is optional and the second two digits
-- (also optional) are minutes.
instance FromJSON ZonedTime where
parseJSON = withText "ZonedTime" (Time.run Time.zonedTime)
instance FromJSONKey ZonedTime where
fromJSONKey = FromJSONKeyTextParser (Time.run Time.zonedTime)
instance FromJSON UTCTime where
parseJSON = withText "UTCTime" (Time.run Time.utcTime)
instance FromJSONKey UTCTime where
fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)
-- | This instance includes a bounds check to prevent maliciously
-- large inputs to fill up the memory of the target system. You can
-- newtype 'Scientific' and provide your own instance using
-- 'withScientific' if you want to allow larger inputs.
instance FromJSON NominalDiffTime where
parseJSON = withBoundedScientific "NominalDiffTime" $ pure . realToFrac
-- | This instance includes a bounds check to prevent maliciously
-- large inputs to fill up the memory of the target system. You can
-- newtype 'Scientific' and provide your own instance using
-- 'withScientific' if you want to allow larger inputs.
instance FromJSON DiffTime where
parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
instance FromJSON SystemTime where
parseJSON v = prependContext "SystemTime" $ do
n <- parseJSON v
let n' = floor (n * fromInteger (resolution n) :: Nano)
let (secs, nano) = n' `divMod` resolution n
return (MkSystemTime (fromInteger secs) (fromInteger nano))
instance FromJSON CalendarDiffTime where
parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime
<$> obj .: "months"
<*> obj .: "time"
instance FromJSON CalendarDiffDays where
parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays
<$> obj .: "months"
<*> obj .: "days"
instance FromJSON DayOfWeek where
parseJSON = withText "DaysOfWeek" parseDayOfWeek
parseDayOfWeek :: T.Text -> Parser DayOfWeek
parseDayOfWeek t = case T.toLower t of
"monday" -> return Monday
"tuesday" -> return Tuesday
"wednesday" -> return Wednesday
"thursday" -> return Thursday
"friday" -> return Friday
"saturday" -> return Saturday
"sunday" -> return Sunday
_ -> fail "Invalid week day"
instance FromJSONKey DayOfWeek where
fromJSONKey = FromJSONKeyTextParser parseDayOfWeek
instance FromJSON QuarterOfYear where
parseJSON = withText "DaysOfWeek" parseQuarterOfYear
parseQuarterOfYear :: T.Text -> Parser QuarterOfYear
parseQuarterOfYear t = case T.toLower t of
"q1" -> return Q1
"q2" -> return Q2
"q3" -> return Q3
"q4" -> return Q4
_ -> fail "Invalid quarter of year"
instance FromJSONKey QuarterOfYear where
fromJSONKey = FromJSONKeyTextParser parseQuarterOfYear
instance FromJSON Quarter where
parseJSON = withText "Quarter" (Time.run Time.quarter)
instance FromJSONKey Quarter where
fromJSONKey = FromJSONKeyTextParser (Time.run Time.quarter)
instance FromJSON Month where
parseJSON = withText "Month" (Time.run Time.month)
instance FromJSONKey Month where
fromJSONKey = FromJSONKeyTextParser (Time.run Time.month)
-------------------------------------------------------------------------------
-- base Monoid/Semigroup
-------------------------------------------------------------------------------
instance FromJSON1 Monoid.Dual where
liftParseJSON p _ = fmap Monoid.Dual . p
instance FromJSON a => FromJSON (Monoid.Dual a) where
parseJSON = parseJSON1
instance FromJSON1 Monoid.First where
liftParseJSON p p' = fmap Monoid.First . liftParseJSON p p'
instance FromJSON a => FromJSON (Monoid.First a) where
parseJSON = parseJSON1
instance FromJSON1 Monoid.Last where
liftParseJSON p p' = fmap Monoid.Last . liftParseJSON p p'
instance FromJSON a => FromJSON (Monoid.Last a) where
parseJSON = parseJSON1
instance FromJSON1 Semigroup.Min where
liftParseJSON p _ a = Semigroup.Min <$> p a
liftParseJSONList _ p a = fmap Semigroup.Min <$> p a
instance (FromJSON a) => FromJSON (Semigroup.Min a) where
parseJSON = parseJSON1
parseJSONList = liftParseJSONList parseJSON parseJSONList
instance FromJSON1 Semigroup.Max where
liftParseJSON p _ a = Semigroup.Max <$> p a
liftParseJSONList _ p a = fmap Semigroup.Max <$> p a
instance (FromJSON a) => FromJSON (Semigroup.Max a) where
parseJSON = parseJSON1
parseJSONList = liftParseJSONList parseJSON parseJSONList
instance FromJSON1 Semigroup.First where
liftParseJSON p _ a = Semigroup.First <$> p a
liftParseJSONList _ p a = fmap Semigroup.First <$> p a
instance (FromJSON a) => FromJSON (Semigroup.First a) where
parseJSON = parseJSON1
parseJSONList = liftParseJSONList parseJSON parseJSONList
instance FromJSON1 Semigroup.Last where
liftParseJSON p _ a = Semigroup.Last <$> p a
liftParseJSONList _ p a = fmap Semigroup.Last <$> p a
instance (FromJSON a) => FromJSON (Semigroup.Last a) where
parseJSON = parseJSON1
parseJSONList = liftParseJSONList parseJSON parseJSONList
instance FromJSON1 Semigroup.WrappedMonoid where
liftParseJSON p _ a = Semigroup.WrapMonoid <$> p a
liftParseJSONList _ p a = fmap Semigroup.WrapMonoid <$> p a
instance (FromJSON a) => FromJSON (Semigroup.WrappedMonoid a) where
parseJSON = parseJSON1
parseJSONList = liftParseJSONList parseJSON parseJSONList
#if !MIN_VERSION_base(4,16,0)
instance FromJSON1 Semigroup.Option where
liftParseJSON p p' = fmap Semigroup.Option . liftParseJSON p p'
instance FromJSON a => FromJSON (Semigroup.Option a) where
parseJSON = parseJSON1
#endif
-------------------------------------------------------------------------------
-- data-fix
-------------------------------------------------------------------------------
-- | @since 1.5.3.0
instance FromJSON1 f => FromJSON (F.Fix f) where
parseJSON = go where go = fmap F.Fix . liftParseJSON go parseJSONList
-- | @since 1.5.3.0
instance (FromJSON1 f, Functor f) => FromJSON (F.Mu f) where
parseJSON = fmap (F.unfoldMu F.unFix) . parseJSON
-- | @since 1.5.3.0
instance (FromJSON1 f, Functor f) => FromJSON (F.Nu f) where
parseJSON = fmap (F.unfoldNu F.unFix) . parseJSON
-------------------------------------------------------------------------------
-- strict
-------------------------------------------------------------------------------
-- | @since 1.5.3.0
instance (FromJSON a, FromJSON b) => FromJSON (S.These a b) where
parseJSON = fmap S.toStrict . parseJSON
-- | @since 1.5.3.0
instance FromJSON2 S.These where
liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs
-- | @since 1.5.3.0
instance FromJSON a => FromJSON1 (S.These a) where
liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas
-- | @since 1.5.3.0
instance (FromJSON a, FromJSON b) => FromJSON (S.Pair a b) where
parseJSON = fmap S.toStrict . parseJSON
-- | @since 1.5.3.0
instance FromJSON2 S.Pair where
liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs
-- | @since 1.5.3.0
instance FromJSON a => FromJSON1 (S.Pair a) where
liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas
-- | @since 1.5.3.0
instance (FromJSON a, FromJSON b) => FromJSON (S.Either a b) where
parseJSON = fmap S.toStrict . parseJSON
-- | @since 1.5.3.0
instance FromJSON2 S.Either where
liftParseJSON2 pa pas pb pbs = fmap S.toStrict . liftParseJSON2 pa pas pb pbs
-- | @since 1.5.3.0
instance FromJSON a => FromJSON1 (S.Either a) where
liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas
-- | @since 1.5.3.0
instance FromJSON a => FromJSON (S.Maybe a) where
parseJSON = fmap S.toStrict . parseJSON
-- | @since 1.5.3.0
instance FromJSON1 S.Maybe where
liftParseJSON pa pas = fmap S.toStrict . liftParseJSON pa pas
-------------------------------------------------------------------------------
-- tagged
-------------------------------------------------------------------------------
instance FromJSON1 Proxy where
liftParseJSON _ _ _ = pure Proxy
instance FromJSON (Proxy a) where
parseJSON _ = pure Proxy
instance FromJSON2 Tagged where
liftParseJSON2 _ _ p _ = fmap Tagged . p
instance FromJSON1 (Tagged a) where
liftParseJSON p _ = fmap Tagged . p
instance FromJSON b => FromJSON (Tagged a b) where
parseJSON = parseJSON1
instance FromJSONKey b => FromJSONKey (Tagged a b) where
fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b)
fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList
-------------------------------------------------------------------------------
-- these
-------------------------------------------------------------------------------
-- | @since 1.5.1.0
instance (FromJSON a, FromJSON b) => FromJSON (These a b) where
parseJSON = withObject "These a b" (p . KM.toList)
where
p [("This", a), ("That", b)] = These <$> parseJSON a <*> parseJSON b
p [("That", b), ("This", a)] = These <$> parseJSON a <*> parseJSON b
p [("This", a)] = This <$> parseJSON a
p [("That", b)] = That <$> parseJSON b
p _ = fail "Expected object with 'This' and 'That' keys only"
-- | @since 1.5.1.0
instance FromJSON a => FromJSON1 (These a) where
liftParseJSON pb _ = withObject "These a b" (p . KM.toList)
where
p [("This", a), ("That", b)] = These <$> parseJSON a <*> pb b
p [("That", b), ("This", a)] = These <$> parseJSON a <*> pb b
p [("This", a)] = This <$> parseJSON a
p [("That", b)] = That <$> pb b
p _ = fail "Expected object with 'This' and 'That' keys only"
-- | @since 1.5.1.0
instance FromJSON2 These where
liftParseJSON2 pa _ pb _ = withObject "These a b" (p . KM.toList)
where
p [("This", a), ("That", b)] = These <$> pa a <*> pb b
p [("That", b), ("This", a)] = These <$> pa a <*> pb b
p [("This", a)] = This <$> pa a
p [("That", b)] = That <$> pb b
p _ = fail "Expected object with 'This' and 'That' keys only"
-- | @since 1.5.1.0
instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (These1 f g) where
liftParseJSON px pl = withObject "These1" (p . KM.toList)
where
p [("This", a), ("That", b)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b
p [("That", b), ("This", a)] = These1 <$> liftParseJSON px pl a <*> liftParseJSON px pl b
p [("This", a)] = This1 <$> liftParseJSON px pl a
p [("That", b)] = That1 <$> liftParseJSON px pl b
p _ = fail "Expected object with 'This' and 'That' keys only"
-- | @since 1.5.1.0
instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (These1 f g a) where
parseJSON = parseJSON1
-------------------------------------------------------------------------------
-- Instances for converting from map keys
-------------------------------------------------------------------------------
instance (FromJSON a, FromJSON b) => FromJSONKey (a,b)
instance (FromJSON a, FromJSON b, FromJSON c) => FromJSONKey (a,b,c)
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)
instance FromJSONKey Char where
fromJSONKey = FromJSONKeyTextParser parseChar
fromJSONKeyList = FromJSONKeyText T.unpack
instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where
fromJSONKey = fromJSONKeyList
-------------------------------------------------------------------------------
-- Tuple instances, see tuple-instances-from.hs
-------------------------------------------------------------------------------
instance FromJSON2 (,) where
liftParseJSON2 pA _ pB _ = withArray "(a, b)" $ \t ->
let n = V.length t
in if n == 2
then (,)
<$> parseJSONElemAtIndex pA 0 t
<*> parseJSONElemAtIndex pB 1 t
else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 2"
instance (FromJSON a) => FromJSON1 ((,) a) where
liftParseJSON = liftParseJSON2 parseJSON parseJSONList
instance (FromJSON a, FromJSON b) => FromJSON (a, b) where
parseJSON = parseJSON2
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"
instance (FromJSON a, FromJSON b) => FromJSON1 ((,,) a b) where
liftParseJSON = liftParseJSON2 parseJSON parseJSONList
instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a, b, c) where
parseJSON = parseJSON2
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"
instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON1 ((,,,) a b c) where
liftParseJSON = liftParseJSON2 parseJSON parseJSONList
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a, b, c, d) where
parseJSON = parseJSON2
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"
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON1 ((,,,,) a b c d) where
liftParseJSON = liftParseJSON2 parseJSON parseJSONList
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON (a, b, c, d, e) where
parseJSON = parseJSON2
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"
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON1 ((,,,,,) a b c d e) where
liftParseJSON = liftParseJSON2 parseJSON parseJSONList
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON (a, b, c, d, e, f) where
parseJSON = parseJSON2
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"
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
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
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"
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
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
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"
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
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
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"
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
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
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"
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
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
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"
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
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
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"
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
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
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"
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
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
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"
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
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