@@ -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
@@ -25,7 +23,6 @@
2523
2624module Data.Aeson.Types.FromJSON
2725 (
28−
2926 -- * Core JSON classes
3027 FromJSON(..)
3128 -- * Liftings to unary and binary type constructors
@@ -121,9 +118,9 @@ import GHC.Generics
121118import Numeric.Natural (Natural)
122119import Text.ParserCombinators.ReadP (readP_to_S)
123120import Unsafe.Coerce (unsafeCoerce)
124−import qualified Data.Aeson.Compat as Compat
125121import qualified Data.Aeson.Parser.Time as Time
126122import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123+import qualified Data.ByteString.Lazy as L
127124import qualified Data.DList as DList
128125import qualified Data.HashMap.Strict as H
129126import qualified Data.HashSet as HashSet
@@ -158,18 +155,8 @@ import qualified Data.Primitive.UnliftedArray as PM
158155import qualified Data.Primitive.PrimArray as PM
159156#endif
160157
161−#ifndef HAS_COERCIBLE
162−#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
163−#endif
164158
165−#if HAS_COERCIBLE
166159import Data.Coerce (Coercible, coerce)
167−coerce' :: Coercible a b => a -> b
168−coerce' = coerce
169−#else
170−coerce' :: a -> b
171−coerce' = unsafeCoerce
172−#endif
173160
174161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
175162parseIndexedJSON p idx value = p value <?> Index idx
@@ -441,11 +428,7 @@ class FromJSONKey a where
441428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
442429-- can be inspected, but cannot be constructed.
443430data CoerceText a where
444−#if HAS_COERCIBLE
445431 CoerceText :: Coercible Text a => CoerceText a
446−#else
447− CoerceText :: CoerceText a
448−#endif
449432
450433-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
451434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -465,7 +448,7 @@ data FromJSONKeyFunction a
465448
466449-- | Only law abiding up to interpretation
467450instance Functor FromJSONKeyFunction where
468− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
451+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
469452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
470453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
471454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -479,9 +462,7 @@ instance Functor FromJSONKeyFunction where
479462--
480463-- On pre GHC 7.8 this is unconstrainted function.
481464fromJSONKeyCoerce ::
482−#if HAS_COERCIBLE
483465 Coercible Text a =>
484−#endif
485466 FromJSONKeyFunction a
486467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
487468
@@ -489,29 +470,18 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
489470--
490471-- See note on 'fromJSONKeyCoerce'.
491472coerceFromJSONKeyFunction ::
492−#if HAS_COERCIBLE
493473 Coercible a b =>
494−#endif
495474 FromJSONKeyFunction a -> FromJSONKeyFunction b
496−#if HAS_COERCIBLE
497475coerceFromJSONKeyFunction = coerce
498−#else
499−coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText
500−coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)
501−coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)
502−coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)
503−#endif
504476
505477{-# RULES
506478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
507479 fmap id x = x
508480 #-}
509−#if HAS_COERCIBLE
510481{-# RULES
511482 "FromJSONKeyCoerce: fmap coerce" forall x .
512483 fmap coerce x = coerceFromJSONKeyFunction x
513484 #-}
514−#endif
515485
516486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
517487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
@@ -706,7 +676,6 @@ instance (FromJSON a) => FromJSON [a] where
706676prependContext :: String -> Parser a -> Parser a
707677prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")
708678
709−
710679-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@
711680-- is an 'Data.Aeson.Object' and fails otherwise.
712681--
@@ -799,13 +768,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v
799768-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
800769-- to the 'Parser' in case of failure.
801770withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
802−withBoundedScientific_ whenFail f v@(Number scientific) =
803− if exponent > 1024
771+withBoundedScientific_ whenFail f (Number scientific) =
772+ if exp10 > 1024
804773 then whenFail (fail msg)
805774 else f scientific
806775 where
807− exponent = base10Exponent scientific
808− 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"
809778withBoundedScientific_ whenFail _ v =
810779 whenFail (typeMismatch "Number" v)
811780{-# INLINE withBoundedScientific_ #-}
@@ -825,7 +794,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)
825794-- | Decode a nested JSON-encoded string.
826795withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
827796withEmbeddedJSON _ innerParser (String txt) =
828− either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
797+ either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
829798 where
830799 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
831800 eitherFormatError = either (Left . uncurry formatError) Right
@@ -894,7 +863,7 @@ parseFieldMaybe' = (.:!)
894863-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
895864explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
896865explicitParseField p obj key = case H.lookup key obj of
897− Nothing -> fail $ "key " ++ show key ++ " not present"
866+ Nothing -> fail $ "key " ++ show key ++ " not found"
898867 Just v -> p v <?> Key key
899868{-# INLINE explicitParseField #-}
900869
@@ -961,7 +930,7 @@ contextType = prependContext
961930contextTag :: Text -> [String] -> Parser a -> Parser a
962931contextTag tagKey cnames = prependFailure
963932 ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++
964− " associated to one of " ++ show cnames ++ ", ")
933+ " containing one of " ++ show cnames ++ ", ")
965934
966935-- | Add the name of the constructor being parsed to a parser's error messages.
967936contextCons :: ConName -> TypeName -> Parser a -> Parser a
@@ -1154,7 +1123,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11541123 withObject tname $ \obj -> do
11551124 tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
11561125 fromMaybe (badTag tag <?> Key tagKey) $
1157− parseFromTaggedObject (tag :* contentsFieldName :* p) obj
1126+ parseFromTaggedObject (tag :* contentsFieldName :* p) obj
11581127 where
11591128 tagKey = pack tagFieldName
11601129 badTag tag = failWith_ $ \cnames ->
@@ -1232,9 +1201,9 @@ class FromTaggedObject' arity f isRecord where
12321201 :: String :* ConName :* TypeName :* Options :* FromArgs arity a
12331202 -> Object -> Tagged isRecord (Parser (f a))
12341203
1235−instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where
1204+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
12361205 -- Records are unpacked in the tagged object
1237− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p
1206+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
12381207
12391208instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
12401209 -- Nonnullary nonrecords are encoded in the contents field
@@ -1275,11 +1244,11 @@ instance OVERLAPPING_
12751244 ) => ConsFromJSON' arity (S1 s a) True where
12761245 consParseJSON' p@(cname :* tname :* opts :* fargs)
12771246 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1278− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)
1247+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12791248
12801249instance RecordFromJSON arity f => ConsFromJSON' arity f True where
12811250 consParseJSON' p@(cname :* tname :* _) =
1282− Tagged . withObject (showCons cname tname) (recordParseJSON p)
1251+ Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12831252
12841253instance OVERLAPPING_
12851254 ConsFromJSON' arity U1 False where
@@ -1305,21 +1274,55 @@ instance (ProductFromJSON arity f, ProductSize f
13051274
13061275--------------------------------------------------------------------------------
13071276
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+
13081288class RecordFromJSON arity f where
13091289 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'
13101313 :: ConName :* TypeName :* Options :* FromArgs arity a
13111314 -> Object -> Parser (f a)
13121315
1313−instance ( RecordFromJSON arity a
1314− , RecordFromJSON arity b
1315− ) => RecordFromJSON arity (a :*: b) where
1316− recordParseJSON p obj =
1317− (:*:) <$> recordParseJSON p obj
1318− <*> 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
13191322
13201323instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1321− RecordFromJSON arity (S1 s a) where
1322− recordParseJSON (cname :* tname :* opts :* fargs) obj = do
1324+ RecordFromJSON' arity (S1 s a) where
1325+ recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
13231326 fv <- contextCons cname tname (obj .: label)
13241327 M1 <$> gParseJSON opts fargs fv <?> Key label
13251328 where
@@ -1327,16 +1330,16 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
13271330 sname = selName (undefined :: M1 _i s _f _p)
13281331
13291332instance INCOHERENT_ (Selector s, FromJSON a) =>
1330− RecordFromJSON arity (S1 s (K1 i (Maybe a))) where
1331− 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
13321335 where
13331336 label = fieldLabelModifier opts sname
13341337 sname = selName (undefined :: M1 _i s _f _p)
13351338
13361339-- Parse an Option like a Maybe.
13371340instance INCOHERENT_ (Selector s, FromJSON a) =>
1338− RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where
1339− 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
13401343 where
13411344 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
13421345 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
@@ -1573,12 +1576,22 @@ instance FromJSONKey Float where
15731576 _ -> Scientific.toRealFloat <$> parseScientificText t
15741577
15751578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1576− parseJSON = withObject "Rational" $ \obj -> do
1577− numerator <- obj .: "numerator"
1578− denominator <- obj .: "denominator"
1579− if denominator == 0
1580− then fail "Ratio denominator was 0"
1581− 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
15821595 {-# INLINE parseJSON #-}
15831596
15841597-- | This instance includes a bounds check to prevent maliciously
@@ -1993,7 +2006,6 @@ instance FromJSON DotNetTime where
19932006-- primitive
19942007-------------------------------------------------------------------------------
19952008
1996−#if MIN_VERSION_base(4,7,0)
19972009instance FromJSON a => FromJSON (PM.Array a) where
19982010 -- note: we could do better than this if vector exposed the data
19992011 -- constructor in Data.Vector.
@@ -2011,7 +2023,6 @@ instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
20112023 parseJSON = fmap Exts.fromList . parseJSON
20122024#endif
20132025#endif
2014−#endif
20152026
20162027-------------------------------------------------------------------------------
20172028-- time