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 @@ -14,14 +14,11 @@ Master [git repository](http://github.com/haskell/aeson): -* `git clone git://github.com/haskell/aeson.git` +* `git clone https://github.com/haskell/aeson.git` See what's changed in recent (and upcoming) releases: * https://github.com/haskell/aeson/blob/master/changelog.md - -(You can create and contribute changes using either git or Mercurial.) - # Authors diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,29 +1,32 @@ +cabal-version: 2.2 name: aeson -version: 2.2.1.0 -license: BSD3 +version: 2.3.1.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.2.2 - || ==8.4.4 - || ==8.6.5 + GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 - || ==9.4.7 - || ==9.6.3 - || ==9.8.1 + || ==9.4.8 + || ==9.6.6 + || ==9.8.4 + || ==9.10.3 + || ==9.12.4 + || ==9.14.1 synopsis: Fast JSON parsing and encoding -cabal-version: 1.12 homepage: https://github.com/haskell/aeson bug-reports: https://github.com/haskell/aeson/issues build-type: Simple @@ -35,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 @@ -84,8 +87,6 @@ Data.Aeson.Internal.TH Data.Aeson.Internal.Unescape Data.Aeson.Internal.UnescapeFromText - Data.Aeson.Internal.Word8 - Data.Aeson.Internal.Word16 Data.Aeson.Parser.Time Data.Aeson.Types.Class Data.Aeson.Types.FromJSON @@ -95,51 +96,50 @@ -- GHC bundled libs build-depends: - base >=4.10.0.0 && <5 + , base >=4.12.0.0 && <5 , bytestring >=0.10.8.2 && <0.13 - , containers >=0.5.10.2 && <0.7 - , deepseq >=1.4.3.0 && <1.6 + , containers >=0.6.0.1 && <0.9 + , deepseq >=1.4.4.0 && <1.6 , exceptions >=0.10.4 && <0.11 - , ghc-prim >=0.5.0.0 && <0.12 - , template-haskell >=2.12.0.0 && <2.22 + , template-haskell >=2.14.0.0 && <2.25 , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2 - , time >=1.8.0.2 && <1.13 + , time >=1.8.0.2 && <1.16 -- Compat build-depends: - generically >=0.1 && <0.2 , time-compat >=1.9.6 && <1.10 - if !impl(ghc >=8.6) - build-depends: contravariant >=1.4.1 && <1.6 + if !impl(ghc >=9.4) + build-depends: generically >=0.1 && <0.2 if !impl(ghc >=9.0) build-depends: integer-gmp -- Other dependencies build-depends: - data-fix >=0.3.2 && <0.4 - , dlist >=1.0 && <1.1 - , hashable >=1.4.2.0 && <1.5 - , indexed-traversable >=0.1.2 && <0.2 - , integer-conversion >=0.1 && <0.2 - , integer-logarithms >=1.0.3.1 && <1.1 - , network-uri >=2.6.4.1 && <2.7 - , OneTuple >=0.4.1.1 && <0.5 - , primitive >=0.8.0.0 && <0.9 - , QuickCheck >=2.14.3 && <2.15 - , scientific >=0.3.7.0 && <0.4 - , semialign >=1.3 && <1.4 - , strict >=0.5 && <0.6 - , tagged >=0.8.7 && <0.9 - , text-iso8601 >=0.1 && <0.2 - , text-short >=0.1.5 && <0.2 - , th-abstraction >=0.5.0.0 && <0.7 - , these >=1.2 && <1.3 - , unordered-containers >=0.2.10.0 && <0.3 - , uuid-types >=1.0.5 && <1.1 - , vector >=0.13.0.0 && <0.14 - , witherable >=0.4.2 && <0.5 + , character-ps ^>=0.1 + , data-fix ^>=0.3.2 + , dlist ^>=1.0 + , hashable ^>=1.4.6.0 || ^>=1.5.0.0 + , indexed-traversable ^>=0.1.2 + , integer-conversion ^>=0.1 + , integer-logarithms ^>=1.0.3.1 + , network-uri ^>=2.6.4.1 + , OneTuple ^>=0.4.1.1 + , primitive ^>=0.8.0.0 || ^>=0.9.0.0 + , QuickCheck ^>=2.14.3 || ^>=2.15 || ^>=2.16.0.0 || ^>=2.17.1.0 || ^>=2.18.0.0 + , scientific ^>=0.3.7.0 + , semialign ^>=1.3 || ^>=1.4 + , strict ^>=0.5 + , tagged ^>=0.8.7 + , 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 + , unordered-containers ^>=0.2.10.0 + , uuid-types ^>=1.0.5 + , vector ^>=0.13.0.0 + , witherable ^>=0.4.2 || ^>=0.5 ghc-options: -Wall @@ -179,6 +179,7 @@ Regression.Issue571 Regression.Issue687 Regression.Issue967 + Regression.Issue1138 RFC8785 SerializationFormatSpec Types @@ -198,7 +199,7 @@ UnitTests.UTCTime build-depends: - aeson + , aeson , base , base-compat , base-orphans >=0.5.3 && <0.10 @@ -206,22 +207,19 @@ , bytestring , containers , data-fix - , deepseq - , Diff >=0.4 && <0.5 + , Diff >=0.4 && <0.6 || ^>=1.0.2 , directory , dlist , filepath , generic-deriving >=1.10 && <1.15 , generically - , ghc-prim >=0.2 , hashable , indexed-traversable , integer-logarithms >=1 && <1.1 , network-uri , OneTuple - , primitive - , QuickCheck >=2.14.2 && <2.15 - , quickcheck-instances >=0.3.29 && <0.4 + , QuickCheck + , quickcheck-instances >=0.3.29 && <0.5 , scientific , strict , tagged @@ -229,7 +227,6 @@ , tasty-golden , tasty-hunit , tasty-quickcheck - , template-haskell , text , text-short , these @@ -243,8 +240,8 @@ build-depends: integer-gmp if impl(ghc >=9.2 && <9.7) - build-depends: nothunks >=0.1.4 && <0.2 + build-depends: nothunks >=0.1.4 && <0.4 source-repository head type: git - location: git://github.com/haskell/aeson.git + location: https://github.com/haskell/aeson.git diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,45 @@ 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.1.0 + +* 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 parsing of fractional numbers to reject exponents smaller than -1024. + This breaking 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. +* 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`: + - Reject years of more than 15 digits. + - Accept 24:00:00 time of day. + +### 2.2.5.0 + +* Support `semialign-1.4` + +### 2.2.4.0 + +* Check for control characters in text literals everywhere + +### 2.2.3.0 + +* Support `hashable-1.4.6.0`. +* Fix an issue where `Hashable Key` wasn't newtype instance over underlying `Text`, + so with `-ordered-keymap` there were correctness issues. +* Add instances for `Data.Semigroup.Sum`, `Product`, `Any`, `All` + +### 2.2.2.0 + +* Support GHC-8.6.5...9.10.1 +* Depend on `character-ps` instead of defining own Word8 pattern synonyms + ### 2.2.1.0 * Add `Data.Aeson.RFC8785`, a JSON Canonicalization Scheme implementation @@ -14,7 +54,7 @@ One gotcha is that internal `Text` values (in `Key`s or `Value` `String`s) will most likely retain the original input `Text` value (its underlying `Array`). It shouldn't be an issue if the `Value` is then decoded to something else so these - `Text` values disapper, but if not (e.g. `Object` keys survive) + `Text` values disappear, but if not (e.g. `Object` keys survive) then users might want to use `Data.Text.copy`. ### 2.2.0.0 @@ -34,7 +74,7 @@ In addition to `Maybe` (and `Option`) fields the `Data.Monoid.First` and `Data.Monoid.Last` are also omitted, as well as the most newtype wrappers, when their wrap omittable type (e.g. newtypes in `Data.Monoid` and `Data.Semigroup`, `Identity`, `Const`, `Tagged`, `Compose`). - Additionall "boring" types like `()` and `Proxy` are omitted as well. + Additionally "boring" types like `()` and `Proxy` are omitted as well. As the omitting is now uniform, type arguments are also omitted (also in `Generic1` derived instance). Resolves issues: @@ -52,7 +92,7 @@ * Move `Data.Aeson.Parser` module into separate [`attoparsec-aeson`](https://hackage.haskell.org/package/attoparsec-aeson) package, as these parsers are not used by `aeson` itself anymore. * Use [`text-iso8601`](https://hackage.haskell.org/package/text-iso8601) package for parsing `time` types. These are slightly faster than previously used (copy of) `attoparsec-iso8601`. Formats accepted is slightly changed: - - The space between time and timezone offset (in `UTCTime` and `ZonedTime`) is disallowed. ISO8601 explictly forbidds it. + - The space between time and timezone offset (in `UTCTime` and `ZonedTime`) is disallowed. ISO8601 explicitly forbids it. - The timezone offsets can be in range -23:59..23:59. This is how Python, joda-time etc seems to do. (Previously the range was -12..+14) * Remove internal `Data.Aeson.Internal` and `Data.Aeson.Internal.Time` modules. Everything from the former is exported elsewhere (`Data.Aeson.Types`), the latter was truly internal. @@ -215,7 +255,7 @@ parseJSON = gParseJSON defaultOptions { rejectUnknownFields = True } ``` -* `FromJSON` instance of `Ratio a` now parses numbers in addtion to +* `FromJSON` instance of `Ratio a` now parses numbers in addition to standard `{numerator=..., denumerator=...}` encoding. Thanks to Aleksey Khudyakov. 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,8 @@ -- -- This function parses immediately, but defers conversion. See -- 'json' for details. +-- +-- Throws an 'Exception' when the file is missing. decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a) decodeFileStrict = fmap decodeStrict . B.readFile @@ -226,12 +228,15 @@ -- 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 is missing. -- +-- 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 is missing. eitherDecodeFileStrict :: (FromJSON a) => FilePath -> IO (Either String a) eitherDecodeFileStrict = fmap eitherDecodeStrict . B.readFile @@ -253,7 +258,9 @@ -- | Like 'decodeFileStrict'' but returns an error message when decoding fails. -- --- Since @2.2.0.0@ an alias for 'eitherDecodeFileStrict''. +-- Throws an 'Exception' when the file is missing. +-- +-- Since @2.2.0.0@ an alias for 'eitherDecodeFileStrict'. eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a) eitherDecodeFileStrict' = eitherDecodeFileStrict {-# INLINE eitherDecodeFileStrict' #-} @@ -557,5 +564,5 @@ -- -- For more information, see -- , --- and +-- and -- (where the relevant parsers are defined). 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, @@ -96,7 +96,7 @@ -- Decoding: strict text ------------------------------------------------------------------------------- --- | Efficiently deserialize a JSON value from a strict 'B.ByteString'. +-- | Efficiently deserialize a JSON value from a strict 'T.Text'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. -- 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 @@ -18,12 +18,12 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS.Unsafe import qualified Data.Scientific as Sci +import qualified Data.Word8.Patterns as W8 import Data.Aeson.Decoding.Internal import Data.Aeson.Decoding.Tokens import Data.Aeson.Internal.Text (unsafeDecodeASCII) import Data.Aeson.Internal.Unescape (unescapeText) -import Data.Aeson.Internal.Word8 -- | Lex (and parse) strict 'ByteString' into 'Tokens' stream. -- @@ -42,17 +42,17 @@ -> ByteString -- whole input, needed for number parsing -> (ByteString -> k) -- continuation -> Tokens k String - tokenCase W8_OPEN_CURLY !bs !_ k = TkRecordOpen (goR bs k) - tokenCase W8_OPEN_SQUARE bs _ k = TkArrayOpen (goA bs k) - tokenCase W8_DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs - tokenCase W8_MINUS bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs + tokenCase W8.LEFT_CURLY !bs !_ k = TkRecordOpen (goR bs k) + tokenCase W8.LEFT_SQUARE bs _ k = TkArrayOpen (goA bs k) + tokenCase W8.DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs + tokenCase W8.HYPHEN bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs tokenCase w _ wbs k - | W8_0 <= w, w <= W8_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs - tokenCase W8_n bs _ k + | W8.DIGIT_0 <= w, w <= W8.DIGIT_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs + tokenCase W8.LOWER_N bs _ k | Just bs1 <- stripPrefix "ull" 3 bs = TkLit LitNull (k bs1) - tokenCase W8_t bs _ k + tokenCase W8.LOWER_T bs _ k | Just bs1 <- stripPrefix "rue" 3 bs = TkLit LitTrue (k bs1) - tokenCase W8_f bs _ k + tokenCase W8.LOWER_F bs _ k | Just bs1 <- stripPrefix "alse" 4 bs = TkLit LitFalse (k bs1) tokenCase _ _ wbs _ = tkErr $ "Unexpected " ++ showBeginning wbs ++ ", expecting JSON value" @@ -60,33 +60,33 @@ goA :: Parser TkArray k goA (skipSpace -> bs) k = case BS.uncons bs of Nothing -> tkErrEOF "JSON value or ]" - Just (W8_CLOSE_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W8.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) Just (w, !bs1) -> TkItem $ tokenCase w bs1 bs $ \bs2 -> goA1 bs2 k goA1 :: Parser TkArray k goA1 (skipSpace -> bs) k = case BS.uncons bs of Nothing -> tkErrEOF ", or ]" - Just (W8_CLOSE_SQUARE, !bs1) -> TkArrayEnd (k bs1) - Just (W8_COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k + Just (W8.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W8.COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k _ -> tkErrBS bs ", or ]" -- Record goR :: Parser TkRecord k goR (skipSpace -> bs) k = case BS.uncons bs of Nothing -> tkErrEOF "record key literal or }" - Just (W8_DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " - Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } + Just (W8.DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " + Just (W8.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } Just _ -> tkErrBS bs "record key literal or }" -- after record pair, expecting ," or } goR1 :: Parser TkRecord k goR1 (skipSpace -> bs) k = case BS.uncons bs of Nothing -> tkErr "Unexpected end-of-input, expecting , or }" - Just (W8_COMMA, !bs1) -> case BS.uncons (skipSpace bs1) of + Just (W8.COMMA, !bs1) -> case BS.uncons (skipSpace bs1) of Nothing -> tkErrEOF "key literal" - Just (W8_DOUBLE_QUOTE, !bs2) -> goRK bs2 k + Just (W8.DOUBLE_QUOTE, !bs2) -> goRK bs2 k Just _ -> tkErrBS bs "key literal" - Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1) + Just (W8.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) _ -> tkErr $ "Unexpected " ++ showBeginning bs ++ ", expecting , or }" -- key of record (after double quote) @@ -97,7 +97,7 @@ goRK' :: Text -> Parser TkRecord k goRK' t (skipSpace -> bs) k = case BS.uncons bs of Nothing -> tkErrEOF ":" - Just (W8_COLON, !bs3) -> TkPair (Key.fromText t) $ goT bs3 $ \bs4 -> goR1 bs4 k + Just (W8.COLON, !bs3) -> TkPair (Key.fromText t) $ goT bs3 $ \bs4 -> goR1 bs4 k Just _ -> tkErrBS bs ":" stripPrefix :: ByteString -> Int -> ByteString -> Maybe ByteString @@ -153,7 +153,9 @@ Right t -> ok t (BS.drop (n + 1) bs0) Left e -> err (show e) Just (92, bs') -> goSlash (n + 1) bs' - Just (_, bs') -> goEsc (n + 1) bs' + Just (w8, bs') + | w8 < 0x20 -> errCC + | otherwise -> goEsc (n + 1) bs' goSlash :: Int -> ByteString -> r goSlash !n !bs = case BS.uncons bs of @@ -161,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 @@ -187,27 +189,27 @@ state_start !bs = case BS.uncons bs of Nothing -> errEnd Just (w8, bs') - | W8_0 < w8, w8 <= W8_9 -> state_i1 1 bs' - | W8_0 == w8 -> state_after0 bs' - | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" + | W8.DIGIT_0 < w8, w8 <= W8.DIGIT_9 -> state_i1 1 bs' + | W8.DIGIT_0 == w8 -> state_after0 bs' + | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" state_after0 :: ByteString -> r state_after0 !bs = case BS.uncons bs of Nothing -> kont (NumInteger 0) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> err "Number literal with leading zero" - | W8_DOT == w8 -> go_dec 0 bs' - | W8_e == w8 || W8_E == w8 -> go_sci 0 0 bs' - | otherwise -> kont (NumInteger 0) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> err "Number literal with leading zero" + | W8.PERIOD == w8 -> go_dec 0 bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci 0 0 bs' + | otherwise -> kont (NumInteger 0) bs state_i1 :: Int -> ByteString -> r state_i1 !n !bs = case BS.uncons bs of Nothing -> kont (NumInteger int) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_i1 (n + 1) bs' - | W8_DOT == w8 -> go_dec int bs' - | W8_e == w8 || W8_E == w8 -> go_sci int 0 bs' - | otherwise -> kont (NumInteger int) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_i1 (n + 1) bs' + | W8.PERIOD == w8 -> go_dec int bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci int 0 bs' + | otherwise -> kont (NumInteger int) bs where int = byteStringToInteger (BS.Unsafe.unsafeTake n bs0) @@ -215,16 +217,16 @@ go_dec !int !bs1 = case BS.uncons bs1 of Nothing -> errEnd Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_dec 1 bs' - | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_dec 1 bs' + | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" where state_dec :: Int -> ByteString -> r state_dec !n !bs = case BS.uncons bs of Nothing -> kont (NumDecimal dec) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_dec (n + 1) bs' - | W8_e == w8 || W8_E == w8 -> go_sci coef (negate n) bs' - | otherwise -> kont (NumDecimal dec) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_dec (n + 1) bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci coef (negate n) bs' + | otherwise -> kont (NumDecimal dec) bs where frac = byteStringToInteger (BS.Unsafe.unsafeTake n bs1) coef = int * 10 ^ n + frac @@ -234,25 +236,25 @@ go_sci !coef !exp10 !bs2 = case BS.uncons bs2 of Nothing -> errEnd Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_pos coef exp10 bs2 1 bs' - | W8_PLUS == w8 -> case BS.uncons bs' of - Nothing -> errEnd + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs2 1 bs' + | W8.PLUS == w8 -> case BS.uncons bs' of + Nothing -> errEnd Just (w8', bs'') - | W8_0 <= w8', w8' <= W8_9 -> go_sci_pos coef exp10 bs' 1 bs'' - | otherwise -> errUnx w8' - | W8_MINUS == w8 -> case BS.uncons bs' of + | W8.DIGIT_0 <= w8', w8' <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs' 1 bs'' + | otherwise -> errUnx w8' + | W8.HYPHEN == w8 -> case BS.uncons bs' of Nothing -> errEnd Just (w8', bs'') - | W8_0 <= w8', w8' <= W8_9 -> go_sci_neg coef exp10 bs' 1 bs'' - | otherwise -> errUnx w8' - | otherwise -> errUnx w8 + | W8.DIGIT_0 <= w8', w8' <= W8.DIGIT_9 -> go_sci_neg coef exp10 bs' 1 bs'' + | otherwise -> errUnx w8' + | otherwise -> errUnx w8 go_sci_pos :: Integer -> Int -> ByteString -> Int -> ByteString -> r go_sci_pos !coef !exp10 !bs2 !n !bs = case BS.uncons bs of Nothing -> kont (NumScientific sci) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' - | otherwise -> kont (NumScientific sci) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' + | otherwise -> kont (NumScientific sci) bs where exp10' = fromInteger (byteStringToInteger (BS.Unsafe.unsafeTake n bs2)) sci = Sci.scientific coef (exp10 + exp10') @@ -261,7 +263,7 @@ go_sci_neg !coef !exp10 !bs2 !n !bs = case BS.uncons bs of Nothing -> kont (NumScientific sci) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' | otherwise -> kont (NumScientific sci) bs where exp10' = fromInteger (byteStringToInteger (BS.Unsafe.unsafeTake n bs2)) 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 @@ -18,12 +18,12 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Scientific as Sci +import qualified Data.Word8.Patterns as W8 import Data.Aeson.Decoding.Internal import Data.Aeson.Decoding.Tokens import Data.Aeson.Internal.Text (unsafeDecodeASCII) import Data.Aeson.Internal.Unescape (unescapeText) -import Data.Aeson.Internal.Word8 -- | Lex (and parse) lazy 'ByteString' into 'Tokens' stream. -- @@ -42,17 +42,17 @@ -> ByteString -- whole input, needed for number parsing -> (ByteString -> k) -- continuation -> Tokens k String - tokenCase W8_OPEN_CURLY !bs !_ k = TkRecordOpen (goR bs k) - tokenCase W8_OPEN_SQUARE bs _ k = TkArrayOpen (goA bs k) - tokenCase W8_DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs - tokenCase W8_MINUS bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs + tokenCase W8.LEFT_CURLY !bs !_ k = TkRecordOpen (goR bs k) + tokenCase W8.LEFT_SQUARE bs _ k = TkArrayOpen (goA bs k) + tokenCase W8.DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs + tokenCase W8.HYPHEN bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs tokenCase w _ wbs k - | W8_0 <= w, w <= W8_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs - tokenCase W8_n bs _ k + | W8.DIGIT_0 <= w, w <= W8.DIGIT_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs + tokenCase W8.LOWER_N bs _ k | Just bs1 <- stripPrefix "ull" 3 bs = TkLit LitNull (k bs1) - tokenCase W8_t bs _ k + tokenCase W8.LOWER_T bs _ k | Just bs1 <- stripPrefix "rue" 3 bs = TkLit LitTrue (k bs1) - tokenCase W8_f bs _ k + tokenCase W8.LOWER_F bs _ k | Just bs1 <- stripPrefix "alse" 4 bs = TkLit LitFalse (k bs1) tokenCase _ _ wbs _ = tkErr $ "Unexpected " ++ showBeginning wbs ++ ", expecting JSON value" @@ -60,33 +60,33 @@ goA :: Parser TkArray k goA (skipSpace -> bs) k = case LBS.uncons bs of Nothing -> tkErrEOF "JSON value or ]" - Just (W8_CLOSE_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W8.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) Just (w, !bs1) -> TkItem $ tokenCase w bs1 bs $ \bs2 -> goA1 bs2 k goA1 :: Parser TkArray k goA1 (skipSpace -> bs) k = case LBS.uncons bs of Nothing -> tkErrEOF ", or ]" - Just (W8_CLOSE_SQUARE, !bs1) -> TkArrayEnd (k bs1) - Just (W8_COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k + Just (W8.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W8.COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k _ -> tkErrBS bs ", or ]" -- Record goR :: Parser TkRecord k goR (skipSpace -> bs) k = case LBS.uncons bs of Nothing -> tkErrEOF "record key literal or }" - Just (W8_DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " - Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } + Just (W8.DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " + Just (W8.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } Just _ -> tkErrBS bs "record key literal or }" -- after record pair, expecting ," or } goR1 :: Parser TkRecord k goR1 (skipSpace -> bs) k = case LBS.uncons bs of Nothing -> tkErr "Unexpected end-of-input, expecting , or }" - Just (W8_COMMA, !bs1) -> case LBS.uncons (skipSpace bs1) of + Just (W8.COMMA, !bs1) -> case LBS.uncons (skipSpace bs1) of Nothing -> tkErrEOF "key literal" - Just (W8_DOUBLE_QUOTE, !bs2) -> goRK bs2 k + Just (W8.DOUBLE_QUOTE, !bs2) -> goRK bs2 k Just _ -> tkErrBS bs "key literal" - Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1) + Just (W8.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) _ -> tkErr $ "Unexpected " ++ showBeginning bs ++ ", expecting , or }" -- key of record (after double quote) @@ -97,7 +97,7 @@ goRK' :: Text -> Parser TkRecord k goRK' t (skipSpace -> bs) k = case LBS.uncons bs of Nothing -> tkErrEOF ":" - Just (W8_COLON, !bs3) -> TkPair (Key.fromText t) $ goT bs3 $ \bs4 -> goR1 bs4 k + Just (W8.COLON, !bs3) -> TkPair (Key.fromText t) $ goT bs3 $ \bs4 -> goR1 bs4 k Just _ -> tkErrBS bs ":" stripPrefix :: ByteString -> Int -> ByteString -> Maybe ByteString @@ -159,7 +159,9 @@ Right t -> ok t (lbsDrop (n + 1) bs0) Left e -> err (show e) Just (92, bs') -> goSlash (n + 1) bs' - Just (_, bs') -> goEsc (n + 1) bs' + Just (w8, bs') + | w8 < 0x20 -> errCC + | otherwise -> goEsc (n + 1) bs' goSlash :: Int -> ByteString -> r goSlash !n !bs = case LBS.uncons bs of @@ -167,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 @@ -193,27 +195,27 @@ state_start !bs = case LBS.uncons bs of Nothing -> errEnd Just (w8, bs') - | W8_0 < w8, w8 <= W8_9 -> state_i1 1 bs' - | W8_0 == w8 -> state_after0 bs' + | W8.DIGIT_0 < w8, w8 <= W8.DIGIT_9 -> state_i1 1 bs' + | W8.DIGIT_0 == w8 -> state_after0 bs' | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" state_after0 :: ByteString -> r state_after0 !bs = case LBS.uncons bs of Nothing -> kont (NumInteger 0) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> err "Number literal with leading zero" - | W8_DOT == w8 -> go_dec 0 bs' - | W8_e == w8 || W8_E == w8 -> go_sci 0 0 bs' - | otherwise -> kont (NumInteger 0) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> err "Number literal with leading zero" + | W8.PERIOD == w8 -> go_dec 0 bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci 0 0 bs' + | otherwise -> kont (NumInteger 0) bs state_i1 :: Int -> ByteString -> r state_i1 !n !bs = case LBS.uncons bs of Nothing -> kont (NumInteger int) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_i1 (n + 1) bs' - | W8_DOT == w8 -> go_dec int bs' - | W8_e == w8 || W8_E == w8 -> go_sci int 0 bs' - | otherwise -> kont (NumInteger int) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_i1 (n + 1) bs' + | W8.PERIOD == w8 -> go_dec int bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci int 0 bs' + | otherwise -> kont (NumInteger int) bs where int = byteStringToInteger (lbsTake n bs0) @@ -221,16 +223,16 @@ go_dec !int !bs1 = case LBS.uncons bs1 of Nothing -> errEnd Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_dec 1 bs' - | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_dec 1 bs' + | otherwise -> err $ "Unexpected " ++ show w8 ++ " while parsing number literal" where state_dec :: Int -> ByteString -> r state_dec !n !bs = case LBS.uncons bs of Nothing -> kont (NumDecimal dec) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_dec (n + 1) bs' - | W8_e == w8 || W8_E == w8 -> go_sci coef (negate n) bs' - | otherwise -> kont (NumDecimal dec) bs + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> state_dec (n + 1) bs' + | W8.LOWER_E == w8 || W8.UPPER_E == w8 -> go_sci coef (negate n) bs' + | otherwise -> kont (NumDecimal dec) bs where frac = byteStringToInteger (lbsTake n bs1) coef = int * 10 ^ n + frac @@ -240,16 +242,16 @@ go_sci !coef !exp10 !bs2 = case LBS.uncons bs2 of Nothing -> errEnd Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_pos coef exp10 bs2 1 bs' - | W8_PLUS == w8 -> case LBS.uncons bs' of + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs2 1 bs' + | W8.PLUS == w8 -> case LBS.uncons bs' of Nothing -> errEnd Just (w8', bs'') - | W8_0 <= w8', w8' <= W8_9 -> go_sci_pos coef exp10 bs' 1 bs'' + | W8.DIGIT_0 <= w8', w8' <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs' 1 bs'' | otherwise -> errUnx w8' - | W8_MINUS == w8 -> case LBS.uncons bs' of + | W8.HYPHEN == w8 -> case LBS.uncons bs' of Nothing -> errEnd Just (w8', bs'') - | W8_0 <= w8', w8' <= W8_9 -> go_sci_neg coef exp10 bs' 1 bs'' + | W8.DIGIT_0 <= w8', w8' <= W8.DIGIT_9 -> go_sci_neg coef exp10 bs' 1 bs'' | otherwise -> errUnx w8' | otherwise -> errUnx w8 @@ -257,7 +259,7 @@ go_sci_pos !coef !exp10 !bs2 !n !bs = case LBS.uncons bs of Nothing -> kont (NumScientific sci) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' | otherwise -> kont (NumScientific sci) bs where exp10' = fromInteger (byteStringToInteger (lbsTake n bs2)) @@ -267,7 +269,7 @@ go_sci_neg !coef !exp10 !bs2 !n !bs = case LBS.uncons bs of Nothing -> kont (NumScientific sci) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' + | W8.DIGIT_0 <= w8, w8 <= W8.DIGIT_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' | otherwise -> kont (NumScientific sci) bs where exp10' = fromInteger (byteStringToInteger (lbsTake n bs2)) 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 @@ -24,9 +24,9 @@ import Data.Aeson.Internal.UnescapeFromText (unescapeFromText) #if MIN_VERSION_text(2,0,0) -import Data.Aeson.Internal.Word8 +import qualified Data.Word8.Patterns as W #else -import Data.Aeson.Internal.Word16 +import qualified Data.Word16.Patterns as W #endif #if MIN_VERSION_text(2,0,0) @@ -36,7 +36,7 @@ #endif --- | Lex (and parse) strict 'ByteString' into 'Tokens' stream. +-- | Lex (and parse) strict 'Text' into 'Tokens' stream. -- -- @since 2.2.1.0 -- @@ -53,51 +53,50 @@ -> Text -- whole input, needed for number parsing -> (Text -> k) -- continuation -> Tokens k String - tokenCase W8_OPEN_CURLY !bs !_ k = TkRecordOpen (goR bs k) - tokenCase W8_OPEN_SQUARE bs _ k = TkArrayOpen (goA bs k) - tokenCase W8_DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs - tokenCase W8_MINUS bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs + tokenCase W.LEFT_CURLY !bs !_ k = TkRecordOpen (goR bs k) + tokenCase W.LEFT_SQUARE bs _ k = TkArrayOpen (goA bs k) + tokenCase W.DOUBLE_QUOTE bs _ k = scanStringLiteral (\t bs' -> TkText t (k bs')) tkErr bs + tokenCase W.HYPHEN bs _ k = scanNumberLiteral (\n bs' -> TkNumber (negateNumber n) (k bs')) tkErr bs tokenCase w _ wbs k - | W8_0 <= w, w <= W8_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs - tokenCase W8_n bs _ k + | W.DIGIT_0 <= w, w <= W.DIGIT_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs + tokenCase W.LOWER_N bs _ k | Just bs1 <- stripPrefix "ull" 3 bs = TkLit LitNull (k bs1) - tokenCase W8_t bs _ k + tokenCase W.LOWER_T bs _ k | Just bs1 <- stripPrefix "rue" 3 bs = TkLit LitTrue (k bs1) - tokenCase W8_f bs _ k + tokenCase W.LOWER_F bs _ k | Just bs1 <- stripPrefix "alse" 4 bs = TkLit LitFalse (k bs1) - tokenCase _ _ wbs _ = tkErr $ "Unexpected " ++ showBeginning wbs ++ ", expecting JSON value" - + tokenCase _ _ wbs _ = tkErr $ "Unexpected " ++ showBeginning wbs ++ ", expecting JSON value" -- Array goA :: Parser TkArray k goA (skipSpace -> bs) k = case unconsPoint bs of Nothing -> tkErrEOF "JSON value or ]" - Just (W8_CLOSE_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) Just (w, !bs1) -> TkItem $ tokenCase w bs1 bs $ \bs2 -> goA1 bs2 k goA1 :: Parser TkArray k goA1 (skipSpace -> bs) k = case unconsPoint bs of Nothing -> tkErrEOF ", or ]" - Just (W8_CLOSE_SQUARE, !bs1) -> TkArrayEnd (k bs1) - Just (W8_COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k + Just (W.RIGHT_SQUARE, !bs1) -> TkArrayEnd (k bs1) + Just (W.COMMA, !bs1) -> TkItem $ goT bs1 $ \bs2 -> goA1 bs2 k _ -> tkErrBS bs ", or ]" -- Record goR :: Parser TkRecord k goR (skipSpace -> bs) k = case unconsPoint bs of Nothing -> tkErrEOF "record key literal or }" - Just (W8_DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " - Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } + Just (W.DOUBLE_QUOTE, !bs1) -> goRK bs1 k -- " + Just (W.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) -- } Just _ -> tkErrBS bs "record key literal or }" -- after record pair, expecting ," or } goR1 :: Parser TkRecord k goR1 (skipSpace -> bs) k = case unconsPoint bs of Nothing -> tkErr "Unexpected end-of-input, expecting , or }" - Just (W8_COMMA, !bs1) -> case unconsPoint (skipSpace bs1) of + Just (W.COMMA, !bs1) -> case unconsPoint (skipSpace bs1) of Nothing -> tkErrEOF "key literal" - Just (W8_DOUBLE_QUOTE, !bs2) -> goRK bs2 k + Just (W.DOUBLE_QUOTE, !bs2) -> goRK bs2 k Just _ -> tkErrBS bs "key literal" - Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1) + Just (W.RIGHT_CURLY, !bs1) -> TkRecordEnd (k bs1) _ -> tkErr $ "Unexpected " ++ showBeginning bs ++ ", expecting , or }" -- key of record (after double quote) @@ -164,7 +163,9 @@ Right t -> ok t (unsafeDropPoints (n + 1) bs0) Left e -> err (show e) Just (92, bs') -> goSlash (n + 1) bs' - Just (_, bs') -> goEsc (n + 1) bs' + Just (w8, bs') + | w8 < 0x20 -> errCC + | otherwise -> goEsc (n + 1) bs' goSlash :: Int -> Text -> r goSlash !n !bs = case unconsPoint bs of @@ -172,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 @@ -196,46 +197,46 @@ scanNumberLiteral kont err bs0 = state_start bs0 where state_start :: Text -> r state_start !bs = case unconsPoint bs of - Nothing -> errEnd + Nothing -> errEnd Just (w8, bs') - | W8_0 < w8, w8 <= W8_9 -> state_i1 1 bs' - | W8_0 == w8 -> state_after0 bs' - | otherwise -> errUnx w8 + | W.DIGIT_0 < w8, w8 <= W.DIGIT_9 -> state_i1 1 bs' + | W.DIGIT_0 == w8 -> state_after0 bs' + | otherwise -> errUnx w8 state_after0 :: Text -> r state_after0 !bs = case unconsPoint bs of - Nothing -> kont (NumInteger 0) bs + Nothing -> kont (NumInteger 0) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> err "Number literal with leading zero" - | W8_DOT == w8 -> go_dec 0 bs' - | W8_e == w8 || W8_E == w8 -> go_sci 0 0 bs' - | otherwise -> kont (NumInteger 0) bs + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> err "Number literal with leading zero" + | W.PERIOD == w8 -> go_dec 0 bs' + | W.LOWER_E == w8 || W.UPPER_E == w8 -> go_sci 0 0 bs' + | otherwise -> kont (NumInteger 0) bs state_i1 :: Int -> Text -> r state_i1 !n !bs = case unconsPoint bs of - Nothing -> kont (NumInteger int) bs + Nothing -> kont (NumInteger int) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_i1 (n + 1) bs' - | W8_DOT == w8 -> go_dec int bs' - | W8_e == w8 || W8_E == w8 -> go_sci int 0 bs' - | otherwise -> kont (NumInteger int) bs + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> state_i1 (n + 1) bs' + | W.PERIOD == w8 -> go_dec int bs' + | W.LOWER_E == w8 || W.UPPER_E == w8 -> go_sci int 0 bs' + | otherwise -> kont (NumInteger int) bs where int = textToInteger (unsafeTakePoints n bs0) go_dec :: Integer -> Text -> r go_dec !int !bs1 = case unconsPoint bs1 of - Nothing -> errEnd + Nothing -> errEnd Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_dec 1 bs' - | otherwise -> errUnx w8 + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> state_dec 1 bs' + | otherwise -> errUnx w8 where state_dec :: Int -> Text -> r state_dec !n !bs = case unconsPoint bs of - Nothing -> kont (NumDecimal dec) bs + Nothing -> kont (NumDecimal dec) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> state_dec (n + 1) bs' - | W8_e == w8 || W8_E == w8 -> go_sci coef (negate n) bs' - | otherwise -> kont (NumDecimal dec) bs + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> state_dec (n + 1) bs' + | W.LOWER_E == w8 || W.UPPER_E == w8 -> go_sci coef (negate n) bs' + | otherwise -> kont (NumDecimal dec) bs where frac = textToInteger (unsafeTakePoints n bs1) coef = int * 10 ^ n + frac @@ -243,37 +244,37 @@ go_sci :: Integer -> Int -> Text -> r go_sci !coef !exp10 !bs2 = case unconsPoint bs2 of - Nothing -> errEnd + Nothing -> errEnd Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_pos coef exp10 bs2 1 bs' - | W8_PLUS == w8 -> case unconsPoint bs' of - Nothing -> errEnd + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> go_sci_pos coef exp10 bs2 1 bs' + | W.PLUS == w8 -> case unconsPoint bs' of + Nothing -> errEnd Just (w8', bs'') - | W8_0 <= w8', w8' <= W8_9 -> go_sci_pos coef exp10 bs' 1 bs'' - | otherwise -> errUnx w8' - | W8_MINUS == w8 -> case unconsPoint bs' of - Nothing -> errEnd + | W.DIGIT_0 <= w8', w8' <= W.DIGIT_9 -> go_sci_pos coef exp10 bs' 1 bs'' + | otherwise -> errUnx w8' + | W.HYPHEN == w8 -> case unconsPoint bs' of + Nothing -> errEnd Just (w8', bs'') - | W8_0 <= w8', w8' <= W8_9 -> go_sci_neg coef exp10 bs' 1 bs'' - | otherwise -> errUnx w8' - | otherwise -> errUnx w8 + | W.DIGIT_0 <= w8', w8' <= W.DIGIT_9 -> go_sci_neg coef exp10 bs' 1 bs'' + | otherwise -> errUnx w8' + | otherwise -> errUnx w8 go_sci_pos :: Integer -> Int -> Text -> Int -> Text -> r go_sci_pos !coef !exp10 !bs2 !n !bs = case unconsPoint bs of - Nothing -> kont (NumScientific sci) bs + Nothing -> kont (NumScientific sci) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' - | otherwise -> kont (NumScientific sci) bs + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> go_sci_pos coef exp10 bs2 (n + 1) bs' + | otherwise -> kont (NumScientific sci) bs where exp10' = fromInteger (textToInteger (unsafeTakePoints n bs2)) sci = Sci.scientific coef (exp10 + exp10') go_sci_neg :: Integer -> Int -> Text -> Int -> Text -> r go_sci_neg !coef !exp10 !bs2 !n !bs = case unconsPoint bs of - Nothing -> kont (NumScientific sci) bs + Nothing -> kont (NumScientific sci) bs Just (w8, bs') - | W8_0 <= w8, w8 <= W8_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' - | otherwise -> kont (NumScientific sci) bs + | W.DIGIT_0 <= w8, w8 <= W.DIGIT_9 -> go_sci_neg coef exp10 bs2 (n + 1) bs' + | otherwise -> kont (NumScientific sci) bs where exp10' = fromInteger (textToInteger (unsafeTakePoints n bs2)) sci = Sci.scientific coef (exp10 - exp10') 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/Internal/Word16.hs b/src/Data/Aeson/Internal/Word16.hs deleted file mode 100644 --- a/src/Data/Aeson/Internal/Word16.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} --- | This is s/Word8/Word16/g copy of .Word8 module. --- This module is used for low-bit working with text <2 (UTF-16) -module Data.Aeson.Internal.Word16 where - -import Data.Word (Word16) - -------------------------------------------------------------------------------- --- Word16 ASCII codes as patterns -------------------------------------------------------------------------------- - --- GHC-8.0 doesn't support giving multiple pattern synonyms type signature at once - --- spaces -pattern W8_SPACE :: Word16 -pattern W8_NL :: Word16 -pattern W8_CR :: Word16 -pattern W8_TAB :: Word16 - -pattern W8_SPACE = 0x20 -pattern W8_NL = 0x0a -pattern W8_CR = 0x0d -pattern W8_TAB = 0x09 - --- punctuation -pattern W8_BACKSLASH :: Word16 -pattern W8_DOUBLE_QUOTE :: Word16 -pattern W8_DOT :: Word16 -pattern W8_COMMA :: Word16 -pattern W8_COLON :: Word16 - -pattern W8_BACKSLASH = 92 -pattern W8_COMMA = 44 -pattern W8_DOT = 46 -pattern W8_DOUBLE_QUOTE = 34 -pattern W8_COLON = 58 - --- parentheses -pattern W8_CLOSE_CURLY :: Word16 -pattern W8_CLOSE_SQUARE :: Word16 -pattern W8_OPEN_SQUARE :: Word16 -pattern W8_OPEN_CURLY :: Word16 - -pattern W8_OPEN_CURLY = 123 -pattern W8_OPEN_SQUARE = 91 -pattern W8_CLOSE_CURLY = 125 -pattern W8_CLOSE_SQUARE = 93 - --- operators -pattern W8_MINUS :: Word16 -pattern W8_PLUS :: Word16 - -pattern W8_PLUS = 43 -pattern W8_MINUS = 45 - --- digits -pattern W8_0 :: Word16 -pattern W8_9 :: Word16 - -pattern W8_0 = 48 -pattern W8_9 = 57 - --- lower case -pattern W8_e :: Word16 -pattern W8_f :: Word16 -pattern W8_n :: Word16 -pattern W8_t :: Word16 - -pattern W8_e = 101 -pattern W8_f = 102 -pattern W8_n = 110 -pattern W8_t = 116 - --- upper case -pattern W8_E :: Word16 -pattern W8_E = 69 diff --git a/src/Data/Aeson/Internal/Word8.hs b/src/Data/Aeson/Internal/Word8.hs deleted file mode 100644 --- a/src/Data/Aeson/Internal/Word8.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Data.Aeson.Internal.Word8 where - -import Data.Word (Word8) - -------------------------------------------------------------------------------- --- Word8 ASCII codes as patterns -------------------------------------------------------------------------------- - --- GHC-8.0 doesn't support giving multiple pattern synonyms type signature at once - --- spaces -pattern W8_SPACE :: Word8 -pattern W8_NL :: Word8 -pattern W8_CR :: Word8 -pattern W8_TAB :: Word8 - -pattern W8_SPACE = 0x20 -pattern W8_NL = 0x0a -pattern W8_CR = 0x0d -pattern W8_TAB = 0x09 - --- punctuation -pattern W8_BACKSLASH :: Word8 -pattern W8_DOUBLE_QUOTE :: Word8 -pattern W8_DOT :: Word8 -pattern W8_COMMA :: Word8 -pattern W8_COLON :: Word8 - -pattern W8_BACKSLASH = 92 -pattern W8_COMMA = 44 -pattern W8_DOT = 46 -pattern W8_DOUBLE_QUOTE = 34 -pattern W8_COLON = 58 - --- parentheses -pattern W8_CLOSE_CURLY :: Word8 -pattern W8_CLOSE_SQUARE :: Word8 -pattern W8_OPEN_SQUARE :: Word8 -pattern W8_OPEN_CURLY :: Word8 - -pattern W8_OPEN_CURLY = 123 -pattern W8_OPEN_SQUARE = 91 -pattern W8_CLOSE_CURLY = 125 -pattern W8_CLOSE_SQUARE = 93 - --- operators -pattern W8_MINUS :: Word8 -pattern W8_PLUS :: Word8 - -pattern W8_PLUS = 43 -pattern W8_MINUS = 45 - --- digits -pattern W8_0 :: Word8 -pattern W8_9 :: Word8 - -pattern W8_0 = 48 -pattern W8_9 = 57 - --- lower case -pattern W8_e :: Word8 -pattern W8_f :: Word8 -pattern W8_n :: Word8 -pattern W8_t :: Word8 - -pattern W8_e = 101 -pattern W8_f = 102 -pattern W8_n = 110 -pattern W8_t = 116 - --- upper case -pattern W8_E :: Word8 -pattern W8_E = 69 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 @@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskellQuotes #-} -- | @@ -29,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 @@ -39,7 +41,7 @@ import qualified Test.QuickCheck as QC newtype Key = Key { unKey :: Text } - deriving (Eq, Ord, Typeable, Data) + deriving (Data) fromString :: String -> Key fromString = Key . T.pack @@ -58,7 +60,7 @@ -- -- Using 'coercing' we can make more efficient implementations -- when 'Key' is backed up by 'Text' without exposing internals. --- +-- coercionToText :: Maybe (Coercion Key Text) coercionToText = Just Coercion {-# INLINE coercionToText #-} @@ -79,13 +81,14 @@ readPrec = fromString <$> readPrec instance Show Key where - showsPrec d (Key k) = showsPrec d k + showsPrec d (Key k) = showsPrec d k instance Data.String.IsString Key where fromString = fromString -instance Hashable Key where - hashWithSalt salt (Key k) = hashWithSalt salt k +deriving newtype instance Eq Key +deriving newtype instance Ord Key +deriving newtype instance Hashable Key instance NFData Key where rnf (Key k) = rnf k 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 @@ -141,7 +140,7 @@ -- | 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. @@ -355,7 +354,7 @@ -- | 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 @@ -689,6 +688,12 @@ ------------------------------------------------------------------------------- -- semialign ------------------------------------------------------------------------------- + +-- | +-- +-- @since 2.2.5.0 +instance SA.Unzip KeyMap where + unzip = SA.unzipDefault instance SA.Zip KeyMap where zipWith = intersectionWith diff --git a/src/Data/Aeson/RFC8785.hs b/src/Data/Aeson/RFC8785.hs --- a/src/Data/Aeson/RFC8785.hs +++ b/src/Data/Aeson/RFC8785.hs @@ -13,7 +13,6 @@ import Data.Aeson.Encoding import Data.Aeson.Encoding.Internal import Data.Aeson.Internal.Prelude -import Data.Aeson.Internal.Word8 import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM @@ -24,6 +23,7 @@ import qualified Data.Scientific as Sci import qualified Data.Text.Encoding as TE import qualified Data.Vector as V +import qualified Data.Word8.Patterns as W8 -- $setup -- >>> import Data.Aeson @@ -94,8 +94,8 @@ -- RFC8785 Appendix D says "don't use bignums". canonicalNumber :: Scientific -> Encoding canonicalNumber m = case compare m 0 of - EQ -> Encoding (B.word8 W8_0) - LT -> Encoding (B.word8 W8_MINUS <> fromEncoding (canonicalNumber' (negate m))) + EQ -> Encoding (B.word8 W8.DIGIT_0) + LT -> Encoding (B.word8 W8.HYPHEN <> fromEncoding (canonicalNumber' (negate m))) GT -> canonicalNumber' m -- input: Positive number @@ -104,36 +104,36 @@ | k <= n, n <= 21 = Encoding $ BP.primMapListFixed BP.word8 ds <> - BP.primMapListFixed BP.word8 (replicate (n - k) W8_0) + BP.primMapListFixed BP.word8 (replicate (n - k) W8.DIGIT_0) | 0 < n, n <= 21 , let (pfx, sfx) = splitAt n ds = Encoding $ BP.primMapListFixed BP.word8 pfx <> - B.word8 W8_DOT <> + B.word8 W8.PERIOD <> BP.primMapListFixed BP.word8 sfx | -6 < n, n <= 0 = Encoding $ - B.word8 W8_0 <> - B.word8 W8_DOT <> - BP.primMapListFixed BP.word8 (replicate (negate n) W8_0) <> + B.word8 W8.DIGIT_0 <> + B.word8 W8.PERIOD <> + BP.primMapListFixed BP.word8 (replicate (negate n) W8.DIGIT_0) <> BP.primMapListFixed BP.word8 ds | k == 1, [d] <- ds = Encoding $ B.word8 d <> - B.word8 W8_e <> - B.word8 (if (n - 1) >= 0 then W8_PLUS else W8_MINUS) <> + B.word8 W8.LOWER_E <> + B.word8 (if (n - 1) >= 0 then W8.PLUS else W8.HYPHEN) <> BP.primMapListFixed BP.word8 (integerToDecimalDigits (abs (toInteger n - 1))) | (d:ds') <- ds = Encoding $ B.word8 d <> - B.word8 W8_DOT <> + B.word8 W8.PERIOD <> BP.primMapListFixed BP.word8 ds' <> - B.word8 W8_e <> - B.word8 (if (n - 1) >= 0 then W8_PLUS else W8_MINUS) <> + B.word8 W8.LOWER_E <> + B.word8 (if (n - 1) >= 0 then W8.PLUS else W8.HYPHEN) <> BP.primMapListFixed BP.word8 (integerToDecimalDigits (abs (toInteger n - 1))) | otherwise @@ -166,4 +166,4 @@ integerToDecimalDigits = go [] where go acc 0 = acc go acc i = case quotRemInteger i 10 of - (# q, r #) -> go (d:acc) q where !d = fromIntegral r + W8_0 + (# q, r #) -> go (d:acc) q where !d = fromIntegral r + W8.DIGIT_0 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 @@ -945,7 +945,7 @@ (appE [|show|] (varE unknownFields))) [] ] - x:xs = [ lookupField argTy + (x,xs) = nonEmpty [ lookupField argTy `appE` dispatchParseJSON jc conName tvMap argTy `appE` litE (stringL $ show tName) `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName) @@ -955,6 +955,11 @@ | (field, argTy) <- zip fields argTys ] +-- 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" + getValField :: Name -> String -> [MatchQ] -> Q Exp getValField obj valFieldName matches = do val <- newName "val" @@ -1056,12 +1061,12 @@ -> [Type] -- ^ The argument types of the constructor. -> Name -- ^ Name of the type to which the constructor belongs. -> Name -- ^ 'Con'structor name. - -> Integer -- ^ 'Con'structor arity. + -> Integer -- ^ 'Con'structor arity. >= 1 -> [Q Match] parseProduct jc tvMap argTys tName conName numArgs = [ do arr <- newName "arr" -- List of: "parseJSON (arr `V.unsafeIndex` )" - let x:xs = [ dispatchParseJSON jc conName tvMap argTy + let (x,xs) = nonEmpty [ dispatchParseJSON jc conName tvMap argTy `appE` infixApp (varE arr) [|V.unsafeIndex|] @@ -1271,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/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 @@ -1,18 +1,20 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -86,13 +88,14 @@ import Data.Aeson.Internal.Prelude import Control.Monad (zipWithM, guard) +import Data.Aeson.Decoding.ByteString.Lazy +import Data.Aeson.Decoding.Conversion (unResult, toResultValue, lbsSpace) import Data.Aeson.Internal.Functions (mapKey, mapKeyO) import Data.Aeson.Internal.Scientific import Data.Aeson.Types.Generic import Data.Aeson.Types.Internal -import Data.Aeson.Decoding.ByteString.Lazy -import Data.Aeson.Decoding.Conversion (unResult, toResultValue, lbsSpace) 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(..)) @@ -100,6 +103,7 @@ import Data.Functor.Sum (Sum(..)) import Data.Functor.These (These1 (..)) import Data.Hashable (Hashable(..)) +import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty(..)) import Data.Ord (Down (..)) import Data.Ratio ((%), Ratio) @@ -213,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 $ @@ -793,11 +803,13 @@ withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a withBoundedScientific_ whenFail f (Number scientific) = if exp10 > 1024 - then whenFail (fail msg) + then whenFail (fail (msg "greater than 1024")) + else if exp10 < -1024 + then whenFail (fail (msg "less than -1024")) else f scientific where exp10 = base10Exponent scientific - msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024" + msg req = "found a number with exponent " ++ show exp10 ++ ", but it must not be " ++ req withBoundedScientific_ whenFail _ v = whenFail (typeMismatch "Number" v) @@ -865,7 +877,7 @@ (.:!) = explicitParseFieldMaybe' parseJSON -- | Retrieve the value associated with the given key of an 'Object'. --- If the key is not present and the 'omittedField' is @'Just' x@ for some @x@, +-- If the key is not present or the field is @null@ and the 'omittedField' is @'Just' x@ for some @x@, -- the result will be that @x@. -- -- @since 2.2.0.0 @@ -873,7 +885,7 @@ (.:?=) = explicitParseFieldOmit omittedField parseJSON -- | Retrieve the value associated with the given key of an 'Object'. --- If the key is not present or the field is @null@ and the 'omittedField' is @'Just' x@ for some @x@, +-- If the key is not present and the 'omittedField' is @'Just' x@ for some @x@, -- the result will be that @x@. -- -- This differs from '.:?=' by attempting to parse 'Null' the same as any @@ -1703,14 +1715,7 @@ _ -> Scientific.toRealFloat <$> parseScientificText t instance (FromJSON a, Integral a) => FromJSON (Ratio a) where - parseJSON (Number x) - | exp10 <= 1024 - , exp10 >= -1024 = return $! realToFrac x - | otherwise = prependContext "Ratio" $ fail msg - where - exp10 = base10Exponent x - msg = "found a number with exponent " ++ show exp10 - ++ ", but it must not be greater than 1024 or less than -1024" + parseJSON n@(Number _) = withBoundedScientific "Ratio" (($!) pure . realToFrac) n parseJSON o = objParser o where objParser = withObject "Rational" $ \obj -> do @@ -1720,6 +1725,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 @@ -1727,6 +1743,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" @@ -1922,17 +1944,10 @@ instance FromJSON1 Identity where liftParseJSON _ p _ a = coerce (p a) - liftParseJSONList _ _ p a = coerce (p a) - liftOmittedField = coerce -instance (FromJSON a) => FromJSON (Identity a) where - parseJSON = parseJSON1 - - parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList - - omittedField = coerce (omittedField @a) +deriving via (a :: Type) instance FromJSON a => FromJSON (Identity a) instance (FromJSONKey a) => FromJSONKey (Identity a) where fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a) @@ -2313,114 +2328,58 @@ ------------------------------------------------------------------------------- -- | @since 2.2.0.0 -instance FromJSON1 Down where - liftParseJSON _ p _ = coerce p - - liftOmittedField = coerce +deriving via Identity instance FromJSON1 Down -- | @since 2.2.0.0 -instance FromJSON a => FromJSON (Down a) where - parseJSON = parseJSON1 +deriving via (a :: Type) instance FromJSON a => FromJSON (Down a) ------------------------------------------------------------------------------- -- base Monoid/Semigroup ------------------------------------------------------------------------------- -instance FromJSON1 Monoid.Dual where - liftParseJSON _ p _ = coerce p - - liftOmittedField = coerce - -instance FromJSON a => FromJSON (Monoid.Dual a) where - parseJSON = parseJSON1 - - -instance FromJSON1 Monoid.First where - liftParseJSON o = coerce (liftParseJSON @Maybe o) - liftOmittedField _ = Just (Monoid.First Nothing) - -instance FromJSON a => FromJSON (Monoid.First a) where - parseJSON = parseJSON1 - omittedField = omittedField1 - -instance FromJSON1 Monoid.Last where - liftParseJSON o = coerce (liftParseJSON @Maybe o) - liftOmittedField _ = Just (Monoid.Last Nothing) - -instance FromJSON a => FromJSON (Monoid.Last a) where - parseJSON = parseJSON1 - omittedField = omittedField1 - -instance FromJSON1 Semigroup.Min where - liftParseJSON _ p _ a = coerce (p a) - - liftParseJSONList _ _ p a = coerce (p a) - - liftOmittedField = coerce - -instance (FromJSON a) => FromJSON (Semigroup.Min a) where - parseJSON = parseJSON1 - - parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList - - omittedField = omittedField1 - -instance FromJSON1 Semigroup.Max where - liftParseJSON _ p _ a = coerce (p a) - - liftParseJSONList _ _ p a = coerce (p a) - liftOmittedField = coerce - -instance (FromJSON a) => FromJSON (Semigroup.Max a) where - parseJSON = parseJSON1 - - parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList - omittedField = omittedField1 - -instance FromJSON1 Semigroup.First where - liftParseJSON _ p _ a = coerce (p a) - - liftParseJSONList _ _ p a = coerce (p a) - liftOmittedField = coerce +deriving via Identity instance FromJSON1 Monoid.Dual +deriving via (a :: Type) instance FromJSON a => FromJSON (Monoid.Dual a) -instance (FromJSON a) => FromJSON (Semigroup.First a) where - parseJSON = parseJSON1 +deriving via Maybe instance FromJSON1 Monoid.First +deriving via Maybe a instance FromJSON a => FromJSON (Monoid.First a) - parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList +deriving via Maybe instance FromJSON1 Monoid.Last +deriving via Maybe a instance FromJSON a => FromJSON (Monoid.Last a) +deriving via Identity instance FromJSON1 Semigroup.Min +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Min a) -instance FromJSON1 Semigroup.Last where - liftParseJSON _ p _ a = coerce (p a) +deriving via Identity instance FromJSON1 Semigroup.Max +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Max a) - liftParseJSONList _ _ p a = coerce (p a) - liftOmittedField = coerce +deriving via Identity instance FromJSON1 Semigroup.First +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.First a) -instance (FromJSON a) => FromJSON (Semigroup.Last a) where - parseJSON = parseJSON1 +deriving via Identity instance FromJSON1 Semigroup.Last +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Last a) - parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList - omittedField = omittedField1 +deriving via Identity instance FromJSON1 Semigroup.WrappedMonoid +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.WrappedMonoid a) -instance FromJSON1 Semigroup.WrappedMonoid where - liftParseJSON _ p _ a = coerce (p a) +-- | @since 2.2.3.0 +deriving via Identity instance FromJSON1 Semigroup.Sum +-- | @since 2.2.3.0 +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Sum a) - liftParseJSONList _ _ p a = coerce (p a) - liftOmittedField = coerce +-- | @since 2.2.3.0 +deriving via Identity instance FromJSON1 Semigroup.Product +-- | @since 2.2.3.0 +deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Product a) -instance (FromJSON a) => FromJSON (Semigroup.WrappedMonoid a) where - parseJSON = parseJSON1 +-- | @since 2.2.3.0 +deriving via Bool instance FromJSON Semigroup.All - parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList - omittedField = omittedField1 +-- | @since 2.2.3.0 +deriving via Bool instance FromJSON Semigroup.Any #if !MIN_VERSION_base(4,16,0) -instance FromJSON1 Semigroup.Option where - liftParseJSON o = coerce (liftParseJSON @Maybe o) - liftOmittedField _ = Just (Semigroup.Option Nothing) - -instance FromJSON a => FromJSON (Semigroup.Option a) where - parseJSON = parseJSON1 - omittedField = omittedField1 +deriving via Maybe instance FromJSON1 Semigroup.Option +deriving via Maybe a instance FromJSON a => FromJSON (Semigroup.Option a) #endif ------------------------------------------------------------------------------- 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 @@ -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 -- @@ -505,7 +505,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 +552,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 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 @@ -1,18 +1,20 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Data.Aeson.Types.ToJSON @@ -67,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) @@ -76,6 +79,7 @@ import Data.Functor.Product (Product(..)) import Data.Functor.Sum (Sum(..)) import Data.Functor.These (These1 (..)) +import Data.Kind (Type) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (isNothing) @@ -364,11 +368,11 @@ instance value ~ Value => KeyValue Value (KM.KeyMap value) where (.=) = explicitToField toJSON {-# INLINE (.=) #-} - + explicitToField f name value = KM.singleton name (f value) {-# INLINE explicitToField #-} --- | An optional key-value pair for envoding to a JSON object +-- | An optional key-value pair for encoding to a JSON object -- -- @since 2.2.0.0 -- @@ -1421,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 @@ -1641,14 +1658,7 @@ liftOmitField o (Identity a) = o a -instance (ToJSON a) => ToJSON (Identity a) where - toJSON = toJSON1 - toJSONList = liftToJSONList omitField toJSON toJSONList - - toEncoding = toEncoding1 - toEncodingList = liftToEncodingList omitField toEncoding toEncodingList - - omitField (Identity x) = omitField x +deriving via (a :: Type) instance ToJSON a => ToJSON (Identity a) instance (ToJSONKey a) => ToJSONKey (Identity a) where toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey @@ -2075,115 +2085,58 @@ ------------------------------------------------------------------------------- -- | @since 2.2.0.0 -instance ToJSON1 Down where - liftToJSON _ t _ = coerce t - liftToEncoding _ t _ = coerce t - liftOmitField = coerce +deriving via Identity instance ToJSON1 Down -- | @since 2.2.0.0 -instance ToJSON a => ToJSON (Down a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - omitField = omitField1 +deriving via (a :: Type) instance ToJSON a => ToJSON (Down a) ------------------------------------------------------------------------------- -- base Monoid/Semigroup ------------------------------------------------------------------------------- -instance ToJSON1 Monoid.Dual where - liftToJSON _ t _ = t . Monoid.getDual - liftToEncoding _ t _ = t . Monoid.getDual - liftOmitField = coerce - -instance ToJSON a => ToJSON (Monoid.Dual a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - omitField = omitField1 - -instance ToJSON1 Monoid.First where - liftToJSON o t to' = liftToJSON o t to' . Monoid.getFirst - liftToEncoding o t to' = liftToEncoding o t to' . Monoid.getFirst - liftOmitField :: forall a. (a -> Bool) -> Monoid.First a -> Bool - liftOmitField _ = coerce (isNothing @a) - -instance ToJSON a => ToJSON (Monoid.First a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - omitField = omitField1 - -instance ToJSON1 Monoid.Last where - liftToJSON o t to' = liftToJSON o t to' . Monoid.getLast - liftToEncoding o t to' = liftToEncoding o t to' . Monoid.getLast - - liftOmitField :: forall a. (a -> Bool) -> Monoid.Last a -> Bool - liftOmitField _ = coerce (isNothing @a) +deriving via Identity instance ToJSON1 Monoid.Dual +deriving via (a :: Type) instance ToJSON a => ToJSON (Monoid.Dual a) -instance ToJSON a => ToJSON (Monoid.Last a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - omitField = omitField1 +deriving via Maybe instance ToJSON1 Monoid.First +deriving via Maybe a instance ToJSON a => ToJSON (Monoid.First a) -instance ToJSON1 Semigroup.Min where - liftToJSON _ t _ (Semigroup.Min x) = t x - liftToEncoding _ t _ (Semigroup.Min x) = t x - liftOmitField = coerce +deriving via Maybe instance ToJSON1 Monoid.Last +deriving via Maybe a instance ToJSON a => ToJSON (Monoid.Last a) -instance ToJSON a => ToJSON (Semigroup.Min a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - omitField = omitField1 +deriving via Identity instance ToJSON1 Semigroup.Min +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Min a) +deriving via Identity instance ToJSON1 Semigroup.Max +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Max a) -instance ToJSON1 Semigroup.Max where - liftToJSON _ t _ (Semigroup.Max x) = t x - liftToEncoding _ t _ (Semigroup.Max x) = t x - liftOmitField = coerce +deriving via Identity instance ToJSON1 Semigroup.First +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.First a) -instance ToJSON a => ToJSON (Semigroup.Max a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - omitField = omitField1 +deriving via Identity instance ToJSON1 Semigroup.Last +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Last a) -instance ToJSON1 Semigroup.First where - liftToJSON _ t _ (Semigroup.First x) = t x - liftToEncoding _ t _ (Semigroup.First x) = t x - liftOmitField = coerce +deriving via Identity instance ToJSON1 Semigroup.WrappedMonoid +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.WrappedMonoid a) -instance ToJSON a => ToJSON (Semigroup.First a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - omitField = omitField1 +-- | @since 2.2.3.0 +deriving via Identity instance ToJSON1 Semigroup.Sum +-- | @since 2.2.3.0 +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Sum a) -instance ToJSON1 Semigroup.Last where - liftToJSON _ t _ (Semigroup.Last x) = t x - liftToEncoding _ t _ (Semigroup.Last x) = t x - liftOmitField = coerce +-- | @since 2.2.3.0 +deriving via Identity instance ToJSON1 Semigroup.Product +-- | @since 2.2.3.0 +deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Product a) -instance ToJSON a => ToJSON (Semigroup.Last a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - omitField = omitField1 +-- | @since 2.2.3.0 +deriving via Bool instance ToJSON Semigroup.All -instance ToJSON1 Semigroup.WrappedMonoid where - liftToJSON _ t _ (Semigroup.WrapMonoid x) = t x - liftToEncoding _ t _ (Semigroup.WrapMonoid x) = t x - liftOmitField = coerce - -instance ToJSON a => ToJSON (Semigroup.WrappedMonoid a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - omitField = omitField1 +-- | @since 2.2.3.0 +deriving via Bool instance ToJSON Semigroup.Any #if !MIN_VERSION_base(4,16,0) -instance ToJSON1 Semigroup.Option where - liftToJSON o t to' = liftToJSON o t to' . Semigroup.getOption - liftToEncoding o t to' = liftToEncoding o t to' . Semigroup.getOption - liftOmitField _ = isNothing . Semigroup.getOption - -instance ToJSON a => ToJSON (Semigroup.Option a) where - toJSON = toJSON1 - toEncoding = toEncoding1 - omitField = omitField1 +deriving via Maybe instance ToJSON1 Semigroup.Option +deriving via Maybe a instance ToJSON a => ToJSON (Semigroup.Option a) #endif ------------------------------------------------------------------------------- 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/Instances.hs b/tests/Instances.hs --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -28,6 +28,11 @@ import Data.Orphans () import Test.QuickCheck.Instances () +#if !MIN_VERSION_base(4,16,0) +import Data.Semigroup (Option (..)) +import Data.Tuple.Solo (Solo (..)) +#endif + -- "System" types. instance Arbitrary DotNetTime where @@ -157,9 +162,13 @@ #if !MIN_VERSION_base(4,16,0) instance Arbitrary OptionField where - arbitrary = OptionField <$> arbitrary + arbitrary = OptionField . Option <$> arbitrary #endif +#if !MIN_VERSION_base(4,16,0) && MIN_VERSION_QuickCheck(2,17,0) +instance Arbitrary a => Arbitrary (Solo a) where + arbitrary = MkSolo <$> arbitrary +#endif instance ApproxEq Char where (=~) = (==) 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) @@ -29,6 +30,7 @@ import Test.Tasty.QuickCheck (testProperty) import Types import qualified Data.Monoid as Monoid +import qualified Data.Semigroup as Semigroup import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Short as ST @@ -80,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)) @@ -87,6 +91,10 @@ , testProperty "Nu" $ roundTripEq @(F.Nu (These Char)) , testProperty "Maybe" $ roundTripEq @(Maybe Int) , testProperty "Monoid.First" $ roundTripEq @(Monoid.First Int) + , testProperty "Semigroup.Sum" $ roundTripEq @(Semigroup.Sum Int) + , testProperty "Semigroup.Product" $ roundTripEq @(Semigroup.Product Int) + , testProperty "Semigroup.All" $ roundTripEq @Semigroup.All + , testProperty "Semigroup.Any" $ roundTripEq @Semigroup.Any , testProperty "Strict Pair" $ roundTripEq @(S.Pair Int Char) , testProperty "Strict Either" $ roundTripEq @(S.Either Int Char) , testProperty "Strict These" $ roundTripEq @(S.These Int Char) diff --git a/tests/Regression/Issue1138.hs b/tests/Regression/Issue1138.hs new file mode 100644 --- /dev/null +++ b/tests/Regression/Issue1138.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +module Regression.Issue1138 (issue1138) where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, assertFailure) + +import Data.Aeson + +assertDecodeFailure :: Either String Value -> IO () +assertDecodeFailure (Right v) = assertFailure $ "Unexpected success: " ++ show v +assertDecodeFailure (Left _) = return () + +issue1138 :: TestTree +issue1138 = testGroup "Issue #1138" $ map (testCase "-") + [ assertDecodeFailure $ eitherDecode "\"\t\"" + , assertDecodeFailure $ eitherDecode "\"\\\\\t\"" + + , assertDecodeFailure $ eitherDecodeStrict "\"\t\"" + , assertDecodeFailure $ eitherDecodeStrict "\"\\\\\t\"" + + , assertDecodeFailure $ eitherDecodeStrictText "\"\t\"" + , assertDecodeFailure $ eitherDecodeStrictText "\"\\\\\t\"" + ] 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 @@ -38,6 +38,7 @@ , Value(..), camelTo, camelTo2 , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse) import Data.Char (toUpper, GeneralCategory(Control,Surrogate), generalCategory) +import Data.Fixed (Nano) import Data.HashMap.Strict (HashMap) import Data.Kind (Type) import Data.List (isSuffixOf) @@ -64,6 +65,7 @@ import Regression.Issue571 import Regression.Issue687 import Regression.Issue967 +import Regression.Issue1138 import UnitTests.OmitNothingFieldsNote import UnitTests.FromJSONKey import UnitTests.Hashable @@ -86,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 { @@ -457,17 +460,22 @@ (eitherDecode "1.37" :: Either String Rational) bigRationalDecoding :: Assertion -bigRationalDecoding = - assertEqual "Decoding an Integer with a large exponent should fail" - (Left "Error in $: parsing Ratio failed, found a number with exponent 2000, but it must not be greater than 1024 or less than -1024") +bigRationalDecoding = do + assertEqual "Decoding a Rational with a large exponent should fail" + (Left "Error in $: parsing Ratio failed, found a number with exponent 2000, but it must not be greater than 1024") ((eitherDecode :: L.ByteString -> Either String Rational) "1e2000") - -smallRationalDecoding :: Assertion -smallRationalDecoding = - assertEqual "Decoding an Integer with a large exponent should fail" - (Left "Error in $: parsing Ratio failed, found a number with exponent -2000, but it must not be greater than 1024 or less than -1024") + assertEqual "Decoding a Rational with a small exponent should fail" + (Left "Error in $: parsing Ratio failed, found a number with exponent -2000, but it must not be less than -1024") ((eitherDecode :: L.ByteString -> Either String Rational) "1e-2000") +bigFixedDecoding :: Assertion +bigFixedDecoding = do + assertEqual "Decoding a Fixed with a large exponent should fail" + (Left "Error in $: parsing Fixed failed, found a number with exponent 9999, but it must not be greater than 1024") + ((eitherDecode :: L.ByteString -> Either String Nano) "1e9999") + assertEqual "Decoding a Fixed with a small exponent should fail" + (Left "Error in $: parsing Fixed failed, found a number with exponent -9999, but it must not be less than -1024") + ((eitherDecode :: L.ByteString -> Either String Nano) "1e-9999") bigScientificExponent :: Assertion bigScientificExponent = @@ -554,7 +562,7 @@ , testCase "Ratio with denominator 0" ratioDenominator0 , testCase "Rational parses number" rationalNumber , testCase "Big rational" bigRationalDecoding - , testCase "Small rational" smallRationalDecoding + , testCase "Big fixed" bigFixedDecoding , testCase "Big scientific exponent" bigScientificExponent , testCase "Big integer decoding" bigIntegerDecoding , testCase "Big natural decoding" bigNaturalDecoding @@ -568,6 +576,7 @@ , issue571 , issue687 , issue967 + , issue1138 , keyMapInsertWithTests , omitNothingFieldsNoteTests , noThunksTests