@@ -5,16 +5,19 @@
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE NoImplicitPrelude #-}
8+{-# LANGUAGE NamedFieldPuns #-}
9{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE RecordWildCards #-}
10{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TypeSynonymInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
16{-# LANGUAGE ViewPatterns #-}
15{-# LANGUAGE ViewPatterns #-}
17+#if __GLASGOW_HASKELL__ >= 706
18+{-# LANGUAGE PolyKinds #-}
18#include "incoherent-compat.h"
21#include "incoherent-compat.h"
19#include "overlapping-compat.h"
22#include "overlapping-compat.h"
@@ -42,9 +45,6 @@ module Data.Aeson.Types.FromJSON
42 , coerceFromJSONKeyFunction
45 , coerceFromJSONKeyFunction
43 , mapFromJSONKeyFunction
46 , mapFromJSONKeyFunction
48 -- * List functions
48 -- * List functions
49 , listParser
49 , listParser
@@ -60,14 +60,12 @@ module Data.Aeson.Types.FromJSON
60 , fromJSON
60 , fromJSON
61 , ifromJSON
61 , ifromJSON
62 , typeMismatch
62 , typeMismatch
64 , parseField
63 , parseField
65 , parseFieldMaybe
64 , parseFieldMaybe
66 , parseFieldMaybe'
65 , parseFieldMaybe'
67 , explicitParseField
66 , explicitParseField
68 , explicitParseFieldMaybe
67 , explicitParseFieldMaybe
69 , explicitParseFieldMaybe'
68 , explicitParseFieldMaybe'
71 -- ** Operators
69 -- ** Operators
@@ -78,16 +76,17 @@ module Data.Aeson.Types.FromJSON
78 , parseOptionalFieldWith
76 , parseOptionalFieldWith
81import Prelude.Compat
80import Prelude.Compat
83−import Control.Applicative ((<|>), Const(..), liftA2)
82+import Control.Applicative ((<|>), Const(..))
84−import Control.Monad (zipWithM)
83+import Control.Monad ((<=<), zipWithM)
85import Data.Aeson.Internal.Functions (mapKey)
84import Data.Aeson.Internal.Functions (mapKey)
86import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
85import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
87import Data.Aeson.Types.Generic
86import Data.Aeson.Types.Generic
88import Data.Aeson.Types.Internal
87import Data.Aeson.Types.Internal
89import Data.Bits (unsafeShiftR)
88import Data.Bits (unsafeShiftR)
90−import Data.Fixed (Fixed, HasResolution (resolution), Nano)
89+import Data.Fixed (Fixed, HasResolution)
91import Data.Functor.Compose (Compose(..))
90import Data.Functor.Compose (Compose(..))
92import Data.Functor.Identity (Identity(..))
91import Data.Functor.Identity (Identity(..))
93import Data.Functor.Product (Product(..))
92import Data.Functor.Product (Product(..))
@@ -103,14 +102,11 @@ import Data.Scientific (Scientific, base10Exponent)
103import Data.Tagged (Tagged(..))
102import Data.Tagged (Tagged(..))
104import Data.Text (Text, pack, unpack)
103import Data.Text (Text, pack, unpack)
105import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
104import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
106−import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
105+import Data.Time.Format (parseTime)
107−import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
108−import Data.Time.Clock.System.Compat (SystemTime (..))
109−import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
106+import Data.Time.Locale.Compat (defaultTimeLocale)
110import Data.Traversable as Tr (sequence)
107import Data.Traversable as Tr (sequence)
111import Data.Vector (Vector)
108import Data.Vector (Vector)
112import Data.Version (Version, parseVersion)
109import Data.Version (Version, parseVersion)
113−import Data.Void (Void)
114import Data.Word (Word16, Word32, Word64, Word8)
110import Data.Word (Word16, Word32, Word64, Word8)
115import Foreign.Storable (Storable)
111import Foreign.Storable (Storable)
116import Foreign.C.Types (CTime (..))
112import Foreign.C.Types (CTime (..))
@@ -118,9 +114,9 @@ import GHC.Generics
118import Numeric.Natural (Natural)
114import Numeric.Natural (Natural)
119import Text.ParserCombinators.ReadP (readP_to_S)
115import Text.ParserCombinators.ReadP (readP_to_S)
120import Unsafe.Coerce (unsafeCoerce)
116import Unsafe.Coerce (unsafeCoerce)
117+import qualified Data.Aeson.Compat as Compat
121import qualified Data.Aeson.Parser.Time as Time
118import qualified Data.Aeson.Parser.Time as Time
122import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
119import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123−import qualified Data.ByteString.Lazy as L
124import qualified Data.DList as DList
120import qualified Data.DList as DList
125import qualified Data.HashMap.Strict as H
121import qualified Data.HashMap.Strict as H
126import qualified Data.HashSet as HashSet
122import qualified Data.HashSet as HashSet
@@ -148,15 +144,23 @@ import qualified Data.Primitive.Array as PM
148import qualified Data.Primitive.SmallArray as PM
144import qualified Data.Primitive.SmallArray as PM
149import qualified Data.Primitive.Types as PM
145import qualified Data.Primitive.Types as PM
151−#if MIN_VERSION_primitive(0,6,4)
147+#if (MIN_VERSION_primitive(0,6,4))
152−#if !MIN_VERSION_primitive(0,7,0)
153import qualified Data.Primitive.UnliftedArray as PM
148import qualified Data.Primitive.UnliftedArray as PM
155import qualified Data.Primitive.PrimArray as PM
149import qualified Data.Primitive.PrimArray as PM
152+#ifndef HAS_COERCIBLE
153+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
159import Data.Coerce (Coercible, coerce)
157import Data.Coerce (Coercible, coerce)
158+coerce' :: Coercible a b => a -> b
162+coerce' = unsafeCoerce
161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
165parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
162parseIndexedJSON p idx value = p value <?> Index idx
166parseIndexedJSON p idx value = p value <?> Index idx
@@ -165,7 +169,7 @@ parseIndexedJSON p idx value = p value <?> Index idx
165parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)
169parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b)
166parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
170parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
168− p = withArray "(k, v)" $ \ab ->
172+ p = withArray "(k,v)" $ \ab ->
169 let n = V.length ab
173 let n = V.length ab
170 in if n == 2
174 in if n == 2
171 then (,) <$> parseJSONElemAtIndex keyParser 0 ab
175 then (,) <$> parseJSONElemAtIndex keyParser 0 ab
@@ -178,33 +182,33 @@ parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a
178parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx
182parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx
180parseRealFloat :: RealFloat a => String -> Value -> Parser a
184parseRealFloat :: RealFloat a => String -> Value -> Parser a
181−parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s
185+parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s
182−parseRealFloat _ Null = pure (0/0)
186+parseRealFloat _ Null = pure (0/0)
183−parseRealFloat name v = prependContext name (unexpected v)
187+parseRealFloat expected v = typeMismatch expected v
184{-# INLINE parseRealFloat #-}
188{-# INLINE parseRealFloat #-}
186−parseIntegralFromScientific :: forall a. Integral a => Scientific -> Parser a
190+parseIntegralFromScientific :: forall a. Integral a => String -> Scientific -> Parser a
187−parseIntegralFromScientific s =
191+parseIntegralFromScientific expected s =
188 case Scientific.floatingOrInteger s :: Either Double a of
192 case Scientific.floatingOrInteger s :: Either Double a of
189 Right x -> pure x
193 Right x -> pure x
190− Left _ -> fail $ "unexpected floating number " ++ show s
194+ Left _ -> fail $ "expected " ++ expected ++ ", encountered floating number " ++ show s
191{-# INLINE parseIntegralFromScientific #-}
195{-# INLINE parseIntegralFromScientific #-}
193parseIntegral :: Integral a => String -> Value -> Parser a
197parseIntegral :: Integral a => String -> Value -> Parser a
194−parseIntegral name =
198+parseIntegral expected =
195− prependContext name . withBoundedScientific' parseIntegralFromScientific
199+ withBoundedScientific expected $ parseIntegralFromScientific expected
196{-# INLINE parseIntegral #-}
200{-# INLINE parseIntegral #-}
198−parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => Scientific -> Parser a
202+parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => String -> Scientific -> Parser a
199−parseBoundedIntegralFromScientific s = maybe
203+parseBoundedIntegralFromScientific expected s = maybe
200− (fail $ "value is either floating or will cause over or underflow " ++ show s)
204+ (fail $ expected ++ " is either floating or will cause over or underflow: " ++ show s)
202 (Scientific.toBoundedInteger s)
206 (Scientific.toBoundedInteger s)
203{-# INLINE parseBoundedIntegralFromScientific #-}
207{-# INLINE parseBoundedIntegralFromScientific #-}
205parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a
209parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a
206−parseBoundedIntegral name =
210+parseBoundedIntegral expected =
207− prependContext name . withScientific' parseBoundedIntegralFromScientific
211+ withScientific expected $ parseBoundedIntegralFromScientific expected
208{-# INLINE parseBoundedIntegral #-}
212{-# INLINE parseBoundedIntegral #-}
210parseScientificText :: Text -> Parser Scientific
214parseScientificText :: Text -> Parser Scientific
@@ -214,20 +218,18 @@ parseScientificText
214 . T.encodeUtf8
218 . T.encodeUtf8
216parseIntegralText :: Integral a => String -> Text -> Parser a
220parseIntegralText :: Integral a => String -> Text -> Parser a
217−parseIntegralText name t =
221+parseIntegralText expected t
218− prependContext name $
219− parseScientificText t
222+ = parseScientificText t
220− >>= rejectLargeExponent
223+ >>= rejectLargeExponent
221− >>= parseIntegralFromScientific
224+ >>= parseIntegralFromScientific expected
223 rejectLargeExponent :: Scientific -> Parser Scientific
226 rejectLargeExponent :: Scientific -> Parser Scientific
224− rejectLargeExponent s = withBoundedScientific' pure (Number s)
227+ rejectLargeExponent s = withBoundedScientific expected pure (Number s)
225{-# INLINE parseIntegralText #-}
228{-# INLINE parseIntegralText #-}
227parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a
230parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a
228−parseBoundedIntegralText name t =
231+parseBoundedIntegralText expected t =
229− prependContext name $
230− parseScientificText t >>= parseBoundedIntegralFromScientific
232+ parseScientificText t >>= parseBoundedIntegralFromScientific expected
232parseOptionalFieldWith :: (Value -> Parser (Maybe a))
234parseOptionalFieldWith :: (Value -> Parser (Maybe a))
233 -> Object -> Text -> Parser (Maybe a)
235 -> Object -> Text -> Parser (Maybe a)
@@ -287,21 +289,14 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
288-- The basic ways to signal a failed conversion are as follows:
290-- The basic ways to signal a failed conversion are as follows:
290−-- * 'fail' yields a custom error message: it is the recommended way of
292+-- * 'empty' and 'mzero' work, but are terse and uninformative;
291−-- reporting a failure;
293−-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:
294+-- * 'fail' yields a custom error message;
294−-- use it when the error is meant to be caught by some @('<|>')@;
296−-- * 'typeMismatch' can be used to report a failure when the encountered value
296+-- * 'typeMismatch' produces an informative message for cases when the
297−-- is not of the expected JSON type; 'unexpected' is an appropriate alternative
297+-- value encountered is not of the expected type.
298−-- when more than one type may be expected, or to keep the expected type
301−-- 'prependFailure' (or 'modifyFailure') add more information to a parser's
304−-- An example type and instance using 'typeMismatch' and 'prependFailure':
299+-- An example type and instance using 'typeMismatch':
307-- \-- Allow ourselves to write 'Text' literals.
302-- \-- Allow ourselves to write 'Text' literals.
@@ -315,15 +310,13 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
315-- '<*>' v '.:' \"y\"
310-- '<*>' v '.:' \"y\"
317-- \-- We do not expect a non-'Object' value here.
312-- \-- We do not expect a non-'Object' value here.
318−-- \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'
313+-- \-- We could use 'mzero' to fail, but 'typeMismatch'
319-- \-- gives a much more informative error message.
314-- \-- gives a much more informative error message.
320−-- 'parseJSON' invalid =
315+-- 'parseJSON' invalid = 'typeMismatch' \"Coord\" invalid
321−-- 'prependFailure' "parsing Coord failed, "
322−-- ('typeMismatch' \"Object\" invalid)
325-- For this common case of only being concerned with a single
318-- For this common case of only being concerned with a single
326−-- type of JSON value, the functions 'withObject', 'withScientific', etc.
319+-- type of JSON value, the functions 'withObject', 'withNumber', etc.
327-- are provided. Their use is to be preferred when possible, since
320-- are provided. Their use is to be preferred when possible, since
328-- they are more terse. Using 'withObject', we can rewrite the above instance
321-- they are more terse. Using 'withObject', we can rewrite the above instance
329-- (assuming the same language extension and data type) as:
322-- (assuming the same language extension and data type) as:
@@ -362,7 +355,7 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
364-- The default implementation will be equivalent to
357-- The default implementation will be equivalent to
365−-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different
358+-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; If you need different
366-- options, you can customize the generic decoding by defining:
359-- options, you can customize the generic decoding by defining:
@@ -380,11 +373,13 @@ class FromJSON a where
380 parseJSON = genericParseJSON defaultOptions
373 parseJSON = genericParseJSON defaultOptions
382 parseJSONList :: Value -> Parser [a]
375 parseJSONList :: Value -> Parser [a]
383− parseJSONList = withArray "[]" $ \a ->
376+ parseJSONList (Array a)
384− zipWithM (parseIndexedJSON parseJSON) [0..]
377+ = zipWithM (parseIndexedJSON parseJSON) [0..]
385 . V.toList
378 . V.toList
381+ parseJSONList v = typeMismatch "[a]" v
388-------------------------------------------------------------------------------
383-------------------------------------------------------------------------------
389-- Classes and types for map keys
384-- Classes and types for map keys
390-------------------------------------------------------------------------------
385-------------------------------------------------------------------------------
@@ -396,16 +391,6 @@ class FromJSON a where
396-- > newtype SomeId = SomeId { getSomeId :: Text }
391-- > newtype SomeId = SomeId { getSomeId :: Text }
397-- > deriving (Eq,Ord,Hashable,FromJSONKey)
392-- > deriving (Eq,Ord,Hashable,FromJSONKey)
399−-- If you have a sum of nullary constructors, you may use the generic
403−-- data Color = Red | Green | Blue
406−-- instance 'FromJSONKey' Color where
407−-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'
409class FromJSONKey a where
394class FromJSONKey a where
410 -- | Strategy for parsing the key of a map-like container.
395 -- | Strategy for parsing the key of a map-like container.
411 fromJSONKey :: FromJSONKeyFunction a
396 fromJSONKey :: FromJSONKeyFunction a
@@ -428,7 +413,11 @@ class FromJSONKey a where
428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
413-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
429-- can be inspected, but cannot be constructed.
414-- can be inspected, but cannot be constructed.
430data CoerceText a where
415data CoerceText a where
431 CoerceText :: Coercible Text a => CoerceText a
417 CoerceText :: Coercible Text a => CoerceText a
419+ CoerceText :: CoerceText a
433-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
422-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
423-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -448,7 +437,7 @@ data FromJSONKeyFunction a
449-- | Only law abiding up to interpretation
438-- | Only law abiding up to interpretation
450instance Functor FromJSONKeyFunction where
439instance Functor FromJSONKeyFunction where
451− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
440+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
441 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
442 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
443 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -462,7 +451,9 @@ instance Functor FromJSONKeyFunction where
463-- On pre GHC 7.8 this is unconstrainted function.
452-- On pre GHC 7.8 this is unconstrainted function.
464fromJSONKeyCoerce ::
453fromJSONKeyCoerce ::
465 Coercible Text a =>
455 Coercible Text a =>
466 FromJSONKeyFunction a
457 FromJSONKeyFunction a
467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
458fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
@@ -470,91 +461,60 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
471-- See note on 'fromJSONKeyCoerce'.
462-- See note on 'fromJSONKeyCoerce'.
472coerceFromJSONKeyFunction ::
463coerceFromJSONKeyFunction ::
473 Coercible a b =>
465 Coercible a b =>
474 FromJSONKeyFunction a -> FromJSONKeyFunction b
467 FromJSONKeyFunction a -> FromJSONKeyFunction b
475coerceFromJSONKeyFunction = coerce
469coerceFromJSONKeyFunction = coerce
471+coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText
472+coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)
473+coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)
474+coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)
478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
479 fmap id x = x
479 fmap id x = x
482 "FromJSONKeyCoerce: fmap coerce" forall x .
483 "FromJSONKeyCoerce: fmap coerce" forall x .
483 fmap coerce x = coerceFromJSONKeyFunction x
484 fmap coerce x = coerceFromJSONKeyFunction x
486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
488-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
489mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
488mapFromJSONKeyFunction = fmap
490mapFromJSONKeyFunction = fmap
490−-- | 'fromJSONKey' for 'Generic' types.
491−-- These types must be sums of nullary constructors, whose names will be used
492−-- as keys for JSON objects.
494−-- See also 'genericToJSONKey'.
499−-- data Color = Red | Green | Blue
500−-- deriving 'Generic'
502−-- instance 'FromJSONKey' Color where
503−-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'
505−genericFromJSONKey :: forall a. (Generic a, GFromJSONKey (Rep a))
507− -> FromJSONKeyFunction a
508−genericFromJSONKey opts = FromJSONKeyTextParser $ \t ->
509− case parseSumFromString (keyModifier opts) t of
511− "invalid key " ++ show t ++ ", expected one of " ++ show cnames
512− Just k -> pure (to k)
514− cnames = unTagged2 (constructorTags (keyModifier opts) :: Tagged2 (Rep a) [String])
516−class (ConstructorNames f, SumFromString f) => GFromJSONKey f where
517−instance (ConstructorNames f, SumFromString f) => GFromJSONKey f where
519-------------------------------------------------------------------------------
492-------------------------------------------------------------------------------
520-- Functions needed for documentation
493-- Functions needed for documentation
521-------------------------------------------------------------------------------
494-------------------------------------------------------------------------------
523-- | Fail parsing due to a type mismatch, with a descriptive message.
496-- | Fail parsing due to a type mismatch, with a descriptive message.
525−-- The following wrappers should generally be prefered:
498+-- Example usage:
526−-- 'withObject', 'withArray', 'withText', 'withBool'.
528−-- ==== Error message example
530−-- > typeMismatch "Object" (String "oops")
500+-- @
531−-- > -- Error: "expected Object, but encountered String"
501+-- instance FromJSON Coord where
502+-- parseJSON ('Object' v) = {- type matches, life is good -}
503+-- parseJSON wat = 'typeMismatch' \"Coord\" wat
532−typeMismatch :: String -- ^ The name of the JSON type being parsed
505+typeMismatch :: String -- ^ The name of the type you are trying to parse.
533− -- (@\"Object\"@, @\"Array\"@, @\"String\"@, @\"Number\"@,
534− -- @\"Boolean\"@, or @\"Null\"@).
535 -> Value -- ^ The actual value encountered.
506 -> Value -- ^ The actual value encountered.
536 -> Parser a
507 -> Parser a
537typeMismatch expected actual =
508typeMismatch expected actual =
538− fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual
509+ fail $ "expected " ++ expected ++ ", encountered " ++ name
540−-- | Fail parsing due to a type mismatch, when the expected types are implicit.
542−-- ==== Error message example
544−-- > unexpected (String "oops")
545−-- > -- Error: "unexpected String"
546−unexpected :: Value -> Parser a
547−unexpected actual = fail $ "unexpected " ++ typeOf actual
549−-- | JSON type of a value, name of the head constructor.
550−typeOf :: Value -> String
551−typeOf v = case v of
511+ name = case actual of
552− Object _ -> "Object"
512+ Object _ -> "Object"
553− Array _ -> "Array"
513+ Array _ -> "Array"
554− String _ -> "String"
514+ String _ -> "String"
555− Number _ -> "Number"
515+ Number _ -> "Number"
556− Bool _ -> "Boolean"
516+ Bool _ -> "Boolean"
557− Null -> "Null"
517+ Null -> "Null"
559-------------------------------------------------------------------------------
519-------------------------------------------------------------------------------
560-- Lifings of FromJSON and ToJSON to unary and binary type constructors
520-- Lifings of FromJSON and ToJSON to unary and binary type constructors
@@ -635,8 +595,9 @@ class FromJSON2 f where
635 -> (Value -> Parser b)
595 -> (Value -> Parser b)
636 -> (Value -> Parser [b])
596 -> (Value -> Parser [b])
637 -> Value -> Parser [f a b]
597 -> Value -> Parser [f a b]
638− liftParseJSONList2 fa ga fb gb = withArray "[]" $ \vals ->
598+ liftParseJSONList2 fa ga fb gb v = case v of
639− fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)
599+ Array vals -> fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)
600+ _ -> typeMismatch "[a]" v
641-- | Lift the standard 'parseJSON' function through the type constructor.
602-- | Lift the standard 'parseJSON' function through the type constructor.
642parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
603parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)
@@ -650,7 +611,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
650-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
611-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
651listParser :: (Value -> Parser a) -> Value -> Parser [a]
612listParser :: (Value -> Parser a) -> Value -> Parser [a]
652listParser f (Array xs) = fmap V.toList (V.mapM f xs)
613listParser f (Array xs) = fmap V.toList (V.mapM f xs)
653−listParser _ v = typeMismatch "Array" v
614+listParser _ v = typeMismatch "[a]" v
654{-# INLINE listParser #-}
615{-# INLINE listParser #-}
656-------------------------------------------------------------------------------
617-------------------------------------------------------------------------------
@@ -668,137 +629,69 @@ instance (FromJSON a) => FromJSON [a] where
668-- Functions
629-- Functions
669-------------------------------------------------------------------------------
630-------------------------------------------------------------------------------
671−-- | Add context to a failure message, indicating the name of the structure
674−-- > prependContext "MyType" (fail "[error message]")
675−-- > -- Error: "parsing MyType failed, [error message]"
676−prependContext :: String -> Parser a -> Parser a
677−prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")
679−-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@
632+-- | @'withObject' expected f value@ applies @f@ to the 'Object' when @value@
680−-- is an 'Data.Aeson.Object' and fails otherwise.
633+-- is an 'Object' and fails using @'typeMismatch' expected@ otherwise.
682−-- ==== Error message example
684−-- > withObject "MyType" f (String "oops")
685−-- > -- Error: "parsing MyType failed, expected Object, but encountered String"
686withObject :: String -> (Object -> Parser a) -> Value -> Parser a
634withObject :: String -> (Object -> Parser a) -> Value -> Parser a
687−withObject _ f (Object obj) = f obj
635+withObject _ f (Object obj) = f obj
688−withObject name _ v = prependContext name (typeMismatch "Object" v)
636+withObject expected _ v = typeMismatch expected v
689{-# INLINE withObject #-}
637{-# INLINE withObject #-}
691−-- | @'withText' name f value@ applies @f@ to the 'Text' when @value@ is a
639+-- | @'withText' expected f value@ applies @f@ to the 'Text' when @value@ is a
692−-- 'Data.Aeson.String' and fails otherwise.
640+-- 'String' and fails using @'typeMismatch' expected@ otherwise.
694−-- ==== Error message example
696−-- > withText "MyType" f Null
697−-- > -- Error: "parsing MyType failed, expected String, but encountered Null"
698withText :: String -> (Text -> Parser a) -> Value -> Parser a
641withText :: String -> (Text -> Parser a) -> Value -> Parser a
699−withText _ f (String txt) = f txt
642+withText _ f (String txt) = f txt
700−withText name _ v = prependContext name (typeMismatch "String" v)
643+withText expected _ v = typeMismatch expected v
701{-# INLINE withText #-}
644{-# INLINE withText #-}
703-- | @'withArray' expected f value@ applies @f@ to the 'Array' when @value@ is
646-- | @'withArray' expected f value@ applies @f@ to the 'Array' when @value@ is
704−-- an 'Data.Aeson.Array' and fails otherwise.
647+-- an 'Array' and fails using @'typeMismatch' expected@ otherwise.
706−-- ==== Error message example
708−-- > withArray "MyType" f (String "oops")
709−-- > -- Error: "parsing MyType failed, expected Array, but encountered String"
710withArray :: String -> (Array -> Parser a) -> Value -> Parser a
648withArray :: String -> (Array -> Parser a) -> Value -> Parser a
711−withArray _ f (Array arr) = f arr
649+withArray _ f (Array arr) = f arr
712−withArray name _ v = prependContext name (typeMismatch "Array" v)
650+withArray expected _ v = typeMismatch expected v
713{-# INLINE withArray #-}
651{-# INLINE withArray #-}
715−-- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number
653+-- | @'withScientific' expected f value@ applies @f@ to the 'Scientific' number
716−-- when @value@ is a 'Data.Aeson.Number' and fails using 'typeMismatch'
654+-- when @value@ is a 'Number' and fails using @'typeMismatch' expected@
717-- otherwise.
655-- otherwise.
719-- /Warning/: If you are converting from a scientific to an unbounded
657-- /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
658-- type such as 'Integer' you may want to add a restriction on the
721-- size of the exponent (see 'withBoundedScientific') to prevent
659-- size of the exponent (see 'withBoundedScientific') to prevent
722-- malicious input from filling up the memory of the target system.
660-- malicious input from filling up the memory of the target system.
724−-- ==== Error message example
726−-- > withScientific "MyType" f (String "oops")
727−-- > -- Error: "parsing MyType failed, expected Number, but encountered String"
728withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
661withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
729−withScientific _ f (Number scientific) = f scientific
662+withScientific _ f (Number scientific) = f scientific
730−withScientific name _ v = prependContext name (typeMismatch "Number" v)
663+withScientific expected _ v = typeMismatch expected v
731{-# INLINE withScientific #-}
664{-# INLINE withScientific #-}
733−-- | A variant of 'withScientific' which doesn't use 'prependContext', so that
666+-- | @'withBoundedScientific' expected f value@ applies @f@ to the 'Scientific' number
734−-- such context can be added separately in a way that also applies when the
667+-- when @value@ is a 'Number' and fails using @'typeMismatch' expected@
735−-- continuation @f :: Scientific -> Parser a@ fails.
668+-- otherwise.
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")
670+-- The conversion will also fail wyth a @'typeMismatch' if the
745−-- > -- Error: "unexpected String"
671+-- 'Scientific' exponent is larger than 1024.
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.
757withBoundedScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
672withBoundedScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
758−withBoundedScientific name f v = withBoundedScientific_ (prependContext name) f v
673+withBoundedScientific _ f v@(Number scientific) =
759−{-# INLINE withBoundedScientific #-}
674+ if base10Exponent scientific > 1024
760−
675+ then typeMismatch "a number with exponent <= 1024" v
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)
774 else f scientific
676 else f scientific
775− where
677+withBoundedScientific expected _ v = typeMismatch expected v
776− exp10 = base10Exponent scientific
678+{-# INLINE withBoundedScientific #-}
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
680-- | @'withBool' expected f value@ applies @f@ to the 'Bool' when @value@ is a
783−-- 'Boolean' and fails otherwise.
681+-- 'Bool' and fails using @'typeMismatch' expected@ otherwise.
785−-- ==== Error message example
787−-- > withBool "MyType" f (String "oops")
788−-- > -- Error: "parsing MyType failed, expected Boolean, but encountered String"
789withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
682withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
790−withBool _ f (Bool arr) = f arr
683+withBool _ f (Bool arr) = f arr
791−withBool name _ v = prependContext name (typeMismatch "Boolean" v)
684+withBool expected _ v = typeMismatch expected v
792{-# INLINE withBool #-}
685{-# INLINE withBool #-}
794-- | Decode a nested JSON-encoded string.
687-- | Decode a nested JSON-encoded string.
795withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
688withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
796withEmbeddedJSON _ innerParser (String txt) =
689withEmbeddedJSON _ innerParser (String txt) =
797− either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
690+ either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
799 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
692 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
800 eitherFormatError = either (Left . uncurry formatError) Right
693 eitherFormatError = either (Left . uncurry formatError) Right
801−withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v)
694+withEmbeddedJSON name _ v = typeMismatch name v
802{-# INLINE withEmbeddedJSON #-}
695{-# INLINE withEmbeddedJSON #-}
804-- | Convert a value from JSON, failing if the types do not match.
697-- | Convert a value from JSON, failing if the types do not match.
@@ -863,7 +756,7 @@ parseFieldMaybe' = (.:!)
863-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
756-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
864explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
757explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
865explicitParseField p obj key = case H.lookup key obj of
758explicitParseField p obj key = case H.lookup key obj of
866− Nothing -> fail $ "key " ++ show key ++ " not found"
759+ Nothing -> fail $ "key " ++ show key ++ " not present"
867 Just v -> p v <?> Key key
760 Just v -> p v <?> Key key
868{-# INLINE explicitParseField #-}
761{-# INLINE explicitParseField #-}
@@ -903,47 +796,11 @@ pmval .!= val = fromMaybe val <$> pmval
903-- Generic parseJSON
796-- Generic parseJSON
904-------------------------------------------------------------------------------
797-------------------------------------------------------------------------------
906−instance GFromJSON arity V1 where
907− -- Whereof we cannot format, thereof we cannot parse:
908− gParseJSON _ _ _ = fail "Attempted to parse empty type"
911instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where
799instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where
912 -- Meta-information, which is not handled elsewhere, is just added to the
800 -- Meta-information, which is not handled elsewhere, is just added to the
913 -- parsed value:
801 -- parsed value:
914 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs
802 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs
916−-- Information for error messages
918−type TypeName = String
919−type ConName = String
921−-- | Add the name of the type being parsed to a parser's error messages.
922−contextType :: TypeName -> Parser a -> Parser a
923−contextType = prependContext
925−-- | Add the tagKey that will be looked up while building an ADT
926−-- | Produce the error equivalent to
927−-- | Left "Error in $: parsing T failed, expected an object with keys "tag" and
928−-- | "contents", where "tag" i-- |s associated to one of ["Foo", "Bar"],
929−-- | The parser returned error was: could not find key "tag"
930−contextTag :: Text -> [String] -> Parser a -> Parser a
931−contextTag tagKey cnames = prependFailure
932− ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++
933− " containing one of " ++ show cnames ++ ", ")
935−-- | Add the name of the constructor being parsed to a parser's error messages.
936−contextCons :: ConName -> TypeName -> Parser a -> Parser a
937−contextCons cname tname = prependContext (showCons cname tname)
939−-- | Render a constructor as @\"MyType(MyConstructor)\"@.
940−showCons :: ConName -> TypeName -> String
941−showCons cname tname = tname ++ "(" ++ cname ++ ")"
943−--------------------------------------------------------------------------------
945−-- Parsing single fields
947instance (FromJSON a) => GFromJSON arity (K1 i a) where
804instance (FromJSON a) => GFromJSON arity (K1 i a) where
948 -- Constant values are decoded using their FromJSON instance:
805 -- Constant values are decoded using their FromJSON instance:
949 gParseJSON _opts _ = fmap K1 . parseJSON
806 gParseJSON _opts _ = fmap K1 . parseJSON
@@ -958,499 +815,342 @@ instance (FromJSON1 f) => GFromJSON One (Rec1 f) where
958 -- FromJSON1 instance:
815 -- FromJSON1 instance:
959 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl
816 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl
961−instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
818+instance GFromJSON arity U1 where
962− -- If an occurrence of the last type parameter is nested inside two
819+ -- Empty constructors are expected to be encoded as an empty array:
963− -- composed types, it is decoded by using the outermost type's FromJSON1
964− -- instance to generically decode the innermost type:
965− gParseJSON opts fargs =
820+ gParseJSON _opts _ v
966− let gpj = gParseJSON opts fargs in
821+ | isEmptyArray v = pure U1
967− fmap Comp1 . liftParseJSON gpj (listParser gpj)
822+ | otherwise = typeMismatch "unit constructor (U1)" v
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.
987instance ( ConsFromJSON arity a
824instance ( ConsFromJSON arity a
988 , AllNullary (C1 c a) allNullary
825 , AllNullary (C1 c a) allNullary
989 , ParseSum arity (C1 c a) allNullary
826 , ParseSum arity (C1 c a) allNullary
991− ) => GFromJSON' arity (C1 c a) where
827+ ) => GFromJSON arity (D1 d (C1 c a)) where
992 -- The option 'tagSingleConstructors' determines whether to wrap
828 -- The option 'tagSingleConstructors' determines whether to wrap
993 -- a single-constructor type.
829 -- a single-constructor type.
994− gParseJSON' p@(_ :* opts :* _)
830+ gParseJSON opts fargs
995 | tagSingleConstructors opts
831 | tagSingleConstructors opts
996− = (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))
833+ . (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))
997− . parseSum p
834+ . parseSum opts fargs
998− | otherwise = fmap M1 . consParseJSON (cname :* p)
835+ | otherwise = fmap M1 . fmap M1 . consParseJSON opts fargs
1000− cname = conName (undefined :: M1 _i c _f _p)
837+instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where
1001−
838+ -- Constructors need to be decoded differently depending on whether they're
1002−-- | Multiple constructors.
839+ -- a record or not. This distinction is made by consParseJSON:
840+ gParseJSON opts fargs = fmap M1 . consParseJSON opts fargs
842+instance ( FromProduct arity a, FromProduct arity b
843+ , ProductSize a, ProductSize b
844+ ) => GFromJSON arity (a :*: b) where
845+ -- Products are expected to be encoded to an array. Here we check whether we
846+ -- got an array of the same size as the product, then parse each of the
847+ -- product's elements using parseProduct:
848+ gParseJSON opts fargs = withArray "product (:*:)" $ \arr ->
849+ let lenArray = V.length arr
850+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
852+ if lenArray == lenProduct
853+ then parseProduct opts fargs arr 0 lenProduct
854+ else fail $ "When expecting a product of " ++ show lenProduct ++
855+ " values, encountered an Array of " ++ show lenArray ++
1003−instance ( AllNullary (a :+: b) allNullary
858+instance ( AllNullary (a :+: b) allNullary
1004− , ParseSum arity (a :+: b) allNullary
859+ , ParseSum arity (a :+: b) allNullary
1005− ) => GFromJSON' arity (a :+: b) where
860+ ) => GFromJSON arity (a :+: b) where
1006 -- If all constructors of a sum datatype are nullary and the
861 -- If all constructors of a sum datatype are nullary and the
1007 -- 'allNullaryToStringTag' option is set they are expected to be
862 -- 'allNullaryToStringTag' option is set they are expected to be
1008 -- encoded as strings. This distinction is made by 'parseSum':
863 -- encoded as strings. This distinction is made by 'parseSum':
1009− gParseJSON' p =
864+ gParseJSON opts fargs =
1010− (unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->
865+ (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->
1011− Parser ((a :+: b) _d))
866+ Parser ((a :+: b) d))
1012− . parseSum p
867+ . parseSum opts fargs
869+instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
870+ -- If an occurrence of the last type parameter is nested inside two
871+ -- composed types, it is decoded by using the outermost type's FromJSON1
872+ -- instance to generically decode the innermost type:
873+ gParseJSON opts fargs =
874+ let gpj = gParseJSON opts fargs in
875+ fmap Comp1 . liftParseJSON gpj (listParser gpj)
1014--------------------------------------------------------------------------------
877--------------------------------------------------------------------------------
1016class ParseSum arity f allNullary where
879class ParseSum arity f allNullary where
1017− parseSum :: TypeName :* Options :* FromArgs arity a
880+ parseSum :: Options -> FromArgs arity a
1019− -> Tagged allNullary (Parser (f a))
881+ -> Value -> Tagged allNullary (Parser (f a))
1021−instance ( ConstructorNames f
1022− , SumFromString f
883+instance ( SumFromString f
1023 , FromPair arity f
884 , FromPair arity f
1024 , FromTaggedObject arity f
885 , FromTaggedObject arity f
1025 , FromUntaggedValue arity f
886 , FromUntaggedValue arity f
1026 ) => ParseSum arity f True where
887 ) => ParseSum arity f True where
1027− parseSum p@(tname :* opts :* _)
888+ parseSum opts fargs
1028− | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts
889+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts
1029− | otherwise = Tagged . parseNonAllNullarySum p
890+ | otherwise = Tagged . parseNonAllNullarySum opts fargs
1031−instance ( ConstructorNames f
1032− , FromPair arity f
892+instance ( FromPair arity f
1033 , FromTaggedObject arity f
893 , FromTaggedObject arity f
1034 , FromUntaggedValue arity f
894 , FromUntaggedValue arity f
1035 ) => ParseSum arity f False where
895 ) => ParseSum arity f False where
1036− parseSum p = Tagged . parseNonAllNullarySum p
896+ parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs
1038--------------------------------------------------------------------------------
898--------------------------------------------------------------------------------
1040−parseAllNullarySum :: (SumFromString f, ConstructorNames f)
900+parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)
1041− => TypeName -> Options -> Value -> Parser (f a)
1042−parseAllNullarySum tname opts =
901+parseAllNullarySum opts = withText "Text" $ \key ->
1043− withText tname $ \tag ->
1044− maybe (badTag tag) return $
902+ maybe (notFound key) return $
1045− parseSumFromString modifier tag
903+ parseSumFromString opts key
1047− badTag tag = failWithCTags tname modifier $ \cnames ->
1048− "expected one of the tags " ++ show cnames ++
1049− ", but found tag " ++ show tag
1050− modifier = constructorTagModifier opts
1052−-- | Fail with an informative error message about a mismatched tag.
1053−-- The error message is parameterized by the list of expected tags,
1054−-- to be inferred from the result type of the parser.
1056− :: forall f a t. ConstructorNames f
1057− => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)
1058−failWithCTags tname modifier f =
1059− contextType tname . fail $ f cnames
1061− cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])
1063class SumFromString f where
905class SumFromString f where
1064− parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
906+ parseSumFromString :: Options -> Text -> Maybe (f a)
1066instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
908instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
1067 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
909 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
1068 (R1 <$> parseSumFromString opts key)
910 (R1 <$> parseSumFromString opts key)
1070instance (Constructor c) => SumFromString (C1 c U1) where
912instance (Constructor c) => SumFromString (C1 c U1) where
1071− parseSumFromString modifier key
913+ parseSumFromString opts key | key == name = Just $ M1 U1
1072− | key == name = Just $ M1 U1
1073− | otherwise = Nothing
914+ | otherwise = Nothing
1075− name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)
916+ name = pack $ constructorTagModifier opts $
1077−-- For genericFromJSONKey
1078−instance SumFromString a => SumFromString (D1 d a) where
1079− parseSumFromString modifier key = M1 <$> parseSumFromString modifier key
1081−-- | List of all constructor tags.
1082−constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]
1083−constructorTags modifier =
1084− fmap DList.toList (constructorNames' modifier)
1086−-- | List of all constructor names of an ADT, after a given conversion
1087−-- function. (Better inlining.)
1088−class ConstructorNames a where
1089− constructorNames' :: (String -> t) -> Tagged2 a (DList.DList t)
1091−instance (ConstructorNames a, ConstructorNames b) => ConstructorNames (a :+: b) where
1092− constructorNames' = liftA2 append constructorNames' constructorNames'
1095− :: Tagged2 a (DList.DList t)
1096− -> Tagged2 b (DList.DList t)
1097− -> Tagged2 (a :+: b) (DList.DList t)
1098− append (Tagged2 xs) (Tagged2 ys) = Tagged2 (DList.append xs ys)
1100−instance Constructor c => ConstructorNames (C1 c a) where
1101− constructorNames' f = Tagged2 (pure (f cname))
1103− cname = conName (undefined :: M1 _i c _f _p)
917+ conName (undefined :: t c U1 p)
1105−-- For genericFromJSONKey
1106−instance ConstructorNames a => ConstructorNames (D1 d a) where
1107− constructorNames' = retag . constructorNames'
1109− retag :: Tagged2 a u -> Tagged2 (D1 d a) u
1110− retag (Tagged2 x) = Tagged2 x
1112--------------------------------------------------------------------------------
919--------------------------------------------------------------------------------
1113−parseNonAllNullarySum :: forall f c arity.
921+parseNonAllNullarySum :: ( FromPair arity f
1115 , FromTaggedObject arity f
922 , FromTaggedObject arity f
1116 , FromUntaggedValue arity f
923 , FromUntaggedValue arity f
1117− , ConstructorNames f
1118− ) => TypeName :* Options :* FromArgs arity c
924+ ) => Options -> FromArgs arity c
1119 -> Value -> Parser (f c)
925 -> Value -> Parser (f c)
1120−parseNonAllNullarySum p@(tname :* opts :* _) =
926+parseNonAllNullarySum opts fargs =
1121 case sumEncoding opts of
927 case sumEncoding opts of
1122 TaggedObject{..} ->
928 TaggedObject{..} ->
1123− withObject tname $ \obj -> do
929+ withObject "Object" $ \obj -> do
1124− tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
1125− fromMaybe (badTag tag <?> Key tagKey) $
1126− parseFromTaggedObject (tag :* contentsFieldName :* p) obj
1128− tagKey = pack tagFieldName
930+ tag <- obj .: pack tagFieldName
1129− badTag tag = failWith_ $ \cnames ->
931+ fromMaybe (notFound tag) $
1130− "expected tag field to be one of " ++ show cnames ++
932+ parseFromTaggedObject opts fargs contentsFieldName obj tag
1131− ", but found tag " ++ show tag
1132− cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
1134 ObjectWithSingleField ->
934 ObjectWithSingleField ->
935+ withObject "Object" $ \obj ->
1135− withObject tname $ \obj -> case H.toList obj of
936+ case H.toList obj of
1136− [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $
937+ [pair@(tag, _)] -> fromMaybe (notFound tag) $
1137− parsePair (tag :* p) v
938+ parsePair opts fargs pair
1138− _ -> contextType tname . fail $
939+ _ -> fail "Object doesn't have a single field"
1139− "expected an Object with a single pair, but found " ++
1140− show (H.size obj) ++ " pairs"
1142− badTag tag = failWith_ $ \cnames ->
1143− "expected an Object with a single pair where the tag is one of " ++
1144− show cnames ++ ", but found tag " ++ show tag
1146 TwoElemArray ->
941 TwoElemArray ->
1147− withArray tname $ \arr -> case V.length arr of
942+ withArray "Array" $ \arr ->
943+ if V.length arr == 2
1148− 2 | String tag <- V.unsafeIndex arr 0 ->
944+ then case V.unsafeIndex arr 0 of
1149− maybe (badTag tag <?> Index 0) (<?> Index 1) $
945+ String tag -> fromMaybe (notFound tag) $
1150− parsePair (tag :* p) (V.unsafeIndex arr 1)
946+ parsePair opts fargs (tag, V.unsafeIndex arr 1)
1152− contextType tname $
1153− fail "tag element is not a String" <?> Index 0
947+ _ -> fail "First element is not a String"
1154− len -> contextType tname . fail $
948+ else fail "Array doesn't have 2 elements"
1155− "expected a 2-element Array, but encountered an Array of length " ++
1158− badTag tag = failWith_ $ \cnames ->
1159− "expected tag of the 2-element Array to be one of " ++
1160− show cnames ++ ", but found tag " ++ show tag
1162− UntaggedValue -> parseUntaggedValue p
950+ UntaggedValue -> parseUntaggedValue opts fargs
1164− failWith_ = failWithCTags tname (constructorTagModifier opts)
1166--------------------------------------------------------------------------------
952--------------------------------------------------------------------------------
1168class FromTaggedObject arity f where
954class FromTaggedObject arity f where
1169− -- The first two components of the parameter tuple are: the constructor tag
1170− -- to match against, and the contents field name.
1171− parseFromTaggedObject
955+ parseFromTaggedObject :: Options -> FromArgs arity a
1172− :: Text :* String :* TypeName :* Options :* FromArgs arity a
1173− -> Object
956+ -> String -> Object
1174− -> Maybe (Parser (f a))
957+ -> Text -> Maybe (Parser (f a))
1176instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
959instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
1177 FromTaggedObject arity (a :+: b) where
960 FromTaggedObject arity (a :+: b) where
1178− parseFromTaggedObject p obj =
961+ parseFromTaggedObject opts fargs contentsFieldName obj tag =
1179− (fmap L1 <$> parseFromTaggedObject p obj) <|>
962+ (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>
1180− (fmap R1 <$> parseFromTaggedObject p obj)
963+ (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)
1182−instance ( IsRecord f isRecord
1183− , FromTaggedObject' arity f isRecord
965+instance ( FromTaggedObject' arity f
1184 , Constructor c
966 , Constructor c
1185 ) => FromTaggedObject arity (C1 c f) where
967 ) => FromTaggedObject arity (C1 c f) where
1186− parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))
968+ parseFromTaggedObject opts fargs contentsFieldName obj tag
1189− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
1190− parseFromTaggedObject' (contentsFieldName :* cname :* p)
969+ | tag == name = Just $ M1 <$> parseFromTaggedObject'
970+ opts fargs contentsFieldName obj
1191− | otherwise = const Nothing
971+ | otherwise = Nothing
1193− tag' = pack $ constructorTagModifier opts cname
973+ name = pack $ constructorTagModifier opts $
1194− cname = conName (undefined :: M1 _i c _f _p)
974+ conName (undefined :: t c f p)
1196--------------------------------------------------------------------------------
976--------------------------------------------------------------------------------
1198−class FromTaggedObject' arity f isRecord where
978+class FromTaggedObject' arity f where
1199− -- The first component of the parameter tuple is the contents field name.
1200− parseFromTaggedObject'
979+ parseFromTaggedObject' :: Options -> FromArgs arity a -> String
1201− :: String :* ConName :* TypeName :* Options :* FromArgs arity a
1202− -> Object -> Tagged isRecord (Parser (f a))
980+ -> Object -> Parser (f a)
1204−instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
982+class FromTaggedObject'' arity f isRecord where
1205− -- Records are unpacked in the tagged object
1206− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
983+ parseFromTaggedObject'' :: Options -> FromArgs arity a -> String
1207−
984+ -> Object -> Tagged isRecord (Parser (f a))
1208−instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
1209− -- Nonnullary nonrecords are encoded in the contents field
1210− parseFromTaggedObject' p obj = Tagged $ do
1211− contents <- contextCons cname tname (obj .: key)
1212− consParseJSON p' contents <?> Key key
1214− key = pack contentsFieldName
1215− contentsFieldName :* p'@(cname :* tname :* _) = p
986+instance ( IsRecord f isRecord
987+ , FromTaggedObject'' arity f isRecord
988+ ) => FromTaggedObject' arity f where
989+ parseFromTaggedObject' opts fargs contentsFieldName =
990+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
991+ parseFromTaggedObject'' opts fargs contentsFieldName
993+instance (FromRecord arity f) => FromTaggedObject'' arity f True where
994+ parseFromTaggedObject'' opts fargs _ =
995+ Tagged . parseRecord opts fargs
997+instance (GFromJSON arity f) => FromTaggedObject'' arity f False where
998+ parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .
999+ (gParseJSON opts fargs <=< (.: pack contentsFieldName))
1217−instance OVERLAPPING_ FromTaggedObject' arity U1 False where
1001+instance OVERLAPPING_ FromTaggedObject'' arity U1 False where
1218− -- Nullary constructors don't need a contents field
1002+ parseFromTaggedObject'' _ _ _ _ = Tagged (pure U1)
1219− parseFromTaggedObject' _ _ = Tagged (pure U1)
1221--------------------------------------------------------------------------------
1004--------------------------------------------------------------------------------
1223−-- | Constructors need to be decoded differently depending on whether they're
1224−-- a record or not. This distinction is made by 'ConsParseJSON'.
1225class ConsFromJSON arity f where
1006class ConsFromJSON arity f where
1227− :: ConName :* TypeName :* Options :* FromArgs arity a
1007+ consParseJSON :: Options -> FromArgs arity a
1228− -> Value -> Parser (f a)
1008+ -> Value -> Parser (f a)
1230class ConsFromJSON' arity f isRecord where
1010class ConsFromJSON' arity f isRecord where
1232− :: ConName :* TypeName :* Options :* FromArgs arity a
1011+ consParseJSON' :: Options -> FromArgs arity a
1233− -> Value -> Tagged isRecord (Parser (f a))
1012+ -> Value -> Tagged isRecord (Parser (f a))
1235instance ( IsRecord f isRecord
1014instance ( IsRecord f isRecord
1236 , ConsFromJSON' arity f isRecord
1015 , ConsFromJSON' arity f isRecord
1237 ) => ConsFromJSON arity f where
1016 ) => ConsFromJSON arity f where
1238− consParseJSON p =
1017+ consParseJSON opts fargs =
1239 (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
1018 (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
1240− . consParseJSON' p
1019+ . consParseJSON' opts fargs
1242instance OVERLAPPING_
1021instance OVERLAPPING_
1243− ( GFromJSON arity a, RecordFromJSON arity (S1 s a)
1022+ ( GFromJSON arity a, FromRecord arity (S1 s a)
1244 ) => ConsFromJSON' arity (S1 s a) True where
1023 ) => ConsFromJSON' arity (S1 s a) True where
1245− consParseJSON' p@(cname :* tname :* opts :* fargs)
1024+ consParseJSON' opts fargs
1246− | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1025+ | unwrapUnaryRecords opts = Tagged . gParseJSON opts fargs
1247− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
1026+ | otherwise = Tagged . withObject "unary record" (parseRecord opts fargs)
1249−instance RecordFromJSON arity f => ConsFromJSON' arity f True where
1250− consParseJSON' p@(cname :* tname :* _) =
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_
1267− GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where
1028+instance FromRecord arity f => ConsFromJSON' arity f True where
1268− consParseJSON' (_ :* _ :* opts :* fargs) =
1029+ consParseJSON' opts fargs =
1269− Tagged . fmap M1 . gParseJSON opts fargs
1030+ Tagged . withObject "record (:*:)" (parseRecord opts fargs)
1271−instance (ProductFromJSON arity f, ProductSize f
1272− ) => ConsFromJSON' arity f False where
1032+instance GFromJSON arity f => ConsFromJSON' arity f False where
1273− consParseJSON' p = Tagged . productParseJSON0 p
1033+ consParseJSON' opts fargs = Tagged . gParseJSON opts fargs
1275--------------------------------------------------------------------------------
1035--------------------------------------------------------------------------------
1277−class FieldNames f where
1037+class FromRecord arity f where
1278− fieldNames :: f a -> [Text] -> [Text]
1038+ parseRecord :: Options -> FromArgs arity a
1279−
1039+ -> Object -> Parser (f a)
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
1041+instance ( FromRecord arity a
1286− fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)
1042+ , FromRecord arity b
1288−class RecordFromJSON arity f where
1290− :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a
1291− -> Object -> Parser (f a)
1293−instance ( FieldNames f
1294− , RecordFromJSON' arity f
1295− ) => RecordFromJSON arity f where
1296− recordParseJSON (fromTaggedSum :* p@(cname :* tname :* opts :* _)) =
1297− \obj -> checkUnknown obj >> recordParseJSON' p obj
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
1043+ ) => FromRecord arity (a :*: b) where
1319− recordParseJSON' p obj =
1044+ parseRecord opts fargs obj =
1320− (:*:) <$> recordParseJSON' p obj
1045+ (:*:) <$> parseRecord opts fargs obj
1321− <*> recordParseJSON' p obj
1046+ <*> parseRecord opts fargs obj
1323instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1048instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1324− RecordFromJSON' arity (S1 s a) where
1049+ FromRecord arity (S1 s a) where
1325− recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
1050+ parseRecord opts fargs =
1326− fv <- contextCons cname tname (obj .: label)
1051+ (<?> Key label) . gParseJSON opts fargs <=< (.: label)
1327− M1 <$> gParseJSON opts fargs fv <?> Key label
1329− label = pack $ fieldLabelModifier opts sname
1053+ label = pack . fieldLabelModifier opts $ selName (undefined :: t s a p)
1330− sname = selName (undefined :: M1 _i s _f _p)
1332instance INCOHERENT_ (Selector s, FromJSON a) =>
1055instance INCOHERENT_ (Selector s, FromJSON a) =>
1333− RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
1056+ FromRecord arity (S1 s (K1 i (Maybe a))) where
1334− recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
1057+ parseRecord opts _ obj = M1 . K1 <$> obj .:? pack label
1336− label = fieldLabelModifier opts sname
1059+ label = fieldLabelModifier opts $
1337− sname = selName (undefined :: M1 _i s _f _p)
1060+ selName (undefined :: t s (K1 i (Maybe a)) p)
1339-- Parse an Option like a Maybe.
1062-- Parse an Option like a Maybe.
1340instance INCOHERENT_ (Selector s, FromJSON a) =>
1063instance INCOHERENT_ (Selector s, FromJSON a) =>
1341− RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
1064+ FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where
1342− recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
1065+ parseRecord opts fargs obj = wrap <$> parseRecord opts fargs obj
1344 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
1067 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))
1068 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
1347--------------------------------------------------------------------------------
1070--------------------------------------------------------------------------------
1350− :: forall f arity a. (ProductFromJSON arity f, ProductSize f)
1351− => ConName :* TypeName :* Options :* FromArgs arity a
1352− -> Value -> Parser (f a)
1353− -- Products are expected to be encoded to an array. Here we check whether we
1354− -- got an array of the same size as the product, then parse each of the
1355− -- product's elements using productParseJSON:
1356−productParseJSON0 p@(cname :* tname :* _ :* _) =
1357− withArray (showCons cname tname) $ \arr ->
1358− let lenArray = V.length arr
1359− lenProduct = (unTagged2 :: Tagged2 f Int -> Int)
1361− if lenArray == lenProduct
1362− then productParseJSON p arr 0 lenProduct
1363− else contextCons cname tname $
1364− fail $ "expected an Array of length " ++ show lenProduct ++
1365− ", but encountered an Array of length " ++ show lenArray
1369−class ProductFromJSON arity f where
1072+class FromProduct arity f where
1370− productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a
1073+ parseProduct :: Options -> FromArgs arity a
1371 -> Array -> Int -> Int
1074 -> Array -> Int -> Int
1372 -> Parser (f a)
1075 -> Parser (f a)
1374−instance ( ProductFromJSON arity a
1077+instance ( FromProduct arity a
1375− , ProductFromJSON arity b
1078+ , FromProduct arity b
1376− ) => ProductFromJSON arity (a :*: b) where
1079+ ) => FromProduct arity (a :*: b) where
1377− productParseJSON p arr ix len =
1080+ parseProduct opts fargs arr ix len =
1378− (:*:) <$> productParseJSON p arr ix lenL
1081+ (:*:) <$> parseProduct opts fargs arr ix lenL
1379− <*> productParseJSON p arr ixR lenR
1082+ <*> parseProduct opts fargs arr ixR lenR
1381 lenL = len `unsafeShiftR` 1
1084 lenL = len `unsafeShiftR` 1
1382 ixR = ix + lenL
1085 ixR = ix + lenL
1383 lenR = len - lenL
1086 lenR = len - lenL
1385−instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where
1088+instance (GFromJSON arity a) => FromProduct arity (S1 s a) where
1386− productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =
1089+ parseProduct opts fargs arr ix _ =
1387− M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix
1090+ gParseJSON opts fargs $ V.unsafeIndex arr ix
1389--------------------------------------------------------------------------------
1092--------------------------------------------------------------------------------
1391class FromPair arity f where
1094class FromPair arity f where
1392− -- The first component of the parameter tuple is the tag to match.
1393− parsePair :: Text :* TypeName :* Options :* FromArgs arity a
1095+ parsePair :: Options -> FromArgs arity a
1395− -> Maybe (Parser (f a))
1096+ -> Pair -> Maybe (Parser (f a))
1397instance ( FromPair arity a
1098instance ( FromPair arity a
1398 , FromPair arity b
1099 , FromPair arity b
1399 ) => FromPair arity (a :+: b) where
1100 ) => FromPair arity (a :+: b) where
1401− (fmap L1 <$> parsePair p pair) <|>
1101+ parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>
1402− (fmap R1 <$> parsePair p pair)
1102+ (fmap R1 <$> parsePair opts fargs pair)
1404instance ( Constructor c
1104instance ( Constructor c
1105+ , GFromJSON arity a
1405 , ConsFromJSON arity a
1106 , ConsFromJSON arity a
1406 ) => FromPair arity (C1 c a) where
1107 ) => FromPair arity (C1 c a) where
1407− parsePair (tag :* p@(_ :* opts :* _)) v
1108+ parsePair opts fargs (tag, value)
1408− | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v
1109+ | tag == tag' = Just $ gParseJSON opts fargs value
1409 | otherwise = Nothing
1110 | otherwise = Nothing
1411− tag' = pack $ constructorTagModifier opts cname
1112+ tag' = pack $ constructorTagModifier opts $
1412− cname = conName (undefined :: M1 _i c _a _p)
1113+ conName (undefined :: t c a p)
1414--------------------------------------------------------------------------------
1115--------------------------------------------------------------------------------
1416class FromUntaggedValue arity f where
1117class FromUntaggedValue arity f where
1417− parseUntaggedValue :: TypeName :* Options :* FromArgs arity a
1118+ parseUntaggedValue :: Options -> FromArgs arity a
1419− -> Parser (f a)
1119+ -> Value -> Parser (f a)
1422 ( FromUntaggedValue arity a
1122 ( FromUntaggedValue arity a
1423 , FromUntaggedValue arity b
1123 , FromUntaggedValue arity b
1424 ) => FromUntaggedValue arity (a :+: b)
1124 ) => FromUntaggedValue arity (a :+: b)
1426− parseUntaggedValue p value =
1126+ parseUntaggedValue opts fargs value =
1427− L1 <$> parseUntaggedValue p value <|>
1127+ L1 <$> parseUntaggedValue opts fargs value <|>
1428− R1 <$> parseUntaggedValue p value
1128+ R1 <$> parseUntaggedValue opts fargs value
1430instance OVERLAPPABLE_
1130instance OVERLAPPABLE_
1431− ( ConsFromJSON arity a
1131+ ( GFromJSON arity a
1432− , Constructor c
1132+ , ConsFromJSON arity a
1433 ) => FromUntaggedValue arity (C1 c a)
1133 ) => FromUntaggedValue arity (C1 c a)
1435− parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)
1135+ parseUntaggedValue = gParseJSON
1437− cname = conName (undefined :: M1 _i c _f _p)
1439instance OVERLAPPING_
1137instance OVERLAPPING_
1440 ( Constructor c )
1138 ( Constructor c )
1441 => FromUntaggedValue arity (C1 c U1)
1139 => FromUntaggedValue arity (C1 c U1)
1443− parseUntaggedValue (tname :* opts :* _) v =
1141+ parseUntaggedValue opts _ (String s)
1444− contextCons cname tname $ case v of
1142+ | s == pack (constructorTagModifier opts (conName (undefined :: t c U1 p))) =
1446− | tag == tag' -> pure $ M1 U1
1143+ pure $ M1 U1
1447− | otherwise -> fail_ tag
1144+ | otherwise =
1448− _ -> typeMismatch "String" v
1145+ fail $ "Invalid tag: " ++ unpack s
1449− where
1146+ parseUntaggedValue _ _ v = typeMismatch (conName (undefined :: t c U1 p)) v
1450− tag' = pack $ constructorTagModifier opts cname
1147+
1451− cname = conName (undefined :: M1 _i c _f _p)
1148+
1452− fail_ tag = fail $
1149+--------------------------------------------------------------------------------
1453− "expected tag " ++ show tag' ++ ", but found tag " ++ show tag
1150+
1151+notFound :: Text -> Parser a
1152+notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"
1153+{-# INLINE notFound #-}
1455-------------------------------------------------------------------------------
1155-------------------------------------------------------------------------------
1456-- Instances
1156-- Instances
@@ -1508,20 +1208,17 @@ instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
1508 parseJSON = parseJSON2
1208 parseJSON = parseJSON2
1509 {-# INLINE parseJSON #-}
1209 {-# INLINE parseJSON #-}
1511−instance FromJSON Void where
1211+
1512− parseJSON _ = fail "Cannot parse Void"
1513− {-# INLINE parseJSON #-}
1515instance FromJSON Bool where
1213instance FromJSON Bool where
1516− parseJSON (Bool b) = pure b
1214+ parseJSON = withBool "Bool" pure
1517− parseJSON v = typeMismatch "Bool" v
1518 {-# INLINE parseJSON #-}
1215 {-# INLINE parseJSON #-}
1520instance FromJSONKey Bool where
1217instance FromJSONKey Bool where
1521 fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
1218 fromJSONKey = FromJSONKeyTextParser $ \t -> case t of
1522 "true" -> pure True
1219 "true" -> pure True
1523 "false" -> pure False
1220 "false" -> pure False
1524− _ -> fail $ "cannot parse key " ++ show t ++ " into Bool"
1221+ _ -> fail $ "Cannot parse key into Bool: " ++ T.unpack t
1526instance FromJSON Ordering where
1223instance FromJSON Ordering where
1527 parseJSON = withText "Ordering" $ \s ->
1224 parseJSON = withText "Ordering" $ \s ->
@@ -1529,30 +1226,25 @@ instance FromJSON Ordering where
1529 "LT" -> return LT
1226 "LT" -> return LT
1530 "EQ" -> return EQ
1227 "EQ" -> return EQ
1531 "GT" -> return GT
1228 "GT" -> return GT
1532− _ -> fail $ "parsing Ordering failed, unexpected " ++ show s ++
1533− " (expected \"LT\", \"EQ\", or \"GT\")"
1229+ _ -> fail "Parsing Ordering value failed: expected \"LT\", \"EQ\", or \"GT\""
1535instance FromJSON () where
1231instance FromJSON () where
1536 parseJSON = withArray "()" $ \v ->
1232 parseJSON = withArray "()" $ \v ->
1537 if V.null v
1233 if V.null v
1538 then pure ()
1234 then pure ()
1539− else prependContext "()" $ fail "expected an empty array"
1235+ else fail "Expected an empty array"
1540 {-# INLINE parseJSON #-}
1236 {-# INLINE parseJSON #-}
1542instance FromJSON Char where
1238instance FromJSON Char where
1543− parseJSON = withText "Char" parseChar
1239+ parseJSON = withText "Char" $ \t ->
1240+ if T.compareLength t 1 == EQ
1241+ then pure $ T.head t
1242+ else fail "Expected a string of length 1"
1544 {-# INLINE parseJSON #-}
1243 {-# INLINE parseJSON #-}
1546− parseJSONList (String s) = pure (T.unpack s)
1245+ parseJSONList = withText "String" $ pure . T.unpack
1547− parseJSONList v = typeMismatch "String" v
1548 {-# INLINE parseJSONList #-}
1246 {-# INLINE parseJSONList #-}
1550−parseChar :: Text -> Parser Char
1552− if T.compareLength t 1 == EQ
1553− then pure $ T.head t
1554− else prependContext "Char" $ fail "expected a string of length 1"
1556instance FromJSON Double where
1248instance FromJSON Double where
1557 parseJSON = parseRealFloat "Double"
1249 parseJSON = parseRealFloat "Double"
1558 {-# INLINE parseJSON #-}
1250 {-# INLINE parseJSON #-}
@@ -1576,22 +1268,12 @@ instance FromJSONKey Float where
1576 _ -> Scientific.toRealFloat <$> parseScientificText t
1268 _ -> Scientific.toRealFloat <$> parseScientificText t
1578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1270instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1579− parseJSON (Number x)
1581− , exp10 >= -1024 = return $! realToFrac x
1582− | otherwise = prependContext "Ratio" $ fail msg
1584− exp10 = base10Exponent x
1585− msg = "found a number with exponent " ++ show exp10
1586− ++ ", but it must not be greater than 1024 or less than -1024"
1587− parseJSON o = objParser o
1589− objParser = withObject "Rational" $ \obj -> do
1271+ parseJSON = withObject "Rational" $ \obj -> do
1590− numerator <- obj .: "numerator"
1272+ numerator <- obj .: "numerator"
1591− denominator <- obj .: "denominator"
1273+ denominator <- obj .: "denominator"
1592− if denominator == 0
1274+ if denominator == 0
1593− then fail "Ratio denominator was 0"
1275+ then fail "Ratio denominator was 0"
1594− else pure $ numerator % denominator
1276+ else pure $ numerator % denominator
1595 {-# INLINE parseJSON #-}
1277 {-# INLINE parseJSON #-}
1597-- | This instance includes a bounds check to prevent maliciously
1279-- | This instance includes a bounds check to prevent maliciously
@@ -1599,7 +1281,7 @@ instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1599-- newtype 'Scientific' and provide your own instance using
1281-- newtype 'Scientific' and provide your own instance using
1600-- 'withScientific' if you want to allow larger inputs.
1282-- 'withScientific' if you want to allow larger inputs.
1601instance HasResolution a => FromJSON (Fixed a) where
1283instance HasResolution a => FromJSON (Fixed a) where
1602− parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac)
1284+ parseJSON = withBoundedScientific "Fixed" $ pure . realToFrac
1603 {-# INLINE parseJSON #-}
1285 {-# INLINE parseJSON #-}
1605instance FromJSON Int where
1287instance FromJSON Int where
@@ -1622,20 +1304,19 @@ instance FromJSONKey Integer where
1623instance FromJSON Natural where
1305instance FromJSON Natural where
1624 parseJSON value = do
1306 parseJSON value = do
1625− integer <- parseIntegral "Natural" value
1307+ integer :: Integer <- parseIntegral "Natural" value
1626− parseNatural integer
1308+ if integer < 0 then
1309+ fail $ "expected Natural, encountered negative number " <> show integer
1311+ pure $ fromIntegral integer
1628instance FromJSONKey Natural where
1313instance FromJSONKey Natural where
1629 fromJSONKey = FromJSONKeyTextParser $ \text -> do
1314 fromJSONKey = FromJSONKeyTextParser $ \text -> do
1630− integer <- parseIntegralText "Natural" text
1315+ integer :: Integer <- parseIntegralText "Natural" text
1631− parseNatural integer
1633−parseNatural :: Integer -> Parser Natural
1634−parseNatural integer =
1635− if integer < 0 then
1316+ if integer < 0 then
1636− fail $ "parsing Natural failed, unexpected negative number " <> show integer
1317+ fail $ "expected Natural, encountered negative number " <> show integer
1638− pure $ fromIntegral integer
1319+ pure $ fromIntegral integer
1640instance FromJSON Int8 where
1321instance FromJSON Int8 where
1641 parseJSON = parseBoundedIntegral "Int8"
1322 parseJSON = parseBoundedIntegral "Int8"
@@ -1732,17 +1413,17 @@ parseVersionText = go . readP_to_S parseVersion . unpack
1733 go [(v,[])] = return v
1414 go [(v,[])] = return v
1734 go (_ : xs) = go xs
1415 go (_ : xs) = go xs
1735− go _ = fail "parsing Version failed"
1416+ go _ = fail "could not parse Version"
1737-------------------------------------------------------------------------------
1418-------------------------------------------------------------------------------
1738-- semigroups NonEmpty
1419-- semigroups NonEmpty
1739-------------------------------------------------------------------------------
1420-------------------------------------------------------------------------------
1741instance FromJSON1 NonEmpty where
1422instance FromJSON1 NonEmpty where
1742− liftParseJSON p _ = withArray "NonEmpty" $
1423+ liftParseJSON p _ = withArray "NonEmpty a" $
1743 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1424 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1745− ne [] = fail "parsing NonEmpty failed, unexpected empty list"
1426+ ne [] = fail "Expected a NonEmpty but got an empty list"
1746 ne (x:xs) = pure (x :| xs)
1427 ne (x:xs) = pure (x :| xs)
1747 {-# INLINE liftParseJSON #-}
1428 {-# INLINE liftParseJSON #-}
@@ -1763,7 +1444,7 @@ instance FromJSON Scientific where
1763-------------------------------------------------------------------------------
1444-------------------------------------------------------------------------------
1765instance FromJSON1 DList.DList where
1446instance FromJSON1 DList.DList where
1766− liftParseJSON p _ = withArray "DList" $
1447+ liftParseJSON p _ = withArray "DList a" $
1767 fmap DList.fromList .
1448 fmap DList.fromList .
1768 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1449 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1769 {-# INLINE liftParseJSON #-}
1450 {-# INLINE liftParseJSON #-}
@@ -1840,7 +1521,7 @@ instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where
1840 inr = "InR"
1521 inr = "InR"
1842 liftParseJSON _ _ _ = fail $
1523 liftParseJSON _ _ _ = fail $
1843− "parsing Sum failed, expected an object with a single property " ++
1524+ "expected an object with a single property " ++
1844 "where the property key should be either " ++
1525 "where the property key should be either " ++
1845 "\"InL\" or \"InR\""
1526 "\"InL\" or \"InR\""
1846 {-# INLINE liftParseJSON #-}
1527 {-# INLINE liftParseJSON #-}
@@ -1854,7 +1535,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where
1854-------------------------------------------------------------------------------
1535-------------------------------------------------------------------------------
1856instance FromJSON1 Seq.Seq where
1537instance FromJSON1 Seq.Seq where
1857− liftParseJSON p _ = withArray "Seq" $
1538+ liftParseJSON p _ = withArray "Seq a" $
1858 fmap Seq.fromList .
1539 fmap Seq.fromList .
1859 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1540 Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1860 {-# INLINE liftParseJSON #-}
1541 {-# INLINE liftParseJSON #-}
@@ -1888,13 +1569,13 @@ instance FromJSON a => FromJSON (IntMap.IntMap a) where
1889instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
1570instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
1890 liftParseJSON p _ = case fromJSONKey of
1571 liftParseJSON p _ = case fromJSONKey of
1891− FromJSONKeyCoerce _ -> withObject "Map" $
1572+ FromJSONKeyCoerce _-> withObject "Map k v" $
1892 fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1573 fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1893− FromJSONKeyText f -> withObject "Map" $
1574+ FromJSONKeyText f -> withObject "Map k v" $
1894 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1575 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1895− FromJSONKeyTextParser f -> withObject "Map" $
1576+ FromJSONKeyTextParser f -> withObject "Map k v" $
1896 H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)
1577 H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)
1897− FromJSONKeyValue f -> withArray "Map" $ \arr ->
1578+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
1898 fmap M.fromList . Tr.sequence .
1579 fmap M.fromList . Tr.sequence .
1899 zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
1580 zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
1900 {-# INLINE liftParseJSON #-}
1581 {-# INLINE liftParseJSON #-}
@@ -1922,18 +1603,18 @@ instance (FromJSON v) => FromJSON (Tree.Tree v) where
1923instance FromJSON UUID.UUID where
1604instance FromJSON UUID.UUID where
1924 parseJSON = withText "UUID" $
1605 parseJSON = withText "UUID" $
1925− maybe (fail "invalid UUID") pure . UUID.fromText
1606+ maybe (fail "Invalid UUID") pure . UUID.fromText
1927instance FromJSONKey UUID.UUID where
1608instance FromJSONKey UUID.UUID where
1928 fromJSONKey = FromJSONKeyTextParser $
1609 fromJSONKey = FromJSONKeyTextParser $
1929− maybe (fail "invalid UUID") pure . UUID.fromText
1610+ maybe (fail "Invalid UUID") pure . UUID.fromText
1931-------------------------------------------------------------------------------
1612-------------------------------------------------------------------------------
1932-- vector
1613-- vector
1933-------------------------------------------------------------------------------
1614-------------------------------------------------------------------------------
1935instance FromJSON1 Vector where
1616instance FromJSON1 Vector where
1936− liftParseJSON p _ = withArray "Vector" $
1617+ liftParseJSON p _ = withArray "Vector a" $
1937 V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
1618 V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
1938 {-# INLINE liftParseJSON #-}
1619 {-# INLINE liftParseJSON #-}
@@ -1947,14 +1628,14 @@ vectorParseJSON s = withArray s $ fmap V.convert . V.mapM (uncurry $ parseIndexe
1947{-# INLINE vectorParseJSON #-}
1628{-# INLINE vectorParseJSON #-}
1949instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
1630instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
1950− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector"
1631+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
1952instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
1633instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
1953− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector"
1634+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
1954 {-# INLINE parseJSON #-}
1635 {-# INLINE parseJSON #-}
1956instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
1637instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
1957− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector"
1638+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
1958 {-# INLINE parseJSON #-}
1639 {-# INLINE parseJSON #-}
1960-------------------------------------------------------------------------------
1641-------------------------------------------------------------------------------
@@ -1968,13 +1649,13 @@ instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
1969instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
1650instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
1970 liftParseJSON p _ = case fromJSONKey of
1651 liftParseJSON p _ = case fromJSONKey of
1971− FromJSONKeyCoerce _ -> withObject "HashMap ~Text" $
1652+ FromJSONKeyCoerce _ -> withObject "HashMap ~Text v" $
1972 uc . H.traverseWithKey (\k v -> p v <?> Key k)
1653 uc . H.traverseWithKey (\k v -> p v <?> Key k)
1973− FromJSONKeyText f -> withObject "HashMap" $
1654+ FromJSONKeyText f -> withObject "HashMap k v" $
1974 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)
1655 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)
1975− FromJSONKeyTextParser f -> withObject "HashMap" $
1656+ FromJSONKeyTextParser f -> withObject "HashMap k v" $
1976 H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)
1657 H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)
1977− FromJSONKeyValue f -> withArray "Map" $ \arr ->
1658+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
1978 fmap H.fromList . Tr.sequence .
1659 fmap H.fromList . Tr.sequence .
1979 zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
1660 zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr
@@ -1997,7 +1678,7 @@ instance FromJSON DotNetTime where
1997 parseJSON = withText "DotNetTime" $ \t ->
1678 parseJSON = withText "DotNetTime" $ \t ->
1998 let (s,m) = T.splitAt (T.length t - 5) t
1679 let (s,m) = T.splitAt (T.length t - 5) t
1999 t' = T.concat [s,".",m]
1680 t' = T.concat [s,".",m]
2000− in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
1681+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
2001 Just d -> pure (DotNetTime d)
1682 Just d -> pure (DotNetTime d)
2002 _ -> fail "could not parse .NET time"
1683 _ -> fail "could not parse .NET time"
2003 {-# INLINE parseJSON #-}
1684 {-# INLINE parseJSON #-}
@@ -2014,15 +1695,13 @@ instance FromJSON a => FromJSON (PM.Array a) where
2014instance FromJSON a => FromJSON (PM.SmallArray a) where
1695instance FromJSON a => FromJSON (PM.SmallArray a) where
2015 parseJSON = fmap Exts.fromList . parseJSON
1696 parseJSON = fmap Exts.fromList . parseJSON
2017−#if MIN_VERSION_primitive(0,6,4)
1698+#if (MIN_VERSION_primitive(0,6,4))
2018instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where
1699instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where
2019 parseJSON = fmap Exts.fromList . parseJSON
1700 parseJSON = fmap Exts.fromList . parseJSON
2021−#if !MIN_VERSION_primitive(0,7,0)
2022instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
1702instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
2023 parseJSON = fmap Exts.fromList . parseJSON
1703 parseJSON = fmap Exts.fromList . parseJSON
2027-------------------------------------------------------------------------------
1706-------------------------------------------------------------------------------
@@ -2091,40 +1770,6 @@ instance FromJSON DiffTime where
2091 parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
1770 parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
2092 {-# INLINE parseJSON #-}
1771 {-# INLINE parseJSON #-}
2094−instance FromJSON SystemTime where
2095− parseJSON v = prependContext "SystemTime" $ do
2097− let n' = floor (n * fromInteger (resolution n) :: Nano)
2098− let (secs, nano) = n' `divMod` resolution n
2099− return (MkSystemTime (fromInteger secs) (fromInteger nano))
2101−instance FromJSON CalendarDiffTime where
2102− parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime
2103− <$> obj .: "months"
2106−instance FromJSON CalendarDiffDays where
2107− parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays
2108− <$> obj .: "months"
2111−instance FromJSON DayOfWeek where
2112− parseJSON = withText "DaysOfWeek" parseDayOfWeek
2114−parseDayOfWeek :: T.Text -> Parser DayOfWeek
2115−parseDayOfWeek t = case T.toLower t of
2116− "monday" -> return Monday
2117− "tuesday" -> return Tuesday
2118− "wednesday" -> return Wednesday
2119− "thursday" -> return Thursday
2120− "friday" -> return Friday
2121− "saturday" -> return Saturday
2122− "sunday" -> return Sunday
2123− _ -> fail "Invalid week day"
2125−instance FromJSONKey DayOfWeek where
2126− fromJSONKey = FromJSONKeyTextParser parseDayOfWeek
2128-------------------------------------------------------------------------------
1773-------------------------------------------------------------------------------
2129-- base Monoid/Semigroup
1774-- base Monoid/Semigroup
2130-------------------------------------------------------------------------------
1775-------------------------------------------------------------------------------
@@ -2245,15 +1890,14 @@ instance FromJSON a => FromJSON (Semigroup.Option a) where
2246instance FromJSON1 Proxy where
1891instance FromJSON1 Proxy where
2247 {-# INLINE liftParseJSON #-}
1892 {-# INLINE liftParseJSON #-}
2248− liftParseJSON _ _ = fromNull "Proxy" Proxy
1893+ liftParseJSON _ _ Null = pure Proxy
1894+ liftParseJSON _ _ v = typeMismatch "Proxy" v
2250instance FromJSON (Proxy a) where
1896instance FromJSON (Proxy a) where
2251 {-# INLINE parseJSON #-}
1897 {-# INLINE parseJSON #-}
2252− parseJSON = fromNull "Proxy" Proxy
1898+ parseJSON Null = pure Proxy
1899+ 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)
2258instance FromJSON2 Tagged where
1902instance FromJSON2 Tagged where
2259 liftParseJSON2 _ _ p _ = fmap Tagged . p
1903 liftParseJSON2 _ _ p _ = fmap Tagged . p
@@ -2280,7 +1924,10 @@ instance (FromJSON a, FromJSON b, FromJSON c) => FromJSONKey (a,b,c)
2280instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)
1924instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d)
2282instance FromJSONKey Char where
1926instance FromJSONKey Char where
2283− fromJSONKey = FromJSONKeyTextParser parseChar
1927+ fromJSONKey = FromJSONKeyTextParser $ \t ->
1929+ then return (T.index t 0)
1930+ else typeMismatch "Expected Char but String didn't contain exactly one character" (String t)
2284 fromJSONKeyList = FromJSONKeyText T.unpack
1931 fromJSONKeyList = FromJSONKeyText T.unpack
2286instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where
1933instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where