diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011, MailRank, Inc. 2014-2021 Aeson project contributors +Copyright (c) 2011, MailRank, Inc. 2014-2026 Aeson project contributors All rights reserved. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -20,9 +20,6 @@ * https://github.com/haskell/aeson/blob/master/changelog.md -(You can create and contribute changes using either git or Mercurial.) - - # Authors This library was originally written by Bryan O'Sullivan. diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,16 +1,18 @@ cabal-version: 2.2 name: aeson -version: 2.2.5.1 +version: 2.3.2.0 license: BSD-3-Clause license-file: LICENSE category: Text, Web, JSON copyright: - (c) 2011-2016 Bryan O'Sullivan - (c) 2011 MailRank, Inc. - + 2014-2026 Aeson project contributors, + 2011-2016 Bryan O'Sullivan, + 2011 MailRank, Inc. author: Bryan O'Sullivan -maintainer: Adam Bergmark -stability: experimental +maintainer: + Li-yao Xia , + Core Libraries Committee +stability: stable tested-with: GHC ==8.6.5 || ==8.8.4 @@ -36,12 +38,12 @@ below. . (A note on naming: in Greek mythology, Aeson was the father of Jason.) - +extra-doc-files: + README.markdown + changelog.md extra-source-files: *.yaml benchmarks/json-data/*.json - changelog.md - README.markdown tests/golden/*.expected tests/JSONTestSuite/results/*.tok tests/JSONTestSuite/results/*.txt @@ -130,7 +132,7 @@ , semialign ^>=1.3 || ^>=1.4 , strict ^>=0.5 , tagged ^>=0.8.7 - , text-iso8601 ^>=0.1.1 + , text-iso8601 >=0.1.1 && < 0.3 , text-short ^>=0.1.5 , th-abstraction ^>=0.5.0.0 || ^>=0.6.0.0 || ^>=0.7.0.0 , these ^>=1.2 @@ -238,7 +240,7 @@ build-depends: integer-gmp if impl(ghc >=9.2 && <9.7) - build-depends: nothunks >=0.1.4 && <0.3 + build-depends: nothunks >=0.1.4 && <0.4 source-repository head type: git diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,15 +1,36 @@ For the latest version of this document, please see [https://github.com/haskell/aeson/blob/master/changelog.md](https://github.com/haskell/aeson/blob/master/changelog.md). +### 2.3.2.0 - 2026-09-12 + +* Remove unsound rewrite rule on `FromJSONKey` (`fmap coerce = coerce`) +* Fix `listParser` to include list indices in error traces + +### 2.3.1.0 - 2026-07-05 + +* Add `FromJSONKey` instance for `Data.Fixed`. +* Add `ToJSON` and `FromJSON` instances for `Data.Complex`. +* Export `isEmptyArray` from `Data.Aeson.Types` module. +* Document that file decoding functions throw an exception when the file is missing. + +### 2.3.0.0 - 2026-05-21 + +* Fix DoS vulnerabilities caused by parsing large numbers (advisory [HSEC-2026-0007](https://haskell.github.io/security-advisories/advisory/HSEC-2026-0007.html)). Backported to 2.2.5.1, see below. +* Fix typo in error message: "~~Unespected~~ Unexpected control character while parsing string literal". +* Support nothunks 0.3. +* Unset executable permissions in some test files and remove a broken symlink. +* In `text-iso8601-0.2.0.0`: + - Accept 24:00:00 time of day. + ### 2.2.5.1 - 2026-08-29 Fix a DoS vulnerability caused by parsing large numbers (advisory [HSEC-2026-0007](https://haskell.github.io/security-advisories/advisory/HSEC-2026-0007.html)). Backported from 2.3.0.0 to ease migration. -* Fix parsing of fractional numbers to reject exponents smaller than -1024. +* (HSEC-2026-0007) Fix parsing of fractional numbers to reject exponents smaller than -1024. This change affects `FromJSON` instances of `Fixed`, `DiffTime`, and `NominalDiffTime`, rejecting more inputs. Error messages for `Ratio` and integral types are also slightly different due to reusing the same bounding logic. -* In `text-iso8601-0.1.1.2`: - - Reject years of more than 15 digits. +* In `text-iso8601-0.1.1.2` (backported from 0.2.0.0): + - (HSEC-2026-0007) Reject years of more than 15 digits. ### 2.2.5.0 diff --git a/src/Data/Aeson.hs b/src/Data/Aeson.hs --- a/src/Data/Aeson.hs +++ b/src/Data/Aeson.hs @@ -199,6 +199,11 @@ -- -- This function parses immediately, but defers conversion. See -- 'json' for details. +-- +-- Throws an exception when the file cannot be accessed +-- (e.g., it is missing or permissions are invalid). +-- This function uses 'Data.ByteString.readFile' without handling +-- any of its exceptions. decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a) decodeFileStrict = fmap decodeStrict . B.readFile @@ -226,12 +231,21 @@ -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. -- --- Since @2.2.0.0@ an alias for 'decodeFileStrict'. +-- Throws an exception when the file cannot be accessed +-- (e.g., it is missing or permissions are invalid). +-- This function uses 'Data.ByteString.readFile' without handling +-- any of its exceptions. -- +-- Since @2.2.0.0@ an alias for 'decodeFileStrict'. decodeFileStrict' :: (FromJSON a) => FilePath -> IO (Maybe a) decodeFileStrict' = decodeFileStrict -- | Like 'decodeFileStrict' but returns an error message when decoding fails. +-- +-- Throws an exception when the file cannot be accessed +-- (e.g., it is missing or permissions are invalid). +-- This function uses 'Data.ByteString.readFile' without handling +-- any of its exceptions. eitherDecodeFileStrict :: (FromJSON a) => FilePath -> IO (Either String a) eitherDecodeFileStrict = fmap eitherDecodeStrict . B.readFile @@ -253,6 +267,11 @@ -- | Like 'decodeFileStrict'' but returns an error message when decoding fails. -- +-- Throws an exception when the file cannot be accessed +-- (e.g., it is missing or permissions are invalid). +-- This function uses 'Data.ByteString.readFile' without handling +-- any of its exceptions. +-- -- Since @2.2.0.0@ an alias for 'eitherDecodeFileStrict'. eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a) eitherDecodeFileStrict' = eitherDecodeFileStrict @@ -367,7 +386,7 @@ -- -- \-- this encodes directly to a bytestring Builder -- 'toEncoding' (Person name age) = --- 'pairs' (\"name\" '.=' 'name' '<>' \"age\" '.=' age) +-- 'pairs' (\"name\" '.=' name '<>' \"age\" '.=' age) -- @ -- -- We can now encode a value like so: @@ -517,7 +536,7 @@ -- -- @ -- 'toEncoding' (Person name age) = --- 'pairs' (\"name\" '.=' 'name' '<>' \"age\" '.=' age) +-- 'pairs' (\"name\" '.=' name '<>' \"age\" '.=' age) -- @ -- -- Any container type that implements 'Foldable' can be encoded to a @@ -559,3 +578,6 @@ -- , -- and -- (where the relevant parsers are defined). + +-- $optionsFields +-- The functions here are in fact record fields of the 'Options' type. diff --git a/src/Data/Aeson/Decoding.hs b/src/Data/Aeson/Decoding.hs --- a/src/Data/Aeson/Decoding.hs +++ b/src/Data/Aeson/Decoding.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} --- | Convertion to and from @aeson@ 'A.Value'. +-- | Conversion to and from @aeson@ 'A.Value'. -- module Data.Aeson.Decoding ( decode, diff --git a/src/Data/Aeson/Decoding/ByteString.hs b/src/Data/Aeson/Decoding/ByteString.hs --- a/src/Data/Aeson/Decoding/ByteString.hs +++ b/src/Data/Aeson/Decoding/ByteString.hs @@ -163,7 +163,7 @@ Just (_, bs') -> goEsc (n + 1) bs' errEnd = err "Unexpected end-of-input while parsing string literal" - errCC = err "Unespected control character while parsing string literal" + errCC = err "Unexpected control character while parsing string literal" ------------------------------------------------------------------------------- -- Number diff --git a/src/Data/Aeson/Decoding/ByteString/Lazy.hs b/src/Data/Aeson/Decoding/ByteString/Lazy.hs --- a/src/Data/Aeson/Decoding/ByteString/Lazy.hs +++ b/src/Data/Aeson/Decoding/ByteString/Lazy.hs @@ -169,7 +169,7 @@ Just (_, bs') -> goEsc (n + 1) bs' errEnd = err "Unexpected end-of-input while parsing string literal" - errCC = err "Unespected control character while parsing string literal" + errCC = err "Unexpected control character while parsing string literal" ------------------------------------------------------------------------------- -- Number diff --git a/src/Data/Aeson/Decoding/Conversion.hs b/src/Data/Aeson/Decoding/Conversion.hs --- a/src/Data/Aeson/Decoding/Conversion.hs +++ b/src/Data/Aeson/Decoding/Conversion.hs @@ -87,7 +87,7 @@ -> (e -> r) -> ([(Key, A.Value)] -> k -> r) -> r - -- here we don't stricly need bang on !v as KM is a Strict (in values) map. + -- here we don't strictly need bang on !v as KM is a Strict (in values) map. -- but we force the value sooner. goR !acc (TkPair t toks) g f = convert toks g $ \ !v k -> goR ((t , v) : acc) k g f goR !acc (TkRecordEnd k) _ f = f acc k diff --git a/src/Data/Aeson/Decoding/Text.hs b/src/Data/Aeson/Decoding/Text.hs --- a/src/Data/Aeson/Decoding/Text.hs +++ b/src/Data/Aeson/Decoding/Text.hs @@ -173,7 +173,7 @@ Just (_, bs') -> goEsc (n + 1) bs' errEnd = err "Unexpected end-of-input while parsing string literal" - errCC = err "Unespected control character while parsing string literal" + errCC = err "Unexpected control character while parsing string literal" ------------------------------------------------------------------------------- -- Number diff --git a/src/Data/Aeson/Encoding/Internal.hs b/src/Data/Aeson/Encoding/Internal.hs --- a/src/Data/Aeson/Encoding/Internal.hs +++ b/src/Data/Aeson/Encoding/Internal.hs @@ -82,7 +82,7 @@ newtype Encoding' tag = Encoding { fromEncoding :: Builder -- ^ Acquire the underlying bytestring builder. - } deriving (Typeable) + } -- | Often used synonym for 'Encoding''. type Encoding = Encoding' Value @@ -128,7 +128,6 @@ -- > toEncoding (Person name age) = pairs ("name" .= name <> "age" .= age) data Series = Empty | Value (Encoding' Series) - deriving (Typeable) pair :: Key -> Encoding -> Series pair name val = pair' (key name) val diff --git a/src/Data/Aeson/Internal/Prelude.hs b/src/Data/Aeson/Internal/Prelude.hs --- a/src/Data/Aeson/Internal/Prelude.hs +++ b/src/Data/Aeson/Internal/Prelude.hs @@ -21,7 +21,6 @@ import Data.String as X (IsString(..)) import Data.Text as X (Text) import Data.Time as X (UTCTime) -import Data.Typeable as X (Typeable) import Data.Vector as X (Vector) import Data.Void as X (Void, absurd) import Data.Word as X (Word8, Word16, Word32, Word64) diff --git a/src/Data/Aeson/Internal/Unescape.hs b/src/Data/Aeson/Internal/Unescape.hs --- a/src/Data/Aeson/Internal/Unescape.hs +++ b/src/Data/Aeson/Internal/Unescape.hs @@ -29,7 +29,7 @@ -- | Unescape JSON text literal. -- --- This function is exporeted mostly for testing and benchmarking purposes. +-- This function is exported mostly for testing and benchmarking purposes. unescapeText :: ByteString -> Either UnicodeException Text unescapeText = unsafeDupablePerformIO . try . unescapeTextIO diff --git a/src/Data/Aeson/Internal/UnescapeFromText.hs b/src/Data/Aeson/Internal/UnescapeFromText.hs --- a/src/Data/Aeson/Internal/UnescapeFromText.hs +++ b/src/Data/Aeson/Internal/UnescapeFromText.hs @@ -24,7 +24,7 @@ -- | Unescape JSON text literal. -- --- This function is exporeted mostly for testing and benchmarking purposes. +-- This function is exported mostly for testing and benchmarking purposes. unescapeFromText :: Text -> Either UnicodeException Text unescapeFromText = unsafeDupablePerformIO . try . unescapeFromTextIO diff --git a/src/Data/Aeson/Key.hs b/src/Data/Aeson/Key.hs --- a/src/Data/Aeson/Key.hs +++ b/src/Data/Aeson/Key.hs @@ -32,7 +32,6 @@ import Data.Semigroup (Semigroup((<>))) import Data.Text (Text) import Data.Type.Coercion (Coercion (..)) -import Data.Typeable (Typeable) import Text.Read (Read (..)) import qualified Data.String @@ -42,7 +41,7 @@ import qualified Test.QuickCheck as QC newtype Key = Key { unKey :: Text } - deriving (Typeable, Data) + deriving (Data) fromString :: String -> Key fromString = Key . T.pack @@ -56,12 +55,7 @@ toText :: Key -> Text toText = unKey --- | @'coercing r1 r2'@ will evaluate to @r1@ if 'Key' is 'Coercible' to 'Text', --- and to @r2@ otherwise. --- --- Using 'coercing' we can make more efficient implementations --- when 'Key' is backed up by 'Text' without exposing internals. --- +-- | Partially exposed coercion for forwards compatibility. coercionToText :: Maybe (Coercion Key Text) coercionToText = Just Coercion {-# INLINE coercionToText #-} diff --git a/src/Data/Aeson/KeyMap.hs b/src/Data/Aeson/KeyMap.hs --- a/src/Data/Aeson/KeyMap.hs +++ b/src/Data/Aeson/KeyMap.hs @@ -114,7 +114,6 @@ import Data.Text (Text) import Data.These (These (..)) import Data.Type.Coercion (Coercion (..)) -import Data.Typeable (Typeable) import Text.Read (Read (..), Lexeme(..), readListPrecDefault, prec, lexP, parens) import qualified Data.Aeson.Key as Key @@ -139,9 +138,9 @@ -- Map ------------------------------------------------------------------------------- --- | A map from JSON key type 'Key' to 'v'. +-- | A map from JSON key type 'Key' to @v@. newtype KeyMap v = KeyMap { unKeyMap :: Map Key v } - deriving (Eq, Ord, Typeable, Data, Functor) + deriving (Eq, Ord, Data, Functor) -- | Construct an empty map. @@ -269,7 +268,7 @@ difference tm1 tm2 = KeyMap (M.difference (unKeyMap tm1) (unKeyMap tm2)) -- | The (left-biased) union of two maps. It prefers the first map when duplicate --- keys are encountered, i.e. ('union' == 'unionWith' 'const'). +-- keys are encountered, i.e. ('union' == 'unionWith' 'Prelude.const'). union :: KeyMap v -> KeyMap v -> KeyMap v union (KeyMap x) (KeyMap y) = KeyMap (M.union x y) @@ -353,9 +352,9 @@ import Data.Ord (comparing) import Prelude (fst) --- | A map from JSON key type 'Key' to 'v'. +-- | A map from JSON key type 'Key' to @v@. newtype KeyMap v = KeyMap { unKeyMap :: HashMap Key v } - deriving (Eq, Ord, Typeable, Data, Functor) + deriving (Eq, Ord, Data, Functor) -- | Construct an empty map. empty :: KeyMap v @@ -478,7 +477,7 @@ difference tm1 tm2 = KeyMap (H.difference (unKeyMap tm1) (unKeyMap tm2)) -- | The (left-biased) union of two maps. It prefers the first map when duplicate --- keys are encountered, i.e. ('union' == 'unionWith' 'const'). +-- keys are encountered, i.e. ('union' == 'unionWith' 'Prelude.const'). union :: KeyMap v -> KeyMap v -> KeyMap v union (KeyMap x) (KeyMap y) = KeyMap (H.union x y) diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -591,7 +591,7 @@ deriveFromJSON2 :: Options -- ^ Encoding options. -> Name - -- ^ Name of the type for which to generate a 'FromJSON3' instance + -- ^ Name of the type for which to generate a 'FromJSON2' instance -- declaration. -> Q [Dec] deriveFromJSON2 = deriveFromJSONCommon fromJSON2Class @@ -955,7 +955,7 @@ | (field, argTy) <- zip fields argTys ] --- A hack, as I'm too lazy to changge code to not assume fields are non empty. +-- A hack, as I'm too lazy to change code to not assume fields are non empty. nonEmpty :: [a] -> (a, [a]) nonEmpty (x:xs) = (x,xs) nonEmpty [] = error "unexpected empty list" @@ -1276,7 +1276,7 @@ varE $ case M.lookup tyName tvMap of Just (tfjoExp, tfjExp, tfjlExp) -> case list of Omit -> tfjoExp - Single -> tfjExp + Single -> tfjExp Plural -> tfjlExp Nothing -> jsonFunValOrListName list jf Arity0 dispatchFunByType jc jf conName tvMap list (SigT ty _) = diff --git a/src/Data/Aeson/Text.hs b/src/Data/Aeson/Text.hs --- a/src/Data/Aeson/Text.hs +++ b/src/Data/Aeson/Text.hs @@ -10,7 +10,7 @@ -- Portability: portable -- -- Most frequently, you'll probably want to encode straight to UTF-8 --- (the standard JSON encoding) using 'encode'. +-- (the standard JSON encoding) using 'Data.Aeson.encode'. -- -- You can use the conversions to 'Builder's when embedding JSON messages as -- parts of a protocol. @@ -47,8 +47,8 @@ -- embedded efficiently in a text-based protocol. -- -- If you are going to immediately encode straight to a --- 'L.ByteString', it is more efficient to use 'encode' (lazy ByteString) --- or @'fromEncoding' . 'toEncoding'@ (ByteString.Builder) instead. +-- 'Data.ByteString.Lazy.ByteString', it is more efficient to use 'Data.Aeson.encode' (lazy ByteString) +-- or @'Data.Aeson.fromEncoding' . 'toEncoding'@ ('Builder') instead. -- -- /Note:/ Uses 'toJSON' encodeToTextBuilder :: ToJSON a => a -> Builder diff --git a/src/Data/Aeson/Types.hs b/src/Data/Aeson/Types.hs --- a/src/Data/Aeson/Types.hs +++ b/src/Data/Aeson/Types.hs @@ -20,6 +20,7 @@ , Series , Array , emptyArray + , isEmptyArray , Pair , Object , emptyObject diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -95,6 +95,7 @@ import Data.Aeson.Types.Generic import Data.Aeson.Types.Internal import Data.Bits (unsafeShiftR) +import Data.Complex (Complex(..)) import Data.Fixed (Fixed, HasResolution (resolution), Nano) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) @@ -216,16 +217,22 @@ (\sci rest -> if T.null rest then return sci else fail $ "Expecting end-of-input, got " ++ show (T.take 10 rest)) fail -parseIntegralText :: Integral a => String -> Text -> Parser a -parseIntegralText name t = +parseBoundedScientificTextTo :: (Scientific -> Parser a) -> String -> Text -> Parser a +parseBoundedScientificTextTo toResultType name t = prependContext name $ parseScientificText t >>= rejectLargeExponent - >>= parseIntegralFromScientific + >>= toResultType where rejectLargeExponent :: Scientific -> Parser Scientific rejectLargeExponent s = withBoundedScientific' pure (Number s) +parseBoundedScientificText :: String -> Text -> Parser Scientific +parseBoundedScientificText = parseBoundedScientificTextTo pure + +parseIntegralText :: Integral a => String -> Text -> Parser a +parseIntegralText = parseBoundedScientificTextTo parseIntegralFromScientific + parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a parseBoundedIntegralText name t = prependContext name $ @@ -463,11 +470,10 @@ fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f) -- | Construct 'FromJSONKeyFunction' for types coercible from 'Text'. This --- conversion is still unsafe, as 'Hashable' and 'Eq' instances of @a@ should be +-- conversion is still unsafe, as 'Hashable', 'Eq', and 'Ord' instances of @a@ should be -- compatible with 'Text' i.e. hash values should be equal for wrapped values as well. --- This property will always be maintained if the 'Hashable' and 'Eq' instances +-- This property will always be maintained if the 'Hashable', 'Eq', and 'Ord' instances -- are derived with generalized newtype deriving. --- compatible with 'Text' i.e. hash values be equal for wrapped values as well. -- -- On pre GHC 7.8 this is unconstrained function. fromJSONKeyCoerce :: @@ -475,19 +481,16 @@ FromJSONKeyFunction a fromJSONKeyCoerce = FromJSONKeyCoerce --- | Semantically the same as @coerceFromJSONKeyFunction = fmap coerce = coerce@. +-- | Coerce the result of a 'FromJSONKeyFunction'. -- --- See note on 'fromJSONKeyCoerce'. +-- __Warning__: This function is unsafe when the argument is +-- 'fromJSONKeyCoerce'. It can break internal invariants of maps. +-- See also the note on 'fromJSONKeyCoerce'. coerceFromJSONKeyFunction :: Coercible a b => FromJSONKeyFunction a -> FromJSONKeyFunction b coerceFromJSONKeyFunction = coerce -{-# RULES - "FromJSONKeyCoerce: fmap coerce" forall x . - fmap coerce x = coerceFromJSONKeyFunction x - #-} - -- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'. mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b mapFromJSONKeyFunction = fmap @@ -683,7 +686,7 @@ -- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'. listParser :: (Value -> Parser a) -> Value -> Parser [a] -listParser f (Array xs) = fmap V.toList (V.mapM f xs) +listParser f (Array xs) = fmap V.toList (V.imapM (\i x -> f x Index i) xs) listParser _ v = typeMismatch "Array" v {-# INLINE listParser #-} @@ -1315,7 +1318,7 @@ -------------------------------------------------------------------------------- -- | Constructors need to be decoded differently depending on whether they're --- a record or not. This distinction is made by 'ConsParseJSON'. +-- a record or not. This distinction is made by 'ConsFromJSON'. class ConsFromJSON arity f where consParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a @@ -1718,6 +1721,17 @@ then fail "Ratio denominator was 0" else pure $ numerator % denominator +-- | A complex number @x+iy@ is encoded as an array @[x, y]@. +-- +-- @since 2.3.1.0 +instance FromJSON a => FromJSON (Complex a) where + parseJSON = withArray "Complex" $ \c -> + let n = V.length c + in if n == 2 + then (:+) <$> parseJSONElemAtIndex parseJSON 0 c + <*> parseJSONElemAtIndex parseJSON 1 c + else fail $ "cannot unpack array of length " ++ show n ++ "into a Complex" + -- | This instance includes a bounds check to prevent maliciously -- large inputs to fill up the memory of the target system. You can -- newtype 'Scientific' and provide your own instance using @@ -1725,6 +1739,12 @@ instance HasResolution a => FromJSON (Fixed a) where parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac) +-- | +-- @since 2.3.1.0 +instance HasResolution a => FromJSONKey (Fixed a) where + fromJSONKey = FromJSONKeyTextParser $ \t -> + realToFrac <$> parseBoundedScientificText "Fixed" t + instance FromJSON Int where parseJSON = parseBoundedIntegral "Int" @@ -2467,7 +2487,7 @@ instance FromJSONKey b => FromJSONKey (Tagged a b) where fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b) - fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList + fromJSONKeyList = coerce (fromJSONKeyList @b) ------------------------------------------------------------------------------- -- these diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -112,18 +112,18 @@ | Index {-# UNPACK #-} !Int -- ^ JSON path element of an index into an -- array, \"array[index]\". - deriving (Eq, Show, Typeable, Ord) + deriving (Eq, Show, Ord) type JSONPath = [JSONPathElement] -- | The internal result of running a 'Parser'. data IResult a = IError JSONPath String | ISuccess a - deriving (Eq, Show, Typeable) + deriving (Eq, Show) -- | The result of running a 'Parser'. data Result a = Error String | Success a - deriving (Eq, Show, Typeable) + deriving (Eq, Show) instance NFData JSONPathElement where rnf (Key t) = rnf t @@ -277,7 +277,7 @@ -- i.e. a parser to which the input has already been applied. newtype Parser a = Parser { runParser :: forall f r. - JSONPath + JSONPath -- Note: the path is accumulated in reverse: cons new elements, however `fail` (and other functions) will reverse the path before calling the failure continuation. -> Failure f r -> Success a f r -> f r @@ -369,7 +369,7 @@ | Number !Scientific | Bool !Bool | Null - deriving (Eq, Read, Typeable, Data, Generic) + deriving (Eq, Read, Data, Generic) -- | Since version 1.5.6.0 version object values are printed in lexicographic key order -- @@ -488,7 +488,9 @@ -- The ordering is total, consistent with 'Eq' instance. -- However, nothing else about the ordering is specified, -- and it may change from environment to environment and version to version --- of either this package or its dependencies ('hashable' and 'unordered-containers'). +-- of either this package or its dependencies +-- ( and +-- ). -- -- @since 1.5.2.0 deriving instance Ord Value @@ -505,7 +507,7 @@ newtype DotNetTime = DotNetTime { fromDotNetTime :: UTCTime -- ^ Acquire the underlying value. - } deriving (Eq, Ord, Read, Show, Typeable, FormatTime) + } deriving (Eq, Ord, Read, Show, FormatTime) instance NFData Value where rnf (Object o) = rnf o @@ -552,8 +554,12 @@ emptyArray :: Value emptyArray = Array V.empty --- | Determines if the 'Value' is an empty 'Array'. --- Note that: @isEmptyArray 'emptyArray'@. +-- | Determines whether the 'Value' is an empty 'Array'. +-- +-- Do note that if this is `False`, the `Value` may be a non-empty +-- array, or it may not even be an array. +-- +-- @since 2.3.1.0 isEmptyArray :: Value -> Bool isEmptyArray (Array arr) = V.null arr isEmptyArray _ = False @@ -727,7 +733,7 @@ -- 'allowOmittedFieds' controls parsing behavior. , allowOmittedFields :: Bool -- ^ If 'True', missing fields of a record will be filled - -- with 'omittedField' values (if they are 'Just'). + -- with 'Data.Aeson.FromJSON.omittedField' values (if they are 'Just'). -- If 'False', all fields will required to present in the record object. , sumEncoding :: SumEncoding -- ^ Specifies how to encode constructors of a sum datatype. @@ -881,7 +887,7 @@ -- | Converts from CamelCase to another lower case, interspersing -- the character between all capital letters and their previous -- entries, except those capital letters that appear together, --- like 'API'. +-- like \"API\". -- -- For use by Aeson template haskell calls. -- diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -69,6 +69,7 @@ import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM import Data.Bits (unsafeShiftR) +import Data.Complex (Complex(..)) import Data.DList (DList) import Data.Fixed (Fixed, HasResolution, Nano) import Data.Foldable (toList) @@ -466,7 +467,7 @@ -- > deriving (Show,Read,Eq,Ord) -- -- It is possible to get the 'ToJSONKey' instance for free as we did --- with 'Foo'. However, in this case, we have a natural way to go to +-- with @Foo@. However, in this case, we have a natural way to go to -- and from 'Text' that does not require any escape sequences. So -- 'ToJSONKeyText' can be used instead of 'ToJSONKeyValue' to encode maps -- as objects instead of arrays of pairs. This instance may be @@ -1424,6 +1425,19 @@ "numerator" .= numerator r <> "denominator" .= denominator r +-- | A complex number @x+iy@ is encoded as an array @[x, y]@. +-- +-- @since 2.3.1.0 +instance ToJSON a => ToJSON (Complex a) where + toJSON (i :+ q) = Array $ V.create $ do + mv <- VM.unsafeNew 2 + VM.unsafeWrite mv 0 (toJSON i) + VM.unsafeWrite mv 1 (toJSON q) + return mv + toEncoding (i :+ q) = E.list id + [ toEncoding i + , toEncoding q + ] instance HasResolution a => ToJSON (Fixed a) where toJSON = Number . realToFrac diff --git a/tests/DoubleToScientific.hs b/tests/DoubleToScientific.hs --- a/tests/DoubleToScientific.hs +++ b/tests/DoubleToScientific.hs @@ -114,7 +114,7 @@ (s, e, lower_boundary_is_closer) = decodeFloat' v lowerBoundaryCloser' = if lower_boundary_is_closer then lowerBoundaryCloser else id --- | return significant, exponent and whether lower boundery is closer. +-- | return significand, exponent and whether lower boundary is closer. -- -- GHC's decodeFloat does "weird" stuff to denormal doubles, -- that messes up our delta calculation. diff --git a/tests/ErrorMessages.hs b/tests/ErrorMessages.hs --- a/tests/ErrorMessages.hs +++ b/tests/ErrorMessages.hs @@ -11,7 +11,7 @@ import Prelude.Compat import Data.Aeson (FromJSON(..), Value, eitherDecode) -import Data.Aeson.Types (Parser, parseEither) +import Data.Aeson.Types (Parser, listParser, parseEither) import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) import Data.Proxy (Proxy(..)) @@ -75,6 +75,10 @@ -- issue #358 , testFor "Seq" (Proxy :: Proxy (Seq Int)) [ "[0,1,true]" + ] + + , testWith "listParser" (listParser parseJSON :: Value -> Parser [Int]) + [ "[true]" ] ] diff --git a/tests/JSONTestSuite/results/n_array_spaces_vertical_tab_formfeed.tok b/tests/JSONTestSuite/results/n_array_spaces_vertical_tab_formfeed.tok --- a/tests/JSONTestSuite/results/n_array_spaces_vertical_tab_formfeed.tok +++ b/tests/JSONTestSuite/results/n_array_spaces_vertical_tab_formfeed.tok @@ -1,3 +1,3 @@ TkArrayOpen TkItem -TkErr "Unespected control character while parsing string literal" +TkErr "Unexpected control character while parsing string literal" diff --git a/tests/JSONTestSuite/results/n_string_unescaped_ctrl_char.tok b/tests/JSONTestSuite/results/n_string_unescaped_ctrl_char.tok --- a/tests/JSONTestSuite/results/n_string_unescaped_ctrl_char.tok +++ b/tests/JSONTestSuite/results/n_string_unescaped_ctrl_char.tok @@ -1,3 +1,3 @@ TkArrayOpen TkItem -TkErr "Unespected control character while parsing string literal" +TkErr "Unexpected control character while parsing string literal" diff --git a/tests/JSONTestSuite/results/n_string_unescaped_newline.tok b/tests/JSONTestSuite/results/n_string_unescaped_newline.tok --- a/tests/JSONTestSuite/results/n_string_unescaped_newline.tok +++ b/tests/JSONTestSuite/results/n_string_unescaped_newline.tok @@ -1,3 +1,3 @@ TkArrayOpen TkItem -TkErr "Unespected control character while parsing string literal" +TkErr "Unexpected control character while parsing string literal" diff --git a/tests/JSONTestSuite/results/n_string_unescaped_tab.tok b/tests/JSONTestSuite/results/n_string_unescaped_tab.tok --- a/tests/JSONTestSuite/results/n_string_unescaped_tab.tok +++ b/tests/JSONTestSuite/results/n_string_unescaped_tab.tok @@ -1,3 +1,3 @@ TkArrayOpen TkItem -TkErr "Unespected control character while parsing string literal" +TkErr "Unexpected control character while parsing string literal" diff --git a/tests/PropUtils.hs b/tests/PropUtils.hs --- a/tests/PropUtils.hs +++ b/tests/PropUtils.hs @@ -31,7 +31,7 @@ import Data.Aeson (eitherDecode, encode) import Data.Aeson.Encoding (encodingToLazyByteString) -import Data.Aeson.Types +import Data.Aeson.Types hiding (isEmptyArray) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM import Data.HashMap.Strict (HashMap) diff --git a/tests/PropertyKeys.hs b/tests/PropertyKeys.hs --- a/tests/PropertyKeys.hs +++ b/tests/PropertyKeys.hs @@ -6,6 +6,7 @@ import Prelude.Compat import Control.Applicative (Const) +import Data.Fixed (Fixed, E3, E6) import Data.Time.Compat (Day, LocalTime, TimeOfDay, UTCTime) import Data.Time.Calendar.Compat (DayOfWeek) import Data.Time.Calendar.Month.Compat (Month) @@ -47,4 +48,6 @@ , testProperty "Lazy Text" $ roundTripKey @LT.Text , testProperty "UUID" $ roundTripKey @UUID.UUID , testProperty "Const Text" $ roundTripKey @(Const T.Text ()) + , testProperty "Fixed E3" $ roundTripKey @(Fixed E3) + , testProperty "Fixed E6" $ roundTripKey @(Fixed E6) ] diff --git a/tests/PropertyRoundTrip.hs b/tests/PropertyRoundTrip.hs --- a/tests/PropertyRoundTrip.hs +++ b/tests/PropertyRoundTrip.hs @@ -7,6 +7,7 @@ import Control.Applicative (Const) import Data.Aeson.Types +import Data.Complex (Complex(..)) import Data.DList (DList) import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) @@ -81,6 +82,8 @@ , testProperty "Seq" $ roundTripEq @(Seq Int) , testProperty "Rational" $ roundTripEq @Rational , testProperty "Ratio Int" $ roundTripEq @(Ratio Int) + , testProperty "Complex Float" $ roundTripEq @(Complex Float) + , testProperty "Complex Double" $ roundTripEq @(Complex Double) , testProperty "UUID" $ roundTripEq @UUID.UUID , testProperty "These" $ roundTripEq @(These Char Bool) , testProperty "Fix" $ roundTripEq @(F.Fix (These Char)) diff --git a/tests/Types.hs b/tests/Types.hs --- a/tests/Types.hs +++ b/tests/Types.hs @@ -41,32 +41,32 @@ -- This definition causes an infinite loop in genericTo and genericFrom! -- , fooMap :: Map.Map String Foo , fooMap :: Map.Map String (Text,Int) - } deriving (Show, Typeable, Data) + } deriving (Show, Data) data UFoo = UFoo { _UFooInt :: Int , uFooInt :: Int - } deriving (Show, Eq, Data, Typeable) + } deriving (Show, Eq, Data) data NoConstructors data OneConstructor = OneConstructor - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Product2 a b = Product2 a b - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Product6 a b c d e f = Product6 a b c d e f - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) data Sum4 a b c d = Alt1 a | Alt2 b | Alt3 c | Alt4 d - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) class ApproxEq a where (=~) :: a -> a -> Bool newtype Approx a = Approx { fromApprox :: a } - deriving (Show, Data, Typeable, ApproxEq, Num) + deriving (Show, Data, ApproxEq, Num) instance (ApproxEq a) => Eq (Approx a) where Approx a == Approx b = a =~ b @@ -93,7 +93,6 @@ data GADT a where GADT :: { gadt :: String } -> GADT String - deriving Typeable deriving instance Data (GADT String) deriving instance Eq (GADT a) diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -88,7 +88,8 @@ _ -> s -- shouldn't happen? where split c' s' = map L.unpack $ L.split c' $ L.pack s' - capitalize t = toUpper (head t) : tail t + capitalize [] = [] + capitalize (x:xs) = toUpper x : xs data Wibble = Wibble { diff --git a/tests/UnitTests/FromJSONKey.hs b/tests/UnitTests/FromJSONKey.hs --- a/tests/UnitTests/FromJSONKey.hs +++ b/tests/UnitTests/FromJSONKey.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingVia, GADTs, GeneralizedNewtypeDeriving, OverloadedStrings #-} module UnitTests.FromJSONKey (fromJSONKeyTests) where import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, Assertion, assertFailure) +import Test.Tasty.HUnit (testCase, Assertion, assertFailure, (@?=)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Ord (Down(..)) import Data.Text (Text) import Data.Tagged (Tagged) import Control.Applicative (Const) @@ -18,6 +21,15 @@ fromJSONKey = fmap MyText' fromJSONKey fromJSONKeyList = error "not used" +newtype DownText = DownText Text + deriving (Eq, Ord) via (Down Text) + deriving FromJSON via Text + +-- Regression test for #1169: don't rewrite fmap coerce to coerce +instance FromJSONKey DownText where + fromJSONKey = fmap w fromJSONKey + where w = DownText ; {-# NOINLINE w #-} + fromJSONKeyTests :: TestTree fromJSONKeyTests = testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions @@ -27,23 +39,22 @@ , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text)) , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText) - , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText') + , assertIsText "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText') , assertIsCoerce "Const Text" (fromJSONKey :: FromJSONKeyFunction (Const Text ())) + + , assertDecodedMapIsValid ] where assertIsCoerce :: String -> FromJSONKeyFunction a -> Assertion assertIsCoerce _ FromJSONKeyCoerce = pure () assertIsCoerce n _ = assertFailure n - assertIsCoerce' :: String -> FromJSONKeyFunction a -> Assertion - assertIsCoerce' _ FromJSONKeyCoerce = pure () - assertIsCoerce' n _ = pickWithRules (assertFailure n) (pure ()) + assertIsText :: String -> FromJSONKeyFunction a -> Assertion + assertIsText _ (FromJSONKeyText _) = pure () + assertIsText n _ = assertFailure n --- | Pick the first when RULES are enabled, e.g. optimisations are on -pickWithRules - :: a -- ^ Pick this when RULES are on - -> a -- ^ use this otherwise - -> a -pickWithRules _ = id -{-# NOINLINE pickWithRules #-} -{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-} +-- Regression test for #1169 (see FromJSONKey DownText) +assertDecodedMapIsValid :: Assertion +assertDecodedMapIsValid = fmap Map.valid decodedMap @?= Just True + where + decodedMap = decode "{\"a\":\"a\",\"b\":\"b\"}" :: Maybe (Map DownText Text) diff --git a/tests/golden/simple.expected b/tests/golden/simple.expected --- a/tests/golden/simple.expected +++ b/tests/golden/simple.expected @@ -20,3 +20,5 @@ Error in $[1].Left[1]: expected Bool, but encountered Number Seq Error in $[2]: parsing Int failed, expected Number, but encountered Boolean +listParser +Error in $[0]: parsing Int failed, expected Number, but encountered Boolean