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