@@ -5,19 +5,17 @@
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE NamedFieldPuns #-}
8+{-# LANGUAGE NoImplicitPrelude #-}
9{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE TypeSynonymInstances #-}
14+{-# LANGUAGE TupleSections #-}
14{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE ViewPatterns #-}
16{-# LANGUAGE ViewPatterns #-}
17−#if __GLASGOW_HASKELL__ >= 706
18+#include "incoherent-compat.h"
18−{-# LANGUAGE PolyKinds #-}
21#include "overlapping-compat.h"
19#include "overlapping-compat.h"
23-- TODO: Drop this when we remove support for Data.Attoparsec.Number
21-- TODO: Drop this when we remove support for Data.Attoparsec.Number
@@ -44,6 +42,9 @@ module Data.Aeson.Types.FromJSON
44 , coerceFromJSONKeyFunction
42 , coerceFromJSONKeyFunction
45 , mapFromJSONKeyFunction
43 , mapFromJSONKeyFunction
47 -- * List functions
48 -- * List functions
48 , listParser
49 , listParser
@@ -51,34 +52,42 @@ module Data.Aeson.Types.FromJSON
51 , withObject
52 , withObject
52 , withText
53 , withText
53 , withArray
54 , withArray
55 , withScientific
55 , withScientific
56 , withBool
56 , withBool
58 -- * Functions
59 -- * Functions
59 , fromJSON
60 , fromJSON
60 , ifromJSON
61 , ifromJSON
68+ , explicitParseFieldMaybe
69+ , explicitParseFieldMaybe'
67 -- * Internal
77 -- * Internal
68 , parseOptionalFieldWith
78 , parseOptionalFieldWith
72import Prelude.Compat
81import Prelude.Compat
74−import Control.Applicative ((<|>), Const(..))
83+import Control.Applicative ((<|>), Const(..), liftA2)
75−import Control.Monad ((<=<), zipWithM)
84+import Control.Monad (zipWithM)
76import Data.Aeson.Internal.Functions (mapKey)
85import Data.Aeson.Internal.Functions (mapKey)
86+import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
77import Data.Aeson.Types.Generic
87import Data.Aeson.Types.Generic
78import Data.Aeson.Types.Internal
88import Data.Aeson.Types.Internal
79−import Data.Attoparsec.Number (Number(..))
80import Data.Bits (unsafeShiftR)
89import Data.Bits (unsafeShiftR)
81−import Data.Fixed (Fixed, HasResolution)
90+import Data.Fixed (Fixed, HasResolution (resolution), Nano)
82import Data.Functor.Compose (Compose(..))
91import Data.Functor.Compose (Compose(..))
83import Data.Functor.Identity (Identity(..))
92import Data.Functor.Identity (Identity(..))
84import Data.Functor.Product (Product(..))
93import Data.Functor.Product (Product(..))
@@ -87,57 +96,67 @@ import Data.Hashable (Hashable(..))
87import Data.Int (Int16, Int32, Int64, Int8)
96import Data.Int (Int16, Int32, Int64, Int8)
88import Data.List.NonEmpty (NonEmpty(..))
97import Data.List.NonEmpty (NonEmpty(..))
89import Data.Maybe (fromMaybe)
98import Data.Maybe (fromMaybe)
90−import Data.Monoid ((<>), Dual(..), First (..), Last (..))
99+import Data.Semigroup ((<>))
91import Data.Proxy (Proxy(..))
100import Data.Proxy (Proxy(..))
92import Data.Ratio ((%), Ratio)
101import Data.Ratio ((%), Ratio)
93−import Data.Scientific (Scientific)
102+import Data.Scientific (Scientific, base10Exponent)
94import Data.Tagged (Tagged(..))
103import Data.Tagged (Tagged(..))
95import Data.Text (Text, pack, unpack)
104import Data.Text (Text, pack, unpack)
96−import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
105+import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
97−import Data.Time.Format (parseTime)
106+import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
107+import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
108+import Data.Time.Clock.System.Compat (SystemTime (..))
98−import Data.Time.Locale.Compat (defaultTimeLocale)
109+import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
99import Data.Traversable as Tr (sequence)
110import Data.Traversable as Tr (sequence)
100import Data.Vector (Vector)
111import Data.Vector (Vector)
101import Data.Version (Version, parseVersion)
112import Data.Version (Version, parseVersion)
113+import Data.Void (Void)
102import Data.Word (Word16, Word32, Word64, Word8)
114import Data.Word (Word16, Word32, Word64, Word8)
103import Foreign.Storable (Storable)
115import Foreign.Storable (Storable)
116+import Foreign.C.Types (CTime (..))
104import GHC.Generics
117import GHC.Generics
105import Numeric.Natural (Natural)
118import Numeric.Natural (Natural)
106import Text.ParserCombinators.ReadP (readP_to_S)
119import Text.ParserCombinators.ReadP (readP_to_S)
120+import Unsafe.Coerce (unsafeCoerce)
107import qualified Data.Aeson.Parser.Time as Time
121import qualified Data.Aeson.Parser.Time as Time
108import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
122import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123+import qualified Data.ByteString.Lazy as L
109import qualified Data.DList as DList
124import qualified Data.DList as DList
110import qualified Data.HashMap.Strict as H
125import qualified Data.HashMap.Strict as H
111import qualified Data.HashSet as HashSet
126import qualified Data.HashSet as HashSet
112import qualified Data.IntMap as IntMap
127import qualified Data.IntMap as IntMap
113import qualified Data.IntSet as IntSet
128import qualified Data.IntSet as IntSet
114import qualified Data.Map as M
129import qualified Data.Map as M
130+import qualified Data.Monoid as Monoid
115import qualified Data.Scientific as Scientific
131import qualified Data.Scientific as Scientific
132+import qualified Data.Semigroup as Semigroup
116import qualified Data.Sequence as Seq
133import qualified Data.Sequence as Seq
117import qualified Data.Set as Set
134import qualified Data.Set as Set
118import qualified Data.Text as T
135import qualified Data.Text as T
119import qualified Data.Text.Encoding as T
136import qualified Data.Text.Encoding as T
120import qualified Data.Text.Lazy as LT
137import qualified Data.Text.Lazy as LT
121import qualified Data.Tree as Tree
138import qualified Data.Tree as Tree
139+import qualified Data.UUID.Types as UUID
122import qualified Data.Vector as V
140import qualified Data.Vector as V
123import qualified Data.Vector.Generic as VG
141import qualified Data.Vector.Generic as VG
124import qualified Data.Vector.Primitive as VP
142import qualified Data.Vector.Primitive as VP
125import qualified Data.Vector.Storable as VS
143import qualified Data.Vector.Storable as VS
126import qualified Data.Vector.Unboxed as VU
144import qualified Data.Vector.Unboxed as VU
127−import Unsafe.Coerce (unsafeCoerce)
129−#ifndef HAS_COERCIBLE
146+import qualified GHC.Exts as Exts
130−#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
147+import qualified Data.Primitive.Array as PM
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
133−#if HAS_COERCIBLE
158+
134import Data.Coerce (Coercible, coerce)
159import Data.Coerce (Coercible, coerce)
135−coerce' :: Coercible a b => a -> b
139−coerce' = unsafeCoerce
142parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
143parseIndexedJSON p idx value = p value <?> Index idx
162parseIndexedJSON p idx value = p value <?> Index idx
@@ -146,7 +165,7 @@ parseIndexedJSON p idx value = p value <?> Index idx
146parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)
165parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)
147parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
166parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
149− p = withArray "(k,v)" $ \ab ->
168+ p = withArray "(k, v)" $ \ab ->
150 let n = V.length ab
169 let n = V.length ab
151 in if n == 2
170 in if n == 2
152 then (,) <$> parseJSONElemAtIndex keyParser 0 ab
171 then (,) <$> parseJSONElemAtIndex keyParser 0 ab
@@ -158,43 +177,34 @@ parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
158parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a
177parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a
159parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx
178parseJSONElemAtIndex 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 #-}
170parseRealFloat :: RealFloat a => String -> Value -> Parser a
180parseRealFloat :: RealFloat a => String -> Value -> Parser a
171−parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s
181+parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s
172−parseRealFloat _ Null = pure (0/0)
182+parseRealFloat _ Null = pure (0/0)
173−parseRealFloat expected v = typeMismatch expected v
183+parseRealFloat name v = prependContext name (unexpected v)
174{-# INLINE parseRealFloat #-}
184{-# INLINE parseRealFloat #-}
176−parseIntegralFromScientific :: forall a. Integral a => String -> Scientific -> Parser a
186+parseIntegralFromScientific :: forall a. Integral a => Scientific -> Parser a
177−parseIntegralFromScientific expected s =
187+parseIntegralFromScientific s =
178 case Scientific.floatingOrInteger s :: Either Double a of
188 case Scientific.floatingOrInteger s :: Either Double a of
179 Right x -> pure x
189 Right x -> pure x
180− Left _ -> fail $ "Floating number specified for " ++ expected ++ ": " ++ show s
190+ Left _ -> fail $ "unexpected floating number " ++ show s
181{-# INLINE parseIntegralFromScientific #-}
191{-# INLINE parseIntegralFromScientific #-}
183parseIntegral :: Integral a => String -> Value -> Parser a
193parseIntegral :: Integral a => String -> Value -> Parser a
184−parseIntegral expected =
194+parseIntegral name =
185− withScientific expected $ parseIntegralFromScientific expected
195+ prependContext name . withBoundedScientific' parseIntegralFromScientific
186{-# INLINE parseIntegral #-}
196{-# INLINE parseIntegral #-}
188−parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => String -> Scientific -> Parser a
198+parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => Scientific -> Parser a
189−parseBoundedIntegralFromScientific expected s = maybe
199+parseBoundedIntegralFromScientific s = maybe
190− (fail $ expected ++ " is either floating or will cause over or underflow: " ++ show s)
200+ (fail $ "value is either floating or will cause over or underflow " ++ show s)
192 (Scientific.toBoundedInteger s)
202 (Scientific.toBoundedInteger s)
193{-# INLINE parseBoundedIntegralFromScientific #-}
203{-# INLINE parseBoundedIntegralFromScientific #-}
195parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a
205parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a
196−parseBoundedIntegral expected =
206+parseBoundedIntegral name =
197− withScientific expected $ parseBoundedIntegralFromScientific expected
207+ prependContext name . withScientific' parseBoundedIntegralFromScientific
198{-# INLINE parseBoundedIntegral #-}
208{-# INLINE parseBoundedIntegral #-}
200parseScientificText :: Text -> Parser Scientific
210parseScientificText :: Text -> Parser Scientific
@@ -204,13 +214,20 @@ parseScientificText
204 . T.encodeUtf8
214 . T.encodeUtf8
206parseIntegralText :: Integral a => String -> Text -> Parser a
216parseIntegralText :: Integral a => String -> Text -> Parser a
207−parseIntegralText expected t =
217+parseIntegralText name t =
218+ prependContext name $
219+ parseScientificText t
220+ >>= rejectLargeExponent
208− parseScientificText t >>= parseIntegralFromScientific expected
221+ >>= parseIntegralFromScientific
223+ rejectLargeExponent :: Scientific -> Parser Scientific
224+ rejectLargeExponent s = withBoundedScientific' pure (Number s)
209{-# INLINE parseIntegralText #-}
225{-# INLINE parseIntegralText #-}
211parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a
227parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a
212−parseBoundedIntegralText expected t =
228+parseBoundedIntegralText name t =
229+ prependContext name $
213− parseScientificText t >>= parseBoundedIntegralFromScientific expected
230+ parseScientificText t >>= parseBoundedIntegralFromScientific
215parseOptionalFieldWith :: (Value -> Parser (Maybe a))
232parseOptionalFieldWith :: (Value -> Parser (Maybe a))
216 -> Object -> Text -> Parser (Maybe a)
233 -> Object -> Text -> Parser (Maybe a)
@@ -270,14 +287,21 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
271-- The basic ways to signal a failed conversion are as follows:
288-- 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;
273−-- * 'empty' and 'mzero' work, but are terse and uninformative
293+-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:
294+-- use it when the error is meant to be caught by some @('<|>')@;
275−-- * 'fail' yields a custom error message
296+-- * 'typeMismatch' can be used to report a failure when the encountered value
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
277−-- * 'typeMismatch' produces an informative message for cases when the
301+-- 'prependFailure' (or 'modifyFailure') add more information to a parser's
278−-- value encountered is not of the expected type
302+-- error messages.
280−-- An example type and instance:
304+-- An example type and instance using 'typeMismatch' and 'prependFailure':
283-- \-- Allow ourselves to write 'Text' literals.
307-- \-- Allow ourselves to write 'Text' literals.
@@ -285,15 +309,30 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
286-- data Coord = Coord { x :: Double, y :: Double }
310-- data Coord = Coord { x :: Double, y :: Double }
288−-- instance FromJSON Coord where
312+-- instance 'FromJSON' Coord where
289−-- parseJSON ('Object' v) = Coord '<$>'
313+-- 'parseJSON' ('Object' v) = Coord
290−-- v '.:' \"x\" '<*>'
314+-- '<$>' v '.:' \"x\"
291−-- v '.:' \"y\"
315+-- '<*>' v '.:' \"y\"
293−-- \-- We do not expect a non-'Object' value here.
317+-- \-- We do not expect a non-'Object' value here.
294−-- \-- We could use 'mzero' to fail, but 'typeMismatch'
318+-- \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'
295−-- \-- gives a much more informative error message.
319+-- \-- gives a much more informative error message.
320+-- 'parseJSON' invalid =
321+-- 'prependFailure' "parsing Coord failed, "
296−-- parseJSON invalid = 'typeMismatch' \"Coord\" invalid
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\"
299-- Instead of manually writing your 'FromJSON' instance, there are two options
338-- Instead of manually writing your 'FromJSON' instance, there are two options
@@ -301,7 +340,7 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
302-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
341-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
303-- instance at compile time. The generated instance is optimized for your type
342-- instance at compile time. The generated instance is optimized for your type
304−-- so will probably be more efficient than the following two options:
343+-- so it will probably be more efficient than the following option.
306-- * The compiler can provide a default generic implementation for
345-- * The compiler can provide a default generic implementation for
307-- 'parseJSON'.
346-- 'parseJSON'.
@@ -319,18 +358,21 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
320-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'
359-- data Coord = Coord { x :: Double, y :: Double } deriving 'Generic'
322−-- instance FromJSON Coord
361+-- instance 'FromJSON' Coord
325−-- If @DefaultSignatures@ doesn't give exactly the results you want,
364+-- The default implementation will be equivalent to
365+-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different
326−-- you can customize the generic decoding with only a tiny amount of
366+-- options, you can customize the generic decoding by defining:
327−-- effort, using 'genericParseJSON' with your preferred 'Options':
369+-- customOptions = 'defaultOptions'
370+-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'
330−-- instance FromJSON Coord where
373+-- instance 'FromJSON' Coord where
331−-- parseJSON = 'genericParseJSON' 'defaultOptions'
374+-- 'parseJSON' = 'genericParseJSON' customOptions
334class FromJSON a where
376class FromJSON a where
335 parseJSON :: Value -> Parser a
377 parseJSON :: Value -> Parser a
@@ -338,13 +380,11 @@ class FromJSON a where
338 parseJSON = genericParseJSON defaultOptions
380 parseJSON = genericParseJSON defaultOptions
340 parseJSONList :: Value -> Parser [a]
382 parseJSONList :: Value -> Parser [a]
341− parseJSONList (Array a)
383+ parseJSONList = withArray "[]" $ \a ->
342− = zipWithM (parseIndexedJSON parseJSON) [0..]
384+ zipWithM (parseIndexedJSON parseJSON) [0..]
343 . V.toList
385 . V.toList
346− parseJSONList v = typeMismatch "[a]" v
348-------------------------------------------------------------------------------
388-------------------------------------------------------------------------------
349-- Classes and types for map keys
389-- Classes and types for map keys
350-------------------------------------------------------------------------------
390-------------------------------------------------------------------------------
@@ -356,6 +396,16 @@ class FromJSON a where
356-- > newtype SomeId = SomeId { getSomeId :: Text }
396-- > newtype SomeId = SomeId { getSomeId :: Text }
357-- > deriving (Eq,Ord,Hashable,FromJSONKey)
397-- > 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'
359class FromJSONKey a where
409class FromJSONKey a where
360 -- | Strategy for parsing the key of a map-like container.
410 -- | Strategy for parsing the key of a map-like container.
361 fromJSONKey :: FromJSONKeyFunction a
411 fromJSONKey :: FromJSONKeyFunction a
@@ -378,11 +428,7 @@ class FromJSONKey a where
378-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
379-- can be inspected, but cannot be constructed.
429-- can be inspected, but cannot be constructed.
380data CoerceText a where
430data CoerceText a where
382 CoerceText :: Coercible Text a => CoerceText a
431 CoerceText :: Coercible Text a => CoerceText a
384− CoerceText :: CoerceText a
387-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
433-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
388-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -402,7 +448,7 @@ data FromJSONKeyFunction a
403-- | Only law abiding up to interpretation
449-- | Only law abiding up to interpretation
404instance Functor FromJSONKeyFunction where
450instance Functor FromJSONKeyFunction where
405− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
451+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
406 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
407 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
408 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -416,9 +462,7 @@ instance Functor FromJSONKeyFunction where
417-- On pre GHC 7.8 this is unconstrainted function.
463-- On pre GHC 7.8 this is unconstrainted function.
418fromJSONKeyCoerce ::
464fromJSONKeyCoerce ::
420 Coercible Text a =>
465 Coercible Text a =>
422 FromJSONKeyFunction a
466 FromJSONKeyFunction a
423fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
@@ -426,60 +470,91 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
427-- See note on 'fromJSONKeyCoerce'.
471-- See note on 'fromJSONKeyCoerce'.
428coerceFromJSONKeyFunction ::
472coerceFromJSONKeyFunction ::
430 Coercible a b =>
473 Coercible a b =>
432 FromJSONKeyFunction a -> FromJSONKeyFunction b
474 FromJSONKeyFunction a -> FromJSONKeyFunction b
434coerceFromJSONKeyFunction = coerce
475coerceFromJSONKeyFunction = 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)
443 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
444 fmap id x = x
479 fmap id x = x
448 "FromJSONKeyCoerce: fmap coerce" forall x .
482 "FromJSONKeyCoerce: fmap coerce" forall x .
449 fmap coerce x = coerceFromJSONKeyFunction x
483 fmap coerce x = coerceFromJSONKeyFunction x
453-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
454mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
455mapFromJSONKeyFunction = fmap
488mapFromJSONKeyFunction = 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
457-------------------------------------------------------------------------------
519-------------------------------------------------------------------------------
458-- Functions needed for documentation
520-- Functions needed for documentation
459-------------------------------------------------------------------------------
521-------------------------------------------------------------------------------
461-- | Fail parsing due to a type mismatch, with a descriptive message.
523-- | Fail parsing due to a type mismatch, with a descriptive message.
463−-- Example usage:
525+-- The following wrappers should generally be prefered:
526+-- 'withObject', 'withArray', 'withText', 'withBool'.
465−-- @
528+-- ==== Error message example
466−-- instance FromJSON Coord where
529+--
467−-- parseJSON ('Object' v) = {- type matches, life is good -}
530+-- > typeMismatch "Object" (String "oops")
468−-- parseJSON wat = 'typeMismatch' \"Coord\" wat
531+-- > -- Error: "expected Object, but encountered String"
470−typeMismatch :: String -- ^ The name of the type you are trying to parse.
532+typeMismatch :: String -- ^ The name of the JSON type being parsed
533+ -- (@\"Object\"@, @\"Array\"@, @\"String\"@, @\"Number\"@,
534+ -- @\"Boolean\"@, or @\"Null\"@).
471 -> Value -- ^ The actual value encountered.
535 -> Value -- ^ The actual value encountered.
472 -> Parser a
536 -> Parser a
473typeMismatch expected actual =
537typeMismatch expected actual =
474− fail $ "expected " ++ expected ++ ", encountered " ++ name
538+ fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual
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
476− name = case actual of
551+typeOf v = case v of
477− Object _ -> "Object"
552+ Object _ -> "Object"
478− Array _ -> "Array"
553+ Array _ -> "Array"
479− String _ -> "String"
554+ String _ -> "String"
480− Number _ -> "Number"
555+ Number _ -> "Number"
481− Bool _ -> "Boolean"
556+ Bool _ -> "Boolean"
482− Null -> "Null"
557+ Null -> "Null"
484-------------------------------------------------------------------------------
559-------------------------------------------------------------------------------
485-- Lifings of FromJSON and ToJSON to unary and binary type constructors
560-- Lifings of FromJSON and ToJSON to unary and binary type constructors
@@ -492,7 +567,7 @@ typeMismatch expected actual =
493-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
568-- * "Data.Aeson.TH" provides Template Haskell functions which will derive an
494-- instance at compile time. The generated instance is optimized for your type
569-- instance at compile time. The generated instance is optimized for your type
495−-- so will probably be more efficient than the following two options:
570+-- so it will probably be more efficient than the following option.
497-- * The compiler can provide a default generic implementation for
572-- * The compiler can provide a default generic implementation for
498-- 'liftParseJSON'.
573-- 'liftParseJSON'.
@@ -510,16 +585,20 @@ typeMismatch expected actual =
511-- data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'
586-- data Pair a b = Pair { pairFst :: a, pairSnd :: b } deriving 'Generic1'
513−-- instance FromJSON a => FromJSON1 (Pair a)
588+-- instance 'FromJSON' a => 'FromJSON1' (Pair a)
516−-- If @DefaultSignatures@ doesn't give exactly the results you want,
591+-- If the default implementation doesn't give exactly the results you want,
517-- you can customize the generic decoding with only a tiny amount of
592-- you can customize the generic decoding with only a tiny amount of
518-- effort, using 'genericLiftParseJSON' with your preferred 'Options':
593-- effort, using 'genericLiftParseJSON' with your preferred 'Options':
596+-- customOptions = 'defaultOptions'
597+-- { 'fieldLabelModifier' = 'map' 'Data.Char.toUpper'
521−-- instance FromJSON a => FromJSON1 (Pair a) where
600+-- instance 'FromJSON' a => 'FromJSON1' (Pair a) where
522−-- liftParseJSON = 'genericLiftParseJSON' 'defaultOptions'
601+-- 'liftParseJSON' = 'genericLiftParseJSON' customOptions
524class FromJSON1 f where
603class FromJSON1 f where
525 liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)
604 liftParseJSON :: (Value -> Parser a) -> (Value -> Parser [a]) -> Value -> Parser (f a)
@@ -556,9 +635,8 @@ class FromJSON2 f where
556 -> (Value -> Parser b)
635 -> (Value -> Parser b)
557 -> (Value -> Parser [b])
636 -> (Value -> Parser [b])
558 -> Value -> Parser [f a b]
637 -> Value -> Parser [f a b]
559− liftParseJSONList2 fa ga fb gb v = case v of
638+ liftParseJSONList2 fa ga fb gb = withArray "[]" $ \vals ->
560− Array vals -> fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)
639+ fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)
561− _ -> typeMismatch "[a]" v
563-- | Lift the standard 'parseJSON' function through the type constructor.
641-- | Lift the standard 'parseJSON' function through the type constructor.
564parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
642parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
@@ -572,7 +650,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
572-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
650-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
573listParser :: (Value -> Parser a) -> Value -> Parser [a]
651listParser :: (Value -> Parser a) -> Value -> Parser [a]
574listParser f (Array xs) = fmap V.toList (V.mapM f xs)
652listParser f (Array xs) = fmap V.toList (V.mapM f xs)
575−listParser _ v = typeMismatch "[a]" v
653+listParser _ v = typeMismatch "Array" v
576{-# INLINE listParser #-}
654{-# INLINE listParser #-}
578-------------------------------------------------------------------------------
656-------------------------------------------------------------------------------
@@ -590,48 +668,139 @@ instance (FromJSON a) => FromJSON [a] where
590-- Functions
668-- Functions
591-------------------------------------------------------------------------------
669-------------------------------------------------------------------------------
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, ")
593−-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@
679+-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@
594−-- and fails using @'typeMismatch' expected@ otherwise.
680+-- is an 'Data.Aeson.Object' and fails otherwise.
682+-- ==== Error message example
684+-- > withObject "MyType" f (String "oops")
685+-- > -- Error: "parsing MyType failed, expected Object, but encountered String"
595withObject :: String -> (Object -> Parser a) -> Value -> Parser a
686withObject :: String -> (Object -> Parser a) -> Value -> Parser a
596−withObject _ f (Object obj) = f obj
687+withObject _ f (Object obj) = f obj
597−withObject expected _ v = typeMismatch expected v
688+withObject name _ v = prependContext name (typeMismatch "Object" v)
598{-# INLINE withObject #-}
689{-# INLINE withObject #-}
600−-- | @withText expected f value@ applies @f@ to the 'Text' when @value@ is a @String@
691+-- | @'withText' name f value@ applies @f@ to the 'Text' when @value@ is a
601−-- and fails using @'typeMismatch' expected@ otherwise.
692+-- 'Data.Aeson.String' and fails otherwise.
694+-- ==== Error message example
696+-- > withText "MyType" f Null
697+-- > -- Error: "parsing MyType failed, expected String, but encountered Null"
602withText :: String -> (Text -> Parser a) -> Value -> Parser a
698withText :: String -> (Text -> Parser a) -> Value -> Parser a
603−withText _ f (String txt) = f txt
699+withText _ f (String txt) = f txt
604−withText expected _ v = typeMismatch expected v
700+withText name _ v = prependContext name (typeMismatch "String" v)
605{-# INLINE withText #-}
701{-# INLINE withText #-}
607−-- | @withArray expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@
703+-- | @'withArray' expected f value@ applies @f@ to the 'Array' when @value@ is
608−-- and fails using @'typeMismatch' expected@ otherwise.
704+-- an 'Data.Aeson.Array' and fails otherwise.
706+-- ==== Error message example
708+-- > withArray "MyType" f (String "oops")
709+-- > -- Error: "parsing MyType failed, expected Array, but encountered String"
609withArray :: String -> (Array -> Parser a) -> Value -> Parser a
710withArray :: String -> (Array -> Parser a) -> Value -> Parser a
610−withArray _ f (Array arr) = f arr
711+withArray _ f (Array arr) = f arr
611−withArray expected _ v = typeMismatch expected v
712+withArray name _ v = prependContext name (typeMismatch "Array" v)
612{-# INLINE withArray #-}
713{-# 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" #-}
621−-- | @withScientific expected f value@ applies @f@ to the 'Scientific' number when @value@ is a 'Number'.
715+-- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number
622−-- and fails using @'typeMismatch' expected@ otherwise.
716+-- when @value@ is a 'Data.Aeson.Number' and fails using 'typeMismatch'
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"
623withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
728withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
624−withScientific _ f (Number scientific) = f scientific
729+withScientific _ f (Number scientific) = f scientific
625−withScientific expected _ v = typeMismatch expected v
730+withScientific name _ v = prependContext name (typeMismatch "Number" v)
626{-# INLINE withScientific #-}
731{-# INLINE withScientific #-}
628−-- | @withBool expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@
733+-- | A variant of 'withScientific' which doesn't use 'prependContext', so that
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
629−-- and fails using @'typeMismatch' expected@ otherwise.
783+-- 'Boolean' and fails otherwise.
785+-- ==== Error message example
787+-- > withBool "MyType" f (String "oops")
788+-- > -- Error: "parsing MyType failed, expected Boolean, but encountered String"
630withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
789withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
631−withBool _ f (Bool arr) = f arr
790+withBool _ f (Bool arr) = f arr
632−withBool expected _ v = typeMismatch expected v
791+withBool name _ v = prependContext name (typeMismatch "Boolean" v)
633{-# INLINE withBool #-}
792{-# 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 #-}
635-- | Convert a value from JSON, failing if the types do not match.
804-- | Convert a value from JSON, failing if the types do not match.
636fromJSON :: (FromJSON a) => Value -> Result a
805fromJSON :: (FromJSON a) => Value -> Result a
637fromJSON = parse parseJSON
806fromJSON = parse parseJSON
@@ -650,32 +819,68 @@ ifromJSON = iparse parseJSON
650-- in an object for it to be valid. If the key and value are
819-- in an object for it to be valid. If the key and value are
651-- optional, use '.:?' instead.
820-- optional, use '.:?' instead.
652(.:) :: (FromJSON a) => Object -> Text -> Parser a
821(.:) :: (FromJSON a) => Object -> Text -> Parser a
653−obj .: key = case H.lookup key obj of
822+(.:) = explicitParseField parseJSON
654− Nothing -> fail $ "key " ++ show key ++ " not present"
655− Just v -> parseJSON v <?> Key key
656{-# INLINE (.:) #-}
823{-# INLINE (.:) #-}
658−-- | Retrieve the value associated with the given key of an 'Object'. The
825+-- | Retrieve the value associated with the given key of an 'Object'. The
659−-- result is 'Nothing' if the key is not present or value is 'Null', or 'empty'
826+-- result is 'Nothing' if the key is not present or if its value is 'Null',
660−-- if the value cannot be converted to the desired type.
827+-- or 'empty' if the value cannot be converted to the desired type.
662-- This accessor is most useful if the key and value can be absent
829-- This accessor is most useful if the key and value can be absent
663-- from an object without affecting its validity. If the key and
830-- from an object without affecting its validity. If the key and
664-- value are mandatory, use '.:' instead.
831-- value are mandatory, use '.:' instead.
665(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
832(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
666−obj .:? key = case H.lookup key obj of
833+(.:?) = explicitParseFieldMaybe parseJSON
667− Nothing -> pure Nothing
668− Just v -> parseJSON v <?> Key key
669{-# INLINE (.:?) #-}
834{-# INLINE (.:?) #-}
671−-- | Like '.:?', but the resulting parser will fail,
836+-- | Retrieve the value associated with the given key of an 'Object'.
672−-- if the key is present but is 'Null'.
837+-- The result is 'Nothing' if the key is not present or 'empty' if the
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'.
673(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
842(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
674−obj .:! key = case H.lookup key obj of
843+(.:!) = explicitParseFieldMaybe' parseJSON
675− Nothing -> pure Nothing
676− Just v -> Just <$> parseJSON v <?> Key key
677{-# INLINE (.:!) #-}
844{-# 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' #-}
679-- | Helper for use in combination with '.:?' to provide default
884-- | Helper for use in combination with '.:?' to provide default
680-- values for optional JSON object fields.
885-- values for optional JSON object fields.
@@ -698,11 +903,47 @@ pmval .!= val = fromMaybe val <$> pmval
698-- Generic parseJSON
903-- Generic parseJSON
699-------------------------------------------------------------------------------
904-------------------------------------------------------------------------------
906+instance GFromJSON arity V1 where
907+ -- Whereof we cannot format, thereof we cannot parse:
908+ gParseJSON _ _ _ = fail "Attempted to parse empty type"
701instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where
911instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where
702 -- Meta-information, which is not handled elsewhere, is just added to the
912 -- Meta-information, which is not handled elsewhere, is just added to the
703 -- parsed value:
913 -- parsed value:
704 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs
914 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
706instance (FromJSON a) => GFromJSON arity (K1 i a) where
947instance (FromJSON a) => GFromJSON arity (K1 i a) where
707 -- Constant values are decoded using their FromJSON instance:
948 -- Constant values are decoded using their FromJSON instance:
708 gParseJSON _opts _ = fmap K1 . parseJSON
949 gParseJSON _opts _ = fmap K1 . parseJSON
@@ -717,327 +958,499 @@ instance (FromJSON1 f) => GFromJSON One (Rec1 f) where
717 -- FromJSON1 instance:
958 -- FromJSON1 instance:
718 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl
959 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
758instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
961instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
759 -- If an occurrence of the last type parameter is nested inside two
962 -- If an occurrence of the last type parameter is nested inside two
760 -- composed types, it is decoded by using the outermost type's FromJSON1
963 -- composed types, it is decoded by using the outermost type's FromJSON1
761 -- instance to generically decode the innermost type:
964 -- instance to generically decode the innermost type:
762 gParseJSON opts fargs =
965 gParseJSON opts fargs =
763− let gpj = gParseJSON opts fargs in
966+ let gpj = gParseJSON opts fargs in
764− fmap Comp1 . liftParseJSON gpj (listParser gpj)
967+ 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))
766--------------------------------------------------------------------------------
1014--------------------------------------------------------------------------------
768class ParseSum arity f allNullary where
1016class ParseSum arity f allNullary where
769− parseSum :: Options -> FromArgs arity a
1017+ parseSum :: TypeName :* Options :* FromArgs arity a
770− -> Value -> Tagged allNullary (Parser (f a))
1019+ -> Tagged allNullary (Parser (f a))
1021+instance ( ConstructorNames f
772−instance ( SumFromString (a :+: b)
1022+ , SumFromString f
773− , FromPair arity (a :+: b)
1023+ , FromPair arity f
774− , FromTaggedObject arity (a :+: b)
1024+ , FromTaggedObject arity f
775− , FromUntaggedValue arity (a :+: b)
1025+ , FromUntaggedValue arity f
776− ) => ParseSum arity (a :+: b) True where
1026+ ) => ParseSum arity f True where
777− parseSum opts fargs
1027+ parseSum p@(tname :* opts :* _)
778− | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts
1028+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts
779− | otherwise = Tagged . parseNonAllNullarySum opts fargs
1029+ | otherwise = Tagged . parseNonAllNullarySum p
1031+instance ( ConstructorNames f
781−instance ( FromPair arity (a :+: b)
1032+ , FromPair arity f
782− , FromTaggedObject arity (a :+: b)
1033+ , FromTaggedObject arity f
783− , FromUntaggedValue arity (a :+: b)
1034+ , FromUntaggedValue arity f
784− ) => ParseSum arity (a :+: b) False where
1035+ ) => ParseSum arity f False where
785− parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs
1036+ parseSum p = Tagged . parseNonAllNullarySum p
787--------------------------------------------------------------------------------
1038--------------------------------------------------------------------------------
789−parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)
1040+parseAllNullarySum :: (SumFromString f, ConstructorNames f)
1041+ => TypeName -> Options -> Value -> Parser (f a)
790−parseAllNullarySum opts = withText "Text" $ \key ->
1042+parseAllNullarySum tname opts =
1043+ withText tname $ \tag ->
791− maybe (notFound key) return $
1044+ maybe (badTag tag) return $
792− parseSumFromString opts key
1045+ parseSumFromString modifier tag
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])
794class SumFromString f where
1063class SumFromString f where
795− parseSumFromString :: Options -> Text -> Maybe (f a)
1064+ parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
797instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
1066instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
798 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
1067 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
799 (R1 <$> parseSumFromString opts key)
1068 (R1 <$> parseSumFromString opts key)
801instance (Constructor c) => SumFromString (C1 c U1) where
1070instance (Constructor c) => SumFromString (C1 c U1) where
802− parseSumFromString opts key | key == name = Just $ M1 U1
1071+ parseSumFromString modifier key
1072+ | key == name = Just $ M1 U1
803− | otherwise = Nothing
1073+ | otherwise = Nothing
805− name = pack $ constructorTagModifier opts $
806− conName (undefined :: t c U1 p)
1075+ name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)
808−--------------------------------------------------------------------------------
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)
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+--------------------------------------------------------------------------------
810−parseNonAllNullarySum :: ( FromPair arity (a :+: b)
1113+parseNonAllNullarySum :: forall f c arity.
811− , FromTaggedObject arity (a :+: b)
1115+ , FromTaggedObject arity f
812− , FromUntaggedValue arity (a :+: b)
1116+ , FromUntaggedValue arity f
1117+ , ConstructorNames f
813− ) => Options -> FromArgs arity c
1118+ ) => TypeName :* Options :* FromArgs arity c
814− -> Value -> Parser ((a :+: b) c)
1119+ -> Value -> Parser (f c)
815−parseNonAllNullarySum opts fargs =
1120+parseNonAllNullarySum p@(tname :* opts :* _) =
816 case sumEncoding opts of
1121 case sumEncoding opts of
817 TaggedObject{..} ->
1122 TaggedObject{..} ->
818− withObject "Object" $ \obj -> do
1123+ withObject tname $ \obj -> do
819− tag <- obj .: pack tagFieldName
1124+ tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
820− fromMaybe (notFound tag) $
1125+ fromMaybe (badTag tag <?> Key tagKey) $
821− parseFromTaggedObject opts fargs contentsFieldName obj tag
1126+ parseFromTaggedObject (tag :* contentsFieldName :* p) obj
1128+ tagKey = pack tagFieldName
1129+ badTag tag = failWith_ $ \cnames ->
1130+ "expected tag field to be one of " ++ show cnames ++
1131+ ", but found tag " ++ show tag
1132+ cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
823 ObjectWithSingleField ->
1134 ObjectWithSingleField ->
824− withObject "Object" $ \obj ->
825− case H.toList obj of
1135+ withObject tname $ \obj -> case H.toList obj of
826− [pair@(tag, _)] -> fromMaybe (notFound tag) $
1136+ [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $
827− parsePair opts fargs pair
1137+ parsePair (tag :* p) v
828− _ -> fail "Object doesn't have a single field"
1138+ _ -> contextType tname . fail $
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
830 TwoElemArray ->
1146 TwoElemArray ->
831− withArray "Array" $ \arr ->
1147+ withArray tname $ \arr -> case V.length arr of
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) $
835− parsePair opts fargs (tag, V.unsafeIndex arr 1)
1150+ parsePair (tag :* p) (V.unsafeIndex arr 1)
1152+ contextType tname $
836− _ -> fail "First element is not a String"
1153+ fail "tag element is not a String" <?> Index 0
837− else fail "Array doesn't have 2 elements"
1154+ len -> contextType tname . fail $
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
839− UntaggedValue -> parseUntaggedValue opts fargs
1162+ UntaggedValue -> parseUntaggedValue p
1164+ failWith_ = failWithCTags tname (constructorTagModifier opts)
841--------------------------------------------------------------------------------
1166--------------------------------------------------------------------------------
843class FromTaggedObject arity f where
1168class 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.
844− parseFromTaggedObject :: Options -> FromArgs arity a
1171+ parseFromTaggedObject
1172+ :: Text :* String :* TypeName :* Options :* FromArgs arity a
845− -> String -> Object
1173+ -> Object
846− -> Text -> Maybe (Parser (f a))
1174+ -> Maybe (Parser (f a))
848instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
1176instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
849 FromTaggedObject arity (a :+: b) where
1177 FromTaggedObject arity (a :+: b) where
850− parseFromTaggedObject opts fargs contentsFieldName obj tag =
1178+ parseFromTaggedObject p obj =
851− (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>
1179+ (fmap L1 <$> parseFromTaggedObject p obj) <|>
852− (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)
1180+ (fmap R1 <$> parseFromTaggedObject p obj)
1182+instance ( IsRecord f isRecord
854−instance ( FromTaggedObject' arity f
1183+ , FromTaggedObject' arity f isRecord
855 , Constructor c
1184 , Constructor c
856 ) => FromTaggedObject arity (C1 c f) where
1185 ) => FromTaggedObject arity (C1 c f) where
857− parseFromTaggedObject opts fargs contentsFieldName obj tag
1186+ parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))
1189+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
858− | tag == name = Just $ M1 <$> parseFromTaggedObject'
1190+ parseFromTaggedObject' (contentsFieldName :* cname :* p)
859− opts fargs contentsFieldName obj
860− | otherwise = Nothing
1191+ | otherwise = const Nothing
862− name = pack $ constructorTagModifier opts $
1193+ tag' = pack $ constructorTagModifier opts cname
863− conName (undefined :: t c f p)
1194+ cname = conName (undefined :: M1 _i c _f _p)
865--------------------------------------------------------------------------------
1196--------------------------------------------------------------------------------
867−class FromTaggedObject' arity f where
1198+class FromTaggedObject' arity f isRecord where
868− parseFromTaggedObject' :: Options -> FromArgs arity a -> String
1199+ -- The first component of the parameter tuple is the contents field name.
869− -> Object -> Parser (f a)
1200+ parseFromTaggedObject'
871−class FromTaggedObject'' arity f isRecord where
872− parseFromTaggedObject'' :: Options -> FromArgs arity a -> String
1201+ :: String :* ConName :* TypeName :* Options :* FromArgs arity a
873− -> Object -> Tagged isRecord (Parser (f a))
1202+ -> Object -> Tagged isRecord (Parser (f a))
875−instance ( IsRecord f isRecord
876− , FromTaggedObject'' arity f isRecord
877− ) => FromTaggedObject' arity f where
1204+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
878− parseFromTaggedObject' opts fargs contentsFieldName =
1205+ -- Records are unpacked in the tagged object
879− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
880− parseFromTaggedObject'' opts fargs contentsFieldName
1206+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
882−instance (FromRecord arity f) => FromTaggedObject'' arity f True where
883− parseFromTaggedObject'' opts fargs _ =
884− Tagged . parseRecord opts fargs Nothing
886−instance (GFromJSON arity f) => FromTaggedObject'' arity f False where
1208+instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
1209+ -- Nonnullary nonrecords are encoded in the contents field
887− parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .
1210+ parseFromTaggedObject' p obj = Tagged $ do
1211+ contents <- contextCons cname tname (obj .: key)
1212+ consParseJSON p' contents <?> Key key
888− (gParseJSON opts fargs <=< (.: pack contentsFieldName))
1214+ key = pack contentsFieldName
1215+ contentsFieldName :* p'@(cname :* tname :* _) = p
890−instance OVERLAPPING_ FromTaggedObject'' arity U1 False where
1217+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)
893--------------------------------------------------------------------------------
1221--------------------------------------------------------------------------------
1223+-- | Constructors need to be decoded differently depending on whether they're
1224+-- a record or not. This distinction is made by 'ConsParseJSON'.
895class ConsFromJSON arity f where
1225class ConsFromJSON arity f where
896− consParseJSON :: Options -> FromArgs arity a
1227+ :: ConName :* TypeName :* Options :* FromArgs arity a
897− -> Value -> Parser (f a)
1228+ -> Value -> Parser (f a)
899class ConsFromJSON' arity f isRecord where
1230class ConsFromJSON' arity f isRecord where
900− consParseJSON' :: Options -> FromArgs arity a
1232+ :: ConName :* TypeName :* Options :* FromArgs arity a
901− -> Maybe Text -- ^ A dummy label
902− -- (Nothing to use proper label)
903− -> Value -> Tagged isRecord (Parser (f a))
1233+ -> Value -> Tagged isRecord (Parser (f a))
905instance ( IsRecord f isRecord
1235instance ( IsRecord f isRecord
906 , ConsFromJSON' arity f isRecord
1236 , ConsFromJSON' arity f isRecord
907 ) => ConsFromJSON arity f where
1237 ) => ConsFromJSON arity f where
908− consParseJSON opts fargs v = let
1238+ consParseJSON p =
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")
913− in (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
1239+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
914− $ consParseJSON' opts fargs lab v2
1240+ . consParseJSON' p
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))
917−instance (FromRecord arity f) => ConsFromJSON' arity f True where
1249+instance RecordFromJSON arity f => ConsFromJSON' arity f True where
918− consParseJSON' opts fargs mlab = Tagged . withObject "record (:*:)"
1250+ consParseJSON' p@(cname :* tname :* _) =
919− (parseRecord opts fargs mlab)
1251+ Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
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_
921−instance (GFromJSON arity f) => ConsFromJSON' arity f False where
1267+ GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where
1268+ consParseJSON' (_ :* _ :* opts :* fargs) =
922− consParseJSON' opts fargs _ = Tagged . gParseJSON opts fargs
1269+ Tagged . fmap M1 . gParseJSON opts fargs
1271+instance (ProductFromJSON arity f, ProductSize f
1272+ ) => ConsFromJSON' arity f False where
1273+ consParseJSON' p = Tagged . productParseJSON0 p
924--------------------------------------------------------------------------------
1275--------------------------------------------------------------------------------
926−class FromRecord arity f where
1277+class FieldNames 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
927− parseRecord :: Options -> FromArgs arity a
1290+ :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a
928− -> Maybe Text -- ^ A dummy label
929− -- (Nothing to use proper label)
930− -> Object -> Parser (f a)
1291+ -> Object -> Parser (f a)
932−instance ( FromRecord arity a
1293+instance ( FieldNames f
933− , FromRecord arity b
1294+ , RecordFromJSON' arity f
934− ) => FromRecord arity (a :*: b) where
1295+ ) => RecordFromJSON arity f where
935− parseRecord opts fargs _ obj =
1296+ recordParseJSON (fromTaggedSum :* p@(cname :* tname :* opts :* _)) =
936− (:*:) <$> parseRecord opts fargs Nothing obj
1297+ \obj -> checkUnknown obj >> recordParseJSON' p 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)
945− label = fromMaybe defLabel lab
946− defLabel = pack . fieldLabelModifier opts $
947− selName (undefined :: t s a p)
949−instance OVERLAPPING_ (Selector s, FromJSON a) =>
950− FromRecord arity (S1 s (K1 i (Maybe a))) where
951− parseRecord _ _ (Just lab) obj = (M1 . K1) <$> obj .:? lab
952− parseRecord opts _ Nothing obj = (M1 . K1) <$> obj .:? pack label
1299+ knownFields :: H.HashMap Text ()
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
954− label = fieldLabelModifier opts $
1329+ label = pack $ fieldLabelModifier opts sname
1330+ sname = selName (undefined :: M1 _i s _f _p)
1332+instance INCOHERENT_ (Selector s, FromJSON a) =>
1333+ RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
1334+ recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
1336+ label = fieldLabelModifier opts sname
955− selName (undefined :: t s (K1 i (Maybe a)) p)
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
1345+ wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
957--------------------------------------------------------------------------------
1347--------------------------------------------------------------------------------
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
959−class FromProduct arity f where
1369+class ProductFromJSON arity f where
960− parseProduct :: Options -> FromArgs arity a
1370+ productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a
961 -> Array -> Int -> Int
1371 -> Array -> Int -> Int
962 -> Parser (f a)
1372 -> Parser (f a)
964−instance ( FromProduct arity a
1374+instance ( ProductFromJSON arity a
965− , FromProduct arity b
1375+ , ProductFromJSON arity b
966− ) => FromProduct arity (a :*: b) where
1376+ ) => ProductFromJSON arity (a :*: b) where
967− parseProduct opts fargs arr ix len =
1377+ productParseJSON p arr ix len =
968− (:*:) <$> parseProduct opts fargs arr ix lenL
1378+ (:*:) <$> productParseJSON p arr ix lenL
969− <*> parseProduct opts fargs arr ixR lenR
1379+ <*> productParseJSON p arr ixR lenR
971 lenL = len `unsafeShiftR` 1
1381 lenL = len `unsafeShiftR` 1
972 ixR = ix + lenL
1382 ixR = ix + lenL
973 lenR = len - lenL
1383 lenR = len - lenL
975−instance (GFromJSON arity a) => FromProduct arity (S1 s a) where
1385+instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where
976− parseProduct opts fargs arr ix _ =
1386+ productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =
977− gParseJSON opts fargs $ V.unsafeIndex arr ix
1387+ M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix
979--------------------------------------------------------------------------------
1389--------------------------------------------------------------------------------
981class FromPair arity f where
1391class FromPair arity f where
1392+ -- The first component of the parameter tuple is the tag to match.
982− parsePair :: Options -> FromArgs arity a
1393+ parsePair :: Text :* TypeName :* Options :* FromArgs arity a
983− -> Pair -> Maybe (Parser (f a))
1395+ -> Maybe (Parser (f a))
985instance ( FromPair arity a
1397instance ( FromPair arity a
986 , FromPair arity b
1398 , FromPair arity b
987 ) => FromPair arity (a :+: b) where
1399 ) => FromPair arity (a :+: b) where
988− parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>
1401+ (fmap L1 <$> parsePair p pair) <|>
989− (fmap R1 <$> parsePair opts fargs pair)
1402+ (fmap R1 <$> parsePair p pair)
991instance ( Constructor c
1404instance ( Constructor c
993 , ConsFromJSON arity a
1405 , ConsFromJSON arity a
994 ) => FromPair arity (C1 c a) where
1406 ) => FromPair arity (C1 c a) where
995− parsePair opts fargs (tag, value)
1407+ parsePair (tag :* p@(_ :* opts :* _)) v
996− | tag == tag' = Just $ gParseJSON opts fargs value
1408+ | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v
997 | otherwise = Nothing
1409 | otherwise = Nothing
999− tag' = pack $ constructorTagModifier opts $
1411+ tag' = pack $ constructorTagModifier opts cname
1000− conName (undefined :: t c a p)
1412+ cname = conName (undefined :: M1 _i c _a _p)
1002--------------------------------------------------------------------------------
1414--------------------------------------------------------------------------------
1004class FromUntaggedValue arity f where
1416class FromUntaggedValue arity f where
1005− parseUntaggedValue :: Options -> FromArgs arity a
1417+ parseUntaggedValue :: TypeName :* Options :* FromArgs arity a
1006− -> Value -> Parser (f a)
1419+ -> Parser (f a)
1009 ( FromUntaggedValue arity a
1422 ( FromUntaggedValue arity a
1010 , FromUntaggedValue arity b
1423 , FromUntaggedValue arity b
1011 ) => FromUntaggedValue arity (a :+: b)
1424 ) => FromUntaggedValue arity (a :+: b)
1013− parseUntaggedValue opts fargs value =
1426+ parseUntaggedValue p value =
1014− L1 <$> parseUntaggedValue opts fargs value <|>
1427+ L1 <$> parseUntaggedValue p value <|>
1015− R1 <$> parseUntaggedValue opts fargs value
1428+ R1 <$> parseUntaggedValue p value
1017instance OVERLAPPABLE_
1430instance OVERLAPPABLE_
1018− ( GFromJSON arity a
1431+ ( ConsFromJSON arity a
1019− , ConsFromJSON arity a
1432+ , Constructor c
1020 ) => FromUntaggedValue arity (C1 c a)
1433 ) => FromUntaggedValue arity (C1 c a)
1022− parseUntaggedValue = gParseJSON
1435+ parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)
1437+ cname = conName (undefined :: M1 _i c _f _p)
1024instance OVERLAPPING_
1439instance OVERLAPPING_
1025 ( Constructor c )
1440 ( Constructor c )
1026 => FromUntaggedValue arity (C1 c U1)
1441 => FromUntaggedValue arity (C1 c U1)
1028− parseUntaggedValue opts _ (String s)
1443+ parseUntaggedValue (tname :* opts :* _) v =
1029− | s == pack (constructorTagModifier opts (conName (undefined :: t c U1 p))) =
1444+ contextCons cname tname $ case v of
1030− pure $ M1 U1
1446+ | tag == tag' -> pure $ M1 U1
1031− | otherwise =
1447+ | otherwise -> fail_ tag
1032− fail $ "Invalid tag: " ++ unpack s
1448+ _ -> typeMismatch "String" v
1033− parseUntaggedValue _ _ v = typeMismatch (conName (undefined :: t c U1 p)) v
1449+ where
1034−
1450+ tag' = pack $ constructorTagModifier opts cname
1035−
1451+ cname = conName (undefined :: M1 _i c _f _p)
1036−--------------------------------------------------------------------------------
1452+ fail_ tag = fail $
1037−
1453+ "expected tag " ++ show tag' ++ ", but found tag " ++ show tag
1038−notFound :: Text -> Parser a
1039−notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"
1040−{-# INLINE notFound #-}
1042-------------------------------------------------------------------------------
1455-------------------------------------------------------------------------------
1043-- Instances
1456-- Instances
@@ -1095,17 +1508,20 @@ instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
1095 parseJSON = parseJSON2
1508 parseJSON = parseJSON2
1096 {-# INLINE parseJSON #-}
1509 {-# INLINE parseJSON #-}
1098−
1511+instance FromJSON Void where
1512+ parseJSON _ = fail "Cannot parse Void"
1513+ {-# INLINE parseJSON #-}
1100instance FromJSON Bool where
1515instance FromJSON Bool where
1101− parseJSON = withBool "Bool" pure
1516+ parseJSON (Bool b) = pure b
1517+ parseJSON v = typeMismatch "Bool" v
1102 {-# INLINE parseJSON #-}
1518 {-# INLINE parseJSON #-}
1104instance FromJSONKey Bool where
1520instance FromJSONKey Bool where
1105 fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
1521 fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
1106 "true" -> pure True
1522 "true" -> pure True
1107 "false" -> pure False
1523 "false" -> pure False
1108− _ -> fail $ "Cannot parse key into Bool: " ++ T.unpack t
1524+ _ -> fail $ "cannot parse key " ++ show t ++ " into Bool"
1110instance FromJSON Ordering where
1526instance FromJSON Ordering where
1111 parseJSON = withText "Ordering" $ \s ->
1527 parseJSON = withText "Ordering" $ \s ->
@@ -1113,25 +1529,30 @@ instance FromJSON Ordering where
1113 "LT" -> return LT
1529 "LT" -> return LT
1114 "EQ" -> return EQ
1530 "EQ" -> return EQ
1115 "GT" -> return GT
1531 "GT" -> return GT
1532+ _ -> fail $ "parsing Ordering failed, unexpected " ++ show s ++
1116− _ -> fail "Parsing Ordering value failed: expected \"LT\", \"EQ\", or \"GT\""
1533+ " (expected \"LT\", \"EQ\", or \"GT\")"
1118instance FromJSON () where
1535instance FromJSON () where
1119 parseJSON = withArray "()" $ \v ->
1536 parseJSON = withArray "()" $ \v ->
1120 if V.null v
1537 if V.null v
1121 then pure ()
1538 then pure ()
1122− else fail "Expected an empty array"
1539+ else prependContext "()" $ fail "expected an empty array"
1123 {-# INLINE parseJSON #-}
1540 {-# INLINE parseJSON #-}
1125instance FromJSON Char where
1542instance FromJSON Char where
1126− parseJSON = withText "Char" $ \t ->
1543+ parseJSON = withText "Char" parseChar
1127− if T.compareLength t 1 == EQ
1128− then pure $ T.head t
1129− else fail "Expected a string of length 1"
1130 {-# INLINE parseJSON #-}
1544 {-# INLINE parseJSON #-}
1132− parseJSONList = withText "String" $ pure . T.unpack
1546+ parseJSONList (String s) = pure (T.unpack s)
1547+ parseJSONList v = typeMismatch "String" v
1133 {-# INLINE parseJSONList #-}
1548 {-# 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"
1135instance FromJSON Double where
1556instance FromJSON Double where
1136 parseJSON = parseRealFloat "Double"
1557 parseJSON = parseRealFloat "Double"
1137 {-# INLINE parseJSON #-}
1558 {-# INLINE parseJSON #-}
@@ -1143,12 +1564,6 @@ instance FromJSONKey Double where
1143 "-Infinity" -> pure (negate 1/0)
1564 "-Infinity" -> pure (negate 1/0)
1144 _ -> Scientific.toRealFloat <$> parseScientificText t
1565 _ -> 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 #-}
1152instance FromJSON Float where
1567instance FromJSON Float where
1153 parseJSON = parseRealFloat "Float"
1568 parseJSON = parseRealFloat "Float"
1154 {-# INLINE parseJSON #-}
1569 {-# INLINE parseJSON #-}
@@ -1161,17 +1576,30 @@ instance FromJSONKey Float where
1161 _ -> Scientific.toRealFloat <$> parseScientificText t
1576 _ -> Scientific.toRealFloat <$> parseScientificText t
1163instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1578instance (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
1164− parseJSON = withObject "Rational" $ \obj ->
1589+ objParser = withObject "Rational" $ \obj -> do
1165− (%) <$> obj .: "numerator"
1590+ numerator <- obj .: "numerator"
1591+ denominator <- obj .: "denominator"
1592+ if denominator == 0
1593+ then fail "Ratio denominator was 0"
1166− <*> obj .: "denominator"
1594+ else pure $ numerator % denominator
1167− {-# INLINE parseJSON #-}
1595+ {-# INLINE parseJSON #-}
1169−-- | /WARNING:/ Only parse fixed-precision numbers from trusted input
1597+-- | This instance includes a bounds check to prevent maliciously
1170−-- since an attacker could easily fill up the memory of the target
1598+-- large inputs to fill up the memory of the target system. You can
1171−-- system by specifying a scientific number with a big exponent like
1599+-- newtype 'Scientific' and provide your own instance using
1172−-- @1e1000000000@.
1600+-- 'withScientific' if you want to allow larger inputs.
1173instance HasResolution a => FromJSON (Fixed a) where
1601instance HasResolution a => FromJSON (Fixed a) where
1174− parseJSON = withScientific "Fixed" $ pure . realToFrac
1602+ parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac)
1175 {-# INLINE parseJSON #-}
1603 {-# INLINE parseJSON #-}
1177instance FromJSON Int where
1605instance FromJSON Int where
@@ -1181,10 +1609,10 @@ instance FromJSON Int where
1181instance FromJSONKey Int where
1609instance FromJSONKey Int where
1182 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"
1610 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"
1184−-- | /WARNING:/ Only parse Integers from trusted input since an
1612+-- | This instance includes a bounds check to prevent maliciously
1185−-- attacker could easily fill up the memory of the target system by
1613+-- large inputs to fill up the memory of the target system. You can
1186−-- specifying a scientific number with a big exponent like
1614+-- newtype 'Scientific' and provide your own instance using
1187−-- @1e1000000000@.
1615+-- 'withScientific' if you want to allow larger inputs.
1188instance FromJSON Integer where
1616instance FromJSON Integer where
1189 parseJSON = parseIntegral "Integer"
1617 parseJSON = parseIntegral "Integer"
1190 {-# INLINE parseJSON #-}
1618 {-# INLINE parseJSON #-}
@@ -1193,16 +1621,21 @@ instance FromJSONKey Integer where
1193 fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer"
1621 fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer"
1195instance FromJSON Natural where
1623instance FromJSON Natural where
1196− parseJSON = withScientific "Natural" $ \s ->
1624+ parseJSON value = do
1197− if Scientific.coefficient s < 0
1625+ integer <- parseIntegral "Natural" value
1198− then fail $ "Expected a Natural number but got the negative number: " <> show s
1626+ parseNatural integer
1199− else pure $ truncate s
1201instance FromJSONKey Natural where
1628instance FromJSONKey Natural where
1202− fromJSONKey = FromJSONKeyTextParser $ \t -> parseScientificText t >>= \s ->
1629+ fromJSONKey = FromJSONKeyTextParser $ \text -> do
1203− if Scientific.coefficient s < 0
1630+ integer <- parseIntegralText "Natural" text
1631+ parseNatural integer
1633+parseNatural :: Integer -> Parser Natural
1634+parseNatural integer =
1635+ if integer < 0 then
1204− then fail $ "Expected a Natural number but got the negative number: " <> show s
1636+ fail $ "parsing Natural failed, unexpected negative number " <> show integer
1205− else pure $ truncate s
1637+ else
1638+ pure $ fromIntegral integer
1207instance FromJSON Int8 where
1640instance FromJSON Int8 where
1208 parseJSON = parseBoundedIntegral "Int8"
1641 parseJSON = parseBoundedIntegral "Int8"
@@ -1267,6 +1700,9 @@ instance FromJSON Word64 where
1267instance FromJSONKey Word64 where
1700instance FromJSONKey Word64 where
1268 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64"
1701 fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64"
1703+instance FromJSON CTime where
1704+ parseJSON = fmap CTime . parseJSON
1705+ {-# INLINE parseJSON #-}
1271instance FromJSON Text where
1707instance FromJSON Text where
1272 parseJSON = withText "Text" pure
1708 parseJSON = withText "Text" pure
@@ -1296,17 +1732,17 @@ parseVersionText = go . readP_to_S parseVersion . unpack
1297 go [(v,[])] = return v
1733 go [(v,[])] = return v
1298 go (_ : xs) = go xs
1734 go (_ : xs) = go xs
1299− go _ = fail "could not parse Version"
1735+ go _ = fail "parsing Version failed"
1301-------------------------------------------------------------------------------
1737-------------------------------------------------------------------------------
1302-- semigroups NonEmpty
1738-- semigroups NonEmpty
1303-------------------------------------------------------------------------------
1739-------------------------------------------------------------------------------
1305instance FromJSON1 NonEmpty where
1741instance FromJSON1 NonEmpty where
1306− liftParseJSON p _ = withArray "NonEmpty a" $
1742+ liftParseJSON p _ = withArray "NonEmpty" $
1307 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1743 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1309− ne [] = fail "Expected a NonEmpty but got an empty list"
1745+ ne [] = fail "parsing NonEmpty failed, unexpected empty list"
1310 ne (x:xs) = pure (x :| xs)
1746 ne (x:xs) = pure (x :| xs)
1311 {-# INLINE liftParseJSON #-}
1747 {-# INLINE liftParseJSON #-}
@@ -1327,7 +1763,7 @@ instance FromJSON Scientific where
1327-------------------------------------------------------------------------------
1763-------------------------------------------------------------------------------
1329instance FromJSON1 DList.DList where
1765instance FromJSON1 DList.DList where
1330− liftParseJSON p _ = withArray "DList a" $
1766+ liftParseJSON p _ = withArray "DList" $
1331 fmap DList.fromList .
1767 fmap DList.fromList .
1332 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1768 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1333 {-# INLINE liftParseJSON #-}
1769 {-# INLINE liftParseJSON #-}
@@ -1354,7 +1790,7 @@ instance (FromJSON a) => FromJSON (Identity a) where
1354 parseJSONList = liftParseJSONList parseJSON parseJSONList
1790 parseJSONList = liftParseJSONList parseJSON parseJSONList
1355 {-# INLINE parseJSONList #-}
1791 {-# INLINE parseJSONList #-}
1357−instance (FromJSONKey a, FromJSON a) => FromJSONKey (Identity a) where
1793+instance (FromJSONKey a) => FromJSONKey (Identity a) where
1358 fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a)
1794 fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a)
1359 fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])
1795 fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])
@@ -1404,7 +1840,7 @@ instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where
1404 inr = "InR"
1840 inr = "InR"
1406 liftParseJSON _ _ _ = fail $
1842 liftParseJSON _ _ _ = fail $
1407− "expected an object with a single property " ++
1843+ "parsing Sum failed, expected an object with a single property " ++
1408 "where the property key should be either " ++
1844 "where the property key should be either " ++
1409 "\"InL\" or \"InR\""
1845 "\"InL\" or \"InR\""
1410 {-# INLINE liftParseJSON #-}
1846 {-# INLINE liftParseJSON #-}
@@ -1418,7 +1854,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where
1418-------------------------------------------------------------------------------
1854-------------------------------------------------------------------------------
1420instance FromJSON1 Seq.Seq where
1856instance FromJSON1 Seq.Seq where
1421− liftParseJSON p _ = withArray "Seq a" $
1857+ liftParseJSON p _ = withArray "Seq" $
1422 fmap Seq.fromList .
1858 fmap Seq.fromList .
1423 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1859 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1424 {-# INLINE liftParseJSON #-}
1860 {-# INLINE liftParseJSON #-}
@@ -1452,15 +1888,15 @@ instance FromJSON a => FromJSON (IntMap.IntMap a) where
1453instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
1889instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
1454 liftParseJSON p _ = case fromJSONKey of
1890 liftParseJSON p _ = case fromJSONKey of
1455− FromJSONKeyCoerce _-> withObject "Map k v" $
1891+ FromJSONKeyCoerce _ -> withObject "Map" $
1456 fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1892 fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1457− FromJSONKeyText f -> withObject "Map k v" $
1893+ FromJSONKeyText f -> withObject "Map" $
1458 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1894 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1459− FromJSONKeyTextParser f -> withObject "Map k v" $
1895+ FromJSONKeyTextParser f -> withObject "Map" $
1460 H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)
1896 H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)
1461− FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
1897+ FromJSONKeyValue f -> withArray "Map" $ \arr ->
1462− M.fromList <$> (Tr.sequence .
1898+ fmap M.fromList . Tr.sequence .
1463− zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
1899+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
1464 {-# INLINE liftParseJSON #-}
1900 {-# INLINE liftParseJSON #-}
1466instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (M.Map k v) where
1902instance (FromJSONKey k, Ord k, FromJSON v) => FromJSON (M.Map k v) where
@@ -1480,12 +1916,24 @@ instance (FromJSON v) => FromJSON (Tree.Tree v) where
1480 parseJSON = parseJSON1
1916 parseJSON = parseJSON1
1481 {-# INLINE parseJSON #-}
1917 {-# 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
1483-------------------------------------------------------------------------------
1931-------------------------------------------------------------------------------
1484-- vector
1932-- vector
1485-------------------------------------------------------------------------------
1933-------------------------------------------------------------------------------
1487instance FromJSON1 Vector where
1935instance FromJSON1 Vector where
1488− liftParseJSON p _ = withArray "Vector a" $
1936+ liftParseJSON p _ = withArray "Vector" $
1489 V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
1937 V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
1490 {-# INLINE liftParseJSON #-}
1938 {-# INLINE liftParseJSON #-}
@@ -1499,14 +1947,14 @@ vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry $ parseIndexe
1499{-# INLINE vectorParseJSON #-}
1947{-# INLINE vectorParseJSON #-}
1501instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
1949instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
1502− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
1950+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector"
1504instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
1952instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
1505− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
1953+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector"
1506 {-# INLINE parseJSON #-}
1954 {-# INLINE parseJSON #-}
1508instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
1956instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
1509− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
1957+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector"
1510 {-# INLINE parseJSON #-}
1958 {-# INLINE parseJSON #-}
1512-------------------------------------------------------------------------------
1960-------------------------------------------------------------------------------
@@ -1520,15 +1968,15 @@ instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
1521instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
1969instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
1522 liftParseJSON p _ = case fromJSONKey of
1970 liftParseJSON p _ = case fromJSONKey of
1523− FromJSONKeyCoerce _ -> withObject "HashMap ~Text v" $
1971+ FromJSONKeyCoerce _ -> withObject "HashMap ~Text" $
1524 uc . H.traverseWithKey (\k v -> p v <?> Key k)
1972 uc . H.traverseWithKey (\k v -> p v <?> Key k)
1525− FromJSONKeyText f -> withObject "HashMap k v" $
1973+ FromJSONKeyText f -> withObject "HashMap" $
1526 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)
1974 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)
1527− FromJSONKeyTextParser f -> withObject "HashMap k v" $
1975+ FromJSONKeyTextParser f -> withObject "HashMap" $
1528 H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)
1976 H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)
1529− FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
1977+ FromJSONKeyValue f -> withArray "Map" $ \arr ->
1530− H.fromList <$> (Tr.sequence .
1978+ fmap H.fromList . Tr.sequence .
1531− zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
1979+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
1533 uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v)
1981 uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v)
1534 uc = unsafeCoerce
1982 uc = unsafeCoerce
@@ -1549,11 +1997,33 @@ instance FromJSON DotNetTime where
1549 parseJSON = withText "DotNetTime" $ \t ->
1997 parseJSON = withText "DotNetTime" $ \t ->
1550 let (s,m) = T.splitAt (T.length t - 5) t
1998 let (s,m) = T.splitAt (T.length t - 5) t
1551 t' = T.concat [s,".",m]
1999 t' = T.concat [s,".",m]
1552− in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
2000+ in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
1553 Just d -> pure (DotNetTime d)
2001 Just d -> pure (DotNetTime d)
1554 _ -> fail "could not parse .NET time"
2002 _ -> fail "could not parse .NET time"
1555 {-# INLINE parseJSON #-}
2003 {-# 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
1557-------------------------------------------------------------------------------
2027-------------------------------------------------------------------------------
1559-------------------------------------------------------------------------------
2029-------------------------------------------------------------------------------
@@ -1579,6 +2049,17 @@ instance FromJSONKey LocalTime where
1579 fromJSONKey = FromJSONKeyTextParser (Time.run Time.localTime)
2049 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.
1582instance FromJSON ZonedTime where
2063instance FromJSON ZonedTime where
1583 parseJSON = withText "ZonedTime" (Time.run Time.zonedTime)
2064 parseJSON = withText "ZonedTime" (Time.run Time.zonedTime)
@@ -1593,41 +2074,168 @@ instance FromJSONKey UTCTime where
1593 fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)
2074 fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)
1596−-- | /WARNING:/ Only parse lengths of time from trusted input
2077+-- | This instance includes a bounds check to prevent maliciously
1597−-- since an attacker could easily fill up the memory of the target
2078+-- large inputs to fill up the memory of the target system. You can
1598−-- system by specifying a scientific number with a big exponent like
2079+-- newtype 'Scientific' and provide your own instance using
1599−-- @1e1000000000@.
2080+-- 'withScientific' if you want to allow larger inputs.
1600instance FromJSON NominalDiffTime where
2081instance FromJSON NominalDiffTime where
1601− parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac
2082+ parseJSON = withBoundedScientific "NominalDiffTime" $ pure . realToFrac
1602 {-# INLINE parseJSON #-}
2083 {-# 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
1604-------------------------------------------------------------------------------
2128-------------------------------------------------------------------------------
1605-- base Monoid/Semigroup
2129-- base Monoid/Semigroup
1606-------------------------------------------------------------------------------
2130-------------------------------------------------------------------------------
1608−instance FromJSON1 Dual where
2132+instance FromJSON1 Monoid.Dual where
1609− liftParseJSON p _ = fmap Dual . p
2133+ liftParseJSON p _ = fmap Monoid.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
1610 {-# INLINE liftParseJSON #-}
2191 {-# INLINE liftParseJSON #-}
2193+ liftParseJSONList _ p a = fmap Semigroup.First <$> p a
2194+ {-# INLINE liftParseJSONList #-}
1612−instance FromJSON a => FromJSON (Dual a) where
2196+instance (FromJSON a) => FromJSON (Semigroup.First a) where
1613 parseJSON = parseJSON1
2197 parseJSON = parseJSON1
1614 {-# INLINE parseJSON #-}
2198 {-# INLINE parseJSON #-}
2200+ parseJSONList = liftParseJSONList parseJSON parseJSONList
2201+ {-# INLINE parseJSONList #-}
1617−instance FromJSON1 First where
2204+instance FromJSON1 Semigroup.Last where
1618− liftParseJSON p p' = fmap First . liftParseJSON p p'
2205+ liftParseJSON p _ a = Semigroup.Last <$> p a
1619 {-# INLINE liftParseJSON #-}
2206 {-# INLINE liftParseJSON #-}
2208+ liftParseJSONList _ p a = fmap Semigroup.Last <$> p a
2209+ {-# INLINE liftParseJSONList #-}
1621−instance FromJSON a => FromJSON (First a) where
2211+instance (FromJSON a) => FromJSON (Semigroup.Last a) where
1622 parseJSON = parseJSON1
2212 parseJSON = parseJSON1
1623 {-# INLINE parseJSON #-}
2213 {-# INLINE parseJSON #-}
2215+ parseJSONList = liftParseJSONList parseJSON parseJSONList
2216+ {-# INLINE parseJSONList #-}
2219+instance FromJSON1 Semigroup.WrappedMonoid 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 #-}
1626−instance FromJSON1 Last where
2234+instance FromJSON1 Semigroup.Option where
1627− liftParseJSON p p' = fmap Last . liftParseJSON p p'
2235+ liftParseJSON p p' = fmap Semigroup.Option . liftParseJSON p p'
1628 {-# INLINE liftParseJSON #-}
2236 {-# INLINE liftParseJSON #-}
1630−instance FromJSON a => FromJSON (Last a) where
2238+instance FromJSON a => FromJSON (Semigroup.Option a) where
1631 parseJSON = parseJSON1
2239 parseJSON = parseJSON1
1632 {-# INLINE parseJSON #-}
2240 {-# INLINE parseJSON #-}
@@ -1635,11 +2243,21 @@ instance FromJSON a => FromJSON (Last a) where
1635-- tagged
2243-- tagged
1636-------------------------------------------------------------------------------
2244-------------------------------------------------------------------------------
2246+instance FromJSON1 Proxy where
2247+ {-# INLINE liftParseJSON #-}
2248+ liftParseJSON _ _ = fromNull "Proxy" Proxy
1638instance FromJSON (Proxy a) where
2250instance FromJSON (Proxy a) where
1639 {-# INLINE parseJSON #-}
2251 {-# INLINE parseJSON #-}
1640− parseJSON Null = pure Proxy
2252+ parseJSON = fromNull "Proxy" 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 #-}
1644instance FromJSON1 (Tagged a) where
2262instance FromJSON1 (Tagged a) where
1645 liftParseJSON p _ = fmap Tagged . p
2263 liftParseJSON p _ = fmap Tagged . p
@@ -1662,10 +2280,7 @@ instance (FromJSON a, FromJSON b, FromJSON c) => FromJSONKey (a,b,c)
1662instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)
2280instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)
1664instance FromJSONKey Char where
2282instance FromJSONKey Char where
1665− fromJSONKey = FromJSONKeyTextParser $ \t ->
2283+ fromJSONKey = FromJSONKeyTextParser parseChar
1667− then return (T.index t 0)
1668− else typeMismatch "Expected Char but String didn't contain exactly one character" (String t)
1669 fromJSONKeyList = FromJSONKeyText T.unpack
2284 fromJSONKeyList = FromJSONKeyText T.unpack
1671instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where
2286instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where