@@ -5,20 +5,16 @@
55{-# LANGUAGE FlexibleInstances #-}
66{-# LANGUAGE GADTs #-}
77{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE NamedFieldPuns #-}
98{-# LANGUAGE NoImplicitPrelude #-}
109{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
1111{-# LANGUAGE RecordWildCards #-}
1212{-# LANGUAGE ScopedTypeVariables #-}
1313{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE TypeSynonymInstances #-}
14+{-# LANGUAGE TupleSections #-}
1515{-# LANGUAGE UndecidableInstances #-}
1616{-# LANGUAGE ViewPatterns #-}
1717
18−#if __GLASGOW_HASKELL__ >= 706
19−{-# LANGUAGE PolyKinds #-}
20−#endif
21−
2218#include "incoherent-compat.h"
2319#include "overlapping-compat.h"
2420
@@ -46,6 +42,9 @@ module Data.Aeson.Types.FromJSON
4642 , coerceFromJSONKeyFunction
4743 , mapFromJSONKeyFunction
4844
45+ , GFromJSONKey()
46+ , genericFromJSONKey
47+
4948 -- * List functions
5049 , listParser
5150
@@ -68,6 +67,7 @@ module Data.Aeson.Types.FromJSON
6867 , explicitParseField
6968 , explicitParseFieldMaybe
7069 , explicitParseFieldMaybe'
70+ , parseIndexedJSON
7171 -- ** Operators
7272 , (.:)
7373 , (.:?)
@@ -87,7 +87,7 @@ import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
8787import Data.Aeson.Types.Generic
8888import Data.Aeson.Types.Internal
8989import Data.Bits (unsafeShiftR)
90−import Data.Fixed (Fixed, HasResolution)
90+import Data.Fixed (Fixed, HasResolution (resolution), Nano)
9191import Data.Functor.Compose (Compose(..))
9292import Data.Functor.Identity (Identity(..))
9393import Data.Functor.Product (Product(..))
@@ -103,8 +103,10 @@ import Data.Scientific (Scientific, base10Exponent)
103103import Data.Tagged (Tagged(..))
104104import Data.Text (Text, pack, unpack)
105105import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
106−import Data.Time.Format (parseTime)
107−import Data.Time.Locale.Compat (defaultTimeLocale)
106+import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
107+import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
108+import Data.Time.Clock.System.Compat (SystemTime (..))
109+import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)
108110import Data.Traversable as Tr (sequence)
109111import Data.Vector (Vector)
110112import Data.Version (Version, parseVersion)
@@ -116,9 +118,9 @@ import GHC.Generics
116118import Numeric.Natural (Natural)
117119import Text.ParserCombinators.ReadP (readP_to_S)
118120import Unsafe.Coerce (unsafeCoerce)
119−import qualified Data.Aeson.Compat as Compat
120121import qualified Data.Aeson.Parser.Time as Time
121122import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123+import qualified Data.ByteString.Lazy as L
122124import qualified Data.DList as DList
123125import qualified Data.HashMap.Strict as H
124126import qualified Data.HashSet as HashSet
@@ -147,22 +149,14 @@ import qualified Data.Primitive.SmallArray as PM
147149import qualified Data.Primitive.Types as PM
148150
149151#if MIN_VERSION_primitive(0,6,4)
152+#if !MIN_VERSION_primitive(0,7,0)
150153import qualified Data.Primitive.UnliftedArray as PM
154+#endif
151155import qualified Data.Primitive.PrimArray as PM
152156#endif
153157
154−#ifndef HAS_COERCIBLE
155−#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
156−#endif
157158
158−#if HAS_COERCIBLE
159159import Data.Coerce (Coercible, coerce)
160−coerce' :: Coercible a b => a -> b
161−coerce' = coerce
162−#else
163−coerce' :: a -> b
164−coerce' = unsafeCoerce
165−#endif
166160
167161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
168162parseIndexedJSON p idx value = p value <?> Index idx
@@ -293,14 +287,21 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
293287--
294288-- The basic ways to signal a failed conversion are as follows:
295289--
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;
292+--
293+-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:
294+-- use it when the error is meant to be caught by some @('<|>')@;
297295--
298−-- * 'fail' yields a custom error message;
296+-- * 'typeMismatch' can be used to report a failure when the encountered value
297+-- is not of the expected JSON type; 'unexpected' is an appropriate alternative
298+-- when more than one type may be expected, or to keep the expected type
299+-- implicit.
299300--
300−-- * 'typeMismatch' produces an informative message for cases when the
301−-- value encountered is not of the expected type.
301+-- 'prependFailure' (or 'modifyFailure') add more information to a parser's
302+-- error messages.
302303--
303−-- An example type and instance using 'typeMismatch':
304+-- An example type and instance using 'typeMismatch' and 'prependFailure':
304305--
305306-- @
306307-- \-- Allow ourselves to write 'Text' literals.
@@ -314,9 +315,11 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
314315-- '<*>' v '.:' \"y\"
315316--
316317-- \-- 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'
318319-- \-- gives a much more informative error message.
319−-- 'parseJSON' invalid = 'typeMismatch' \"Coord\" invalid
320+-- 'parseJSON' invalid =
321+-- 'prependFailure' "parsing Coord failed, "
322+-- ('typeMismatch' \"Object\" invalid)
320323-- @
321324--
322325-- 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)
359362-- @
360363--
361364-- The default implementation will be equivalent to
362−-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; If you need different
365+-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different
363366-- options, you can customize the generic decoding by defining:
364367--
365368-- @
@@ -393,6 +396,16 @@ class FromJSON a where
393396-- > newtype SomeId = SomeId { getSomeId :: Text }
394397-- > deriving (Eq,Ord,Hashable,FromJSONKey)
395398--
399+-- If you have a sum of nullary constructors, you may use the generic
400+-- implementation:
401+--
402+-- @
403+-- data Color = Red | Green | Blue
404+-- deriving Generic
405+--
406+-- instance 'FromJSONKey' Color where
407+-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'
408+-- @
396409class FromJSONKey a where
397410 -- | Strategy for parsing the key of a map-like container.
398411 fromJSONKey :: FromJSONKeyFunction a
@@ -415,11 +428,7 @@ class FromJSONKey a where
415428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
416429-- can be inspected, but cannot be constructed.
417430data CoerceText a where
418−#if HAS_COERCIBLE
419431 CoerceText :: Coercible Text a => CoerceText a
420−#else
421− CoerceText :: CoerceText a
422−#endif
423432
424433-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
425434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -439,7 +448,7 @@ data FromJSONKeyFunction a
439448
440449-- | Only law abiding up to interpretation
441450instance Functor FromJSONKeyFunction where
442− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
451+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
443452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
444453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
445454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -453,9 +462,7 @@ instance Functor FromJSONKeyFunction where
453462--
454463-- On pre GHC 7.8 this is unconstrainted function.
455464fromJSONKeyCoerce ::
456−#if HAS_COERCIBLE
457465 Coercible Text a =>
458−#endif
459466 FromJSONKeyFunction a
460467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
461468
@@ -463,34 +470,52 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
463470--
464471-- See note on 'fromJSONKeyCoerce'.
465472coerceFromJSONKeyFunction ::
466−#if HAS_COERCIBLE
467473 Coercible a b =>
468−#endif
469474 FromJSONKeyFunction a -> FromJSONKeyFunction b
470−#if HAS_COERCIBLE
471475coerceFromJSONKeyFunction = coerce
472−#else
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)
477−#endif
478476
479477{-# RULES
480478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
481479 fmap id x = x
482480 #-}
483−#if HAS_COERCIBLE
484481{-# RULES
485482 "FromJSONKeyCoerce: fmap coerce" forall x .
486483 fmap coerce x = coerceFromJSONKeyFunction x
487484 #-}
488−#endif
489485
490486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
491487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
492488mapFromJSONKeyFunction = fmap
493489
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.
493+--
494+-- See also 'genericToJSONKey'.
495+--
496+-- === __Example__
497+--
498+-- @
499+-- data Color = Red | Green | Blue
500+-- deriving 'Generic'
501+--
502+-- instance 'FromJSONKey' Color where
503+-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'
504+-- @
505+genericFromJSONKey :: forall a. (Generic a, GFromJSONKey (Rep a))
506+ => JSONKeyOptions
507+ -> FromJSONKeyFunction a
508+genericFromJSONKey opts = FromJSONKeyTextParser $ \t ->
509+ case parseSumFromString (keyModifier opts) t of
510+ Nothing -> fail $
511+ "invalid key " ++ show t ++ ", expected one of " ++ show cnames
512+ Just k -> pure (to k)
513+ where
514+ cnames = unTagged2 (constructorTags (keyModifier opts) :: Tagged2 (Rep a) [String])
515+
516+class (ConstructorNames f, SumFromString f) => GFromJSONKey f where
517+instance (ConstructorNames f, SumFromString f) => GFromJSONKey f where
518+
494519-------------------------------------------------------------------------------
495520-- Functions needed for documentation
496521-------------------------------------------------------------------------------
@@ -743,13 +768,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v
743768-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
744769-- to the 'Parser' in case of failure.
745770withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
746−withBoundedScientific_ whenFail f v@(Number scientific) =
747− if exponent > 1024
771+withBoundedScientific_ whenFail f (Number scientific) =
772+ if exp10 > 1024
748773 then whenFail (fail msg)
749774 else f scientific
750775 where
751− exponent = base10Exponent scientific
752− msg = "found a number with exponent " ++ show exponent ++ ", but it must not be greater than 1024"
776+ exp10 = base10Exponent scientific
777+ msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"
753778withBoundedScientific_ whenFail _ v =
754779 whenFail (typeMismatch "Number" v)
755780{-# INLINE withBoundedScientific_ #-}
@@ -769,7 +794,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)
769794-- | Decode a nested JSON-encoded string.
770795withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
771796withEmbeddedJSON _ innerParser (String txt) =
772− either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
797+ either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
773798 where
774799 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
775800 eitherFormatError = either (Left . uncurry formatError) Right
@@ -838,7 +863,7 @@ parseFieldMaybe' = (.:!)
838863-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
839864explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
840865explicitParseField 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"
842867 Just v -> p v <?> Key key
843868{-# INLINE explicitParseField #-}
844869
@@ -897,6 +922,16 @@ type ConName = String
897922contextType :: TypeName -> Parser a -> Parser a
898923contextType = prependContext
899924
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 ++ ", ")
934+
900935-- | Add the name of the constructor being parsed to a parser's error messages.
901936contextCons :: ConName -> TypeName -> Parser a -> Parser a
902937contextCons cname tname = prependContext (showCons cname tname)
@@ -1007,41 +1042,46 @@ parseAllNullarySum :: (SumFromString f, ConstructorNames f)
10071042parseAllNullarySum tname opts =
10081043 withText tname $ \tag ->
10091044 maybe (badTag tag) return $
1010− parseSumFromString opts tag
1045+ parseSumFromString modifier tag
10111046 where
1012− badTag tag = failWithCTags tname opts $ \cnames ->
1047+ badTag tag = failWithCTags tname modifier $ \cnames ->
10131048 "expected one of the tags " ++ show cnames ++
10141049 ", but found tag " ++ show tag
1050+ modifier = constructorTagModifier opts
10151051
10161052-- | Fail with an informative error message about a mismatched tag.
10171053-- The error message is parameterized by the list of expected tags,
10181054-- to be inferred from the result type of the parser.
10191055failWithCTags
1020− :: forall f a. ConstructorNames f
1021− => TypeName -> Options -> ([String] -> String) -> Parser (f a)
1022−failWithCTags tname opts f =
1056+ :: forall f a t. ConstructorNames f
1057+ => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)
1058+failWithCTags tname modifier f =
10231059 contextType tname . fail $ f cnames
10241060 where
1025− cnames = unTagged2 (constructorTags opts :: Tagged2 f [String])
1061+ cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])
10261062
10271063class SumFromString f where
1028− parseSumFromString :: Options -> Text -> Maybe (f a)
1064+ parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
10291065
10301066instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
10311067 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
10321068 (R1 <$> parseSumFromString opts key)
10331069
10341070instance (Constructor c) => SumFromString (C1 c U1) where
1035− parseSumFromString opts key | key == name = Just $ M1 U1
1036− | otherwise = Nothing
1037− where
1038− name = pack $ constructorTagModifier opts $
1039− conName (undefined :: M1 _i c _f _p)
1071+ parseSumFromString modifier key
1072+ | key == name = Just $ M1 U1
1073+ | otherwise = Nothing
1074+ where
1075+ name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)
1076+
1077+-- For genericFromJSONKey
1078+instance SumFromString a => SumFromString (D1 d a) where
1079+ parseSumFromString modifier key = M1 <$> parseSumFromString modifier key
10401080
10411081-- | List of all constructor tags.
1042−constructorTags :: ConstructorNames a => Options -> Tagged2 a [String]
1043−constructorTags opts =
1044− fmap DList.toList (constructorNames' (constructorTagModifier opts))
1082+constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]
1083+constructorTags modifier =
1084+ fmap DList.toList (constructorNames' modifier)
10451085
10461086-- | List of all constructor names of an ADT, after a given conversion
10471087-- function. (Better inlining.)
@@ -1062,9 +1102,16 @@ instance Constructor c => ConstructorNames (C1 c a) where
10621102 where
10631103 cname = conName (undefined :: M1 _i c _f _p)
10641104
1065−--------------------------------------------------------------------------------
1105+-- For genericFromJSONKey
1106+instance ConstructorNames a => ConstructorNames (D1 d a) where
1107+ constructorNames' = retag . constructorNames'
1108+ where
1109+ retag :: Tagged2 a u -> Tagged2 (D1 d a) u
1110+ retag (Tagged2 x) = Tagged2 x
10661111
1067−parseNonAllNullarySum :: ( FromPair arity f
1112+--------------------------------------------------------------------------------
1113+parseNonAllNullarySum :: forall f c arity.
1114+ ( FromPair arity f
10681115 , FromTaggedObject arity f
10691116 , FromUntaggedValue arity f
10701117 , ConstructorNames f
@@ -1074,7 +1121,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
10741121 case sumEncoding opts of
10751122 TaggedObject{..} ->
10761123 withObject tname $ \obj -> do
1077− tag <- contextType tname $ obj .: tagKey
1124+ tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
10781125 fromMaybe (badTag tag <?> Key tagKey) $
10791126 parseFromTaggedObject (tag :* contentsFieldName :* p) obj
10801127 where
@@ -1082,6 +1129,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
10821129 badTag tag = failWith_ $ \cnames ->
10831130 "expected tag field to be one of " ++ show cnames ++
10841131 ", but found tag " ++ show tag
1132+ cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
10851133
10861134 ObjectWithSingleField ->
10871135 withObject tname $ \obj -> case H.toList obj of
@@ -1113,7 +1161,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11131161
11141162 UntaggedValue -> parseUntaggedValue p
11151163 where
1116− failWith_ = failWithCTags tname opts
1164+ failWith_ = failWithCTags tname (constructorTagModifier opts)
11171165
11181166--------------------------------------------------------------------------------
11191167
@@ -1153,9 +1201,9 @@ class FromTaggedObject' arity f isRecord where
11531201 :: String :* ConName :* TypeName :* Options :* FromArgs arity a
11541202 -> Object -> Tagged isRecord (Parser (f a))
11551203
1156−instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where
1204+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
11571205 -- Records are unpacked in the tagged object
1158− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p
1206+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
11591207
11601208instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
11611209 -- Nonnullary nonrecords are encoded in the contents field
@@ -1196,11 +1244,11 @@ instance OVERLAPPING_
11961244 ) => ConsFromJSON' arity (S1 s a) True where
11971245 consParseJSON' p@(cname :* tname :* opts :* fargs)
11981246 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1199− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)
1247+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12001248
12011249instance RecordFromJSON arity f => ConsFromJSON' arity f True where
12021250 consParseJSON' p@(cname :* tname :* _) =
1203− Tagged . withObject (showCons cname tname) (recordParseJSON p)
1251+ Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12041252
12051253instance OVERLAPPING_
12061254 ConsFromJSON' arity U1 False where
@@ -1226,21 +1274,55 @@ instance (ProductFromJSON arity f, ProductSize f
12261274
12271275--------------------------------------------------------------------------------
12281276
1277+class FieldNames f where
1278+ fieldNames :: f a -> [Text] -> [Text]
1279+
1280+instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where
1281+ fieldNames _ =
1282+ fieldNames (undefined :: a x) .
1283+ fieldNames (undefined :: b y)
1284+
1285+instance (Selector s) => FieldNames (S1 s f) where
1286+ fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)
1287+
12291288class RecordFromJSON arity f where
12301289 recordParseJSON
1290+ :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a
1291+ -> Object -> Parser (f a)
1292+
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
1298+ where
1299+ knownFields :: H.HashMap Text ()
1300+ knownFields = H.fromList $ map (,()) $
1301+ fieldNames (undefined :: f a)
1302+ [pack (tagFieldName (sumEncoding opts)) | fromTaggedSum]
1303+ checkUnknown =
1304+ if not (rejectUnknownFields opts)
1305+ then \_ -> return ()
1306+ else \obj -> case H.keys (H.difference obj knownFields) of
1307+ [] -> return ()
1308+ unknownFields -> contextCons cname tname $
1309+ fail ("unknown fields: " ++ show unknownFields)
1310+
1311+class RecordFromJSON' arity f where
1312+ recordParseJSON'
12311313 :: ConName :* TypeName :* Options :* FromArgs arity a
12321314 -> Object -> Parser (f a)
12331315
1234−instance ( RecordFromJSON arity a
1235− , RecordFromJSON arity b
1236− ) => RecordFromJSON arity (a :*: b) where
1237− recordParseJSON p obj =
1238− (:*:) <$> recordParseJSON p obj
1239− <*> recordParseJSON p obj
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
12401322
12411323instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1242− RecordFromJSON arity (S1 s a) where
1243− recordParseJSON (cname :* tname :* opts :* fargs) obj = do
1324+ RecordFromJSON' arity (S1 s a) where
1325+ recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
12441326 fv <- contextCons cname tname (obj .: label)
12451327 M1 <$> gParseJSON opts fargs fv <?> Key label
12461328 where
@@ -1248,16 +1330,16 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
12481330 sname = selName (undefined :: M1 _i s _f _p)
12491331
12501332instance INCOHERENT_ (Selector s, FromJSON a) =>
1251− RecordFromJSON arity (S1 s (K1 i (Maybe a))) where
1252− recordParseJSON (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
1333+ RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
1334+ recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
12531335 where
12541336 label = fieldLabelModifier opts sname
12551337 sname = selName (undefined :: M1 _i s _f _p)
12561338
12571339-- Parse an Option like a Maybe.
12581340instance INCOHERENT_ (Selector s, FromJSON a) =>
1259− RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where
1260− recordParseJSON p obj = wrap <$> recordParseJSON p obj
1341+ RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
1342+ recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
12611343 where
12621344 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
12631345 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
@@ -1494,12 +1576,22 @@ instance FromJSONKey Float where
14941576 _ -> Scientific.toRealFloat <$> parseScientificText t
14951577
14961578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1497− parseJSON = withObject "Rational" $ \obj -> do
1498− numerator <- obj .: "numerator"
1499− denominator <- obj .: "denominator"
1500− if denominator == 0
1501− then fail "Ratio denominator was 0"
1502− else pure $ numerator % denominator
1579+ parseJSON (Number x)
1580+ | exp10 <= 1024
1581+ , exp10 >= -1024 = return $! realToFrac x
1582+ | otherwise = prependContext "Ratio" $ fail msg
1583+ where
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
1588+ where
1589+ objParser = withObject "Rational" $ \obj -> do
1590+ numerator <- obj .: "numerator"
1591+ denominator <- obj .: "denominator"
1592+ if denominator == 0
1593+ then fail "Ratio denominator was 0"
1594+ else pure $ numerator % denominator
15031595 {-# INLINE parseJSON #-}
15041596
15051597-- | This instance includes a bounds check to prevent maliciously
@@ -1650,7 +1742,7 @@ instance FromJSON1 NonEmpty where
16501742 liftParseJSON p _ = withArray "NonEmpty" $
16511743 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
16521744 where
1653− ne [] = fail "parsing NonEmpty failed, unpexpected empty list"
1745+ ne [] = fail "parsing NonEmpty failed, unexpected empty list"
16541746 ne (x:xs) = pure (x :| xs)
16551747 {-# INLINE liftParseJSON #-}
16561748
@@ -1905,7 +1997,7 @@ instance FromJSON DotNetTime where
19051997 parseJSON = withText "DotNetTime" $ \t ->
19061998 let (s,m) = T.splitAt (T.length t - 5) t
19071999 t' = T.concat [s,".",m]
1908− in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
2000+ in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
19092001 Just d -> pure (DotNetTime d)
19102002 _ -> fail "could not parse .NET time"
19112003 {-# INLINE parseJSON #-}
@@ -1914,7 +2006,6 @@ instance FromJSON DotNetTime where
19142006-- primitive
19152007-------------------------------------------------------------------------------
19162008
1917−#if MIN_VERSION_base(4,7,0)
19182009instance FromJSON a => FromJSON (PM.Array a) where
19192010 -- note: we could do better than this if vector exposed the data
19202011 -- constructor in Data.Vector.
@@ -1927,6 +2018,7 @@ instance FromJSON a => FromJSON (PM.SmallArray a) where
19272018instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where
19282019 parseJSON = fmap Exts.fromList . parseJSON
19292020
2021+#if !MIN_VERSION_primitive(0,7,0)
19302022instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
19312023 parseJSON = fmap Exts.fromList . parseJSON
19322024#endif
@@ -1999,6 +2091,40 @@ instance FromJSON DiffTime where
19992091 parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
20002092 {-# INLINE parseJSON #-}
20012093
2094+instance FromJSON SystemTime where
2095+ parseJSON v = prependContext "SystemTime" $ do
2096+ n <- parseJSON v
2097+ let n' = floor (n * fromInteger (resolution n) :: Nano)
2098+ let (secs, nano) = n' `divMod` resolution n
2099+ return (MkSystemTime (fromInteger secs) (fromInteger nano))
2100+
2101+instance FromJSON CalendarDiffTime where
2102+ parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime
2103+ <$> obj .: "months"
2104+ <*> obj .: "time"
2105+
2106+instance FromJSON CalendarDiffDays where
2107+ parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays
2108+ <$> obj .: "months"
2109+ <*> obj .: "days"
2110+
2111+instance FromJSON DayOfWeek where
2112+ parseJSON = withText "DaysOfWeek" parseDayOfWeek
2113+
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"
2124+
2125+instance FromJSONKey DayOfWeek where
2126+ fromJSONKey = FromJSONKeyTextParser parseDayOfWeek
2127+
20022128-------------------------------------------------------------------------------
20032129-- base Monoid/Semigroup
20042130-------------------------------------------------------------------------------