@@ -5,16 +5,20 @@
55{-# LANGUAGE FlexibleInstances #-}
66{-# LANGUAGE GADTs #-}
77{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE NamedFieldPuns #-}
89{-# LANGUAGE NoImplicitPrelude #-}
910{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
1111{-# LANGUAGE RecordWildCards #-}
1212{-# LANGUAGE ScopedTypeVariables #-}
1313{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeSynonymInstances #-}
1515{-# LANGUAGE UndecidableInstances #-}
1616{-# LANGUAGE ViewPatterns #-}
1717
18+#if __GLASGOW_HASKELL__ >= 706
19+{-# LANGUAGE PolyKinds #-}
20+#endif
21+
1822#include "incoherent-compat.h"
1923#include "overlapping-compat.h"
2024
@@ -42,9 +46,6 @@ module Data.Aeson.Types.FromJSON
4246 , coerceFromJSONKeyFunction
4347 , mapFromJSONKeyFunction
4448
45− , GFromJSONKey()
46− , genericFromJSONKey
47−
4849 -- * List functions
4950 , listParser
5051
@@ -67,7 +68,6 @@ module Data.Aeson.Types.FromJSON
6768 , explicitParseField
6869 , explicitParseFieldMaybe
6970 , 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 (resolution), Nano)
90+import Data.Fixed (Fixed, HasResolution)
9191import Data.Functor.Compose (Compose(..))
9292import Data.Functor.Identity (Identity(..))
9393import Data.Functor.Product (Product(..))
@@ -103,10 +103,8 @@ 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.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)
106+import Data.Time.Format (parseTime)
107+import Data.Time.Locale.Compat (defaultTimeLocale)
110108import Data.Traversable as Tr (sequence)
111109import Data.Vector (Vector)
112110import Data.Version (Version, parseVersion)
@@ -118,9 +116,9 @@ import GHC.Generics
118116import Numeric.Natural (Natural)
119117import Text.ParserCombinators.ReadP (readP_to_S)
120118import Unsafe.Coerce (unsafeCoerce)
119+import qualified Data.Aeson.Compat as Compat
121120import qualified Data.Aeson.Parser.Time as Time
122121import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123−import qualified Data.ByteString.Lazy as L
124122import qualified Data.DList as DList
125123import qualified Data.HashMap.Strict as H
126124import qualified Data.HashSet as HashSet
@@ -149,14 +147,22 @@ import qualified Data.Primitive.SmallArray as PM
149147import qualified Data.Primitive.Types as PM
150148
151149#if MIN_VERSION_primitive(0,6,4)
152−#if !MIN_VERSION_primitive(0,7,0)
153150import qualified Data.Primitive.UnliftedArray as PM
154−#endif
155151import qualified Data.Primitive.PrimArray as PM
156152#endif
157153
154+#ifndef HAS_COERCIBLE
155+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
156+#endif
158157
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
160166
161167parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
162168parseIndexedJSON p idx value = p value <?> Index idx
@@ -287,21 +293,14 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
287293--
288294-- The basic ways to signal a failed conversion are as follows:
289295--
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 @('<|>')@;
296+-- * 'empty' and 'mzero' work, but are terse and uninformative;
295297--
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.
298+-- * 'fail' yields a custom error message;
300299--
301−-- 'prependFailure' (or 'modifyFailure') add more information to a parser's
302−-- error messages.
300+-- * 'typeMismatch' produces an informative message for cases when the
301+-- value encountered is not of the expected type.
303302--
304−-- An example type and instance using 'typeMismatch' and 'prependFailure':
303+-- An example type and instance using 'typeMismatch':
305304--
306305-- @
307306-- \-- Allow ourselves to write 'Text' literals.
@@ -315,11 +314,9 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
315314-- '<*>' v '.:' \"y\"
316315--
317316-- \-- We do not expect a non-'Object' value here.
318−-- \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'
317+-- \-- We could use 'mzero' to fail, but 'typeMismatch'
319318-- \-- gives a much more informative error message.
320−-- 'parseJSON' invalid =
321−-- 'prependFailure' "parsing Coord failed, "
322−-- ('typeMismatch' \"Object\" invalid)
319+-- 'parseJSON' invalid = 'typeMismatch' \"Coord\" invalid
323320-- @
324321--
325322-- For this common case of only being concerned with a single
@@ -362,7 +359,7 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)
362359-- @
363360--
364361-- The default implementation will be equivalent to
365−-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different
362+-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; If you need different
366363-- options, you can customize the generic decoding by defining:
367364--
368365-- @
@@ -396,16 +393,6 @@ class FromJSON a where
396393-- > newtype SomeId = SomeId { getSomeId :: Text }
397394-- > deriving (Eq,Ord,Hashable,FromJSONKey)
398395--
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−-- @
409396class FromJSONKey a where
410397 -- | Strategy for parsing the key of a map-like container.
411398 fromJSONKey :: FromJSONKeyFunction a
@@ -428,7 +415,11 @@ class FromJSONKey a where
428415-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
429416-- can be inspected, but cannot be constructed.
430417data CoerceText a where
418+#if HAS_COERCIBLE
431419 CoerceText :: Coercible Text a => CoerceText a
420+#else
421+ CoerceText :: CoerceText a
422+#endif
432423
433424-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
434425-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -448,7 +439,7 @@ data FromJSONKeyFunction a
448439
449440-- | Only law abiding up to interpretation
450441instance Functor FromJSONKeyFunction where
451− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
442+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
452443 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
453444 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
454445 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -462,7 +453,9 @@ instance Functor FromJSONKeyFunction where
462453--
463454-- On pre GHC 7.8 this is unconstrainted function.
464455fromJSONKeyCoerce ::
456+#if HAS_COERCIBLE
465457 Coercible Text a =>
458+#endif
466459 FromJSONKeyFunction a
467460fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
468461
@@ -470,52 +463,34 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
470463--
471464-- See note on 'fromJSONKeyCoerce'.
472465coerceFromJSONKeyFunction ::
466+#if HAS_COERCIBLE
473467 Coercible a b =>
468+#endif
474469 FromJSONKeyFunction a -> FromJSONKeyFunction b
470+#if HAS_COERCIBLE
475471coerceFromJSONKeyFunction = 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
476478
477479{-# RULES
478480 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
479481 fmap id x = x
480482 #-}
483+#if HAS_COERCIBLE
481484{-# RULES
482485 "FromJSONKeyCoerce: fmap coerce" forall x .
483486 fmap coerce x = coerceFromJSONKeyFunction x
484487 #-}
488+#endif
485489
486490-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
487491mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
488492mapFromJSONKeyFunction = fmap
489493
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−
519494-------------------------------------------------------------------------------
520495-- Functions needed for documentation
521496-------------------------------------------------------------------------------
@@ -768,13 +743,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v
768743-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
769744-- to the 'Parser' in case of failure.
770745withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
771−withBoundedScientific_ whenFail f (Number scientific) =
772− if exp10 > 1024
746+withBoundedScientific_ whenFail f v@(Number scientific) =
747+ if exponent > 1024
773748 then whenFail (fail msg)
774749 else f scientific
775750 where
776− exp10 = base10Exponent scientific
777− msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"
751+ exponent = base10Exponent scientific
752+ msg = "found a number with exponent " ++ show exponent ++ ", but it must not be greater than 1024"
778753withBoundedScientific_ whenFail _ v =
779754 whenFail (typeMismatch "Number" v)
780755{-# INLINE withBoundedScientific_ #-}
@@ -794,7 +769,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)
794769-- | Decode a nested JSON-encoded string.
795770withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
796771withEmbeddedJSON _ innerParser (String txt) =
797− either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
772+ either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
798773 where
799774 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
800775 eitherFormatError = either (Left . uncurry formatError) Right
@@ -863,7 +838,7 @@ parseFieldMaybe' = (.:!)
863838-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
864839explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
865840explicitParseField p obj key = case H.lookup key obj of
866− Nothing -> fail $ "key " ++ show key ++ " not found"
841+ Nothing -> fail $ "key " ++ show key ++ " not present"
867842 Just v -> p v <?> Key key
868843{-# INLINE explicitParseField #-}
869844
@@ -922,16 +897,6 @@ type ConName = String
922897contextType :: TypeName -> Parser a -> Parser a
923898contextType = prependContext
924899
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−
935900-- | Add the name of the constructor being parsed to a parser's error messages.
936901contextCons :: ConName -> TypeName -> Parser a -> Parser a
937902contextCons cname tname = prependContext (showCons cname tname)
@@ -1042,46 +1007,41 @@ parseAllNullarySum :: (SumFromString f, ConstructorNames f)
10421007parseAllNullarySum tname opts =
10431008 withText tname $ \tag ->
10441009 maybe (badTag tag) return $
1045− parseSumFromString modifier tag
1010+ parseSumFromString opts tag
10461011 where
1047− badTag tag = failWithCTags tname modifier $ \cnames ->
1012+ badTag tag = failWithCTags tname opts $ \cnames ->
10481013 "expected one of the tags " ++ show cnames ++
10491014 ", but found tag " ++ show tag
1050− modifier = constructorTagModifier opts
10511015
10521016-- | Fail with an informative error message about a mismatched tag.
10531017-- The error message is parameterized by the list of expected tags,
10541018-- to be inferred from the result type of the parser.
10551019failWithCTags
1056− :: forall f a t. ConstructorNames f
1057− => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)
1058−failWithCTags tname modifier f =
1020+ :: forall f a. ConstructorNames f
1021+ => TypeName -> Options -> ([String] -> String) -> Parser (f a)
1022+failWithCTags tname opts f =
10591023 contextType tname . fail $ f cnames
10601024 where
1061− cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])
1025+ cnames = unTagged2 (constructorTags opts :: Tagged2 f [String])
10621026
10631027class SumFromString f where
1064− parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
1028+ parseSumFromString :: Options -> Text -> Maybe (f a)
10651029
10661030instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
10671031 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
10681032 (R1 <$> parseSumFromString opts key)
10691033
10701034instance (Constructor c) => SumFromString (C1 c U1) where
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
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)
10801040
10811041-- | List of all constructor tags.
1082−constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]
1083−constructorTags modifier =
1084− fmap DList.toList (constructorNames' modifier)
1042+constructorTags :: ConstructorNames a => Options -> Tagged2 a [String]
1043+constructorTags opts =
1044+ fmap DList.toList (constructorNames' (constructorTagModifier opts))
10851045
10861046-- | List of all constructor names of an ADT, after a given conversion
10871047-- function. (Better inlining.)
@@ -1102,16 +1062,9 @@ instance Constructor c => ConstructorNames (C1 c a) where
11021062 where
11031063 cname = conName (undefined :: M1 _i c _f _p)
11041064
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
1111−
11121065--------------------------------------------------------------------------------
1113−parseNonAllNullarySum :: forall f c arity.
1114− ( FromPair arity f
1066+
1067+parseNonAllNullarySum :: ( FromPair arity f
11151068 , FromTaggedObject arity f
11161069 , FromUntaggedValue arity f
11171070 , ConstructorNames f
@@ -1121,7 +1074,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11211074 case sumEncoding opts of
11221075 TaggedObject{..} ->
11231076 withObject tname $ \obj -> do
1124− tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
1077+ tag <- contextType tname $ obj .: tagKey
11251078 fromMaybe (badTag tag <?> Key tagKey) $
11261079 parseFromTaggedObject (tag :* contentsFieldName :* p) obj
11271080 where
@@ -1129,7 +1082,6 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11291082 badTag tag = failWith_ $ \cnames ->
11301083 "expected tag field to be one of " ++ show cnames ++
11311084 ", but found tag " ++ show tag
1132− cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
11331085
11341086 ObjectWithSingleField ->
11351087 withObject tname $ \obj -> case H.toList obj of
@@ -1161,7 +1113,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11611113
11621114 UntaggedValue -> parseUntaggedValue p
11631115 where
1164− failWith_ = failWithCTags tname (constructorTagModifier opts)
1116+ failWith_ = failWithCTags tname opts
11651117
11661118--------------------------------------------------------------------------------
11671119
@@ -1201,9 +1153,9 @@ class FromTaggedObject' arity f isRecord where
12011153 :: String :* ConName :* TypeName :* Options :* FromArgs arity a
12021154 -> Object -> Tagged isRecord (Parser (f a))
12031155
1204−instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
1156+instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where
12051157 -- Records are unpacked in the tagged object
1206− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
1158+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p
12071159
12081160instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
12091161 -- Nonnullary nonrecords are encoded in the contents field
@@ -1244,11 +1196,11 @@ instance OVERLAPPING_
12441196 ) => ConsFromJSON' arity (S1 s a) True where
12451197 consParseJSON' p@(cname :* tname :* opts :* fargs)
12461198 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1247− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
1199+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)
12481200
12491201instance RecordFromJSON arity f => ConsFromJSON' arity f True where
12501202 consParseJSON' p@(cname :* tname :* _) =
1251− Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
1203+ Tagged . withObject (showCons cname tname) (recordParseJSON p)
12521204
12531205instance OVERLAPPING_
12541206 ConsFromJSON' arity U1 False where
@@ -1274,55 +1226,21 @@ instance (ProductFromJSON arity f, ProductSize f
12741226
12751227--------------------------------------------------------------------------------
12761228
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−
12881229class RecordFromJSON arity f where
12891230 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'
13131231 :: ConName :* TypeName :* Options :* FromArgs arity a
13141232 -> Object -> Parser (f a)
13151233
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
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
13221240
13231241instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1324− RecordFromJSON' arity (S1 s a) where
1325− recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
1242+ RecordFromJSON arity (S1 s a) where
1243+ recordParseJSON (cname :* tname :* opts :* fargs) obj = do
13261244 fv <- contextCons cname tname (obj .: label)
13271245 M1 <$> gParseJSON opts fargs fv <?> Key label
13281246 where
@@ -1330,16 +1248,16 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
13301248 sname = selName (undefined :: M1 _i s _f _p)
13311249
13321250instance INCOHERENT_ (Selector s, FromJSON a) =>
1333− RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
1334− recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
1251+ RecordFromJSON arity (S1 s (K1 i (Maybe a))) where
1252+ recordParseJSON (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
13351253 where
13361254 label = fieldLabelModifier opts sname
13371255 sname = selName (undefined :: M1 _i s _f _p)
13381256
13391257-- Parse an Option like a Maybe.
13401258instance INCOHERENT_ (Selector s, FromJSON a) =>
1341− RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
1342− recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
1259+ RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where
1260+ recordParseJSON p obj = wrap <$> recordParseJSON p obj
13431261 where
13441262 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
13451263 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
@@ -1576,22 +1494,12 @@ instance FromJSONKey Float where
15761494 _ -> Scientific.toRealFloat <$> parseScientificText t
15771495
15781496instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
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
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
15951503 {-# INLINE parseJSON #-}
15961504
15971505-- | This instance includes a bounds check to prevent maliciously
@@ -1742,7 +1650,7 @@ instance FromJSON1 NonEmpty where
17421650 liftParseJSON p _ = withArray "NonEmpty" $
17431651 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
17441652 where
1745− ne [] = fail "parsing NonEmpty failed, unexpected empty list"
1653+ ne [] = fail "parsing NonEmpty failed, unpexpected empty list"
17461654 ne (x:xs) = pure (x :| xs)
17471655 {-# INLINE liftParseJSON #-}
17481656
@@ -1997,7 +1905,7 @@ instance FromJSON DotNetTime where
19971905 parseJSON = withText "DotNetTime" $ \t ->
19981906 let (s,m) = T.splitAt (T.length t - 5) t
19991907 t' = T.concat [s,".",m]
2000− in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
1908+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
20011909 Just d -> pure (DotNetTime d)
20021910 _ -> fail "could not parse .NET time"
20031911 {-# INLINE parseJSON #-}
@@ -2006,6 +1914,7 @@ instance FromJSON DotNetTime where
20061914-- primitive
20071915-------------------------------------------------------------------------------
20081916
1917+#if MIN_VERSION_base(4,7,0)
20091918instance FromJSON a => FromJSON (PM.Array a) where
20101919 -- note: we could do better than this if vector exposed the data
20111920 -- constructor in Data.Vector.
@@ -2018,7 +1927,6 @@ instance FromJSON a => FromJSON (PM.SmallArray a) where
20181927instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where
20191928 parseJSON = fmap Exts.fromList . parseJSON
20201929
2021−#if !MIN_VERSION_primitive(0,7,0)
20221930instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
20231931 parseJSON = fmap Exts.fromList . parseJSON
20241932#endif
@@ -2091,40 +1999,6 @@ instance FromJSON DiffTime where
20911999 parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
20922000 {-# INLINE parseJSON #-}
20932001
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−
21282002-------------------------------------------------------------------------------
21292003-- base Monoid/Semigroup
21302004-------------------------------------------------------------------------------