@@ -7,14 +7,16 @@
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE NoImplicitPrelude #-}
8{-# LANGUAGE NoImplicitPrelude #-}
9{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE RecordWildCards #-}
10{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE TupleSections #-}
15{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
16{-# LANGUAGE ViewPatterns #-}
14{-# LANGUAGE ViewPatterns #-}
16+#if __GLASGOW_HASKELL__ >= 706
17+{-# LANGUAGE PolyKinds #-}
18#include "incoherent-compat.h"
20#include "incoherent-compat.h"
19#include "overlapping-compat.h"
21#include "overlapping-compat.h"
@@ -23,6 +25,7 @@
24module Data.Aeson.Types.FromJSON
26module Data.Aeson.Types.FromJSON
26 -- * Core JSON classes
29 -- * Core JSON classes
27 FromJSON(..)
30 FromJSON(..)
28 -- * Liftings to unary and binary type constructors
31 -- * Liftings to unary and binary type constructors
@@ -118,9 +121,9 @@ import GHC.Generics
118import Numeric.Natural (Natural)
121import Numeric.Natural (Natural)
119import Text.ParserCombinators.ReadP (readP_to_S)
122import Text.ParserCombinators.ReadP (readP_to_S)
120import Unsafe.Coerce (unsafeCoerce)
123import Unsafe.Coerce (unsafeCoerce)
124+import qualified Data.Aeson.Compat as Compat
121import qualified Data.Aeson.Parser.Time as Time
125import qualified Data.Aeson.Parser.Time as Time
122import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
126import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
123−import qualified Data.ByteString.Lazy as L
124import qualified Data.DList as DList
127import qualified Data.DList as DList
125import qualified Data.HashMap.Strict as H
128import qualified Data.HashMap.Strict as H
126import qualified Data.HashSet as HashSet
129import qualified Data.HashSet as HashSet
@@ -155,8 +158,18 @@ import qualified Data.Primitive.UnliftedArray as PM
155import qualified Data.Primitive.PrimArray as PM
158import qualified Data.Primitive.PrimArray as PM
161+#ifndef HAS_COERCIBLE
162+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
159import Data.Coerce (Coercible, coerce)
166import Data.Coerce (Coercible, coerce)
167+coerce' :: Coercible a b => a -> b
171+coerce' = unsafeCoerce
161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
174parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
162parseIndexedJSON p idx value = p value <?> Index idx
175parseIndexedJSON p idx value = p value <?> Index idx
@@ -428,7 +441,11 @@ class FromJSONKey a where
428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
441-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'
429-- can be inspected, but cannot be constructed.
442-- can be inspected, but cannot be constructed.
430data CoerceText a where
443data CoerceText a where
431 CoerceText :: Coercible Text a => CoerceText a
445 CoerceText :: Coercible Text a => CoerceText a
447+ CoerceText :: CoerceText a
433-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
450-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the
434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
451-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'
@@ -448,7 +465,7 @@ data FromJSONKeyFunction a
449-- | Only law abiding up to interpretation
466-- | Only law abiding up to interpretation
450instance Functor FromJSONKeyFunction where
467instance Functor FromJSONKeyFunction where
451− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)
468+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')
452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
469 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)
453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
470 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)
454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
471 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)
@@ -462,7 +479,9 @@ instance Functor FromJSONKeyFunction where
463-- On pre GHC 7.8 this is unconstrainted function.
480-- On pre GHC 7.8 this is unconstrainted function.
464fromJSONKeyCoerce ::
481fromJSONKeyCoerce ::
465 Coercible Text a =>
483 Coercible Text a =>
466 FromJSONKeyFunction a
485 FromJSONKeyFunction a
467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
486fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
@@ -470,18 +489,29 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
471-- See note on 'fromJSONKeyCoerce'.
490-- See note on 'fromJSONKeyCoerce'.
472coerceFromJSONKeyFunction ::
491coerceFromJSONKeyFunction ::
473 Coercible a b =>
493 Coercible a b =>
474 FromJSONKeyFunction a -> FromJSONKeyFunction b
495 FromJSONKeyFunction a -> FromJSONKeyFunction b
475coerceFromJSONKeyFunction = coerce
497coerceFromJSONKeyFunction = coerce
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)
478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
506 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
479 fmap id x = x
507 fmap id x = x
482 "FromJSONKeyCoerce: fmap coerce" forall x .
511 "FromJSONKeyCoerce: fmap coerce" forall x .
483 fmap coerce x = coerceFromJSONKeyFunction x
512 fmap coerce x = coerceFromJSONKeyFunction x
486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
516-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
517mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
@@ -676,6 +706,7 @@ instance (FromJSON a) => FromJSON [a] where
676prependContext :: String -> Parser a -> Parser a
706prependContext :: String -> Parser a -> Parser a
677prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")
707prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")
679-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@
710-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@
680-- is an 'Data.Aeson.Object' and fails otherwise.
711-- is an 'Data.Aeson.Object' and fails otherwise.
@@ -768,13 +799,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v
768-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
799-- | A variant of 'withBoundedScientific_' parameterized by a function to apply
769-- to the 'Parser' in case of failure.
800-- to the 'Parser' in case of failure.
770withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
801withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a
771−withBoundedScientific_ whenFail f (Number scientific) =
802+withBoundedScientific_ whenFail f v@(Number scientific) =
772− if exp10 > 1024
803+ if exponent > 1024
773 then whenFail (fail msg)
804 then whenFail (fail msg)
774 else f scientific
805 else f scientific
776− exp10 = base10Exponent scientific
807+ exponent = base10Exponent scientific
777− msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"
808+ msg = "found a number with exponent " ++ show exponent ++ ", but it must not be greater than 1024"
778withBoundedScientific_ whenFail _ v =
809withBoundedScientific_ whenFail _ v =
779 whenFail (typeMismatch "Number" v)
810 whenFail (typeMismatch "Number" v)
780{-# INLINE withBoundedScientific_ #-}
811{-# INLINE withBoundedScientific_ #-}
@@ -794,7 +825,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)
794-- | Decode a nested JSON-encoded string.
825-- | Decode a nested JSON-encoded string.
795withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
826withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a
796withEmbeddedJSON _ innerParser (String txt) =
827withEmbeddedJSON _ innerParser (String txt) =
797− either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)
828+ either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
799 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
830 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
800 eitherFormatError = either (Left . uncurry formatError) Right
831 eitherFormatError = either (Left . uncurry formatError) Right
@@ -863,7 +894,7 @@ parseFieldMaybe' = (.:!)
863-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
894-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@
864explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
895explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
865explicitParseField p obj key = case H.lookup key obj of
896explicitParseField p obj key = case H.lookup key obj of
866− Nothing -> fail $ "key " ++ show key ++ " not found"
897+ Nothing -> fail $ "key " ++ show key ++ " not present"
867 Just v -> p v <?> Key key
898 Just v -> p v <?> Key key
868{-# INLINE explicitParseField #-}
899{-# INLINE explicitParseField #-}
@@ -930,7 +961,7 @@ contextType = prependContext
930contextTag :: Text -> [String] -> Parser a -> Parser a
961contextTag :: Text -> [String] -> Parser a -> Parser a
931contextTag tagKey cnames = prependFailure
962contextTag tagKey cnames = prependFailure
932 ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++
963 ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++
933− " containing one of " ++ show cnames ++ ", ")
964+ " associated to one of " ++ show cnames ++ ", ")
935-- | Add the name of the constructor being parsed to a parser's error messages.
966-- | Add the name of the constructor being parsed to a parser's error messages.
936contextCons :: ConName -> TypeName -> Parser a -> Parser a
967contextCons :: ConName -> TypeName -> Parser a -> Parser a
@@ -1123,7 +1154,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
1123 withObject tname $ \obj -> do
1154 withObject tname $ \obj -> do
1124 tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
1155 tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey
1125 fromMaybe (badTag tag <?> Key tagKey) $
1156 fromMaybe (badTag tag <?> Key tagKey) $
1126− parseFromTaggedObject (tag :* contentsFieldName :* p) obj
1157+ parseFromTaggedObject (tag :* contentsFieldName :* p) obj
1128 tagKey = pack tagFieldName
1159 tagKey = pack tagFieldName
1129 badTag tag = failWith_ $ \cnames ->
1160 badTag tag = failWith_ $ \cnames ->
@@ -1201,9 +1232,9 @@ class FromTaggedObject' arity f isRecord where
1201 :: String :* ConName :* TypeName :* Options :* FromArgs arity a
1232 :: String :* ConName :* TypeName :* Options :* FromArgs arity a
1202 -> Object -> Tagged isRecord (Parser (f a))
1233 -> Object -> Tagged isRecord (Parser (f a))
1204−instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where
1235+instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where
1205 -- Records are unpacked in the tagged object
1236 -- Records are unpacked in the tagged object
1206− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)
1237+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p
1208instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
1239instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
1209 -- Nonnullary nonrecords are encoded in the contents field
1240 -- Nonnullary nonrecords are encoded in the contents field
@@ -1244,11 +1275,11 @@ instance OVERLAPPING_
1244 ) => ConsFromJSON' arity (S1 s a) True where
1275 ) => ConsFromJSON' arity (S1 s a) True where
1245 consParseJSON' p@(cname :* tname :* opts :* fargs)
1276 consParseJSON' p@(cname :* tname :* opts :* fargs)
1246 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1277 | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1247− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
1278+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)
1249instance RecordFromJSON arity f => ConsFromJSON' arity f True where
1280instance RecordFromJSON arity f => ConsFromJSON' arity f True where
1250 consParseJSON' p@(cname :* tname :* _) =
1281 consParseJSON' p@(cname :* tname :* _) =
1251− Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))
1282+ Tagged . withObject (showCons cname tname) (recordParseJSON p)
1253instance OVERLAPPING_
1284instance OVERLAPPING_
1254 ConsFromJSON' arity U1 False where
1285 ConsFromJSON' arity U1 False where
@@ -1274,55 +1305,21 @@ instance (ProductFromJSON arity f, ProductSize f
1275--------------------------------------------------------------------------------
1306--------------------------------------------------------------------------------
1277−class FieldNames f where
1278− fieldNames :: f a -> [Text] -> [Text]
1280−instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where
1282− fieldNames (undefined :: a x) .
1283− fieldNames (undefined :: b y)
1285−instance (Selector s) => FieldNames (S1 s f) where
1286− fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)
1288class RecordFromJSON arity f where
1308class RecordFromJSON arity f where
1289 recordParseJSON
1309 recordParseJSON
1290− :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a
1291− -> Object -> Parser (f a)
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
1299− knownFields :: H.HashMap Text ()
1300− knownFields = H.fromList $ map (,()) $
1301− fieldNames (undefined :: f a)
1302− [pack (tagFieldName (sumEncoding opts)) | fromTaggedSum]
1304− if not (rejectUnknownFields opts)
1305− then \_ -> return ()
1306− else \obj -> case H.keys (H.difference obj knownFields) of
1308− unknownFields -> contextCons cname tname $
1309− fail ("unknown fields: " ++ show unknownFields)
1311−class RecordFromJSON' arity f where
1313 :: ConName :* TypeName :* Options :* FromArgs arity a
1310 :: ConName :* TypeName :* Options :* FromArgs arity a
1314 -> Object -> Parser (f a)
1311 -> Object -> Parser (f a)
1316−instance ( RecordFromJSON' arity a
1313+instance ( RecordFromJSON arity a
1317− , RecordFromJSON' arity b
1314+ , RecordFromJSON arity b
1318− ) => RecordFromJSON' arity (a :*: b) where
1315+ ) => RecordFromJSON arity (a :*: b) where
1319− recordParseJSON' p obj =
1316+ recordParseJSON p obj =
1320− (:*:) <$> recordParseJSON' p obj
1317+ (:*:) <$> recordParseJSON p obj
1321− <*> recordParseJSON' p obj
1318+ <*> recordParseJSON p obj
1323instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1320instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1324− RecordFromJSON' arity (S1 s a) where
1321+ RecordFromJSON arity (S1 s a) where
1325− recordParseJSON' (cname :* tname :* opts :* fargs) obj = do
1322+ recordParseJSON (cname :* tname :* opts :* fargs) obj = do
1326 fv <- contextCons cname tname (obj .: label)
1323 fv <- contextCons cname tname (obj .: label)
1327 M1 <$> gParseJSON opts fargs fv <?> Key label
1324 M1 <$> gParseJSON opts fargs fv <?> Key label
@@ -1330,16 +1327,16 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1330 sname = selName (undefined :: M1 _i s _f _p)
1327 sname = selName (undefined :: M1 _i s _f _p)
1332instance INCOHERENT_ (Selector s, FromJSON a) =>
1329instance INCOHERENT_ (Selector s, FromJSON a) =>
1333− RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where
1330+ RecordFromJSON arity (S1 s (K1 i (Maybe a))) where
1334− recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
1331+ recordParseJSON (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
1336 label = fieldLabelModifier opts sname
1333 label = fieldLabelModifier opts sname
1337 sname = selName (undefined :: M1 _i s _f _p)
1334 sname = selName (undefined :: M1 _i s _f _p)
1339-- Parse an Option like a Maybe.
1336-- Parse an Option like a Maybe.
1340instance INCOHERENT_ (Selector s, FromJSON a) =>
1337instance INCOHERENT_ (Selector s, FromJSON a) =>
1341− RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where
1338+ RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where
1342− recordParseJSON' p obj = wrap <$> recordParseJSON' p obj
1339+ recordParseJSON p obj = wrap <$> recordParseJSON p obj
1344 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
1341 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
1345 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
1342 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
@@ -1576,22 +1573,12 @@ instance FromJSONKey Float where
1576 _ -> Scientific.toRealFloat <$> parseScientificText t
1573 _ -> Scientific.toRealFloat <$> parseScientificText t
1578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1575instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
1579− parseJSON (Number x)
1581− , exp10 >= -1024 = return $! realToFrac x
1582− | otherwise = prependContext "Ratio" $ fail msg
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
1589− objParser = withObject "Rational" $ \obj -> do
1576+ parseJSON = withObject "Rational" $ \obj -> do
1590− numerator <- obj .: "numerator"
1577+ numerator <- obj .: "numerator"
1591− denominator <- obj .: "denominator"
1578+ denominator <- obj .: "denominator"
1592− if denominator == 0
1579+ if denominator == 0
1593− then fail "Ratio denominator was 0"
1580+ then fail "Ratio denominator was 0"
1594− else pure $ numerator % denominator
1581+ else pure $ numerator % denominator
1595 {-# INLINE parseJSON #-}
1582 {-# INLINE parseJSON #-}
1597-- | This instance includes a bounds check to prevent maliciously
1584-- | This instance includes a bounds check to prevent maliciously
@@ -2006,6 +1993,7 @@ instance FromJSON DotNetTime where
2006-- primitive
1993-- primitive
2007-------------------------------------------------------------------------------
1994-------------------------------------------------------------------------------
1996+#if MIN_VERSION_base(4,7,0)
2009instance FromJSON a => FromJSON (PM.Array a) where
1997instance FromJSON a => FromJSON (PM.Array a) where
2010 -- note: we could do better than this if vector exposed the data
1998 -- note: we could do better than this if vector exposed the data
2011 -- constructor in Data.Vector.
1999 -- constructor in Data.Vector.
@@ -2023,6 +2011,7 @@ instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where
2023 parseJSON = fmap Exts.fromList . parseJSON
2011 parseJSON = fmap Exts.fromList . parseJSON
2027-------------------------------------------------------------------------------
2016-------------------------------------------------------------------------------