@@ -5,20 +5,16 @@
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE NamedFieldPuns #-}
9{-# LANGUAGE NoImplicitPrelude #-}
8{-# LANGUAGE NoImplicitPrelude #-}
10{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE TypeSynonymInstances #-}
14+{-# LANGUAGE TupleSections #-}
15{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
16{-# LANGUAGE ViewPatterns #-}
16{-# LANGUAGE ViewPatterns #-}
18−#if __GLASGOW_HASKELL__ >= 706
19−{-# LANGUAGE PolyKinds #-}
22#include "incoherent-compat.h"
18#include "incoherent-compat.h"
23#include "overlapping-compat.h"
19#include "overlapping-compat.h"
@@ -46,6 +42,9 @@ module Data.Aeson.Types.FromJSON
46 , coerceFromJSONKeyFunction
42 , coerceFromJSONKeyFunction
47 , mapFromJSONKeyFunction
43 , mapFromJSONKeyFunction
49 -- * List functions
48 -- * List functions
50 , listParser
49 , listParser
@@ -68,6 +67,7 @@ module Data.Aeson.Types.FromJSON
68 , explicitParseField
67 , explicitParseField
69 , explicitParseFieldMaybe
68 , explicitParseFieldMaybe
70 , explicitParseFieldMaybe'
69 , explicitParseFieldMaybe'
71 -- ** Operators
71 -- ** Operators
@@ -80,14 +80,14 @@ module Data.Aeson.Types.FromJSON
81import Prelude.Compat
81import Prelude.Compat
83−import Control.Applicative ((<|>), Const(..))
83+import Control.Applicative ((<|>), Const(..), liftA2)
84−import Control.Monad ((<=<), zipWithM)
84+import Control.Monad (zipWithM)
85import Data.Aeson.Internal.Functions (mapKey)
85import Data.Aeson.Internal.Functions (mapKey)
86import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
86import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
87import Data.Aeson.Types.Generic
87import Data.Aeson.Types.Generic
88import Data.Aeson.Types.Internal
88import Data.Aeson.Types.Internal
89import Data.Bits (unsafeShiftR)
89import Data.Bits (unsafeShiftR)
90−import Data.Fixed (Fixed, HasResolution)
90+import Data.Fixed (Fixed, HasResolution (resolution), Nano)
91import Data.Functor.Compose (Compose(..))
91import Data.Functor.Compose (Compose(..))
92import Data.Functor.Identity (Identity(..))
92import Data.Functor.Identity (Identity(..))
93import Data.Functor.Product (Product(..))
93import Data.Functor.Product (Product(..))
@@ -103,8 +103,10 @@ import Data.Scientific (Scientific, base10Exponent)
103import Data.Tagged (Tagged(..))
103import Data.Tagged (Tagged(..))
104import Data.Text (Text, pack, unpack)
104import Data.Text (Text, pack, unpack)
105import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
105import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
106−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 (..))
107−import Data.Time.Locale.Compat (defaultTimeLocale)
109+import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
108import Data.Traversable as Tr (sequence)
110import Data.Traversable as Tr (sequence)
109import Data.Vector (Vector)
111import Data.Vector (Vector)
110import Data.Version (Version, parseVersion)
112import Data.Version (Version, parseVersion)
@@ -116,9 +118,9 @@ import GHC.Generics
116import Numeric.Natural (Natural)
118import Numeric.Natural (Natural)
117import Text.ParserCombinators.ReadP (readP_to_S)
119import Text.ParserCombinators.ReadP (readP_to_S)
118import Unsafe.Coerce (unsafeCoerce)
120import Unsafe.Coerce (unsafeCoerce)
119−import qualified Data.Aeson.Compat as Compat
120import qualified Data.Aeson.Parser.Time as Time
121import qualified Data.Aeson.Parser.Time as Time
121import 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
122import qualified Data.DList as DList
124import qualified Data.DList as DList
123import qualified Data.HashMap.Strict as H
125import qualified Data.HashMap.Strict as H
124import qualified Data.HashSet as HashSet
126import qualified Data.HashSet as HashSet
@@ -147,22 +149,14 @@ import qualified Data.Primitive.SmallArray as PM
147import qualified Data.Primitive.Types as PM
149import qualified Data.Primitive.Types as PM
149#if MIN_VERSION_primitive(0,6,4)
151#if MIN_VERSION_primitive(0,6,4)
152+#if !MIN_VERSION_primitive(0,7,0)
150import qualified Data.Primitive.UnliftedArray as PM
153import qualified Data.Primitive.UnliftedArray as PM
151import qualified Data.Primitive.PrimArray as PM
155import qualified Data.Primitive.PrimArray as PM
154−#ifndef HAS_COERCIBLE
155−#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
159import Data.Coerce (Coercible, coerce)
159import Data.Coerce (Coercible, coerce)
160−coerce' :: Coercible a b => a -> b
164−coerce' = unsafeCoerce
167parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
168parseIndexedJSON p idx value = p value <?> Index idx
162parseIndexedJSON p idx value = p value <?> Index idx
@@ -293,14 +287,21 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
294-- The basic ways to signal a failed conversion are as follows:
288-- The basic ways to signal a failed conversion are as follows:
296−-- * '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;
298−-- * '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 @('<|>')@;
300−-- * 'typeMismatch' produces an informative message for cases when the
296+-- * 'typeMismatch' can be used to report a failure when the encountered value
301−-- 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
303−-- An example type and instance using 'typeMismatch':
304+-- An example type and instance using 'typeMismatch' and 'prependFailure':
306-- \-- Allow ourselves to write 'Text' literals.
307-- \-- Allow ourselves to write 'Text' literals.
@@ -314,9 +315,11 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
314-- '<*>' v '.:' \"y\"
315-- '<*>' v '.:' \"y\"
316-- \-- We do not expect a non-'Object' value here.
317-- \-- We do not expect a non-'Object' value here.
317−-- \-- We could use 'mzero' to fail, but 'typeMismatch'
318+-- \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'
318-- \-- gives a much more informative error message.
319-- \-- gives a much more informative error message.
320+-- 'parseJSON' invalid =
321+-- 'prependFailure' "parsing Coord failed, "
319−-- 'parseJSON' invalid = 'typeMismatch' \"Coord\" invalid
322+-- ('typeMismatch' \"Object\" invalid)
322-- For this common case of only being concerned with a single
325-- For this common case of only being concerned with a single
@@ -359,7 +362,7 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
361-- The default implementation will be equivalent to
364-- The default implementation will be equivalent to
362−-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; If you need different
365+-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different
363-- options, you can customize the generic decoding by defining:
366-- options, you can customize the generic decoding by defining:
@@ -393,6 +396,16 @@ class FromJSON a where
393-- > newtype SomeId = SomeId { getSomeId :: Text }
396-- > newtype SomeId = SomeId { getSomeId :: Text }
394-- > 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'
396class FromJSONKey a where
409class FromJSONKey a where
397 -- | Strategy for parsing the key of a map-like container.
410 -- | Strategy for parsing the key of a map-like container.
398 fromJSONKey :: FromJSONKeyFunction a
411 fromJSONKey :: FromJSONKeyFunction a
@@ -415,11 +428,7 @@ class FromJSONKey a where
415-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
416-- can be inspected, but cannot be constructed.
429-- can be inspected, but cannot be constructed.
417data CoerceText a where
430data CoerceText a where
419 CoerceText :: Coercible Text a => CoerceText a
431 CoerceText :: Coercible Text a => CoerceText a
421− CoerceText :: CoerceText a
424-- | 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
425-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -439,7 +448,7 @@ data FromJSONKeyFunction a
440-- | Only law abiding up to interpretation
449-- | Only law abiding up to interpretation
441instance Functor FromJSONKeyFunction where
450instance Functor FromJSONKeyFunction where
442− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
451+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
443 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
444 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
445 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -453,9 +462,7 @@ instance Functor FromJSONKeyFunction where
454-- On pre GHC 7.8 this is unconstrainted function.
463-- On pre GHC 7.8 this is unconstrainted function.
455fromJSONKeyCoerce ::
464fromJSONKeyCoerce ::
457 Coercible Text a =>
465 Coercible Text a =>
459 FromJSONKeyFunction a
466 FromJSONKeyFunction a
460fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
@@ -463,34 +470,52 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
464-- See note on 'fromJSONKeyCoerce'.
471-- See note on 'fromJSONKeyCoerce'.
465coerceFromJSONKeyFunction ::
472coerceFromJSONKeyFunction ::
467 Coercible a b =>
473 Coercible a b =>
469 FromJSONKeyFunction a -> FromJSONKeyFunction b
474 FromJSONKeyFunction a -> FromJSONKeyFunction b
471coerceFromJSONKeyFunction = coerce
475coerceFromJSONKeyFunction = coerce
473−coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText
474−coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)
475−coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)
476−coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)
480 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
481 fmap id x = x
479 fmap id x = x
485 "FromJSONKeyCoerce: fmap coerce" forall x .
482 "FromJSONKeyCoerce: fmap coerce" forall x .
486 fmap coerce x = coerceFromJSONKeyFunction x
483 fmap coerce x = coerceFromJSONKeyFunction x
490-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
491mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
492mapFromJSONKeyFunction = 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
494-------------------------------------------------------------------------------
519-------------------------------------------------------------------------------
495-- Functions needed for documentation
520-- Functions needed for documentation
496-------------------------------------------------------------------------------
521-------------------------------------------------------------------------------
@@ -743,13 +768,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v
743-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
768-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
744-- to the 'Parser' in case of failure.
769-- to the 'Parser' in case of failure.
745withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
770withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
746−withBoundedScientific_ whenFail f v@(Number scientific) =
771+withBoundedScientific_ whenFail f (Number scientific) =
747− if exponent > 1024
772+ if exp10 > 1024
748 then whenFail (fail msg)
773 then whenFail (fail msg)
749 else f scientific
774 else f scientific
751− exponent = base10Exponent scientific
776+ exp10 = base10Exponent scientific
752− msg = "found a number with exponent " ++ show exponent ++ ", but it must not be greater than 1024"
777+ msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"
753withBoundedScientific_ whenFail _ v =
778withBoundedScientific_ whenFail _ v =
754 whenFail (typeMismatch "Number" v)
779 whenFail (typeMismatch "Number" v)
755{-# INLINE withBoundedScientific_ #-}
780{-# INLINE withBoundedScientific_ #-}
@@ -769,7 +794,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)
769-- | Decode a nested JSON-encoded string.
794-- | Decode a nested JSON-encoded string.
770withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
795withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
771withEmbeddedJSON _ innerParser (String txt) =
796withEmbeddedJSON _ innerParser (String txt) =
772− either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
797+ either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
774 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
799 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
775 eitherFormatError = either (Left . uncurry formatError) Right
800 eitherFormatError = either (Left . uncurry formatError) Right
@@ -838,7 +863,7 @@ parseFieldMaybe' = (.:!)
838-- 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)@
839explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
864explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
840explicitParseField p obj key = case H.lookup key obj of
865explicitParseField p obj key = case H.lookup key obj of
841− Nothing -> fail $ "key " ++ show key ++ " not present"
866+ Nothing -> fail $ "key " ++ show key ++ " not found"
842 Just v -> p v <?> Key key
867 Just v -> p v <?> Key key
843{-# INLINE explicitParseField #-}
868{-# INLINE explicitParseField #-}
@@ -888,6 +913,37 @@ instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where
888 -- parsed value:
913 -- parsed value:
889 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
891instance (FromJSON a) => GFromJSON arity (K1 i a) where
947instance (FromJSON a) => GFromJSON arity (K1 i a) where
892 -- Constant values are decoded using their FromJSON instance:
948 -- Constant values are decoded using their FromJSON instance:
893 gParseJSON _opts _ = fmap K1 . parseJSON
949 gParseJSON _opts _ = fmap K1 . parseJSON
@@ -902,342 +958,499 @@ instance (FromJSON1 f) => GFromJSON One (Rec1 f) where
902 -- FromJSON1 instance:
958 -- FromJSON1 instance:
903 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl
959 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl
905−instance GFromJSON arity U1 where
961+instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
906− -- 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:
907− gParseJSON _opts _ v
965+ gParseJSON opts fargs =
908− | isEmptyArray v = pure U1
966+ let gpj = gParseJSON opts fargs in
909− | 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.
911instance ( ConsFromJSON arity a
987instance ( ConsFromJSON arity a
912 , AllNullary (C1 c a) allNullary
988 , AllNullary (C1 c a) allNullary
913 , ParseSum arity (C1 c a) allNullary
989 , ParseSum arity (C1 c a) allNullary
914− ) => GFromJSON arity (D1 d (C1 c a)) where
991+ ) => GFromJSON' arity (C1 c a) where
915 -- The option 'tagSingleConstructors' determines whether to wrap
992 -- The option 'tagSingleConstructors' determines whether to wrap
916 -- a single-constructor type.
993 -- a single-constructor type.
917− gParseJSON opts fargs
994+ gParseJSON' p@(_ :* opts :* _)
918 | tagSingleConstructors opts
995 | tagSingleConstructors opts
920− . (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))
921− . parseSum opts fargs
997+ . parseSum p
922− | otherwise = fmap M1 . fmap M1 . consParseJSON opts fargs
998+ | otherwise = fmap M1 . consParseJSON (cname :* p)
924−instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where
1000+ cname = conName (undefined :: M1 _i c _f _p)
925− -- Constructors need to be decoded differently depending on whether they're
1001+
926− -- a record or not. This distinction is made by consParseJSON:
1002+-- | Multiple constructors.
927− gParseJSON opts fargs = fmap M1 . consParseJSON opts fargs
929−instance ( FromProduct arity a, FromProduct arity b
930− , ProductSize a, ProductSize b
931− ) => GFromJSON arity (a :*: b) where
932− -- Products are expected to be encoded to an array. Here we check whether we
933− -- got an array of the same size as the product, then parse each of the
934− -- product's elements using parseProduct:
935− gParseJSON opts fargs = withArray "product (:*:)" $ \arr ->
936− let lenArray = V.length arr
937− lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
939− if lenArray == lenProduct
940− then parseProduct opts fargs arr 0 lenProduct
941− else fail $ "When expecting a product of " ++ show lenProduct ++
942− " values, encountered an Array of " ++ show lenArray ++
945−instance ( AllNullary (a :+: b) allNullary
1003+instance ( AllNullary (a :+: b) allNullary
946− , ParseSum arity (a :+: b) allNullary
1004+ , ParseSum arity (a :+: b) allNullary
947− ) => GFromJSON arity (a :+: b) where
1005+ ) => GFromJSON' arity (a :+: b) where
948 -- If all constructors of a sum datatype are nullary and the
1006 -- If all constructors of a sum datatype are nullary and the
949 -- 'allNullaryToStringTag' option is set they are expected to be
1007 -- 'allNullaryToStringTag' option is set they are expected to be
950 -- encoded as strings. This distinction is made by 'parseSum':
1008 -- encoded as strings. This distinction is made by 'parseSum':
951− gParseJSON opts fargs =
1009+ gParseJSON' p =
952− (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->
1010+ (unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->
953− Parser ((a :+: b) d))
1011+ Parser ((a :+: b) _d))
954− . parseSum opts fargs
1012+ . parseSum p
956−instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
957− -- If an occurrence of the last type parameter is nested inside two
958− -- composed types, it is decoded by using the outermost type's FromJSON1
959− -- instance to generically decode the innermost type:
960− gParseJSON opts fargs =
961− let gpj = gParseJSON opts fargs in
962− fmap Comp1 . liftParseJSON gpj (listParser gpj)
964--------------------------------------------------------------------------------
1014--------------------------------------------------------------------------------
966class ParseSum arity f allNullary where
1016class ParseSum arity f allNullary where
967− parseSum :: Options -> FromArgs arity a
1017+ parseSum :: TypeName :* Options :* FromArgs arity a
968− -> Value -> Tagged allNullary (Parser (f a))
1019+ -> Tagged allNullary (Parser (f a))
1021+instance ( ConstructorNames f
970−instance ( SumFromString f
1022+ , SumFromString f
971 , FromPair arity f
1023 , FromPair arity f
972 , FromTaggedObject arity f
1024 , FromTaggedObject arity f
973 , FromUntaggedValue arity f
1025 , FromUntaggedValue arity f
974 ) => ParseSum arity f True where
1026 ) => ParseSum arity f True where
975− parseSum opts fargs
1027+ parseSum p@(tname :* opts :* _)
976− | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts
1028+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts
977− | otherwise = Tagged . parseNonAllNullarySum opts fargs
1029+ | otherwise = Tagged . parseNonAllNullarySum p
1031+instance ( ConstructorNames f
979−instance ( FromPair arity f
1032+ , FromPair arity f
980 , FromTaggedObject arity f
1033 , FromTaggedObject arity f
981 , FromUntaggedValue arity f
1034 , FromUntaggedValue arity f
982 ) => ParseSum arity f False where
1035 ) => ParseSum arity f False where
983− parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs
1036+ parseSum p = Tagged . parseNonAllNullarySum p
985--------------------------------------------------------------------------------
1038--------------------------------------------------------------------------------
987−parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)
1040+parseAllNullarySum :: (SumFromString f, ConstructorNames f)
1041+ => TypeName -> Options -> Value -> Parser (f a)
988−parseAllNullarySum opts = withText "Text" $ \key ->
1042+parseAllNullarySum tname opts =
1043+ withText tname $ \tag ->
989− maybe (notFound key) return $
1044+ maybe (badTag tag) return $
990− 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])
992class SumFromString f where
1063class SumFromString f where
993− parseSumFromString :: Options -> Text -> Maybe (f a)
1064+ parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
995instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
1066instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
996 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
1067 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
997 (R1 <$> parseSumFromString opts key)
1068 (R1 <$> parseSumFromString opts key)
999instance (Constructor c) => SumFromString (C1 c U1) where
1070instance (Constructor c) => SumFromString (C1 c U1) where
1000− parseSumFromString opts key | key == name = Just $ M1 U1
1071+ parseSumFromString modifier key
1072+ | key == name = Just $ M1 U1
1001− | otherwise = Nothing
1073+ | otherwise = Nothing
1003− name = pack $ constructorTagModifier opts $
1004− conName (undefined :: t c U1 p)
1075+ name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)
1006−--------------------------------------------------------------------------------
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+--------------------------------------------------------------------------------
1008−parseNonAllNullarySum :: ( FromPair arity f
1113+parseNonAllNullarySum :: forall f c arity.
1009 , FromTaggedObject arity f
1115 , FromTaggedObject arity f
1010 , FromUntaggedValue arity f
1116 , FromUntaggedValue arity f
1117+ , ConstructorNames f
1011− ) => Options -> FromArgs arity c
1118+ ) => TypeName :* Options :* FromArgs arity c
1012 -> Value -> Parser (f c)
1119 -> Value -> Parser (f c)
1013−parseNonAllNullarySum opts fargs =
1120+parseNonAllNullarySum p@(tname :* opts :* _) =
1014 case sumEncoding opts of
1121 case sumEncoding opts of
1015 TaggedObject{..} ->
1122 TaggedObject{..} ->
1016− withObject "Object" $ \obj -> do
1123+ withObject tname $ \obj -> do
1017− tag <- obj .: pack tagFieldName
1124+ tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
1018− fromMaybe (notFound tag) $
1125+ fromMaybe (badTag tag <?> Key tagKey) $
1019− 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])
1021 ObjectWithSingleField ->
1134 ObjectWithSingleField ->
1022− withObject "Object" $ \obj ->
1023− case H.toList obj of
1135+ withObject tname $ \obj -> case H.toList obj of
1024− [pair@(tag, _)] -> fromMaybe (notFound tag) $
1136+ [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $
1025− parsePair opts fargs pair
1137+ parsePair (tag :* p) v
1026− _ -> 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
1028 TwoElemArray ->
1146 TwoElemArray ->
1029− withArray "Array" $ \arr ->
1147+ withArray tname $ \arr -> case V.length arr of
1030− if V.length arr == 2
1148+ 2 | String tag <- V.unsafeIndex arr 0 ->
1031− then case V.unsafeIndex arr 0 of
1149+ maybe (badTag tag <?> Index 0) (<?> Index 1) $
1032− String tag -> fromMaybe (notFound tag) $
1033− parsePair opts fargs (tag, V.unsafeIndex arr 1)
1150+ parsePair (tag :* p) (V.unsafeIndex arr 1)
1152+ contextType tname $
1034− _ -> fail "First element is not a String"
1153+ fail "tag element is not a String" <?> Index 0
1035− 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
1037− UntaggedValue -> parseUntaggedValue opts fargs
1162+ UntaggedValue -> parseUntaggedValue p
1164+ failWith_ = failWithCTags tname (constructorTagModifier opts)
1039--------------------------------------------------------------------------------
1166--------------------------------------------------------------------------------
1041class 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.
1042− parseFromTaggedObject :: Options -> FromArgs arity a
1171+ parseFromTaggedObject
1172+ :: Text :* String :* TypeName :* Options :* FromArgs arity a
1043− -> String -> Object
1173+ -> Object
1044− -> Text -> Maybe (Parser (f a))
1174+ -> Maybe (Parser (f a))
1046instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
1176instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
1047 FromTaggedObject arity (a :+: b) where
1177 FromTaggedObject arity (a :+: b) where
1048− parseFromTaggedObject opts fargs contentsFieldName obj tag =
1178+ parseFromTaggedObject p obj =
1049− (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>
1179+ (fmap L1 <$> parseFromTaggedObject p obj) <|>
1050− (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)
1180+ (fmap R1 <$> parseFromTaggedObject p obj)
1182+instance ( IsRecord f isRecord
1052−instance ( FromTaggedObject' arity f
1183+ , FromTaggedObject' arity f isRecord
1053 , Constructor c
1184 , Constructor c
1054 ) => FromTaggedObject arity (C1 c f) where
1185 ) => FromTaggedObject arity (C1 c f) where
1055− parseFromTaggedObject opts fargs contentsFieldName obj tag
1186+ parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))
1189+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
1056− | tag == name = Just $ M1 <$> parseFromTaggedObject'
1190+ parseFromTaggedObject' (contentsFieldName :* cname :* p)
1057− opts fargs contentsFieldName obj
1058− | otherwise = Nothing
1191+ | otherwise = const Nothing
1060− name = pack $ constructorTagModifier opts $
1193+ tag' = pack $ constructorTagModifier opts cname
1061− conName (undefined :: t c f p)
1194+ cname = conName (undefined :: M1 _i c _f _p)
1063--------------------------------------------------------------------------------
1196--------------------------------------------------------------------------------
1065−class FromTaggedObject' arity f where
1198+class FromTaggedObject' arity f isRecord where
1066− parseFromTaggedObject' :: Options -> FromArgs arity a -> String
1199+ -- The first component of the parameter tuple is the contents field name.
1067− -> Object -> Parser (f a)
1200+ parseFromTaggedObject'
1069−class FromTaggedObject'' arity f isRecord where
1070− parseFromTaggedObject'' :: Options -> FromArgs arity a -> String
1201+ :: String :* ConName :* TypeName :* Options :* FromArgs arity a
1071− -> Object -> Tagged isRecord (Parser (f a))
1202+ -> Object -> Tagged isRecord (Parser (f a))
1073−instance ( IsRecord f isRecord
1074− , FromTaggedObject'' arity f isRecord
1075− ) => FromTaggedObject' arity f where
1204+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
1076− parseFromTaggedObject' opts fargs contentsFieldName =
1205+ -- Records are unpacked in the tagged object
1077− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
1078− parseFromTaggedObject'' opts fargs contentsFieldName
1206+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
1080−instance (FromRecord arity f) => FromTaggedObject'' arity f True where
1081− parseFromTaggedObject'' opts fargs _ =
1082− Tagged . parseRecord opts fargs
1084−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
1085− parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .
1210+ parseFromTaggedObject' p obj = Tagged $ do
1211+ contents <- contextCons cname tname (obj .: key)
1212+ consParseJSON p' contents <?> Key key
1086− (gParseJSON opts fargs <=< (.: pack contentsFieldName))
1214+ key = pack contentsFieldName
1215+ contentsFieldName :* p'@(cname :* tname :* _) = p
1088−instance OVERLAPPING_ FromTaggedObject'' arity U1 False where
1217+instance OVERLAPPING_ FromTaggedObject' arity U1 False where
1218+ -- Nullary constructors don't need a contents field
1089− parseFromTaggedObject'' _ _ _ _ = Tagged (pure U1)
1219+ parseFromTaggedObject' _ _ = Tagged (pure U1)
1091--------------------------------------------------------------------------------
1221--------------------------------------------------------------------------------
1223+-- | Constructors need to be decoded differently depending on whether they're
1224+-- a record or not. This distinction is made by 'ConsParseJSON'.
1093class ConsFromJSON arity f where
1225class ConsFromJSON arity f where
1094− consParseJSON :: Options -> FromArgs arity a
1227+ :: ConName :* TypeName :* Options :* FromArgs arity a
1095− -> Value -> Parser (f a)
1228+ -> Value -> Parser (f a)
1097class ConsFromJSON' arity f isRecord where
1230class ConsFromJSON' arity f isRecord where
1098− consParseJSON' :: Options -> FromArgs arity a
1232+ :: ConName :* TypeName :* Options :* FromArgs arity a
1099− -> Value -> Tagged isRecord (Parser (f a))
1233+ -> Value -> Tagged isRecord (Parser (f a))
1101instance ( IsRecord f isRecord
1235instance ( IsRecord f isRecord
1102 , ConsFromJSON' arity f isRecord
1236 , ConsFromJSON' arity f isRecord
1103 ) => ConsFromJSON arity f where
1237 ) => ConsFromJSON arity f where
1104− consParseJSON opts fargs =
1238+ consParseJSON p =
1105 (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
1239 (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
1106− . consParseJSON' opts fargs
1240+ . consParseJSON' p
1108instance OVERLAPPING_
1242instance OVERLAPPING_
1109− ( GFromJSON arity a, FromRecord arity (S1 s a)
1243+ ( GFromJSON arity a, RecordFromJSON arity (S1 s a)
1110 ) => ConsFromJSON' arity (S1 s a) True where
1244 ) => ConsFromJSON' arity (S1 s a) True where
1111− consParseJSON' opts fargs
1245+ consParseJSON' p@(cname :* tname :* opts :* fargs)
1112− | unwrapUnaryRecords opts = Tagged . gParseJSON opts fargs
1246+ | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1113− | 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))
1115−instance FromRecord arity f => ConsFromJSON' arity f True where
1253+instance OVERLAPPING_
1254+ ConsFromJSON' arity U1 False where
1255+ -- Empty constructors are expected to be encoded as an empty array:
1116− consParseJSON' opts fargs =
1256+ consParseJSON' (cname :* tname :* _) v =
1117− Tagged . withObject "record (:*:)" (parseRecord opts fargs)
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
1268+ consParseJSON' (_ :* _ :* opts :* fargs) =
1269+ Tagged . fmap M1 . gParseJSON opts fargs
1271+instance (ProductFromJSON arity f, ProductSize f
1119−instance GFromJSON arity f => ConsFromJSON' arity f False where
1272+ ) => ConsFromJSON' arity f False where
1120− consParseJSON' opts fargs = Tagged . gParseJSON opts fargs
1273+ consParseJSON' p = Tagged . productParseJSON0 p
1122--------------------------------------------------------------------------------
1275--------------------------------------------------------------------------------
1124−class FromRecord arity f where
1277+class FieldNames f where
1125− parseRecord :: Options -> FromArgs arity a
1278+ fieldNames :: f a -> [Text] -> [Text]
1126− -> Object -> Parser (f a)
1128−instance ( FromRecord arity a
1280+instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where
1129− , FromRecord arity b
1281+ fieldNames _ =
1130− ) => FromRecord arity (a :*: b) where
1282+ fieldNames (undefined :: a x) .
1131− parseRecord opts fargs obj =
1283+ fieldNames (undefined :: b y)
1132− (:*:) <$> parseRecord opts fargs obj
1133− <*> parseRecord opts fargs obj
1135−instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1285+instance (Selector s) => FieldNames (S1 s f) where
1136− FromRecord arity (S1 s a) where
1286+ fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)
1137− parseRecord opts fargs =
1287+
1138− (<?> 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
1140− 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)
1142instance INCOHERENT_ (Selector s, FromJSON a) =>
1332instance INCOHERENT_ (Selector s, FromJSON a) =>
1143− FromRecord arity (S1 s (K1 i (Maybe a))) where
1333+ RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
1144− parseRecord opts _ obj = M1 . K1 <$> obj .:? pack label
1334+ recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
1146− label = fieldLabelModifier opts $
1336+ label = fieldLabelModifier opts sname
1147− selName (undefined :: t s (K1 i (Maybe a)) p)
1337+ sname = selName (undefined :: M1 _i s _f _p)
1149-- Parse an Option like a Maybe.
1339-- Parse an Option like a Maybe.
1150instance INCOHERENT_ (Selector s, FromJSON a) =>
1340instance INCOHERENT_ (Selector s, FromJSON a) =>
1151− FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where
1341+ RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
1152− parseRecord opts fargs obj = wrap <$> parseRecord opts fargs obj
1342+ recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
1154 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
1155 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
1345 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
1157--------------------------------------------------------------------------------
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
1159−class FromProduct arity f where
1369+class ProductFromJSON arity f where
1160− parseProduct :: Options -> FromArgs arity a
1370+ productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a
1161 -> Array -> Int -> Int
1371 -> Array -> Int -> Int
1162 -> Parser (f a)
1372 -> Parser (f a)
1164−instance ( FromProduct arity a
1374+instance ( ProductFromJSON arity a
1165− , FromProduct arity b
1375+ , ProductFromJSON arity b
1166− ) => FromProduct arity (a :*: b) where
1376+ ) => ProductFromJSON arity (a :*: b) where
1167− parseProduct opts fargs arr ix len =
1377+ productParseJSON p arr ix len =
1168− (:*:) <$> parseProduct opts fargs arr ix lenL
1378+ (:*:) <$> productParseJSON p arr ix lenL
1169− <*> parseProduct opts fargs arr ixR lenR
1379+ <*> productParseJSON p arr ixR lenR
1171 lenL = len `unsafeShiftR` 1
1381 lenL = len `unsafeShiftR` 1
1172 ixR = ix + lenL
1382 ixR = ix + lenL
1173 lenR = len - lenL
1383 lenR = len - lenL
1175−instance (GFromJSON arity a) => FromProduct arity (S1 s a) where
1385+instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where
1176− parseProduct opts fargs arr ix _ =
1386+ productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =
1177− gParseJSON opts fargs $ V.unsafeIndex arr ix
1387+ M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix
1179--------------------------------------------------------------------------------
1389--------------------------------------------------------------------------------
1181class FromPair arity f where
1391class FromPair arity f where
1392+ -- The first component of the parameter tuple is the tag to match.
1182− parsePair :: Options -> FromArgs arity a
1393+ parsePair :: Text :* TypeName :* Options :* FromArgs arity a
1183− -> Pair -> Maybe (Parser (f a))
1395+ -> Maybe (Parser (f a))
1185instance ( FromPair arity a
1397instance ( FromPair arity a
1186 , FromPair arity b
1398 , FromPair arity b
1187 ) => FromPair arity (a :+: b) where
1399 ) => FromPair arity (a :+: b) where
1188− parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>
1401+ (fmap L1 <$> parsePair p pair) <|>
1189− (fmap R1 <$> parsePair opts fargs pair)
1402+ (fmap R1 <$> parsePair p pair)
1191instance ( Constructor c
1404instance ( Constructor c
1192− , GFromJSON arity a
1193 , ConsFromJSON arity a
1405 , ConsFromJSON arity a
1194 ) => FromPair arity (C1 c a) where
1406 ) => FromPair arity (C1 c a) where
1195− parsePair opts fargs (tag, value)
1407+ parsePair (tag :* p@(_ :* opts :* _)) v
1196− | tag == tag' = Just $ gParseJSON opts fargs value
1408+ | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v
1197 | otherwise = Nothing
1409 | otherwise = Nothing
1199− tag' = pack $ constructorTagModifier opts $
1411+ tag' = pack $ constructorTagModifier opts cname
1200− conName (undefined :: t c a p)
1412+ cname = conName (undefined :: M1 _i c _a _p)
1202--------------------------------------------------------------------------------
1414--------------------------------------------------------------------------------
1204class FromUntaggedValue arity f where
1416class FromUntaggedValue arity f where
1205− parseUntaggedValue :: Options -> FromArgs arity a
1417+ parseUntaggedValue :: TypeName :* Options :* FromArgs arity a
1206− -> Value -> Parser (f a)
1419+ -> Parser (f a)
1209 ( FromUntaggedValue arity a
1422 ( FromUntaggedValue arity a
1210 , FromUntaggedValue arity b
1423 , FromUntaggedValue arity b
1211 ) => FromUntaggedValue arity (a :+: b)
1424 ) => FromUntaggedValue arity (a :+: b)
1213− parseUntaggedValue opts fargs value =
1426+ parseUntaggedValue p value =
1214− L1 <$> parseUntaggedValue opts fargs value <|>
1427+ L1 <$> parseUntaggedValue p value <|>
1215− R1 <$> parseUntaggedValue opts fargs value
1428+ R1 <$> parseUntaggedValue p value
1217instance OVERLAPPABLE_
1430instance OVERLAPPABLE_
1218− ( GFromJSON arity a
1431+ ( ConsFromJSON arity a
1219− , ConsFromJSON arity a
1432+ , Constructor c
1220 ) => FromUntaggedValue arity (C1 c a)
1433 ) => FromUntaggedValue arity (C1 c a)
1222− parseUntaggedValue = gParseJSON
1435+ parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)
1437+ cname = conName (undefined :: M1 _i c _f _p)
1224instance OVERLAPPING_
1439instance OVERLAPPING_
1225 ( Constructor c )
1440 ( Constructor c )
1226 => FromUntaggedValue arity (C1 c U1)
1441 => FromUntaggedValue arity (C1 c U1)
1228− parseUntaggedValue opts _ (String s)
1443+ parseUntaggedValue (tname :* opts :* _) v =
1229− | s == pack (constructorTagModifier opts (conName (undefined :: t c U1 p))) =
1444+ contextCons cname tname $ case v of
1230− pure $ M1 U1
1446+ | tag == tag' -> pure $ M1 U1
1231− | otherwise =
1447+ | otherwise -> fail_ tag
1232− fail $ "Invalid tag: " ++ unpack s
1448+ _ -> typeMismatch "String" v
1233− parseUntaggedValue _ _ v = typeMismatch (conName (undefined :: t c U1 p)) v
1449+ where
1234−
1450+ tag' = pack $ constructorTagModifier opts cname
1235−
1451+ cname = conName (undefined :: M1 _i c _f _p)
1236−--------------------------------------------------------------------------------
1452+ fail_ tag = fail $
1237−
1453+ "expected tag " ++ show tag' ++ ", but found tag " ++ show tag
1238−notFound :: Text -> Parser a
1239−notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"
1240−{-# INLINE notFound #-}
1242-------------------------------------------------------------------------------
1455-------------------------------------------------------------------------------
1243-- Instances
1456-- Instances
@@ -1363,12 +1576,22 @@ instance FromJSONKey Float where
1363 _ -> Scientific.toRealFloat <$> parseScientificText t
1576 _ -> Scientific.toRealFloat <$> parseScientificText t
1365instance (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
1366− parseJSON = withObject "Rational" $ \obj -> do
1589+ objParser = withObject "Rational" $ \obj -> do
1367− numerator <- obj .: "numerator"
1590+ numerator <- obj .: "numerator"
1368− denominator <- obj .: "denominator"
1591+ denominator <- obj .: "denominator"
1369− if denominator == 0
1592+ if denominator == 0
1370− then fail "Ratio denominator was 0"
1593+ then fail "Ratio denominator was 0"
1371− else pure $ numerator % denominator
1594+ else pure $ numerator % denominator
1372 {-# INLINE parseJSON #-}
1595 {-# INLINE parseJSON #-}
1374-- | This instance includes a bounds check to prevent maliciously
1597-- | This instance includes a bounds check to prevent maliciously
@@ -1519,7 +1742,7 @@ instance FromJSON1 NonEmpty where
1519 liftParseJSON p _ = withArray "NonEmpty" $
1742 liftParseJSON p _ = withArray "NonEmpty" $
1520 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1743 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1522− ne [] = fail "parsing NonEmpty failed, unpexpected empty list"
1745+ ne [] = fail "parsing NonEmpty failed, unexpected empty list"
1523 ne (x:xs) = pure (x :| xs)
1746 ne (x:xs) = pure (x :| xs)
1524 {-# INLINE liftParseJSON #-}
1747 {-# INLINE liftParseJSON #-}
@@ -1774,7 +1997,7 @@ instance FromJSON DotNetTime where
1774 parseJSON = withText "DotNetTime" $ \t ->
1997 parseJSON = withText "DotNetTime" $ \t ->
1775 let (s,m) = T.splitAt (T.length t - 5) t
1998 let (s,m) = T.splitAt (T.length t - 5) t
1776 t' = T.concat [s,".",m]
1999 t' = T.concat [s,".",m]
1777− in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
2000+ in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
1778 Just d -> pure (DotNetTime d)
2001 Just d -> pure (DotNetTime d)
1779 _ -> fail "could not parse .NET time"
2002 _ -> fail "could not parse .NET time"
1780 {-# INLINE parseJSON #-}
2003 {-# INLINE parseJSON #-}
@@ -1783,7 +2006,6 @@ instance FromJSON DotNetTime where
1783-- primitive
2006-- primitive
1784-------------------------------------------------------------------------------
2007-------------------------------------------------------------------------------
1786−#if MIN_VERSION_base(4,7,0)
1787instance FromJSON a => FromJSON (PM.Array a) where
2009instance FromJSON a => FromJSON (PM.Array a) where
1788 -- note: we could do better than this if vector exposed the data
2010 -- note: we could do better than this if vector exposed the data
1789 -- constructor in Data.Vector.
2011 -- constructor in Data.Vector.
@@ -1796,6 +2018,7 @@ instance FromJSON a => FromJSON (PM.SmallArray a) where
1796instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where
2018instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where
1797 parseJSON = fmap Exts.fromList . parseJSON
2019 parseJSON = fmap Exts.fromList . parseJSON
2021+#if !MIN_VERSION_primitive(0,7,0)
1799instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
2022instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
1800 parseJSON = fmap Exts.fromList . parseJSON
2023 parseJSON = fmap Exts.fromList . parseJSON
@@ -1868,6 +2091,40 @@ instance FromJSON DiffTime where
1868 parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
2091 parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
1869 {-# 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
1871-------------------------------------------------------------------------------
2128-------------------------------------------------------------------------------
1872-- base Monoid/Semigroup
2129-- base Monoid/Semigroup
1873-------------------------------------------------------------------------------
2130-------------------------------------------------------------------------------