@@ -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
@@ -1230,9 +1201,9 @@ class FromTaggedObject' arity f isRecord where
12301201 :: String :* ConName :* TypeName :* Options :* FromArgs arity a
12311202 -> Object -> Tagged isRecord (Parser (f a))
12321203
1233−instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where
1204+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
12341205 -- Records are unpacked in the tagged object
1235− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p
1206+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
12361207
12371208instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
12381209 -- Nonnullary nonrecords are encoded in the contents field
@@ -1273,11 +1244,11 @@ instance OVERLAPPING_
12731244 ) => ConsFromJSON' arity (S1 s a) True where
12741245 consParseJSON' p@(cname :* tname :* opts :* fargs)
12751246 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1276− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)
1247+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12771248
12781249instance RecordFromJSON arity f => ConsFromJSON' arity f True where
12791250 consParseJSON' p@(cname :* tname :* _) =
1280− Tagged . withObject (showCons cname tname) (recordParseJSON p)
1251+ Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
12811252
12821253instance OVERLAPPING_
12831254 ConsFromJSON' arity U1 False where
@@ -1303,21 +1274,55 @@ instance (ProductFromJSON arity f, ProductSize f
13031274
13041275--------------------------------------------------------------------------------
13051276
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+
13061288class RecordFromJSON arity f where
13071289 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'
13081313 :: ConName :* TypeName :* Options :* FromArgs arity a
13091314 -> Object -> Parser (f a)
13101315
1311−instance ( RecordFromJSON arity a
1312− , RecordFromJSON arity b
1313− ) => RecordFromJSON arity (a :*: b) where
1314− recordParseJSON p obj =
1315− (:*:) <$> recordParseJSON p obj
1316− <*> 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
13171322
13181323instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1319− RecordFromJSON arity (S1 s a) where
1320− recordParseJSON (cname :* tname :* opts :* fargs) obj = do
1324+ RecordFromJSON' arity (S1 s a) where
1325+ recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
13211326 fv <- contextCons cname tname (obj .: label)
13221327 M1 <$> gParseJSON opts fargs fv <?> Key label
13231328 where
@@ -1325,16 +1330,16 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
13251330 sname = selName (undefined :: M1 _i s _f _p)
13261331
13271332instance INCOHERENT_ (Selector s, FromJSON a) =>
1328− RecordFromJSON arity (S1 s (K1 i (Maybe a))) where
1329− 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
13301335 where
13311336 label = fieldLabelModifier opts sname
13321337 sname = selName (undefined :: M1 _i s _f _p)
13331338
13341339-- Parse an Option like a Maybe.
13351340instance INCOHERENT_ (Selector s, FromJSON a) =>
1336− RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where
1337− 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
13381343 where
13391344 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
13401345 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
@@ -1571,12 +1576,22 @@ instance FromJSONKey Float where
15711576 _ -> Scientific.toRealFloat <$> parseScientificText t
15721577
15731578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1574− parseJSON = withObject "Rational" $ \obj -> do
1575− numerator <- obj .: "numerator"
1576− denominator <- obj .: "denominator"
1577− if denominator == 0
1578− then fail "Ratio denominator was 0"
1579− 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
15801595 {-# INLINE parseJSON #-}
15811596
15821597-- | This instance includes a bounds check to prevent maliciously
@@ -1991,7 +2006,6 @@ instance FromJSON DotNetTime where
19912006-- primitive
19922007-------------------------------------------------------------------------------
19932008
1994−#if MIN_VERSION_base(4,7,0)
19952009instance FromJSON a => FromJSON (PM.Array a) where
19962010 -- note: we could do better than this if vector exposed the data
19972011 -- constructor in Data.Vector.
@@ -2009,7 +2023,6 @@ instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
20092023 parseJSON = fmap Exts.fromList . parseJSON
20102024#endif
20112025#endif
2012−#endif
20132026
20142027-------------------------------------------------------------------------------
20152028-- time