@@ -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
@@ -705,7 +676,6 @@ instance (FromJSON a) => FromJSON [a] where
705676prependContext :: String -> Parser a -> Parser a
706677prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")
707678
708−
709679-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@
710680-- is an 'Data.Aeson.Object' and fails otherwise.
711681--
@@ -798,13 +768,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v
798768-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
799769-- to the 'Parser' in case of failure.
800770withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
801−withBoundedScientific_ whenFail f v@(Number scientific) =
802− if exponent > 1024
771+withBoundedScientific_ whenFail f (Number scientific) =
772+ if exp10 > 1024
803773 then whenFail (fail msg)
804774 else f scientific
805775 where
806− exponent = base10Exponent scientific
807− 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"
808778withBoundedScientific_ whenFail _ v =
809779 whenFail (typeMismatch "Number" v)
810780{-# INLINE withBoundedScientific_ #-}
@@ -824,7 +794,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)
824794-- | Decode a nested JSON-encoded string.
825795withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
826796withEmbeddedJSON _ innerParser (String txt) =
827− either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
797+ either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
828798 where
829799 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
830800 eitherFormatError = either (Left . uncurry formatError) Right
@@ -893,7 +863,7 @@ parseFieldMaybe' = (.:!)
893863-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
894864explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
895865explicitParseField p obj key = case H.lookup key obj of
896− Nothing -> fail $ "key " ++ show key ++ " not present"
866+ Nothing -> fail $ "key " ++ show key ++ " not found"
897867 Just v -> p v <?> Key key
898868{-# INLINE explicitParseField #-}
899869
@@ -952,8 +922,6 @@ type ConName = String
952922contextType :: TypeName -> Parser a -> Parser a
953923contextType = prependContext
954924
955−
956−
957925-- | Add the tagKey that will be looked up while building an ADT
958926-- | Produce the error equivalent to
959927-- | Left "Error in $: parsing T failed, expected an object with keys "tag" and
@@ -961,9 +929,8 @@ contextType = prependContext
961929-- | The parser returned error was: could not find key "tag"
962930contextTag :: Text -> [String] -> Parser a -> Parser a
963931contextTag tagKey cnames = prependFailure
964− ("expected an object with key \"" ++ unpack tagKey ++
965− "\" where \"tag\" is associated to one of " ++ show cnames ++
966− ". The parser returned error was: ")
932+ ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++
933+ " containing one of " ++ show cnames ++ ", ")
967934
968935-- | Add the name of the constructor being parsed to a parser's error messages.
969936contextCons :: ConName -> TypeName -> Parser a -> Parser a
@@ -1154,17 +1121,15 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11541121 case sumEncoding opts of
11551122 TaggedObject{..} ->
11561123 withObject tname $ \obj -> do
1157− tag <- (contextType tname) . (contextTag tagKey cnames_) $ obj .: tagKey
1124+ tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
11581125 fromMaybe (badTag tag <?> Key tagKey) $
1159− parseFromTaggedObject (tag :* contentsFieldName :* p) obj
1126+ parseFromTaggedObject (tag :* contentsFieldName :* p) obj
11601127 where
11611128 tagKey = pack tagFieldName
11621129 badTag tag = failWith_ $ \cnames ->
11631130 "expected tag field to be one of " ++ show cnames ++
11641131 ", but found tag " ++ show tag
11651132 cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
1166− --cname_ = conName (undefined :: M1 _i c _f _p)
1167− -- forall f a. ConstructorNames f
11681133
11691134 ObjectWithSingleField ->
11701135 withObject tname $ \obj -> case H.toList obj of
@@ -1236,9 +1201,9 @@ class FromTaggedObject' arity f isRecord where
12361201 :: String :* ConName :* TypeName :* Options :* FromArgs arity a
12371202 -> Object -> Tagged isRecord (Parser (f a))
12381203
1239−instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where
1204+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
12401205 -- Records are unpacked in the tagged object
1241− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p
1206+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
12421207
12431208instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
12441209 -- Nonnullary nonrecords are encoded in the contents field
@@ -1279,11 +1244,11 @@ instance OVERLAPPING_
12791244 ) => ConsFromJSON' arity (S1 s a) True where
12801245 consParseJSON' p@(cname :* tname :* opts :* fargs)
12811246 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1282− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)
1247+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12831248
12841249instance RecordFromJSON arity f => ConsFromJSON' arity f True where
12851250 consParseJSON' p@(cname :* tname :* _) =
1286− Tagged . withObject (showCons cname tname) (recordParseJSON p)
1251+ Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12871252
12881253instance OVERLAPPING_
12891254 ConsFromJSON' arity U1 False where
@@ -1309,21 +1274,55 @@ instance (ProductFromJSON arity f, ProductSize f
13091274
13101275--------------------------------------------------------------------------------
13111276
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+
13121288class RecordFromJSON arity f where
13131289 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'
13141313 :: ConName :* TypeName :* Options :* FromArgs arity a
13151314 -> Object -> Parser (f a)
13161315
1317−instance ( RecordFromJSON arity a
1318− , RecordFromJSON arity b
1319− ) => RecordFromJSON arity (a :*: b) where
1320− recordParseJSON p obj =
1321− (:*:) <$> recordParseJSON p obj
1322− <*> 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
13231322
13241323instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1325− RecordFromJSON arity (S1 s a) where
1326− recordParseJSON (cname :* tname :* opts :* fargs) obj = do
1324+ RecordFromJSON' arity (S1 s a) where
1325+ recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
13271326 fv <- contextCons cname tname (obj .: label)
13281327 M1 <$> gParseJSON opts fargs fv <?> Key label
13291328 where
@@ -1331,16 +1330,16 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
13311330 sname = selName (undefined :: M1 _i s _f _p)
13321331
13331332instance INCOHERENT_ (Selector s, FromJSON a) =>
1334− RecordFromJSON arity (S1 s (K1 i (Maybe a))) where
1335− 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
13361335 where
13371336 label = fieldLabelModifier opts sname
13381337 sname = selName (undefined :: M1 _i s _f _p)
13391338
13401339-- Parse an Option like a Maybe.
13411340instance INCOHERENT_ (Selector s, FromJSON a) =>
1342− RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where
1343− 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
13441343 where
13451344 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
13461345 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
@@ -1577,12 +1576,22 @@ instance FromJSONKey Float where
15771576 _ -> Scientific.toRealFloat <$> parseScientificText t
15781577
15791578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1580− parseJSON = withObject "Rational" $ \obj -> do
1581− numerator <- obj .: "numerator"
1582− denominator <- obj .: "denominator"
1583− if denominator == 0
1584− then fail "Ratio denominator was 0"
1585− 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
15861595 {-# INLINE parseJSON #-}
15871596
15881597-- | This instance includes a bounds check to prevent maliciously
@@ -1997,7 +2006,6 @@ instance FromJSON DotNetTime where
19972006-- primitive
19982007-------------------------------------------------------------------------------
19992008
2000−#if MIN_VERSION_base(4,7,0)
20012009instance FromJSON a => FromJSON (PM.Array a) where
20022010 -- note: we could do better than this if vector exposed the data
20032011 -- constructor in Data.Vector.
@@ -2015,7 +2023,6 @@ instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
20152023 parseJSON = fmap Exts.fromList . parseJSON
20162024#endif
20172025#endif
2018−#endif
20192026
20202027-------------------------------------------------------------------------------
20212028-- time