@@ -7,16 +7,14 @@
77{-# LANGUAGE MultiParamTypeClasses #-}
88{-# LANGUAGE NoImplicitPrelude #-}
99{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
1011{-# LANGUAGE RecordWildCards #-}
1112{-# LANGUAGE ScopedTypeVariables #-}
1213{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE TupleSections #-}
1315{-# LANGUAGE UndecidableInstances #-}
1416{-# LANGUAGE ViewPatterns #-}
1517
16−#if __GLASGOW_HASKELL__ >= 706
17−{-# LANGUAGE PolyKinds #-}
18−#endif
19−
2018#include "incoherent-compat.h"
2119#include "overlapping-compat.h"
2220
@@ -120,9 +118,9 @@ import GHC.Generics
120118import Numeric.Natural (Natural)
121119import Text.ParserCombinators.ReadP (readP_to_S)
122120import Unsafe.Coerce (unsafeCoerce)
123−import qualified Data.Aeson.Compat as Compat
124121import qualified Data.Aeson.Parser.Time as Time
125122import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123+import qualified Data.ByteString.Lazy as L
126124import qualified Data.DList as DList
127125import qualified Data.HashMap.Strict as H
128126import qualified Data.HashSet as HashSet
@@ -157,18 +155,8 @@ import qualified Data.Primitive.UnliftedArray as PM
157155import qualified Data.Primitive.PrimArray as PM
158156#endif
159157
160−#ifndef HAS_COERCIBLE
161−#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
162−#endif
163158
164−#if HAS_COERCIBLE
165159import Data.Coerce (Coercible, coerce)
166−coerce' :: Coercible a b => a -> b
167−coerce' = coerce
168−#else
169−coerce' :: a -> b
170−coerce' = unsafeCoerce
171−#endif
172160
173161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
174162parseIndexedJSON p idx value = p value <?> Index idx
@@ -440,11 +428,7 @@ class FromJSONKey a where
440428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
441429-- can be inspected, but cannot be constructed.
442430data CoerceText a where
443−#if HAS_COERCIBLE
444431 CoerceText :: Coercible Text a => CoerceText a
445−#else
446− CoerceText :: CoerceText a
447−#endif
448432
449433-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
450434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -464,7 +448,7 @@ data FromJSONKeyFunction a
464448
465449-- | Only law abiding up to interpretation
466450instance Functor FromJSONKeyFunction where
467− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
451+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
468452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
469453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
470454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -478,9 +462,7 @@ instance Functor FromJSONKeyFunction where
478462--
479463-- On pre GHC 7.8 this is unconstrainted function.
480464fromJSONKeyCoerce ::
481−#if HAS_COERCIBLE
482465 Coercible Text a =>
483−#endif
484466 FromJSONKeyFunction a
485467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
486468
@@ -488,29 +470,18 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
488470--
489471-- See note on 'fromJSONKeyCoerce'.
490472coerceFromJSONKeyFunction ::
491−#if HAS_COERCIBLE
492473 Coercible a b =>
493−#endif
494474 FromJSONKeyFunction a -> FromJSONKeyFunction b
495−#if HAS_COERCIBLE
496475coerceFromJSONKeyFunction = coerce
497−#else
498−coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText
499−coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)
500−coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)
501−coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)
502−#endif
503476
504477{-# RULES
505478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
506479 fmap id x = x
507480 #-}
508−#if HAS_COERCIBLE
509481{-# RULES
510482 "FromJSONKeyCoerce: fmap coerce" forall x .
511483 fmap coerce x = coerceFromJSONKeyFunction x
512484 #-}
513−#endif
514485
515486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
516487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
@@ -797,13 +768,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v
797768-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
798769-- to the 'Parser' in case of failure.
799770withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
800−withBoundedScientific_ whenFail f v@(Number scientific) =
801− if exponent > 1024
771+withBoundedScientific_ whenFail f (Number scientific) =
772+ if exp10 > 1024
802773 then whenFail (fail msg)
803774 else f scientific
804775 where
805− exponent = base10Exponent scientific
806− 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"
807778withBoundedScientific_ whenFail _ v =
808779 whenFail (typeMismatch "Number" v)
809780{-# INLINE withBoundedScientific_ #-}
@@ -823,7 +794,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)
823794-- | Decode a nested JSON-encoded string.
824795withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
825796withEmbeddedJSON _ innerParser (String txt) =
826− either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
797+ either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
827798 where
828799 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
829800 eitherFormatError = either (Left . uncurry formatError) Right
@@ -892,7 +863,7 @@ parseFieldMaybe' = (.:!)
892863-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
893864explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
894865explicitParseField p obj key = case H.lookup key obj of
895− Nothing -> fail $ "key " ++ show key ++ " not present"
866+ Nothing -> fail $ "key " ++ show key ++ " not found"
896867 Just v -> p v <?> Key key
897868{-# INLINE explicitParseField #-}
898869
@@ -951,6 +922,16 @@ type ConName = String
951922contextType :: TypeName -> Parser a -> Parser a
952923contextType = prependContext
953924
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+
954935-- | Add the name of the constructor being parsed to a parser's error messages.
955936contextCons :: ConName -> TypeName -> Parser a -> Parser a
956937contextCons cname tname = prependContext (showCons cname tname)
@@ -1129,8 +1110,8 @@ instance ConstructorNames a => ConstructorNames (D1 d a) where
11291110 retag (Tagged2 x) = Tagged2 x
11301111
11311112--------------------------------------------------------------------------------
1132−
1133−parseNonAllNullarySum :: ( FromPair arity f
1113+parseNonAllNullarySum :: forall f c arity.
1114+ ( FromPair arity f
11341115 , FromTaggedObject arity f
11351116 , FromUntaggedValue arity f
11361117 , ConstructorNames f
@@ -1140,7 +1121,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11401121 case sumEncoding opts of
11411122 TaggedObject{..} ->
11421123 withObject tname $ \obj -> do
1143− tag <- contextType tname $ obj .: tagKey
1124+ tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
11441125 fromMaybe (badTag tag <?> Key tagKey) $
11451126 parseFromTaggedObject (tag :* contentsFieldName :* p) obj
11461127 where
@@ -1148,6 +1129,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11481129 badTag tag = failWith_ $ \cnames ->
11491130 "expected tag field to be one of " ++ show cnames ++
11501131 ", but found tag " ++ show tag
1132+ cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
11511133
11521134 ObjectWithSingleField ->
11531135 withObject tname $ \obj -> case H.toList obj of
@@ -1219,9 +1201,9 @@ class FromTaggedObject' arity f isRecord where
12191201 :: String :* ConName :* TypeName :* Options :* FromArgs arity a
12201202 -> Object -> Tagged isRecord (Parser (f a))
12211203
1222−instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where
1204+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
12231205 -- Records are unpacked in the tagged object
1224− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p
1206+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
12251207
12261208instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
12271209 -- Nonnullary nonrecords are encoded in the contents field
@@ -1262,11 +1244,11 @@ instance OVERLAPPING_
12621244 ) => ConsFromJSON' arity (S1 s a) True where
12631245 consParseJSON' p@(cname :* tname :* opts :* fargs)
12641246 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1265− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)
1247+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12661248
12671249instance RecordFromJSON arity f => ConsFromJSON' arity f True where
12681250 consParseJSON' p@(cname :* tname :* _) =
1269− Tagged . withObject (showCons cname tname) (recordParseJSON p)
1251+ Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12701252
12711253instance OVERLAPPING_
12721254 ConsFromJSON' arity U1 False where
@@ -1292,21 +1274,55 @@ instance (ProductFromJSON arity f, ProductSize f
12921274
12931275--------------------------------------------------------------------------------
12941276
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+
12951288class RecordFromJSON arity f where
12961289 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'
12971313 :: ConName :* TypeName :* Options :* FromArgs arity a
12981314 -> Object -> Parser (f a)
12991315
1300−instance ( RecordFromJSON arity a
1301− , RecordFromJSON arity b
1302− ) => RecordFromJSON arity (a :*: b) where
1303− recordParseJSON p obj =
1304− (:*:) <$> recordParseJSON p obj
1305− <*> 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
13061322
13071323instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1308− RecordFromJSON arity (S1 s a) where
1309− recordParseJSON (cname :* tname :* opts :* fargs) obj = do
1324+ RecordFromJSON' arity (S1 s a) where
1325+ recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
13101326 fv <- contextCons cname tname (obj .: label)
13111327 M1 <$> gParseJSON opts fargs fv <?> Key label
13121328 where
@@ -1314,16 +1330,16 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
13141330 sname = selName (undefined :: M1 _i s _f _p)
13151331
13161332instance INCOHERENT_ (Selector s, FromJSON a) =>
1317− RecordFromJSON arity (S1 s (K1 i (Maybe a))) where
1318− 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
13191335 where
13201336 label = fieldLabelModifier opts sname
13211337 sname = selName (undefined :: M1 _i s _f _p)
13221338
13231339-- Parse an Option like a Maybe.
13241340instance INCOHERENT_ (Selector s, FromJSON a) =>
1325− RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where
1326− 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
13271343 where
13281344 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
13291345 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
@@ -1560,12 +1576,22 @@ instance FromJSONKey Float where
15601576 _ -> Scientific.toRealFloat <$> parseScientificText t
15611577
15621578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1563− parseJSON = withObject "Rational" $ \obj -> do
1564− numerator <- obj .: "numerator"
1565− denominator <- obj .: "denominator"
1566− if denominator == 0
1567− then fail "Ratio denominator was 0"
1568− 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
15691595 {-# INLINE parseJSON #-}
15701596
15711597-- | This instance includes a bounds check to prevent maliciously
@@ -1980,7 +2006,6 @@ instance FromJSON DotNetTime where
19802006-- primitive
19812007-------------------------------------------------------------------------------
19822008
1983−#if MIN_VERSION_base(4,7,0)
19842009instance FromJSON a => FromJSON (PM.Array a) where
19852010 -- note: we could do better than this if vector exposed the data
19862011 -- constructor in Data.Vector.
@@ -1998,7 +2023,6 @@ instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
19982023 parseJSON = fmap Exts.fromList . parseJSON
19992024#endif
20002025#endif
2001−#endif
20022026
20032027-------------------------------------------------------------------------------
20042028-- time