@@ -5,17 +5,19 @@
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE NoImplicitPrelude #-}
8+{-# LANGUAGE NamedFieldPuns #-}
9{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE RecordWildCards #-}
10{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TypeSynonymInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
16{-# LANGUAGE ViewPatterns #-}
15{-# LANGUAGE ViewPatterns #-}
18−#include "incoherent-compat.h"
17+#if __GLASGOW_HASKELL__ >= 706
18+{-# LANGUAGE PolyKinds #-}
19#include "overlapping-compat.h"
21#include "overlapping-compat.h"
21-- TODO: Drop this when we remove support for Data.Attoparsec.Number
23-- TODO: Drop this when we remove support for Data.Attoparsec.Number
@@ -42,9 +44,6 @@ module Data.Aeson.Types.FromJSON
42 , coerceFromJSONKeyFunction
44 , coerceFromJSONKeyFunction
43 , mapFromJSONKeyFunction
45 , mapFromJSONKeyFunction
48 -- * List functions
47 -- * List functions
49 , listParser
48 , listParser
@@ -52,42 +51,34 @@ module Data.Aeson.Types.FromJSON
52 , withObject
51 , withObject
53 , withText
52 , withText
54 , withArray
53 , withArray
55 , withScientific
55 , withScientific
56 , withBool
56 , withBool
59 -- * Functions
58 -- * Functions
60 , fromJSON
59 , fromJSON
61 , ifromJSON
60 , ifromJSON
68− , explicitParseFieldMaybe
69− , explicitParseFieldMaybe'
77 -- * Internal
67 -- * Internal
78 , parseOptionalFieldWith
68 , parseOptionalFieldWith
81import Prelude.Compat
72import Prelude.Compat
83−import Control.Applicative ((<|>), Const(..), liftA2)
74+import Control.Applicative ((<|>), Const(..))
84−import Control.Monad (zipWithM)
75+import Control.Monad ((<=<), zipWithM)
85import Data.Aeson.Internal.Functions (mapKey)
76import Data.Aeson.Internal.Functions (mapKey)
86−import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
87import Data.Aeson.Types.Generic
77import Data.Aeson.Types.Generic
88import Data.Aeson.Types.Internal
78import Data.Aeson.Types.Internal
79+import Data.Attoparsec.Number (Number(..))
89import Data.Bits (unsafeShiftR)
80import Data.Bits (unsafeShiftR)
90−import Data.Fixed (Fixed, HasResolution (resolution), Nano)
81+import Data.Fixed (Fixed, HasResolution)
91import Data.Functor.Compose (Compose(..))
82import Data.Functor.Compose (Compose(..))
92import Data.Functor.Identity (Identity(..))
83import Data.Functor.Identity (Identity(..))
93import Data.Functor.Product (Product(..))
84import Data.Functor.Product (Product(..))
@@ -96,67 +87,57 @@ import Data.Hashable (Hashable(..))
96import Data.Int (Int16, Int32, Int64, Int8)
87import Data.Int (Int16, Int32, Int64, Int8)
97import Data.List.NonEmpty (NonEmpty(..))
88import Data.List.NonEmpty (NonEmpty(..))
98import Data.Maybe (fromMaybe)
89import Data.Maybe (fromMaybe)
99−import Data.Semigroup ((<>))
90+import Data.Monoid ((<>), Dual(..), First (..), Last (..))
100import Data.Proxy (Proxy(..))
91import Data.Proxy (Proxy(..))
101import Data.Ratio ((%), Ratio)
92import Data.Ratio ((%), Ratio)
102−import Data.Scientific (Scientific, base10Exponent)
93+import Data.Scientific (Scientific)
103import Data.Tagged (Tagged(..))
94import Data.Tagged (Tagged(..))
104import Data.Text (Text, pack, unpack)
95import Data.Text (Text, pack, unpack)
105−import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
96+import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
106−import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
97+import Data.Time.Format (parseTime)
107−import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
108−import Data.Time.Clock.System.Compat (SystemTime (..))
109−import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
98+import Data.Time.Locale.Compat (defaultTimeLocale)
110import Data.Traversable as Tr (sequence)
99import Data.Traversable as Tr (sequence)
111import Data.Vector (Vector)
100import Data.Vector (Vector)
112import Data.Version (Version, parseVersion)
101import Data.Version (Version, parseVersion)
113−import Data.Void (Void)
114import Data.Word (Word16, Word32, Word64, Word8)
102import Data.Word (Word16, Word32, Word64, Word8)
115import Foreign.Storable (Storable)
103import Foreign.Storable (Storable)
116−import Foreign.C.Types (CTime (..))
117import GHC.Generics
104import GHC.Generics
118import Numeric.Natural (Natural)
105import Numeric.Natural (Natural)
119import Text.ParserCombinators.ReadP (readP_to_S)
106import Text.ParserCombinators.ReadP (readP_to_S)
120−import Unsafe.Coerce (unsafeCoerce)
121import qualified Data.Aeson.Parser.Time as Time
107import qualified Data.Aeson.Parser.Time as Time
122import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
108import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123−import qualified Data.ByteString.Lazy as L
124import qualified Data.DList as DList
109import qualified Data.DList as DList
125import qualified Data.HashMap.Strict as H
110import qualified Data.HashMap.Strict as H
126import qualified Data.HashSet as HashSet
111import qualified Data.HashSet as HashSet
127import qualified Data.IntMap as IntMap
112import qualified Data.IntMap as IntMap
128import qualified Data.IntSet as IntSet
113import qualified Data.IntSet as IntSet
129import qualified Data.Map as M
114import qualified Data.Map as M
130−import qualified Data.Monoid as Monoid
131import qualified Data.Scientific as Scientific
115import qualified Data.Scientific as Scientific
132−import qualified Data.Semigroup as Semigroup
133import qualified Data.Sequence as Seq
116import qualified Data.Sequence as Seq
134import qualified Data.Set as Set
117import qualified Data.Set as Set
135import qualified Data.Text as T
118import qualified Data.Text as T
136import qualified Data.Text.Encoding as T
119import qualified Data.Text.Encoding as T
137import qualified Data.Text.Lazy as LT
120import qualified Data.Text.Lazy as LT
138import qualified Data.Tree as Tree
121import qualified Data.Tree as Tree
139−import qualified Data.UUID.Types as UUID
140import qualified Data.Vector as V
122import qualified Data.Vector as V
141import qualified Data.Vector.Generic as VG
123import qualified Data.Vector.Generic as VG
142import qualified Data.Vector.Primitive as VP
124import qualified Data.Vector.Primitive as VP
143import qualified Data.Vector.Storable as VS
125import qualified Data.Vector.Storable as VS
144import qualified Data.Vector.Unboxed as VU
126import qualified Data.Vector.Unboxed as VU
127+import Unsafe.Coerce (unsafeCoerce)
146−import qualified GHC.Exts as Exts
129+#ifndef HAS_COERCIBLE
147−import qualified Data.Primitive.Array as PM
130+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
148−import qualified Data.Primitive.SmallArray as PM
149−import qualified Data.Primitive.Types as PM
151−#if MIN_VERSION_primitive(0,6,4)
152−#if !MIN_VERSION_primitive(0,7,0)
153−import qualified Data.Primitive.UnliftedArray as PM
155−import qualified Data.Primitive.PrimArray as PM
158−
133+#if HAS_COERCIBLE
159import Data.Coerce (Coercible, coerce)
134import Data.Coerce (Coercible, coerce)
135+coerce' :: Coercible a b => a -> b
139+coerce' = unsafeCoerce
161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
142parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
162parseIndexedJSON p idx value = p value <?> Index idx
143parseIndexedJSON p idx value = p value <?> Index idx
@@ -165,7 +146,7 @@ parseIndexedJSON p idx value = p value <?> Index idx
165parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)
146parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)
166parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
147parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
168− p = withArray "(k, v)" $ \ab ->
149+ p = withArray "(k,v)" $ \ab ->
169 let n = V.length ab
150 let n = V.length ab
170 in if n == 2
151 in if n == 2
171 then (,) <$> parseJSONElemAtIndex keyParser 0 ab
152 then (,) <$> parseJSONElemAtIndex keyParser 0 ab
@@ -177,34 +158,43 @@ parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
177parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a
158parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a
178parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx
159parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx
161+scientificToNumber :: Scientific -> Number
163+ | e < 0 = D $ Scientific.toRealFloat s
164+ | otherwise = I $ c * 10 ^ e
166+ e = Scientific.base10Exponent s
167+ c = Scientific.coefficient s
168+{-# INLINE scientificToNumber #-}
180parseRealFloat :: RealFloat a => String -> Value -> Parser a
170parseRealFloat :: RealFloat a => String -> Value -> Parser a
181−parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s
171+parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s
182−parseRealFloat _ Null = pure (0/0)
172+parseRealFloat _ Null = pure (0/0)
183−parseRealFloat name v = prependContext name (unexpected v)
173+parseRealFloat expected v = typeMismatch expected v
184{-# INLINE parseRealFloat #-}
174{-# INLINE parseRealFloat #-}
186−parseIntegralFromScientific :: forall a. Integral a => Scientific -> Parser a
176+parseIntegralFromScientific :: forall a. Integral a => String -> Scientific -> Parser a
187−parseIntegralFromScientific s =
177+parseIntegralFromScientific expected s =
188 case Scientific.floatingOrInteger s :: Either Double a of
178 case Scientific.floatingOrInteger s :: Either Double a of
189 Right x -> pure x
179 Right x -> pure x
190− Left _ -> fail $ "unexpected floating number " ++ show s
180+ Left _ -> fail $ "Floating number specified for " ++ expected ++ ": " ++ show s
191{-# INLINE parseIntegralFromScientific #-}
181{-# INLINE parseIntegralFromScientific #-}
193parseIntegral :: Integral a => String -> Value -> Parser a
183parseIntegral :: Integral a => String -> Value -> Parser a
194−parseIntegral name =
184+parseIntegral expected =
195− prependContext name . withBoundedScientific' parseIntegralFromScientific
185+ withScientific expected $ parseIntegralFromScientific expected
196{-# INLINE parseIntegral #-}
186{-# INLINE parseIntegral #-}
198−parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => Scientific -> Parser a
188+parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => String -> Scientific -> Parser a
199−parseBoundedIntegralFromScientific s = maybe
189+parseBoundedIntegralFromScientific expected s = maybe
200− (fail $ "value is either floating or will cause over or underflow " ++ show s)
190+ (fail $ expected ++ " is either floating or will cause over or underflow: " ++ show s)
202 (Scientific.toBoundedInteger s)
192 (Scientific.toBoundedInteger s)
203{-# INLINE parseBoundedIntegralFromScientific #-}
193{-# INLINE parseBoundedIntegralFromScientific #-}
205parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a
195parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a
206−parseBoundedIntegral name =
196+parseBoundedIntegral expected =
207− prependContext name . withScientific' parseBoundedIntegralFromScientific
197+ withScientific expected $ parseBoundedIntegralFromScientific expected
208{-# INLINE parseBoundedIntegral #-}
198{-# INLINE parseBoundedIntegral #-}
210parseScientificText :: Text -> Parser Scientific
200parseScientificText :: Text -> Parser Scientific
@@ -214,20 +204,13 @@ parseScientificText
214 . T.encodeUtf8
204 . T.encodeUtf8
216parseIntegralText :: Integral a => String -> Text -> Parser a
206parseIntegralText :: Integral a => String -> Text -> Parser a
217−parseIntegralText name t =
207+parseIntegralText expected t =
218− prependContext name $
219− parseScientificText t
220− >>= rejectLargeExponent
221− >>= parseIntegralFromScientific
208+ parseScientificText t >>= parseIntegralFromScientific expected
223− rejectLargeExponent :: Scientific -> Parser Scientific
224− rejectLargeExponent s = withBoundedScientific' pure (Number s)
225{-# INLINE parseIntegralText #-}
209{-# INLINE parseIntegralText #-}
227parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a
211parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a
228−parseBoundedIntegralText name t =
212+parseBoundedIntegralText expected t =
229− prependContext name $
230− parseScientificText t >>= parseBoundedIntegralFromScientific
213+ parseScientificText t >>= parseBoundedIntegralFromScientific expected
232parseOptionalFieldWith :: (Value -> Parser (Maybe a))
215parseOptionalFieldWith :: (Value -> Parser (Maybe a))
233 -> Object -> Text -> Parser (Maybe a)
216 -> Object -> Text -> Parser (Maybe a)
@@ -287,21 +270,14 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
288-- The basic ways to signal a failed conversion are as follows:
271-- The basic ways to signal a failed conversion are as follows:
290−-- * 'fail' yields a custom error message: it is the recommended way of
291−-- reporting a failure;
293−-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:
273+-- * 'empty' and 'mzero' work, but are terse and uninformative
294−-- use it when the error is meant to be caught by some @('<|>')@;
296−-- * 'typeMismatch' can be used to report a failure when the encountered value
275+-- * 'fail' yields a custom error message
297−-- is not of the expected JSON type; 'unexpected' is an appropriate alternative
298−-- when more than one type may be expected, or to keep the expected type
301−-- 'prependFailure' (or 'modifyFailure') add more information to a parser's
277+-- * 'typeMismatch' produces an informative message for cases when the
302−-- error messages.
278+-- value encountered is not of the expected type
304−-- An example type and instance using 'typeMismatch' and 'prependFailure':
280+-- An example type and instance:
307-- \-- Allow ourselves to write 'Text' literals.
283-- \-- Allow ourselves to write 'Text' literals.
@@ -309,30 +285,15 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
310-- data Coord = Coord { x :: Double, y :: Double }
286-- data Coord = Coord { x :: Double, y :: Double }
312−-- instance 'FromJSON' Coord where
288+-- instance FromJSON Coord where
313−-- 'parseJSON' ('Object' v) = Coord
289+-- parseJSON ('Object' v) = Coord '<$>'
314−-- '<$>' v '.:' \"x\"
290+-- v '.:' \"x\" '<*>'
315−-- '<*>' v '.:' \"y\"
291+-- v '.:' \"y\"
317−-- \-- We do not expect a non-'Object' value here.
293+-- \-- We do not expect a non-'Object' value here.
318−-- \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'
294+-- \-- We could use 'mzero' to fail, but 'typeMismatch'
319−-- \-- gives a much more informative error message.
295+-- \-- gives a much more informative error message.
320−-- 'parseJSON' invalid =
296+-- parseJSON invalid = 'typeMismatch' \"Coord\" invalid
321−-- 'prependFailure' "parsing Coord failed, "
322−-- ('typeMismatch' \"Object\" invalid)
325−-- For this common case of only being concerned with a single
326−-- type of JSON value, the functions 'withObject', 'withScientific', etc.
327−-- are provided. Their use is to be preferred when possible, since
328−-- they are more terse. Using 'withObject', we can rewrite the above instance
329−-- (assuming the same language extension and data type) as:
332−-- instance 'FromJSON' Coord where
333−-- 'parseJSON' = 'withObject' \"Coord\" $ \\v -> Coord
334−-- '<$>' v '.:' \"x\"
335−-- '<*>' v '.:' \"y\"
338-- Instead of manually writing your 'FromJSON' instance, there are two options
299-- Instead of manually writing your 'FromJSON' instance, there are two options
@@ -340,7 +301,7 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
341-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
302-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
342-- instance at compile time. The generated instance is optimized for your type
303-- instance at compile time. The generated instance is optimized for your type
343−-- so it will probably be more efficient than the following option.
304+-- so will probably be more efficient than the following two options:
345-- * The compiler can provide a default generic implementation for
306-- * The compiler can provide a default generic implementation for
346-- 'parseJSON'.
307-- 'parseJSON'.
@@ -358,21 +319,18 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
359-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'
320-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'
361−-- instance 'FromJSON' Coord
322+-- instance FromJSON Coord
364−-- The default implementation will be equivalent to
325+-- If @DefaultSignatures@ doesn't give exactly the results you want,
365−-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different
366−-- options, you can customize the generic decoding by defining:
326+-- you can customize the generic decoding with only a tiny amount of
327+-- effort, using 'genericParseJSON' with your preferred 'Options':
369−-- customOptions = 'defaultOptions'
370−-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'
373−-- instance 'FromJSON' Coord where
330+-- instance FromJSON Coord where
374−-- 'parseJSON' = 'genericParseJSON' customOptions
331+-- parseJSON = 'genericParseJSON' 'defaultOptions'
376class FromJSON a where
334class FromJSON a where
377 parseJSON :: Value -> Parser a
335 parseJSON :: Value -> Parser a
@@ -380,11 +338,13 @@ class FromJSON a where
380 parseJSON = genericParseJSON defaultOptions
338 parseJSON = genericParseJSON defaultOptions
382 parseJSONList :: Value -> Parser [a]
340 parseJSONList :: Value -> Parser [a]
383− parseJSONList = withArray "[]" $ \a ->
341+ parseJSONList (Array a)
384− zipWithM (parseIndexedJSON parseJSON) [0..]
342+ = zipWithM (parseIndexedJSON parseJSON) [0..]
385 . V.toList
343 . V.toList
346+ parseJSONList v = typeMismatch "[a]" v
388-------------------------------------------------------------------------------
348-------------------------------------------------------------------------------
389-- Classes and types for map keys
349-- Classes and types for map keys
390-------------------------------------------------------------------------------
350-------------------------------------------------------------------------------
@@ -396,16 +356,6 @@ class FromJSON a where
396-- > newtype SomeId = SomeId { getSomeId :: Text }
356-- > newtype SomeId = SomeId { getSomeId :: Text }
397-- > deriving (Eq,Ord,Hashable,FromJSONKey)
357-- > deriving (Eq,Ord,Hashable,FromJSONKey)
399−-- If you have a sum of nullary constructors, you may use the generic
403−-- data Color = Red | Green | Blue
406−-- instance 'FromJSONKey' Color where
407−-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'
409class FromJSONKey a where
359class FromJSONKey a where
410 -- | Strategy for parsing the key of a map-like container.
360 -- | Strategy for parsing the key of a map-like container.
411 fromJSONKey :: FromJSONKeyFunction a
361 fromJSONKey :: FromJSONKeyFunction a
@@ -428,7 +378,11 @@ class FromJSONKey a where
428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
378-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
429-- can be inspected, but cannot be constructed.
379-- can be inspected, but cannot be constructed.
430data CoerceText a where
380data CoerceText a where
431 CoerceText :: Coercible Text a => CoerceText a
382 CoerceText :: Coercible Text a => CoerceText a
384+ CoerceText :: CoerceText a
433-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
387-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
388-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -448,7 +402,7 @@ data FromJSONKeyFunction a
449-- | Only law abiding up to interpretation
403-- | Only law abiding up to interpretation
450instance Functor FromJSONKeyFunction where
404instance Functor FromJSONKeyFunction where
451− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
405+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
406 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
407 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
408 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -462,7 +416,9 @@ instance Functor FromJSONKeyFunction where
463-- On pre GHC 7.8 this is unconstrainted function.
417-- On pre GHC 7.8 this is unconstrainted function.
464fromJSONKeyCoerce ::
418fromJSONKeyCoerce ::
465 Coercible Text a =>
420 Coercible Text a =>
466 FromJSONKeyFunction a
422 FromJSONKeyFunction a
467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
423fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
@@ -470,91 +426,60 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
471-- See note on 'fromJSONKeyCoerce'.
427-- See note on 'fromJSONKeyCoerce'.
472coerceFromJSONKeyFunction ::
428coerceFromJSONKeyFunction ::
473 Coercible a b =>
430 Coercible a b =>
474 FromJSONKeyFunction a -> FromJSONKeyFunction b
432 FromJSONKeyFunction a -> FromJSONKeyFunction b
475coerceFromJSONKeyFunction = coerce
434coerceFromJSONKeyFunction = coerce
436+coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText
437+coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)
438+coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)
439+coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)
478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
443 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
479 fmap id x = x
444 fmap id x = x
482 "FromJSONKeyCoerce: fmap coerce" forall x .
448 "FromJSONKeyCoerce: fmap coerce" forall x .
483 fmap coerce x = coerceFromJSONKeyFunction x
449 fmap coerce x = coerceFromJSONKeyFunction x
486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
453-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
454mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
488mapFromJSONKeyFunction = fmap
455mapFromJSONKeyFunction = fmap
490−-- | 'fromJSONKey' for 'Generic' types.
491−-- These types must be sums of nullary constructors, whose names will be used
492−-- as keys for JSON objects.
494−-- See also 'genericToJSONKey'.
499−-- data Color = Red | Green | Blue
500−-- deriving 'Generic'
502−-- instance 'FromJSONKey' Color where
503−-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'
505−genericFromJSONKey :: forall a. (Generic a, GFromJSONKey (Rep a))
507− -> FromJSONKeyFunction a
508−genericFromJSONKey opts = FromJSONKeyTextParser $ \t ->
509− case parseSumFromString (keyModifier opts) t of
511− "invalid key " ++ show t ++ ", expected one of " ++ show cnames
512− Just k -> pure (to k)
514− cnames = unTagged2 (constructorTags (keyModifier opts) :: Tagged2 (Rep a) [String])
516−class (ConstructorNames f, SumFromString f) => GFromJSONKey f where
517−instance (ConstructorNames f, SumFromString f) => GFromJSONKey f where
519-------------------------------------------------------------------------------
457-------------------------------------------------------------------------------
520-- Functions needed for documentation
458-- Functions needed for documentation
521-------------------------------------------------------------------------------
459-------------------------------------------------------------------------------
523-- | Fail parsing due to a type mismatch, with a descriptive message.
461-- | Fail parsing due to a type mismatch, with a descriptive message.
525−-- The following wrappers should generally be prefered:
463+-- Example usage:
526−-- 'withObject', 'withArray', 'withText', 'withBool'.
528−-- ==== Error message example
530−-- > typeMismatch "Object" (String "oops")
465+-- @
531−-- > -- Error: "expected Object, but encountered String"
466+-- instance FromJSON Coord where
467+-- parseJSON ('Object' v) = {- type matches, life is good -}
468+-- parseJSON wat = 'typeMismatch' \"Coord\" wat
532−typeMismatch :: String -- ^ The name of the JSON type being parsed
470+typeMismatch :: String -- ^ The name of the type you are trying to parse.
533− -- (@\"Object\"@, @\"Array\"@, @\"String\"@, @\"Number\"@,
534− -- @\"Boolean\"@, or @\"Null\"@).
535 -> Value -- ^ The actual value encountered.
471 -> Value -- ^ The actual value encountered.
536 -> Parser a
472 -> Parser a
537typeMismatch expected actual =
473typeMismatch expected actual =
538− fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual
474+ fail $ "expected " ++ expected ++ ", encountered " ++ name
540−-- | Fail parsing due to a type mismatch, when the expected types are implicit.
542−-- ==== Error message example
544−-- > unexpected (String "oops")
545−-- > -- Error: "unexpected String"
546−unexpected :: Value -> Parser a
547−unexpected actual = fail $ "unexpected " ++ typeOf actual
549−-- | JSON type of a value, name of the head constructor.
550−typeOf :: Value -> String
551−typeOf v = case v of
476+ name = case actual of
552− Object _ -> "Object"
477+ Object _ -> "Object"
553− Array _ -> "Array"
478+ Array _ -> "Array"
554− String _ -> "String"
479+ String _ -> "String"
555− Number _ -> "Number"
480+ Number _ -> "Number"
556− Bool _ -> "Boolean"
481+ Bool _ -> "Boolean"
557− Null -> "Null"
482+ Null -> "Null"
559-------------------------------------------------------------------------------
484-------------------------------------------------------------------------------
560-- Lifings of FromJSON and ToJSON to unary and binary type constructors
485-- Lifings of FromJSON and ToJSON to unary and binary type constructors
@@ -567,7 +492,7 @@ typeOf v = case v of
568-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
493-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
569-- instance at compile time. The generated instance is optimized for your type
494-- instance at compile time. The generated instance is optimized for your type
570−-- so it will probably be more efficient than the following option.
495+-- so will probably be more efficient than the following two options:
572-- * The compiler can provide a default generic implementation for
497-- * The compiler can provide a default generic implementation for
573-- 'liftParseJSON'.
498-- 'liftParseJSON'.
@@ -585,20 +510,16 @@ typeOf v = case v of
586-- data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'
511-- data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'
588−-- instance 'FromJSON' a => 'FromJSON1' (Pair a)
513+-- instance FromJSON a => FromJSON1 (Pair a)
591−-- If the default implementation doesn't give exactly the results you want,
516+-- If @DefaultSignatures@ doesn't give exactly the results you want,
592-- you can customize the generic decoding with only a tiny amount of
517-- you can customize the generic decoding with only a tiny amount of
593-- effort, using 'genericLiftParseJSON' with your preferred 'Options':
518-- effort, using 'genericLiftParseJSON' with your preferred 'Options':
596−-- customOptions = 'defaultOptions'
597−-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'
600−-- instance 'FromJSON' a => 'FromJSON1' (Pair a) where
521+-- instance FromJSON a => FromJSON1 (Pair a) where
601−-- 'liftParseJSON' = 'genericLiftParseJSON' customOptions
522+-- liftParseJSON = 'genericLiftParseJSON' 'defaultOptions'
603class FromJSON1 f where
524class FromJSON1 f where
604 liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)
525 liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)
@@ -635,8 +556,9 @@ class FromJSON2 f where
635 -> (Value -> Parser b)
556 -> (Value -> Parser b)
636 -> (Value -> Parser [b])
557 -> (Value -> Parser [b])
637 -> Value -> Parser [f a b]
558 -> Value -> Parser [f a b]
638− liftParseJSONList2 fa ga fb gb = withArray "[]" $ \vals ->
559+ liftParseJSONList2 fa ga fb gb v = case v of
639− fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)
560+ Array vals -> fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)
561+ _ -> typeMismatch "[a]" v
641-- | Lift the standard 'parseJSON' function through the type constructor.
563-- | Lift the standard 'parseJSON' function through the type constructor.
642parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
564parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
@@ -650,7 +572,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
650-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
572-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
651listParser :: (Value -> Parser a) -> Value -> Parser [a]
573listParser :: (Value -> Parser a) -> Value -> Parser [a]
652listParser f (Array xs) = fmap V.toList (V.mapM f xs)
574listParser f (Array xs) = fmap V.toList (V.mapM f xs)
653−listParser _ v = typeMismatch "Array" v
575+listParser _ v = typeMismatch "[a]" v
654{-# INLINE listParser #-}
576{-# INLINE listParser #-}
656-------------------------------------------------------------------------------
578-------------------------------------------------------------------------------
@@ -668,139 +590,48 @@ instance (FromJSON a) => FromJSON [a] where
668-- Functions
590-- Functions
669-------------------------------------------------------------------------------
591-------------------------------------------------------------------------------
671−-- | Add context to a failure message, indicating the name of the structure
674−-- > prependContext "MyType" (fail "[error message]")
675−-- > -- Error: "parsing MyType failed, [error message]"
676−prependContext :: String -> Parser a -> Parser a
677−prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")
679−-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@
593+-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@
680−-- is an 'Data.Aeson.Object' and fails otherwise.
594+-- and fails using @'typeMismatch' expected@ otherwise.
682−-- ==== Error message example
684−-- > withObject "MyType" f (String "oops")
685−-- > -- Error: "parsing MyType failed, expected Object, but encountered String"
686withObject :: String -> (Object -> Parser a) -> Value -> Parser a
595withObject :: String -> (Object -> Parser a) -> Value -> Parser a
687−withObject _ f (Object obj) = f obj
596+withObject _ f (Object obj) = f obj
688−withObject name _ v = prependContext name (typeMismatch "Object" v)
597+withObject expected _ v = typeMismatch expected v
689{-# INLINE withObject #-}
598{-# INLINE withObject #-}
691−-- | @'withText' name f value@ applies @f@ to the 'Text' when @value@ is a
600+-- | @withText expected f value@ applies @f@ to the 'Text' when @value@ is a @String@
692−-- 'Data.Aeson.String' and fails otherwise.
601+-- and fails using @'typeMismatch' expected@ otherwise.
694−-- ==== Error message example
696−-- > withText "MyType" f Null
697−-- > -- Error: "parsing MyType failed, expected String, but encountered Null"
698withText :: String -> (Text -> Parser a) -> Value -> Parser a
602withText :: String -> (Text -> Parser a) -> Value -> Parser a
699−withText _ f (String txt) = f txt
603+withText _ f (String txt) = f txt
700−withText name _ v = prependContext name (typeMismatch "String" v)
604+withText expected _ v = typeMismatch expected v
701{-# INLINE withText #-}
605{-# INLINE withText #-}
703−-- | @'withArray' expected f value@ applies @f@ to the 'Array' when @value@ is
607+-- | @withArray expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@
704−-- an 'Data.Aeson.Array' and fails otherwise.
608+-- and fails using @'typeMismatch' expected@ otherwise.
706−-- ==== Error message example
708−-- > withArray "MyType" f (String "oops")
709−-- > -- Error: "parsing MyType failed, expected Array, but encountered String"
710withArray :: String -> (Array -> Parser a) -> Value -> Parser a
609withArray :: String -> (Array -> Parser a) -> Value -> Parser a
711−withArray _ f (Array arr) = f arr
610+withArray _ f (Array arr) = f arr
712−withArray name _ v = prependContext name (typeMismatch "Array" v)
611+withArray expected _ v = typeMismatch expected v
713{-# INLINE withArray #-}
612{-# INLINE withArray #-}
614+-- | @withNumber expected f value@ applies @f@ to the 'Number' when @value@ is a 'Number'.
615+-- and fails using @'typeMismatch' expected@ otherwise.
616+withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
617+withNumber expected f = withScientific expected (f . scientificToNumber)
618+{-# INLINE withNumber #-}
619+{-# DEPRECATED withNumber "Use withScientific instead" #-}
715−-- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number
621+-- | @withScientific expected f value@ applies @f@ to the 'Scientific' number when @value@ is a 'Number'.
716−-- when @value@ is a 'Data.Aeson.Number' and fails using 'typeMismatch'
622+-- and fails using @'typeMismatch' expected@ otherwise.
719−-- /Warning/: If you are converting from a scientific to an unbounded
720−-- type such as 'Integer' you may want to add a restriction on the
721−-- size of the exponent (see 'withBoundedScientific') to prevent
722−-- malicious input from filling up the memory of the target system.
724−-- ==== Error message example
726−-- > withScientific "MyType" f (String "oops")
727−-- > -- Error: "parsing MyType failed, expected Number, but encountered String"
728withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
623withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
729−withScientific _ f (Number scientific) = f scientific
624+withScientific _ f (Number scientific) = f scientific
730−withScientific name _ v = prependContext name (typeMismatch "Number" v)
625+withScientific expected _ v = typeMismatch expected v
731{-# INLINE withScientific #-}
626{-# INLINE withScientific #-}
733−-- | A variant of 'withScientific' which doesn't use 'prependContext', so that
628+-- | @withBool expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@
734−-- such context can be added separately in a way that also applies when the
735−-- continuation @f :: Scientific -> Parser a@ fails.
737−-- /Warning/: If you are converting from a scientific to an unbounded
738−-- type such as 'Integer' you may want to add a restriction on the
739−-- size of the exponent (see 'withBoundedScientific') to prevent
740−-- malicious input from filling up the memory of the target system.
742−-- ==== Error message examples
744−-- > withScientific' f (String "oops")
745−-- > -- Error: "unexpected String"
747−-- > prependContext "MyType" (withScientific' f (String "oops"))
748−-- > -- Error: "parsing MyType failed, unexpected String"
749−withScientific' :: (Scientific -> Parser a) -> Value -> Parser a
750−withScientific' f v = case v of
752− _ -> typeMismatch "Number" v
753−{-# INLINE withScientific' #-}
755−-- | @'withBoundedScientific' name f value@ applies @f@ to the 'Scientific' number
756−-- when @value@ is a 'Number' with exponent less than or equal to 1024.
757−withBoundedScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
758−withBoundedScientific name f v = withBoundedScientific_ (prependContext name) f v
759−{-# INLINE withBoundedScientific #-}
761−-- | A variant of 'withBoundedScientific' which doesn't use 'prependContext',
762−-- so that such context can be added separately in a way that also applies
763−-- when the continuation @f :: Scientific -> Parser a@ fails.
764−withBoundedScientific' :: (Scientific -> Parser a) -> Value -> Parser a
765−withBoundedScientific' f v = withBoundedScientific_ id f v
766−{-# INLINE withBoundedScientific' #-}
768−-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
769−-- to the 'Parser' in case of failure.
770−withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
771−withBoundedScientific_ whenFail f (Number scientific) =
773− then whenFail (fail msg)
776− exp10 = base10Exponent scientific
777− msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"
778−withBoundedScientific_ whenFail _ v =
779− whenFail (typeMismatch "Number" v)
780−{-# INLINE withBoundedScientific_ #-}
782−-- | @'withBool' expected f value@ applies @f@ to the 'Bool' when @value@ is a
783−-- 'Boolean' and fails otherwise.
629+-- and fails using @'typeMismatch' expected@ otherwise.
785−-- ==== Error message example
787−-- > withBool "MyType" f (String "oops")
788−-- > -- Error: "parsing MyType failed, expected Boolean, but encountered String"
789withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
630withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
790−withBool _ f (Bool arr) = f arr
631+withBool _ f (Bool arr) = f arr
791−withBool name _ v = prependContext name (typeMismatch "Boolean" v)
632+withBool expected _ v = typeMismatch expected v
792{-# INLINE withBool #-}
633{-# INLINE withBool #-}
794−-- | Decode a nested JSON-encoded string.
795−withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
796−withEmbeddedJSON _ innerParser (String txt) =
797− either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
799− eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
800− eitherFormatError = either (Left . uncurry formatError) Right
801−withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v)
802−{-# INLINE withEmbeddedJSON #-}
804-- | Convert a value from JSON, failing if the types do not match.
635-- | Convert a value from JSON, failing if the types do not match.
805fromJSON :: (FromJSON a) => Value -> Result a
636fromJSON :: (FromJSON a) => Value -> Result a
806fromJSON = parse parseJSON
637fromJSON = parse parseJSON
@@ -819,68 +650,32 @@ ifromJSON = iparse parseJSON
819-- in an object for it to be valid. If the key and value are
650-- in an object for it to be valid. If the key and value are
820-- optional, use '.:?' instead.
651-- optional, use '.:?' instead.
821(.:) :: (FromJSON a) => Object -> Text -> Parser a
652(.:) :: (FromJSON a) => Object -> Text -> Parser a
822−(.:) = explicitParseField parseJSON
653+obj .: key = case H.lookup key obj of
654+ Nothing -> fail $ "key " ++ show key ++ " not present"
655+ Just v -> parseJSON v <?> Key key
823{-# INLINE (.:) #-}
656{-# INLINE (.:) #-}
825−-- | Retrieve the value associated with the given key of an 'Object'. The
658+-- | Retrieve the value associated with the given key of an 'Object'. The
826−-- result is 'Nothing' if the key is not present or if its value is 'Null',
659+-- result is 'Nothing' if the key is not present or value is 'Null', or 'empty'
827−-- or 'empty' if the value cannot be converted to the desired type.
660+-- if the value cannot be converted to the desired type.
829-- This accessor is most useful if the key and value can be absent
662-- This accessor is most useful if the key and value can be absent
830-- from an object without affecting its validity. If the key and
663-- from an object without affecting its validity. If the key and
831-- value are mandatory, use '.:' instead.
664-- value are mandatory, use '.:' instead.
832(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
665(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
833−(.:?) = explicitParseFieldMaybe parseJSON
666+obj .:? key = case H.lookup key obj of
667+ Nothing -> pure Nothing
668+ Just v -> parseJSON v <?> Key key
834{-# INLINE (.:?) #-}
669{-# INLINE (.:?) #-}
836−-- | Retrieve the value associated with the given key of an 'Object'.
671+-- | Like '.:?', but the resulting parser will fail,
837−-- The result is 'Nothing' if the key is not present or 'empty' if the
672+-- if the key is present but is 'Null'.
838−-- value cannot be converted to the desired type.
840−-- This differs from '.:?' by attempting to parse 'Null' the same as any
841−-- other JSON value, instead of interpreting it as 'Nothing'.
842(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
673(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
843−(.:!) = explicitParseFieldMaybe' parseJSON
674+obj .:! key = case H.lookup key obj of
675+ Nothing -> pure Nothing
676+ Just v -> Just <$> parseJSON v <?> Key key
844{-# INLINE (.:!) #-}
677{-# INLINE (.:!) #-}
846−-- | Function variant of '.:'.
847−parseField :: (FromJSON a) => Object -> Text -> Parser a
849−{-# INLINE parseField #-}
851−-- | Function variant of '.:?'.
852−parseFieldMaybe :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
853−parseFieldMaybe = (.:?)
854−{-# INLINE parseFieldMaybe #-}
856−-- | Function variant of '.:!'.
857−parseFieldMaybe' :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
858−parseFieldMaybe' = (.:!)
859−{-# INLINE parseFieldMaybe' #-}
861−-- | Variant of '.:' with explicit parser function.
863−-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
864−explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
865−explicitParseField p obj key = case H.lookup key obj of
866− Nothing -> fail $ "key " ++ show key ++ " not found"
867− Just v -> p v <?> Key key
868−{-# INLINE explicitParseField #-}
870−-- | Variant of '.:?' with explicit parser function.
871−explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)
872−explicitParseFieldMaybe p obj key = case H.lookup key obj of
873− Nothing -> pure Nothing
874− Just v -> liftParseJSON p (listParser p) v <?> Key key -- listParser isn't used by maybe instance.
875−{-# INLINE explicitParseFieldMaybe #-}
877−-- | Variant of '.:!' with explicit parser function.
878−explicitParseFieldMaybe' :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)
879−explicitParseFieldMaybe' p obj key = case H.lookup key obj of
880− Nothing -> pure Nothing
881− Just v -> Just <$> p v <?> Key key
882−{-# INLINE explicitParseFieldMaybe' #-}
884-- | Helper for use in combination with '.:?' to provide default
679-- | Helper for use in combination with '.:?' to provide default
885-- values for optional JSON object fields.
680-- values for optional JSON object fields.
@@ -903,47 +698,11 @@ pmval .!= val = fromMaybe val <$> pmval
903-- Generic parseJSON
698-- Generic parseJSON
904-------------------------------------------------------------------------------
699-------------------------------------------------------------------------------
906−instance GFromJSON arity V1 where
907− -- Whereof we cannot format, thereof we cannot parse:
908− gParseJSON _ _ _ = fail "Attempted to parse empty type"
911instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where
701instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where
912 -- Meta-information, which is not handled elsewhere, is just added to the
702 -- Meta-information, which is not handled elsewhere, is just added to the
913 -- parsed value:
703 -- parsed value:
914 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs
704 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs
916−-- Information for error messages
918−type TypeName = String
919−type ConName = String
921−-- | Add the name of the type being parsed to a parser's error messages.
922−contextType :: TypeName -> Parser a -> Parser a
923−contextType = prependContext
925−-- | Add the tagKey that will be looked up while building an ADT
926−-- | Produce the error equivalent to
927−-- | Left "Error in $: parsing T failed, expected an object with keys "tag" and
928−-- | "contents", where "tag" i-- |s associated to one of ["Foo", "Bar"],
929−-- | The parser returned error was: could not find key "tag"
930−contextTag :: Text -> [String] -> Parser a -> Parser a
931−contextTag tagKey cnames = prependFailure
932− ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++
933− " containing one of " ++ show cnames ++ ", ")
935−-- | Add the name of the constructor being parsed to a parser's error messages.
936−contextCons :: ConName -> TypeName -> Parser a -> Parser a
937−contextCons cname tname = prependContext (showCons cname tname)
939−-- | Render a constructor as @\"MyType(MyConstructor)\"@.
940−showCons :: ConName -> TypeName -> String
941−showCons cname tname = tname ++ "(" ++ cname ++ ")"
943−--------------------------------------------------------------------------------
945−-- Parsing single fields
947instance (FromJSON a) => GFromJSON arity (K1 i a) where
706instance (FromJSON a) => GFromJSON arity (K1 i a) where
948 -- Constant values are decoded using their FromJSON instance:
707 -- Constant values are decoded using their FromJSON instance:
949 gParseJSON _opts _ = fmap K1 . parseJSON
708 gParseJSON _opts _ = fmap K1 . parseJSON
@@ -958,499 +717,327 @@ instance (FromJSON1 f) => GFromJSON One (Rec1 f) where
958 -- FromJSON1 instance:
717 -- FromJSON1 instance:
959 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl
718 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl
720+instance GFromJSON arity U1 where
721+ -- Empty constructors are expected to be encoded as an empty array:
722+ gParseJSON _opts _ v
723+ | isEmptyArray v = pure U1
724+ | otherwise = typeMismatch "unit constructor (U1)" v
726+instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where
727+ -- Constructors need to be decoded differently depending on whether they're
728+ -- a record or not. This distinction is made by consParseJSON:
729+ gParseJSON opts fargs = fmap M1 . consParseJSON opts fargs
731+instance ( FromProduct arity a, FromProduct arity b
732+ , ProductSize a, ProductSize b
733+ ) => GFromJSON arity (a :*: b) where
734+ -- Products are expected to be encoded to an array. Here we check whether we
735+ -- got an array of the same size as the product, then parse each of the
736+ -- product's elements using parseProduct:
737+ gParseJSON opts fargs = withArray "product (:*:)" $ \arr ->
738+ let lenArray = V.length arr
739+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
741+ if lenArray == lenProduct
742+ then parseProduct opts fargs arr 0 lenProduct
743+ else fail $ "When expecting a product of " ++ show lenProduct ++
744+ " values, encountered an Array of " ++ show lenArray ++
747+instance ( AllNullary (a :+: b) allNullary
748+ , ParseSum arity (a :+: b) allNullary
749+ ) => GFromJSON arity (a :+: b) where
750+ -- If all constructors of a sum datatype are nullary and the
751+ -- 'allNullaryToStringTag' option is set they are expected to be
752+ -- encoded as strings. This distinction is made by 'parseSum':
753+ gParseJSON opts fargs =
754+ (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->
755+ Parser ((a :+: b) d))
756+ . parseSum opts fargs
961instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
758instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
962 -- If an occurrence of the last type parameter is nested inside two
759 -- If an occurrence of the last type parameter is nested inside two
963 -- composed types, it is decoded by using the outermost type's FromJSON1
760 -- composed types, it is decoded by using the outermost type's FromJSON1
964 -- instance to generically decode the innermost type:
761 -- instance to generically decode the innermost type:
965 gParseJSON opts fargs =
762 gParseJSON opts fargs =
966− let gpj = gParseJSON opts fargs in
763+ let gpj = gParseJSON opts fargs in
967− fmap Comp1 . liftParseJSON gpj (listParser gpj)
764+ fmap Comp1 . liftParseJSON gpj (listParser gpj)
969−--------------------------------------------------------------------------------
971−instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where
972− -- Meta-information, which is not handled elsewhere, is just added to the
974− gParseJSON opts fargs = fmap M1 . gParseJSON' (tname :* opts :* fargs)
976− tname = moduleName proxy ++ "." ++ datatypeName proxy
977− proxy = undefined :: M1 _i d _f _p
979−-- | 'GFromJSON', after unwrapping the 'D1' constructor, now carrying the data
981−class GFromJSON' arity f where
982− gParseJSON' :: TypeName :* Options :* FromArgs arity a
986−-- | Single constructor.
987−instance ( ConsFromJSON arity a
988− , AllNullary (C1 c a) allNullary
989− , ParseSum arity (C1 c a) allNullary
991− ) => GFromJSON' arity (C1 c a) where
992− -- The option 'tagSingleConstructors' determines whether to wrap
993− -- a single-constructor type.
994− gParseJSON' p@(_ :* opts :* _)
995− | tagSingleConstructors opts
996− = (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))
998− | otherwise = fmap M1 . consParseJSON (cname :* p)
1000− cname = conName (undefined :: M1 _i c _f _p)
1002−-- | Multiple constructors.
1003−instance ( AllNullary (a :+: b) allNullary
1004− , ParseSum arity (a :+: b) allNullary
1005− ) => GFromJSON' arity (a :+: b) where
1006− -- If all constructors of a sum datatype are nullary and the
1007− -- 'allNullaryToStringTag' option is set they are expected to be
1008− -- encoded as strings. This distinction is made by 'parseSum':
1010− (unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->
1011− Parser ((a :+: b) _d))
1014--------------------------------------------------------------------------------
766--------------------------------------------------------------------------------
1016class ParseSum arity f allNullary where
768class ParseSum arity f allNullary where
1017− parseSum :: TypeName :* Options :* FromArgs arity a
769+ parseSum :: Options -> FromArgs arity a
1019− -> Tagged allNullary (Parser (f a))
770+ -> Value -> Tagged allNullary (Parser (f a))
1021−instance ( ConstructorNames f
1022− , SumFromString f
772+instance ( SumFromString (a :+: b)
1023− , FromPair arity f
773+ , FromPair arity (a :+: b)
1024− , FromTaggedObject arity f
774+ , FromTaggedObject arity (a :+: b)
1025− , FromUntaggedValue arity f
775+ , FromUntaggedValue arity (a :+: b)
1026− ) => ParseSum arity f True where
776+ ) => ParseSum arity (a :+: b) True where
1027− parseSum p@(tname :* opts :* _)
777+ parseSum opts fargs
1028− | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts
778+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts
1029− | otherwise = Tagged . parseNonAllNullarySum p
779+ | otherwise = Tagged . parseNonAllNullarySum opts fargs
1031−instance ( ConstructorNames f
1032− , FromPair arity f
781+instance ( FromPair arity (a :+: b)
1033− , FromTaggedObject arity f
782+ , FromTaggedObject arity (a :+: b)
1034− , FromUntaggedValue arity f
783+ , FromUntaggedValue arity (a :+: b)
1035− ) => ParseSum arity f False where
784+ ) => ParseSum arity (a :+: b) False where
1036− parseSum p = Tagged . parseNonAllNullarySum p
785+ parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs
1038--------------------------------------------------------------------------------
787--------------------------------------------------------------------------------
1040−parseAllNullarySum :: (SumFromString f, ConstructorNames f)
789+parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)
1041− => TypeName -> Options -> Value -> Parser (f a)
1042−parseAllNullarySum tname opts =
790+parseAllNullarySum opts = withText "Text" $ \key ->
1043− withText tname $ \tag ->
1044− maybe (badTag tag) return $
791+ maybe (notFound key) return $
1045− parseSumFromString modifier tag
792+ parseSumFromString opts key
1047− badTag tag = failWithCTags tname modifier $ \cnames ->
1048− "expected one of the tags " ++ show cnames ++
1049− ", but found tag " ++ show tag
1050− modifier = constructorTagModifier opts
1052−-- | Fail with an informative error message about a mismatched tag.
1053−-- The error message is parameterized by the list of expected tags,
1054−-- to be inferred from the result type of the parser.
1056− :: forall f a t. ConstructorNames f
1057− => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)
1058−failWithCTags tname modifier f =
1059− contextType tname . fail $ f cnames
1061− cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])
1063class SumFromString f where
794class SumFromString f where
1064− parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
795+ parseSumFromString :: Options -> Text -> Maybe (f a)
1066instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
797instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
1067 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
798 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
1068 (R1 <$> parseSumFromString opts key)
799 (R1 <$> parseSumFromString opts key)
1070instance (Constructor c) => SumFromString (C1 c U1) where
801instance (Constructor c) => SumFromString (C1 c U1) where
1071− parseSumFromString modifier key
802+ parseSumFromString opts key | key == name = Just $ M1 U1
1072− | key == name = Just $ M1 U1
1073− | otherwise = Nothing
803+ | otherwise = Nothing
1075− name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)
805+ name = pack $ constructorTagModifier opts $
1077−-- For genericFromJSONKey
1078−instance SumFromString a => SumFromString (D1 d a) where
1079− parseSumFromString modifier key = M1 <$> parseSumFromString modifier key
1081−-- | List of all constructor tags.
1082−constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]
1083−constructorTags modifier =
1084− fmap DList.toList (constructorNames' modifier)
1086−-- | List of all constructor names of an ADT, after a given conversion
1087−-- function. (Better inlining.)
1088−class ConstructorNames a where
1089− constructorNames' :: (String -> t) -> Tagged2 a (DList.DList t)
1091−instance (ConstructorNames a, ConstructorNames b) => ConstructorNames (a :+: b) where
1092− constructorNames' = liftA2 append constructorNames' constructorNames'
1095− :: Tagged2 a (DList.DList t)
1096− -> Tagged2 b (DList.DList t)
1097− -> Tagged2 (a :+: b) (DList.DList t)
1098− append (Tagged2 xs) (Tagged2 ys) = Tagged2 (DList.append xs ys)
1100−instance Constructor c => ConstructorNames (C1 c a) where
1101− constructorNames' f = Tagged2 (pure (f cname))
1103− cname = conName (undefined :: M1 _i c _f _p)
806+ conName (undefined :: t c U1 p)
1105−-- For genericFromJSONKey
1106−instance ConstructorNames a => ConstructorNames (D1 d a) where
1107− constructorNames' = retag . constructorNames'
1109− retag :: Tagged2 a u -> Tagged2 (D1 d a) u
1110− retag (Tagged2 x) = Tagged2 x
1112--------------------------------------------------------------------------------
808--------------------------------------------------------------------------------
1113−parseNonAllNullarySum :: forall f c arity.
810+parseNonAllNullarySum :: ( FromPair arity (a :+: b)
1115− , FromTaggedObject arity f
811+ , FromTaggedObject arity (a :+: b)
1116− , FromUntaggedValue arity f
812+ , FromUntaggedValue arity (a :+: b)
1117− , ConstructorNames f
1118− ) => TypeName :* Options :* FromArgs arity c
813+ ) => Options -> FromArgs arity c
1119− -> Value -> Parser (f c)
814+ -> Value -> Parser ((a :+: b) c)
1120−parseNonAllNullarySum p@(tname :* opts :* _) =
815+parseNonAllNullarySum opts fargs =
1121 case sumEncoding opts of
816 case sumEncoding opts of
1122 TaggedObject{..} ->
817 TaggedObject{..} ->
1123− withObject tname $ \obj -> do
818+ withObject "Object" $ \obj -> do
1124− tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
1125− fromMaybe (badTag tag <?> Key tagKey) $
1126− parseFromTaggedObject (tag :* contentsFieldName :* p) obj
1128− tagKey = pack tagFieldName
819+ tag <- obj .: pack tagFieldName
1129− badTag tag = failWith_ $ \cnames ->
820+ fromMaybe (notFound tag) $
1130− "expected tag field to be one of " ++ show cnames ++
821+ parseFromTaggedObject opts fargs contentsFieldName obj tag
1131− ", but found tag " ++ show tag
1132− cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
1134 ObjectWithSingleField ->
823 ObjectWithSingleField ->
824+ withObject "Object" $ \obj ->
1135− withObject tname $ \obj -> case H.toList obj of
825+ case H.toList obj of
1136− [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $
826+ [pair@(tag, _)] -> fromMaybe (notFound tag) $
1137− parsePair (tag :* p) v
827+ parsePair opts fargs pair
1138− _ -> contextType tname . fail $
828+ _ -> fail "Object doesn't have a single field"
1139− "expected an Object with a single pair, but found " ++
1140− show (H.size obj) ++ " pairs"
1142− badTag tag = failWith_ $ \cnames ->
1143− "expected an Object with a single pair where the tag is one of " ++
1144− show cnames ++ ", but found tag " ++ show tag
1146 TwoElemArray ->
830 TwoElemArray ->
1147− withArray tname $ \arr -> case V.length arr of
831+ withArray "Array" $ \arr ->
832+ if V.length arr == 2
1148− 2 | String tag <- V.unsafeIndex arr 0 ->
833+ then case V.unsafeIndex arr 0 of
1149− maybe (badTag tag <?> Index 0) (<?> Index 1) $
834+ String tag -> fromMaybe (notFound tag) $
1150− parsePair (tag :* p) (V.unsafeIndex arr 1)
835+ parsePair opts fargs (tag, V.unsafeIndex arr 1)
1152− contextType tname $
1153− fail "tag element is not a String" <?> Index 0
836+ _ -> fail "First element is not a String"
1154− len -> contextType tname . fail $
837+ else fail "Array doesn't have 2 elements"
1155− "expected a 2-element Array, but encountered an Array of length " ++
1158− badTag tag = failWith_ $ \cnames ->
1159− "expected tag of the 2-element Array to be one of " ++
1160− show cnames ++ ", but found tag " ++ show tag
1162− UntaggedValue -> parseUntaggedValue p
839+ UntaggedValue -> parseUntaggedValue opts fargs
1164− failWith_ = failWithCTags tname (constructorTagModifier opts)
1166--------------------------------------------------------------------------------
841--------------------------------------------------------------------------------
1168class FromTaggedObject arity f where
843class FromTaggedObject arity f where
1169− -- The first two components of the parameter tuple are: the constructor tag
1170− -- to match against, and the contents field name.
1171− parseFromTaggedObject
844+ parseFromTaggedObject :: Options -> FromArgs arity a
1172− :: Text :* String :* TypeName :* Options :* FromArgs arity a
1173− -> Object
845+ -> String -> Object
1174− -> Maybe (Parser (f a))
846+ -> Text -> Maybe (Parser (f a))
1176instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
848instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
1177 FromTaggedObject arity (a :+: b) where
849 FromTaggedObject arity (a :+: b) where
1178− parseFromTaggedObject p obj =
850+ parseFromTaggedObject opts fargs contentsFieldName obj tag =
1179− (fmap L1 <$> parseFromTaggedObject p obj) <|>
851+ (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>
1180− (fmap R1 <$> parseFromTaggedObject p obj)
852+ (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)
1182−instance ( IsRecord f isRecord
1183− , FromTaggedObject' arity f isRecord
854+instance ( FromTaggedObject' arity f
1184 , Constructor c
855 , Constructor c
1185 ) => FromTaggedObject arity (C1 c f) where
856 ) => FromTaggedObject arity (C1 c f) where
1186− parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))
857+ parseFromTaggedObject opts fargs contentsFieldName obj tag
1189− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
1190− parseFromTaggedObject' (contentsFieldName :* cname :* p)
858+ | tag == name = Just $ M1 <$> parseFromTaggedObject'
859+ opts fargs contentsFieldName obj
1191− | otherwise = const Nothing
860+ | otherwise = Nothing
1193− tag' = pack $ constructorTagModifier opts cname
862+ name = pack $ constructorTagModifier opts $
1194− cname = conName (undefined :: M1 _i c _f _p)
863+ conName (undefined :: t c f p)
1196--------------------------------------------------------------------------------
865--------------------------------------------------------------------------------
1198−class FromTaggedObject' arity f isRecord where
867+class FromTaggedObject' arity f where
1199− -- The first component of the parameter tuple is the contents field name.
868+ parseFromTaggedObject' :: Options -> FromArgs arity a -> String
1200− parseFromTaggedObject'
869+ -> Object -> Parser (f a)
871+class FromTaggedObject'' arity f isRecord where
1201− :: String :* ConName :* TypeName :* Options :* FromArgs arity a
872+ parseFromTaggedObject'' :: Options -> FromArgs arity a -> String
1202− -> Object -> Tagged isRecord (Parser (f a))
873+ -> Object -> Tagged isRecord (Parser (f a))
875+instance ( IsRecord f isRecord
876+ , FromTaggedObject'' arity f isRecord
1204−instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
877+ ) => FromTaggedObject' arity f where
1205− -- Records are unpacked in the tagged object
878+ parseFromTaggedObject' opts fargs contentsFieldName =
1206− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
879+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
1207−
880+ parseFromTaggedObject'' opts fargs contentsFieldName
1208−instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
882+instance (FromRecord arity f) => FromTaggedObject'' arity f True where
1209− -- Nonnullary nonrecords are encoded in the contents field
1210− parseFromTaggedObject' p obj = Tagged $ do
883+ parseFromTaggedObject'' opts fargs _ =
1211− contents <- contextCons cname tname (obj .: key)
884+ Tagged . parseRecord opts fargs Nothing
1212− consParseJSON p' contents <?> Key key
1214− key = pack contentsFieldName
1215− contentsFieldName :* p'@(cname :* tname :* _) = p
886+instance (GFromJSON arity f) => FromTaggedObject'' arity f False where
887+ parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .
888+ (gParseJSON opts fargs <=< (.: pack contentsFieldName))
1217−instance OVERLAPPING_ FromTaggedObject' arity U1 False where
890+instance OVERLAPPING_ FromTaggedObject'' arity U1 False where
1218− -- Nullary constructors don't need a contents field
891+ parseFromTaggedObject'' _ _ _ _ = Tagged (pure U1)
1219− parseFromTaggedObject' _ _ = Tagged (pure U1)
1221--------------------------------------------------------------------------------
893--------------------------------------------------------------------------------
1223−-- | Constructors need to be decoded differently depending on whether they're
1224−-- a record or not. This distinction is made by 'ConsParseJSON'.
1225class ConsFromJSON arity f where
895class ConsFromJSON arity f where
1227− :: ConName :* TypeName :* Options :* FromArgs arity a
896+ consParseJSON :: Options -> FromArgs arity a
1228− -> Value -> Parser (f a)
897+ -> Value -> Parser (f a)
1230class ConsFromJSON' arity f isRecord where
899class ConsFromJSON' arity f isRecord where
1232− :: ConName :* TypeName :* Options :* FromArgs arity a
900+ consParseJSON' :: Options -> FromArgs arity a
901+ -> Maybe Text -- ^ A dummy label
902+ -- (Nothing to use proper label)
1233− -> Value -> Tagged isRecord (Parser (f a))
903+ -> Value -> Tagged isRecord (Parser (f a))
1235instance ( IsRecord f isRecord
905instance ( IsRecord f isRecord
1236 , ConsFromJSON' arity f isRecord
906 , ConsFromJSON' arity f isRecord
1237 ) => ConsFromJSON arity f where
907 ) => ConsFromJSON arity f where
1238− consParseJSON p =
908+ consParseJSON opts fargs v = let
909+ (v2,lab) = case (unwrapUnaryRecords opts,isUnary (undefined :: f a)) of
910+ -- use a dummy object with a dummy label
911+ (True,True) -> (object [(pack "dummy",v)], Just $ pack "dummy")
1239− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
913+ in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
1240− . consParseJSON' p
914+ $ consParseJSON' opts fargs lab v2
1242−instance OVERLAPPING_
1243− ( GFromJSON arity a, RecordFromJSON arity (S1 s a)
1244− ) => ConsFromJSON' arity (S1 s a) True where
1245− consParseJSON' p@(cname :* tname :* opts :* fargs)
1246− | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1247− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
1249−instance RecordFromJSON arity f => ConsFromJSON' arity f True where
917+instance (FromRecord arity f) => ConsFromJSON' arity f True where
1250− consParseJSON' p@(cname :* tname :* _) =
918+ consParseJSON' opts fargs mlab = Tagged . withObject "record (:*:)"
1251− Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
919+ (parseRecord opts fargs mlab)
1253−instance OVERLAPPING_
1254− ConsFromJSON' arity U1 False where
1255− -- Empty constructors are expected to be encoded as an empty array:
1256− consParseJSON' (cname :* tname :* _) v =
1257− Tagged . contextCons cname tname $ case v of
1258− Array a | V.null a -> pure U1
1259− | otherwise -> fail_ a
1260− _ -> typeMismatch "Array" v
1263− "expected an empty Array, but encountered an Array of length " ++
1266−instance OVERLAPPING_
1267− GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where
921+instance (GFromJSON arity f) => ConsFromJSON' arity f False where
1268− consParseJSON' (_ :* _ :* opts :* fargs) =
1269− Tagged . fmap M1 . gParseJSON opts fargs
922+ consParseJSON' opts fargs _ = Tagged . gParseJSON opts fargs
1271−instance (ProductFromJSON arity f, ProductSize f
1272− ) => ConsFromJSON' arity f False where
1273− consParseJSON' p = Tagged . productParseJSON0 p
1275--------------------------------------------------------------------------------
924--------------------------------------------------------------------------------
1277−class FieldNames f where
926+class FromRecord arity f where
1278− fieldNames :: f a -> [Text] -> [Text]
1280−instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where
1282− fieldNames (undefined :: a x) .
1283− fieldNames (undefined :: b y)
1285−instance (Selector s) => FieldNames (S1 s f) where
1286− fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)
1288−class RecordFromJSON arity f where
1290− :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a
927+ parseRecord :: Options -> FromArgs arity a
928+ -> Maybe Text -- ^ A dummy label
929+ -- (Nothing to use proper label)
1291− -> Object -> Parser (f a)
930+ -> Object -> Parser (f a)
1293−instance ( FieldNames f
932+instance ( FromRecord arity a
1294− , RecordFromJSON' arity f
933+ , FromRecord arity b
1295− ) => RecordFromJSON arity f where
934+ ) => FromRecord arity (a :*: b) where
1296− recordParseJSON (fromTaggedSum :* p@(cname :* tname :* opts :* _)) =
935+ parseRecord opts fargs _ obj =
1297− \obj -> checkUnknown obj >> recordParseJSON' p obj
936+ (:*:) <$> parseRecord opts fargs Nothing obj
937+ <*> parseRecord opts fargs Nothing obj
939+instance ( Selector s
941+ ) => FromRecord arity (S1 s a) where
942+ parseRecord opts fargs lab =
943+ (<?> Key label) . gParseJSON opts fargs <=< (.: label)
1299− knownFields :: H.HashMap Text ()
945+ label = fromMaybe defLabel lab
1300− knownFields = H.fromList $ map (,()) $
1301− fieldNames (undefined :: f a)
1302− [pack (tagFieldName (sumEncoding opts)) | fromTaggedSum]
1304− if not (rejectUnknownFields opts)
1305− then \_ -> return ()
1306− else \obj -> case H.keys (H.difference obj knownFields) of
1308− unknownFields -> contextCons cname tname $
1309− fail ("unknown fields: " ++ show unknownFields)
1311−class RecordFromJSON' arity f where
1313− :: ConName :* TypeName :* Options :* FromArgs arity a
1314− -> Object -> Parser (f a)
1316−instance ( RecordFromJSON' arity a
1317− , RecordFromJSON' arity b
1318− ) => RecordFromJSON' arity (a :*: b) where
1319− recordParseJSON' p obj =
1320− (:*:) <$> recordParseJSON' p obj
1321− <*> recordParseJSON' p obj
1323−instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1324− RecordFromJSON' arity (S1 s a) where
1325− recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
1326− fv <- contextCons cname tname (obj .: label)
1327− M1 <$> gParseJSON opts fargs fv <?> Key label
1329− label = pack $ fieldLabelModifier opts sname
946+ defLabel = pack . fieldLabelModifier opts $
1330− sname = selName (undefined :: M1 _i s _f _p)
947+ selName (undefined :: t s a p)
1332−instance INCOHERENT_ (Selector s, FromJSON a) =>
949+instance OVERLAPPING_ (Selector s, FromJSON a) =>
1333− RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
950+ FromRecord arity (S1 s (K1 i (Maybe a))) where
1334− recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
951+ parseRecord _ _ (Just lab) obj = (M1 . K1) <$> obj .:? lab
1335− where
952+ parseRecord opts _ Nothing obj = (M1 . K1) <$> obj .:? pack label
1336− label = fieldLabelModifier opts sname
1337− sname = selName (undefined :: M1 _i s _f _p)
1339−-- Parse an Option like a Maybe.
1340−instance INCOHERENT_ (Selector s, FromJSON a) =>
1341− RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
1342− recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
1344− wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
954+ label = fieldLabelModifier opts $
1345− wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
955+ selName (undefined :: t s (K1 i (Maybe a)) p)
1347--------------------------------------------------------------------------------
957--------------------------------------------------------------------------------
1350− :: forall f arity a. (ProductFromJSON arity f, ProductSize f)
1351− => ConName :* TypeName :* Options :* FromArgs arity a
1352− -> Value -> Parser (f a)
1353− -- Products are expected to be encoded to an array. Here we check whether we
1354− -- got an array of the same size as the product, then parse each of the
1355− -- product's elements using productParseJSON:
1356−productParseJSON0 p@(cname :* tname :* _ :* _) =
1357− withArray (showCons cname tname) $ \arr ->
1358− let lenArray = V.length arr
1359− lenProduct = (unTagged2 :: Tagged2 f Int -> Int)
1361− if lenArray == lenProduct
1362− then productParseJSON p arr 0 lenProduct
1363− else contextCons cname tname $
1364− fail $ "expected an Array of length " ++ show lenProduct ++
1365− ", but encountered an Array of length " ++ show lenArray
1369−class ProductFromJSON arity f where
959+class FromProduct arity f where
1370− productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a
960+ parseProduct :: Options -> FromArgs arity a
1371 -> Array -> Int -> Int
961 -> Array -> Int -> Int
1372 -> Parser (f a)
962 -> Parser (f a)
1374−instance ( ProductFromJSON arity a
964+instance ( FromProduct arity a
1375− , ProductFromJSON arity b
965+ , FromProduct arity b
1376− ) => ProductFromJSON arity (a :*: b) where
966+ ) => FromProduct arity (a :*: b) where
1377− productParseJSON p arr ix len =
967+ parseProduct opts fargs arr ix len =
1378− (:*:) <$> productParseJSON p arr ix lenL
968+ (:*:) <$> parseProduct opts fargs arr ix lenL
1379− <*> productParseJSON p arr ixR lenR
969+ <*> parseProduct opts fargs arr ixR lenR
1381 lenL = len `unsafeShiftR` 1
971 lenL = len `unsafeShiftR` 1
1382 ixR = ix + lenL
972 ixR = ix + lenL
1383 lenR = len - lenL
973 lenR = len - lenL
1385−instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where
975+instance (GFromJSON arity a) => FromProduct arity (S1 s a) where
1386− productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =
976+ parseProduct opts fargs arr ix _ =
1387− M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix
977+ gParseJSON opts fargs $ V.unsafeIndex arr ix
1389--------------------------------------------------------------------------------
979--------------------------------------------------------------------------------
1391class FromPair arity f where
981class FromPair arity f where
1392− -- The first component of the parameter tuple is the tag to match.
1393− parsePair :: Text :* TypeName :* Options :* FromArgs arity a
982+ parsePair :: Options -> FromArgs arity a
1395− -> Maybe (Parser (f a))
983+ -> Pair -> Maybe (Parser (f a))
1397instance ( FromPair arity a
985instance ( FromPair arity a
1398 , FromPair arity b
986 , FromPair arity b
1399 ) => FromPair arity (a :+: b) where
987 ) => FromPair arity (a :+: b) where
1401− (fmap L1 <$> parsePair p pair) <|>
988+ parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>
1402− (fmap R1 <$> parsePair p pair)
989+ (fmap R1 <$> parsePair opts fargs pair)
1404instance ( Constructor c
991instance ( Constructor c
1405 , ConsFromJSON arity a
993 , ConsFromJSON arity a
1406 ) => FromPair arity (C1 c a) where
994 ) => FromPair arity (C1 c a) where
1407− parsePair (tag :* p@(_ :* opts :* _)) v
995+ parsePair opts fargs (tag, value)
1408− | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v
996+ | tag == tag' = Just $ gParseJSON opts fargs value
1409 | otherwise = Nothing
997 | otherwise = Nothing
1411− tag' = pack $ constructorTagModifier opts cname
999+ tag' = pack $ constructorTagModifier opts $
1412− cname = conName (undefined :: M1 _i c _a _p)
1000+ conName (undefined :: t c a p)
1414--------------------------------------------------------------------------------
1002--------------------------------------------------------------------------------
1416class FromUntaggedValue arity f where
1004class FromUntaggedValue arity f where
1417− parseUntaggedValue :: TypeName :* Options :* FromArgs arity a
1005+ parseUntaggedValue :: Options -> FromArgs arity a
1419− -> Parser (f a)
1006+ -> Value -> Parser (f a)
1422 ( FromUntaggedValue arity a
1009 ( FromUntaggedValue arity a
1423 , FromUntaggedValue arity b
1010 , FromUntaggedValue arity b
1424 ) => FromUntaggedValue arity (a :+: b)
1011 ) => FromUntaggedValue arity (a :+: b)
1426− parseUntaggedValue p value =
1013+ parseUntaggedValue opts fargs value =
1427− L1 <$> parseUntaggedValue p value <|>
1014+ L1 <$> parseUntaggedValue opts fargs value <|>
1428− R1 <$> parseUntaggedValue p value
1015+ R1 <$> parseUntaggedValue opts fargs value
1430instance OVERLAPPABLE_
1017instance OVERLAPPABLE_
1431− ( ConsFromJSON arity a
1018+ ( GFromJSON arity a
1432− , Constructor c
1019+ , ConsFromJSON arity a
1433 ) => FromUntaggedValue arity (C1 c a)
1020 ) => FromUntaggedValue arity (C1 c a)
1435− parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)
1022+ parseUntaggedValue = gParseJSON
1437− cname = conName (undefined :: M1 _i c _f _p)
1439instance OVERLAPPING_
1024instance OVERLAPPING_
1440 ( Constructor c )
1025 ( Constructor c )
1441 => FromUntaggedValue arity (C1 c U1)
1026 => FromUntaggedValue arity (C1 c U1)
1443− parseUntaggedValue (tname :* opts :* _) v =
1028+ parseUntaggedValue opts _ (String s)
1444− contextCons cname tname $ case v of
1029+ | s == pack (constructorTagModifier opts (conName (undefined :: t c U1 p))) =
1446− | tag == tag' -> pure $ M1 U1
1030+ pure $ M1 U1
1447− | otherwise -> fail_ tag
1031+ | otherwise =
1448− _ -> typeMismatch "String" v
1032+ fail $ "Invalid tag: " ++ unpack s
1449− where
1033+ parseUntaggedValue _ _ v = typeMismatch (conName (undefined :: t c U1 p)) v
1450− tag' = pack $ constructorTagModifier opts cname
1034+
1451− cname = conName (undefined :: M1 _i c _f _p)
1035+
1452− fail_ tag = fail $
1036+--------------------------------------------------------------------------------
1453− "expected tag " ++ show tag' ++ ", but found tag " ++ show tag
1037+
1038+notFound :: Text -> Parser a
1039+notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"
1040+{-# INLINE notFound #-}
1455-------------------------------------------------------------------------------
1042-------------------------------------------------------------------------------
1456-- Instances
1043-- Instances
@@ -1508,20 +1095,17 @@ instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
1508 parseJSON = parseJSON2
1095 parseJSON = parseJSON2
1509 {-# INLINE parseJSON #-}
1096 {-# INLINE parseJSON #-}
1511−instance FromJSON Void where
1098+
1512− parseJSON _ = fail "Cannot parse Void"
1513− {-# INLINE parseJSON #-}
1515instance FromJSON Bool where
1100instance FromJSON Bool where
1516− parseJSON (Bool b) = pure b
1101+ parseJSON = withBool "Bool" pure
1517− parseJSON v = typeMismatch "Bool" v
1518 {-# INLINE parseJSON #-}
1102 {-# INLINE parseJSON #-}
1520instance FromJSONKey Bool where
1104instance FromJSONKey Bool where
1521 fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
1105 fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
1522 "true" -> pure True
1106 "true" -> pure True
1523 "false" -> pure False
1107 "false" -> pure False
1524− _ -> fail $ "cannot parse key " ++ show t ++ " into Bool"
1108+ _ -> fail $ "Cannot parse key into Bool: " ++ T.unpack t
1526instance FromJSON Ordering where
1110instance FromJSON Ordering where
1527 parseJSON = withText "Ordering" $ \s ->
1111 parseJSON = withText "Ordering" $ \s ->
@@ -1529,30 +1113,25 @@ instance FromJSON Ordering where
1529 "LT" -> return LT
1113 "LT" -> return LT
1530 "EQ" -> return EQ
1114 "EQ" -> return EQ
1531 "GT" -> return GT
1115 "GT" -> return GT
1532− _ -> fail $ "parsing Ordering failed, unexpected " ++ show s ++
1533− " (expected \"LT\", \"EQ\", or \"GT\")"
1116+ _ -> fail "Parsing Ordering value failed: expected \"LT\", \"EQ\", or \"GT\""
1535instance FromJSON () where
1118instance FromJSON () where
1536 parseJSON = withArray "()" $ \v ->
1119 parseJSON = withArray "()" $ \v ->
1537 if V.null v
1120 if V.null v
1538 then pure ()
1121 then pure ()
1539− else prependContext "()" $ fail "expected an empty array"
1122+ else fail "Expected an empty array"
1540 {-# INLINE parseJSON #-}
1123 {-# INLINE parseJSON #-}
1542instance FromJSON Char where
1125instance FromJSON Char where
1543− parseJSON = withText "Char" parseChar
1126+ parseJSON = withText "Char" $ \t ->
1127+ if T.compareLength t 1 == EQ
1128+ then pure $ T.head t
1129+ else fail "Expected a string of length 1"
1544 {-# INLINE parseJSON #-}
1130 {-# INLINE parseJSON #-}
1546− parseJSONList (String s) = pure (T.unpack s)
1132+ parseJSONList = withText "String" $ pure . T.unpack
1547− parseJSONList v = typeMismatch "String" v
1548 {-# INLINE parseJSONList #-}
1133 {-# INLINE parseJSONList #-}
1550−parseChar :: Text -> Parser Char
1552− if T.compareLength t 1 == EQ
1553− then pure $ T.head t
1554− else prependContext "Char" $ fail "expected a string of length 1"
1556instance FromJSON Double where
1135instance FromJSON Double where
1557 parseJSON = parseRealFloat "Double"
1136 parseJSON = parseRealFloat "Double"
1558 {-# INLINE parseJSON #-}
1137 {-# INLINE parseJSON #-}
@@ -1564,6 +1143,12 @@ instance FromJSONKey Double where
1564 "-Infinity" -> pure (negate 1/0)
1143 "-Infinity" -> pure (negate 1/0)
1565 _ -> Scientific.toRealFloat <$> parseScientificText t
1144 _ -> Scientific.toRealFloat <$> parseScientificText t
1146+instance FromJSON Number where
1147+ parseJSON (Number s) = pure $ scientificToNumber s
1148+ parseJSON Null = pure (D (0/0))
1149+ parseJSON v = typeMismatch "Number" v
1150+ {-# INLINE parseJSON #-}
1567instance FromJSON Float where
1152instance FromJSON Float where
1568 parseJSON = parseRealFloat "Float"
1153 parseJSON = parseRealFloat "Float"
1569 {-# INLINE parseJSON #-}
1154 {-# INLINE parseJSON #-}
@@ -1576,30 +1161,17 @@ instance FromJSONKey Float where
1576 _ -> Scientific.toRealFloat <$> parseScientificText t
1161 _ -> Scientific.toRealFloat <$> parseScientificText t
1578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1163instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1579− parseJSON (Number x)
1581− , exp10 >= -1024 = return $! realToFrac x
1582− | otherwise = prependContext "Ratio" $ fail msg
1584− exp10 = base10Exponent x
1585− msg = "found a number with exponent " ++ show exp10
1586− ++ ", but it must not be greater than 1024 or less than -1024"
1587− parseJSON o = objParser o
1589− objParser = withObject "Rational" $ \obj -> do
1164+ parseJSON = withObject "Rational" $ \obj ->
1590− numerator <- obj .: "numerator"
1165+ (%) <$> obj .: "numerator"
1591− denominator <- obj .: "denominator"
1592− if denominator == 0
1593− then fail "Ratio denominator was 0"
1594− else pure $ numerator % denominator
1166+ <*> obj .: "denominator"
1595− {-# INLINE parseJSON #-}
1167+ {-# INLINE parseJSON #-}
1597−-- | This instance includes a bounds check to prevent maliciously
1169+-- | /WARNING:/ Only parse fixed-precision numbers from trusted input
1598−-- large inputs to fill up the memory of the target system. You can
1170+-- since an attacker could easily fill up the memory of the target
1599−-- newtype 'Scientific' and provide your own instance using
1171+-- system by specifying a scientific number with a big exponent like
1600−-- 'withScientific' if you want to allow larger inputs.
1172+-- @1e1000000000@.
1601instance HasResolution a => FromJSON (Fixed a) where
1173instance HasResolution a => FromJSON (Fixed a) where
1602− parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac)
1174+ parseJSON = withScientific "Fixed" $ pure . realToFrac
1603 {-# INLINE parseJSON #-}
1175 {-# INLINE parseJSON #-}
1605instance FromJSON Int where
1177instance FromJSON Int where
@@ -1609,10 +1181,10 @@ instance FromJSON Int where
1609instance FromJSONKey Int where
1181instance FromJSONKey Int where
1610 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"
1182 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"
1612−-- | This instance includes a bounds check to prevent maliciously
1184+-- | /WARNING:/ Only parse Integers from trusted input since an
1613−-- large inputs to fill up the memory of the target system. You can
1185+-- attacker could easily fill up the memory of the target system by
1614−-- newtype 'Scientific' and provide your own instance using
1186+-- specifying a scientific number with a big exponent like
1615−-- 'withScientific' if you want to allow larger inputs.
1187+-- @1e1000000000@.
1616instance FromJSON Integer where
1188instance FromJSON Integer where
1617 parseJSON = parseIntegral "Integer"
1189 parseJSON = parseIntegral "Integer"
1618 {-# INLINE parseJSON #-}
1190 {-# INLINE parseJSON #-}
@@ -1621,21 +1193,16 @@ instance FromJSONKey Integer where
1621 fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer"
1193 fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer"
1623instance FromJSON Natural where
1195instance FromJSON Natural where
1624− parseJSON value = do
1196+ parseJSON = withScientific "Natural" $ \s ->
1625− integer <- parseIntegral "Natural" value
1197+ if Scientific.coefficient s < 0
1626− parseNatural integer
1198+ then fail $ "Expected a Natural number but got the negative number: " <> show s
1199+ else pure $ truncate s
1628instance FromJSONKey Natural where
1201instance FromJSONKey Natural where
1629− fromJSONKey = FromJSONKeyTextParser $ \text -> do
1202+ fromJSONKey = FromJSONKeyTextParser $ \t -> parseScientificText t >>= \s ->
1630− integer <- parseIntegralText "Natural" text
1203+ if Scientific.coefficient s < 0
1631− parseNatural integer
1633−parseNatural :: Integer -> Parser Natural
1634−parseNatural integer =
1635− if integer < 0 then
1636− fail $ "parsing Natural failed, unexpected negative number " <> show integer
1204+ then fail $ "Expected a Natural number but got the negative number: " <> show s
1637− else
1205+ else pure $ truncate s
1638− pure $ fromIntegral integer
1640instance FromJSON Int8 where
1207instance FromJSON Int8 where
1641 parseJSON = parseBoundedIntegral "Int8"
1208 parseJSON = parseBoundedIntegral "Int8"
@@ -1700,9 +1267,6 @@ instance FromJSON Word64 where
1700instance FromJSONKey Word64 where
1267instance FromJSONKey Word64 where
1701 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64"
1268 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64"
1703−instance FromJSON CTime where
1704− parseJSON = fmap CTime . parseJSON
1705− {-# INLINE parseJSON #-}
1707instance FromJSON Text where
1271instance FromJSON Text where
1708 parseJSON = withText "Text" pure
1272 parseJSON = withText "Text" pure
@@ -1732,17 +1296,17 @@ parseVersionText = go . readP_to_S parseVersion . unpack
1733 go [(v,[])] = return v
1297 go [(v,[])] = return v
1734 go (_ : xs) = go xs
1298 go (_ : xs) = go xs
1735− go _ = fail "parsing Version failed"
1299+ go _ = fail "could not parse Version"
1737-------------------------------------------------------------------------------
1301-------------------------------------------------------------------------------
1738-- semigroups NonEmpty
1302-- semigroups NonEmpty
1739-------------------------------------------------------------------------------
1303-------------------------------------------------------------------------------
1741instance FromJSON1 NonEmpty where
1305instance FromJSON1 NonEmpty where
1742− liftParseJSON p _ = withArray "NonEmpty" $
1306+ liftParseJSON p _ = withArray "NonEmpty a" $
1743 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1307 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1745− ne [] = fail "parsing NonEmpty failed, unexpected empty list"
1309+ ne [] = fail "Expected a NonEmpty but got an empty list"
1746 ne (x:xs) = pure (x :| xs)
1310 ne (x:xs) = pure (x :| xs)
1747 {-# INLINE liftParseJSON #-}
1311 {-# INLINE liftParseJSON #-}
@@ -1763,7 +1327,7 @@ instance FromJSON Scientific where
1763-------------------------------------------------------------------------------
1327-------------------------------------------------------------------------------
1765instance FromJSON1 DList.DList where
1329instance FromJSON1 DList.DList where
1766− liftParseJSON p _ = withArray "DList" $
1330+ liftParseJSON p _ = withArray "DList a" $
1767 fmap DList.fromList .
1331 fmap DList.fromList .
1768 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1332 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1769 {-# INLINE liftParseJSON #-}
1333 {-# INLINE liftParseJSON #-}
@@ -1790,7 +1354,7 @@ instance (FromJSON a) => FromJSON (Identity a) where
1790 parseJSONList = liftParseJSONList parseJSON parseJSONList
1354 parseJSONList = liftParseJSONList parseJSON parseJSONList
1791 {-# INLINE parseJSONList #-}
1355 {-# INLINE parseJSONList #-}
1793−instance (FromJSONKey a) => FromJSONKey (Identity a) where
1357+instance (FromJSONKey a, FromJSON a) => FromJSONKey (Identity a) where
1794 fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a)
1358 fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a)
1795 fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])
1359 fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])
@@ -1840,7 +1404,7 @@ instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where
1840 inr = "InR"
1404 inr = "InR"
1842 liftParseJSON _ _ _ = fail $
1406 liftParseJSON _ _ _ = fail $
1843− "parsing Sum failed, expected an object with a single property " ++
1407+ "expected an object with a single property " ++
1844 "where the property key should be either " ++
1408 "where the property key should be either " ++
1845 "\"InL\" or \"InR\""
1409 "\"InL\" or \"InR\""
1846 {-# INLINE liftParseJSON #-}
1410 {-# INLINE liftParseJSON #-}
@@ -1854,7 +1418,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where
1854-------------------------------------------------------------------------------
1418-------------------------------------------------------------------------------
1856instance FromJSON1 Seq.Seq where
1420instance FromJSON1 Seq.Seq where
1857− liftParseJSON p _ = withArray "Seq" $
1421+ liftParseJSON p _ = withArray "Seq a" $
1858 fmap Seq.fromList .
1422 fmap Seq.fromList .
1859 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1423 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1860 {-# INLINE liftParseJSON #-}
1424 {-# INLINE liftParseJSON #-}
@@ -1888,15 +1452,15 @@ instance FromJSON a => FromJSON (IntMap.IntMap a) where
1889instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
1453instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
1890 liftParseJSON p _ = case fromJSONKey of
1454 liftParseJSON p _ = case fromJSONKey of
1891− FromJSONKeyCoerce _ -> withObject "Map" $
1455+ FromJSONKeyCoerce _-> withObject "Map k v" $
1892 fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1456 fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1893− FromJSONKeyText f -> withObject "Map" $
1457+ FromJSONKeyText f -> withObject "Map k v" $
1894 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1458 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1895− FromJSONKeyTextParser f -> withObject "Map" $
1459+ FromJSONKeyTextParser f -> withObject "Map k v" $
1896 H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)
1460 H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)
1897− FromJSONKeyValue f -> withArray "Map" $ \arr ->
1461+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
1898− fmap M.fromList . Tr.sequence .
1462+ M.fromList <$> (Tr.sequence .
1899− zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
1463+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
1900 {-# INLINE liftParseJSON #-}
1464 {-# INLINE liftParseJSON #-}
1902instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (M.Map k v) where
1466instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (M.Map k v) where
@@ -1916,24 +1480,12 @@ instance (FromJSON v) => FromJSON (Tree.Tree v) where
1916 parseJSON = parseJSON1
1480 parseJSON = parseJSON1
1917 {-# INLINE parseJSON #-}
1481 {-# INLINE parseJSON #-}
1919−-------------------------------------------------------------------------------
1921−-------------------------------------------------------------------------------
1923−instance FromJSON UUID.UUID where
1924− parseJSON = withText "UUID" $
1925− maybe (fail "invalid UUID") pure . UUID.fromText
1927−instance FromJSONKey UUID.UUID where
1928− fromJSONKey = FromJSONKeyTextParser $
1929− maybe (fail "invalid UUID") pure . UUID.fromText
1931-------------------------------------------------------------------------------
1483-------------------------------------------------------------------------------
1932-- vector
1484-- vector
1933-------------------------------------------------------------------------------
1485-------------------------------------------------------------------------------
1935instance FromJSON1 Vector where
1487instance FromJSON1 Vector where
1936− liftParseJSON p _ = withArray "Vector" $
1488+ liftParseJSON p _ = withArray "Vector a" $
1937 V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
1489 V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
1938 {-# INLINE liftParseJSON #-}
1490 {-# INLINE liftParseJSON #-}
@@ -1947,14 +1499,14 @@ vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry $ parseIndexe
1947{-# INLINE vectorParseJSON #-}
1499{-# INLINE vectorParseJSON #-}
1949instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
1501instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
1950− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector"
1502+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
1952instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
1504instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
1953− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector"
1505+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
1954 {-# INLINE parseJSON #-}
1506 {-# INLINE parseJSON #-}
1956instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
1508instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
1957− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector"
1509+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
1958 {-# INLINE parseJSON #-}
1510 {-# INLINE parseJSON #-}
1960-------------------------------------------------------------------------------
1512-------------------------------------------------------------------------------
@@ -1968,15 +1520,15 @@ instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
1969instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
1521instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
1970 liftParseJSON p _ = case fromJSONKey of
1522 liftParseJSON p _ = case fromJSONKey of
1971− FromJSONKeyCoerce _ -> withObject "HashMap ~Text" $
1523+ FromJSONKeyCoerce _ -> withObject "HashMap ~Text v" $
1972 uc . H.traverseWithKey (\k v -> p v <?> Key k)
1524 uc . H.traverseWithKey (\k v -> p v <?> Key k)
1973− FromJSONKeyText f -> withObject "HashMap" $
1525+ FromJSONKeyText f -> withObject "HashMap k v" $
1974 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)
1526 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)
1975− FromJSONKeyTextParser f -> withObject "HashMap" $
1527+ FromJSONKeyTextParser f -> withObject "HashMap k v" $
1976 H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)
1528 H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)
1977− FromJSONKeyValue f -> withArray "Map" $ \arr ->
1529+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
1978− fmap H.fromList . Tr.sequence .
1530+ H.fromList <$> (Tr.sequence .
1979− zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
1531+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
1981 uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v)
1533 uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v)
1982 uc = unsafeCoerce
1534 uc = unsafeCoerce
@@ -1997,33 +1549,11 @@ instance FromJSON DotNetTime where
1997 parseJSON = withText "DotNetTime" $ \t ->
1549 parseJSON = withText "DotNetTime" $ \t ->
1998 let (s,m) = T.splitAt (T.length t - 5) t
1550 let (s,m) = T.splitAt (T.length t - 5) t
1999 t' = T.concat [s,".",m]
1551 t' = T.concat [s,".",m]
2000− in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
1552+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
2001 Just d -> pure (DotNetTime d)
1553 Just d -> pure (DotNetTime d)
2002 _ -> fail "could not parse .NET time"
1554 _ -> fail "could not parse .NET time"
2003 {-# INLINE parseJSON #-}
1555 {-# INLINE parseJSON #-}
2005−-------------------------------------------------------------------------------
2007−-------------------------------------------------------------------------------
2009−instance FromJSON a => FromJSON (PM.Array a) where
2010− -- note: we could do better than this if vector exposed the data
2011− -- constructor in Data.Vector.
2012− parseJSON = fmap Exts.fromList . parseJSON
2014−instance FromJSON a => FromJSON (PM.SmallArray a) where
2015− parseJSON = fmap Exts.fromList . parseJSON
2017−#if MIN_VERSION_primitive(0,6,4)
2018−instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where
2019− parseJSON = fmap Exts.fromList . parseJSON
2021−#if !MIN_VERSION_primitive(0,7,0)
2022−instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
2023− parseJSON = fmap Exts.fromList . parseJSON
2027-------------------------------------------------------------------------------
1557-------------------------------------------------------------------------------
2029-------------------------------------------------------------------------------
1559-------------------------------------------------------------------------------
@@ -2049,17 +1579,6 @@ instance FromJSONKey LocalTime where
2049 fromJSONKey = FromJSONKeyTextParser (Time.run Time.localTime)
1579 fromJSONKey = FromJSONKeyTextParser (Time.run Time.localTime)
2052−-- | Supported string formats:
2054−-- @YYYY-MM-DD HH:MM Z@
2055−-- @YYYY-MM-DD HH:MM:SS Z@
2056−-- @YYYY-MM-DD HH:MM:SS.SSS Z@
2058−-- The first space may instead be a @T@, and the second space is
2059−-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a
2060−-- time zone offset of the form @+0000@ or @-08:00@, where the first
2061−-- two digits are hours, the @:@ is optional and the second two digits
2062−-- (also optional) are minutes.
2063instance FromJSON ZonedTime where
1582instance FromJSON ZonedTime where
2064 parseJSON = withText "ZonedTime" (Time.run Time.zonedTime)
1583 parseJSON = withText "ZonedTime" (Time.run Time.zonedTime)
@@ -2074,168 +1593,41 @@ instance FromJSONKey UTCTime where
2074 fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)
1593 fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)
2077−-- | This instance includes a bounds check to prevent maliciously
1596+-- | /WARNING:/ Only parse lengths of time from trusted input
2078−-- large inputs to fill up the memory of the target system. You can
1597+-- since an attacker could easily fill up the memory of the target
2079−-- newtype 'Scientific' and provide your own instance using
1598+-- system by specifying a scientific number with a big exponent like
2080−-- 'withScientific' if you want to allow larger inputs.
1599+-- @1e1000000000@.
2081instance FromJSON NominalDiffTime where
1600instance FromJSON NominalDiffTime where
2082− parseJSON = withBoundedScientific "NominalDiffTime" $ pure . realToFrac
1601+ parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac
2083 {-# INLINE parseJSON #-}
1602 {-# INLINE parseJSON #-}
2086−-- | This instance includes a bounds check to prevent maliciously
2087−-- large inputs to fill up the memory of the target system. You can
2088−-- newtype 'Scientific' and provide your own instance using
2089−-- 'withScientific' if you want to allow larger inputs.
2090−instance FromJSON DiffTime where
2091− parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
2092− {-# INLINE parseJSON #-}
2094−instance FromJSON SystemTime where
2095− parseJSON v = prependContext "SystemTime" $ do
2097− let n' = floor (n * fromInteger (resolution n) :: Nano)
2098− let (secs, nano) = n' `divMod` resolution n
2099− return (MkSystemTime (fromInteger secs) (fromInteger nano))
2101−instance FromJSON CalendarDiffTime where
2102− parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime
2103− <$> obj .: "months"
2106−instance FromJSON CalendarDiffDays where
2107− parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays
2108− <$> obj .: "months"
2111−instance FromJSON DayOfWeek where
2112− parseJSON = withText "DaysOfWeek" parseDayOfWeek
2114−parseDayOfWeek :: T.Text -> Parser DayOfWeek
2115−parseDayOfWeek t = case T.toLower t of
2116− "monday" -> return Monday
2117− "tuesday" -> return Tuesday
2118− "wednesday" -> return Wednesday
2119− "thursday" -> return Thursday
2120− "friday" -> return Friday
2121− "saturday" -> return Saturday
2122− "sunday" -> return Sunday
2123− _ -> fail "Invalid week day"
2125−instance FromJSONKey DayOfWeek where
2126− fromJSONKey = FromJSONKeyTextParser parseDayOfWeek
2128-------------------------------------------------------------------------------
1604-------------------------------------------------------------------------------
2129-- base Monoid/Semigroup
1605-- base Monoid/Semigroup
2130-------------------------------------------------------------------------------
1606-------------------------------------------------------------------------------
2132−instance FromJSON1 Monoid.Dual where
1608+instance FromJSON1 Dual where
2133− liftParseJSON p _ = fmap Monoid.Dual . p
1609+ liftParseJSON p _ = fmap Dual . p
2134− {-# INLINE liftParseJSON #-}
2136−instance FromJSON a => FromJSON (Monoid.Dual a) where
2137− parseJSON = parseJSON1
2138− {-# INLINE parseJSON #-}
2141−instance FromJSON1 Monoid.First where
2142− liftParseJSON p p' = fmap Monoid.First . liftParseJSON p p'
2143− {-# INLINE liftParseJSON #-}
2145−instance FromJSON a => FromJSON (Monoid.First a) where
2146− parseJSON = parseJSON1
2147− {-# INLINE parseJSON #-}
2150−instance FromJSON1 Monoid.Last where
2151− liftParseJSON p p' = fmap Monoid.Last . liftParseJSON p p'
2152− {-# INLINE liftParseJSON #-}
2154−instance FromJSON a => FromJSON (Monoid.Last a) where
2155− parseJSON = parseJSON1
2156− {-# INLINE parseJSON #-}
2159−instance FromJSON1 Semigroup.Min where
2160− liftParseJSON p _ a = Semigroup.Min <$> p a
2161− {-# INLINE liftParseJSON #-}
2163− liftParseJSONList _ p a = fmap Semigroup.Min <$> p a
2164− {-# INLINE liftParseJSONList #-}
2166−instance (FromJSON a) => FromJSON (Semigroup.Min a) where
2167− parseJSON = parseJSON1
2168− {-# INLINE parseJSON #-}
2170− parseJSONList = liftParseJSONList parseJSON parseJSONList
2171− {-# INLINE parseJSONList #-}
2174−instance FromJSON1 Semigroup.Max where
2175− liftParseJSON p _ a = Semigroup.Max <$> p a
2176− {-# INLINE liftParseJSON #-}
2178− liftParseJSONList _ p a = fmap Semigroup.Max <$> p a
2179− {-# INLINE liftParseJSONList #-}
2181−instance (FromJSON a) => FromJSON (Semigroup.Max a) where
2182− parseJSON = parseJSON1
2183− {-# INLINE parseJSON #-}
2185− parseJSONList = liftParseJSONList parseJSON parseJSONList
2186− {-# INLINE parseJSONList #-}
2189−instance FromJSON1 Semigroup.First where
2190− liftParseJSON p _ a = Semigroup.First <$> p a
2191 {-# INLINE liftParseJSON #-}
1610 {-# INLINE liftParseJSON #-}
2193− liftParseJSONList _ p a = fmap Semigroup.First <$> p a
2194− {-# INLINE liftParseJSONList #-}
2196−instance (FromJSON a) => FromJSON (Semigroup.First a) where
1612+instance FromJSON a => FromJSON (Dual a) where
2197 parseJSON = parseJSON1
1613 parseJSON = parseJSON1
2198 {-# INLINE parseJSON #-}
1614 {-# INLINE parseJSON #-}
2200− parseJSONList = liftParseJSONList parseJSON parseJSONList
2201− {-# INLINE parseJSONList #-}
2204−instance FromJSON1 Semigroup.Last where
1617+instance FromJSON1 First where
2205− liftParseJSON p _ a = Semigroup.Last <$> p a
1618+ liftParseJSON p p' = fmap First . liftParseJSON p p'
2206 {-# INLINE liftParseJSON #-}
1619 {-# INLINE liftParseJSON #-}
2208− liftParseJSONList _ p a = fmap Semigroup.Last <$> p a
2209− {-# INLINE liftParseJSONList #-}
2211−instance (FromJSON a) => FromJSON (Semigroup.Last a) where
1621+instance FromJSON a => FromJSON (First a) where
2212 parseJSON = parseJSON1
1622 parseJSON = parseJSON1
2213 {-# INLINE parseJSON #-}
1623 {-# INLINE parseJSON #-}
2215− parseJSONList = liftParseJSONList parseJSON parseJSONList
2216− {-# INLINE parseJSONList #-}
2219−instance FromJSON1 Semigroup.WrappedMonoid where
1626+instance FromJSON1 Last where
2220− liftParseJSON p _ a = Semigroup.WrapMonoid <$> p a
2221− {-# INLINE liftParseJSON #-}
2223− liftParseJSONList _ p a = fmap Semigroup.WrapMonoid <$> p a
2224− {-# INLINE liftParseJSONList #-}
2226−instance (FromJSON a) => FromJSON (Semigroup.WrappedMonoid a) where
2227− parseJSON = parseJSON1
2228− {-# INLINE parseJSON #-}
2230− parseJSONList = liftParseJSONList parseJSON parseJSONList
2231− {-# INLINE parseJSONList #-}
2234−instance FromJSON1 Semigroup.Option where
2235− liftParseJSON p p' = fmap Semigroup.Option . liftParseJSON p p'
1627+ liftParseJSON p p' = fmap Last . liftParseJSON p p'
2236 {-# INLINE liftParseJSON #-}
1628 {-# INLINE liftParseJSON #-}
2238−instance FromJSON a => FromJSON (Semigroup.Option a) where
1630+instance FromJSON a => FromJSON (Last a) where
2239 parseJSON = parseJSON1
1631 parseJSON = parseJSON1
2240 {-# INLINE parseJSON #-}
1632 {-# INLINE parseJSON #-}
@@ -2243,21 +1635,11 @@ instance FromJSON a => FromJSON (Semigroup.Option a) where
2243-- tagged
1635-- tagged
2244-------------------------------------------------------------------------------
1636-------------------------------------------------------------------------------
2246−instance FromJSON1 Proxy where
2247− {-# INLINE liftParseJSON #-}
2248− liftParseJSON _ _ = fromNull "Proxy" Proxy
2250instance FromJSON (Proxy a) where
1638instance FromJSON (Proxy a) where
2251 {-# INLINE parseJSON #-}
1639 {-# INLINE parseJSON #-}
2252− parseJSON = fromNull "Proxy" Proxy
1640+ parseJSON Null = pure Proxy
1641+ parseJSON v = typeMismatch "Proxy" v
2254−fromNull :: String -> a -> Value -> Parser a
2255−fromNull _ a Null = pure a
2256−fromNull c _ v = prependContext c (typeMismatch "Null" v)
2258−instance FromJSON2 Tagged where
2259− liftParseJSON2 _ _ p _ = fmap Tagged . p
2260− {-# INLINE liftParseJSON2 #-}
2262instance FromJSON1 (Tagged a) where
1644instance FromJSON1 (Tagged a) where
2263 liftParseJSON p _ = fmap Tagged . p
1645 liftParseJSON p _ = fmap Tagged . p
@@ -2280,7 +1662,10 @@ instance (FromJSON a, FromJSON b, FromJSON c) => FromJSONKey (a,b,c)
2280instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)
1662instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)
2282instance FromJSONKey Char where
1664instance FromJSONKey Char where
2283− fromJSONKey = FromJSONKeyTextParser parseChar
1665+ fromJSONKey = FromJSONKeyTextParser $ \t ->
1667+ then return (T.index t 0)
1668+ else typeMismatch "Expected Char but String didn't contain exactly one character" (String t)
2284 fromJSONKeyList = FromJSONKeyText T.unpack
1669 fromJSONKeyList = FromJSONKeyText T.unpack
2286instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where
1671instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where