@@ -7,14 +7,16 @@
77{-# LANGUAGE MultiParamTypeClasses #-}
88{-# LANGUAGE NoImplicitPrelude #-}
99{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
1110{-# LANGUAGE RecordWildCards #-}
1211{-# LANGUAGE ScopedTypeVariables #-}
1312{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE TupleSections #-}
1513{-# LANGUAGE UndecidableInstances #-}
1614{-# LANGUAGE ViewPatterns #-}
1715
16+#if __GLASGOW_HASKELL__ >= 706
17+{-# LANGUAGE PolyKinds #-}
18+#endif
19+
1820#include "incoherent-compat.h"
1921#include "overlapping-compat.h"
2022
@@ -118,9 +120,9 @@ import GHC.Generics
118120import Numeric.Natural (Natural)
119121import Text.ParserCombinators.ReadP (readP_to_S)
120122import Unsafe.Coerce (unsafeCoerce)
123+import qualified Data.Aeson.Compat as Compat
121124import qualified Data.Aeson.Parser.Time as Time
122125import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123−import qualified Data.ByteString.Lazy as L
124126import qualified Data.DList as DList
125127import qualified Data.HashMap.Strict as H
126128import qualified Data.HashSet as HashSet
@@ -155,8 +157,18 @@ import qualified Data.Primitive.UnliftedArray as PM
155157import qualified Data.Primitive.PrimArray as PM
156158#endif
157159
160+#ifndef HAS_COERCIBLE
161+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
162+#endif
158163
164+#if HAS_COERCIBLE
159165import 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
160172
161173parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
162174parseIndexedJSON p idx value = p value <?> Index idx
@@ -428,7 +440,11 @@ class FromJSONKey a where
428440-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
429441-- can be inspected, but cannot be constructed.
430442data CoerceText a where
443+#if HAS_COERCIBLE
431444 CoerceText :: Coercible Text a => CoerceText a
445+#else
446+ CoerceText :: CoerceText a
447+#endif
432448
433449-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
434450-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -448,7 +464,7 @@ data FromJSONKeyFunction a
448464
449465-- | Only law abiding up to interpretation
450466instance Functor FromJSONKeyFunction where
451− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
467+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
452468 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
453469 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
454470 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -462,7 +478,9 @@ instance Functor FromJSONKeyFunction where
462478--
463479-- On pre GHC 7.8 this is unconstrainted function.
464480fromJSONKeyCoerce ::
481+#if HAS_COERCIBLE
465482 Coercible Text a =>
483+#endif
466484 FromJSONKeyFunction a
467485fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
468486
@@ -470,18 +488,29 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
470488--
471489-- See note on 'fromJSONKeyCoerce'.
472490coerceFromJSONKeyFunction ::
491+#if HAS_COERCIBLE
473492 Coercible a b =>
493+#endif
474494 FromJSONKeyFunction a -> FromJSONKeyFunction b
495+#if HAS_COERCIBLE
475496coerceFromJSONKeyFunction = 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
476503
477504{-# RULES
478505 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
479506 fmap id x = x
480507 #-}
508+#if HAS_COERCIBLE
481509{-# RULES
482510 "FromJSONKeyCoerce: fmap coerce" forall x .
483511 fmap coerce x = coerceFromJSONKeyFunction x
484512 #-}
513+#endif
485514
486515-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
487516mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
@@ -676,6 +705,7 @@ instance (FromJSON a) => FromJSON [a] where
676705prependContext :: String -> Parser a -> Parser a
677706prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")
678707
708+
679709-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@
680710-- is an 'Data.Aeson.Object' and fails otherwise.
681711--
@@ -768,13 +798,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v
768798-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
769799-- to the 'Parser' in case of failure.
770800withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
771−withBoundedScientific_ whenFail f (Number scientific) =
772− if exp10 > 1024
801+withBoundedScientific_ whenFail f v@(Number scientific) =
802+ if exponent > 1024
773803 then whenFail (fail msg)
774804 else f scientific
775805 where
776− exp10 = base10Exponent scientific
777− msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"
806+ exponent = base10Exponent scientific
807+ msg = "found a number with exponent " ++ show exponent ++ ", but it must not be greater than 1024"
778808withBoundedScientific_ whenFail _ v =
779809 whenFail (typeMismatch "Number" v)
780810{-# INLINE withBoundedScientific_ #-}
@@ -794,7 +824,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)
794824-- | Decode a nested JSON-encoded string.
795825withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
796826withEmbeddedJSON _ innerParser (String txt) =
797− either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
827+ either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
798828 where
799829 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
800830 eitherFormatError = either (Left . uncurry formatError) Right
@@ -863,7 +893,7 @@ parseFieldMaybe' = (.:!)
863893-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
864894explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
865895explicitParseField p obj key = case H.lookup key obj of
866− Nothing -> fail $ "key " ++ show key ++ " not found"
896+ Nothing -> fail $ "key " ++ show key ++ " not present"
867897 Just v -> p v <?> Key key
868898{-# INLINE explicitParseField #-}
869899
@@ -922,6 +952,8 @@ type ConName = String
922952contextType :: TypeName -> Parser a -> Parser a
923953contextType = prependContext
924954
955+
956+
925957-- | Add the tagKey that will be looked up while building an ADT
926958-- | Produce the error equivalent to
927959-- | Left "Error in $: parsing T failed, expected an object with keys "tag" and
@@ -929,8 +961,9 @@ contextType = prependContext
929961-- | The parser returned error was: could not find key "tag"
930962contextTag :: Text -> [String] -> Parser a -> Parser a
931963contextTag tagKey cnames = prependFailure
932− ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++
933− " containing one of " ++ show cnames ++ ", ")
964+ ("expected an object with key \"" ++ unpack tagKey ++
965+ "\" where \"tag\" is associated to one of " ++ show cnames ++
966+ ". The parser returned error was: ")
934967
935968-- | Add the name of the constructor being parsed to a parser's error messages.
936969contextCons :: ConName -> TypeName -> Parser a -> Parser a
@@ -1121,15 +1154,17 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11211154 case sumEncoding opts of
11221155 TaggedObject{..} ->
11231156 withObject tname $ \obj -> do
1124− tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
1157+ tag <- (contextType tname) . (contextTag tagKey cnames_) $ obj .: tagKey
11251158 fromMaybe (badTag tag <?> Key tagKey) $
1126− parseFromTaggedObject (tag :* contentsFieldName :* p) obj
1159+ parseFromTaggedObject (tag :* contentsFieldName :* p) obj
11271160 where
11281161 tagKey = pack tagFieldName
11291162 badTag tag = failWith_ $ \cnames ->
11301163 "expected tag field to be one of " ++ show cnames ++
11311164 ", but found tag " ++ show tag
11321165 cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])
1166+ --cname_ = conName (undefined :: M1 _i c _f _p)
1167+ -- forall f a. ConstructorNames f
11331168
11341169 ObjectWithSingleField ->
11351170 withObject tname $ \obj -> case H.toList obj of
@@ -1201,9 +1236,9 @@ class FromTaggedObject' arity f isRecord where
12011236 :: String :* ConName :* TypeName :* Options :* FromArgs arity a
12021237 -> Object -> Tagged isRecord (Parser (f a))
12031238
1204−instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
1239+instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where
12051240 -- Records are unpacked in the tagged object
1206− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
1241+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p
12071242
12081243instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
12091244 -- Nonnullary nonrecords are encoded in the contents field
@@ -1244,11 +1279,11 @@ instance OVERLAPPING_
12441279 ) => ConsFromJSON' arity (S1 s a) True where
12451280 consParseJSON' p@(cname :* tname :* opts :* fargs)
12461281 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1247− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
1282+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)
12481283
12491284instance RecordFromJSON arity f => ConsFromJSON' arity f True where
12501285 consParseJSON' p@(cname :* tname :* _) =
1251− Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
1286+ Tagged . withObject (showCons cname tname) (recordParseJSON p)
12521287
12531288instance OVERLAPPING_
12541289 ConsFromJSON' arity U1 False where
@@ -1274,55 +1309,21 @@ instance (ProductFromJSON arity f, ProductSize f
12741309
12751310--------------------------------------------------------------------------------
12761311
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−
12881312class RecordFromJSON arity f where
12891313 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'
13131314 :: ConName :* TypeName :* Options :* FromArgs arity a
13141315 -> Object -> Parser (f a)
13151316
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
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
13221323
13231324instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1324− RecordFromJSON' arity (S1 s a) where
1325− recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
1325+ RecordFromJSON arity (S1 s a) where
1326+ recordParseJSON (cname :* tname :* opts :* fargs) obj = do
13261327 fv <- contextCons cname tname (obj .: label)
13271328 M1 <$> gParseJSON opts fargs fv <?> Key label
13281329 where
@@ -1330,16 +1331,16 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
13301331 sname = selName (undefined :: M1 _i s _f _p)
13311332
13321333instance INCOHERENT_ (Selector s, FromJSON a) =>
1333− RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
1334− recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
1334+ RecordFromJSON arity (S1 s (K1 i (Maybe a))) where
1335+ recordParseJSON (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
13351336 where
13361337 label = fieldLabelModifier opts sname
13371338 sname = selName (undefined :: M1 _i s _f _p)
13381339
13391340-- Parse an Option like a Maybe.
13401341instance INCOHERENT_ (Selector s, FromJSON a) =>
1341− RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
1342− recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
1342+ RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where
1343+ recordParseJSON p obj = wrap <$> recordParseJSON p obj
13431344 where
13441345 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
13451346 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
@@ -1576,22 +1577,12 @@ instance FromJSONKey Float where
15761577 _ -> Scientific.toRealFloat <$> parseScientificText t
15771578
15781579instance (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
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
15951586 {-# INLINE parseJSON #-}
15961587
15971588-- | This instance includes a bounds check to prevent maliciously
@@ -2006,6 +1997,7 @@ instance FromJSON DotNetTime where
20061997-- primitive
20071998-------------------------------------------------------------------------------
20081999
2000+#if MIN_VERSION_base(4,7,0)
20092001instance FromJSON a => FromJSON (PM.Array a) where
20102002 -- note: we could do better than this if vector exposed the data
20112003 -- constructor in Data.Vector.
@@ -2023,6 +2015,7 @@ instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
20232015 parseJSON = fmap Exts.fromList . parseJSON
20242016#endif
20252017#endif
2018+#endif
20262019
20272020-------------------------------------------------------------------------------
20282021-- time