From e79a7ca4515ad9c9b62e7da989ec05e4a1013240 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 9 Jun 2023 19:54:29 +0300 Subject: [PATCH] Use Decoding parsers as default Move Data.Aeson.Parser(.Internal) into new package attoparsec-aeson Update tests and benchmarks (mostly cleanup). Very few error messages are now different, e.g. on unexpected end-of-input. --- .github/workflows/haskell-ci.yml | 11 +- .hlint.yaml | 1 + Makefile | 2 +- aeson.cabal | 12 +- attoparsec-aeson/LICENSE | 30 +++++ attoparsec-aeson/attoparsec-aeson.cabal | 59 +++++++++ .../src/Data/Aeson/Internal/ByteString.hs | 1 + .../src/Data/Aeson/Internal/Text.hs | 1 + .../src/Data/Aeson/Internal/Word8.hs | 1 + .../src}/Data/Aeson/Parser.hs | 0 .../src}/Data/Aeson/Parser/Internal.hs | 31 +++-- benchmarks/aeson-benchmarks.cabal | 1 + benchmarks/bench/CompareWithJSON.hs | 14 +-- benchmarks/bench/Issue673.hs | 104 +++------------ benchmarks/bench/aeson-benchmark-suite.hs | 2 +- cabal.project | 1 + changelog.md | 2 + src/Data/Aeson.hs | 119 ++---------------- src/Data/Aeson/Decoding.hs | 76 +---------- src/Data/Aeson/Decoding/ByteString.hs | 2 +- src/Data/Aeson/Decoding/ByteString/Lazy.hs | 2 +- src/Data/Aeson/Decoding/Conversion.hs | 78 ++++++++++++ src/Data/Aeson/Encoding/Builder.hs | 28 ++++- src/Data/Aeson/Internal/ByteString.hs | 25 +++- .../Data/Aeson/Internal/Unescape.hs | 6 +- src/Data/Aeson/Parser/Unescape.hs | 7 -- src/Data/Aeson/Types.hs | 3 + src/Data/Aeson/Types/FromJSON.hs | 13 +- src/Data/Aeson/Types/Internal.hs | 17 +++ tests/ErrorMessages.hs | 9 +- tests/PropUtils.hs | 9 +- tests/UnitTests.hs | 12 +- tests/golden/generic.expected | 10 +- tests/golden/th.expected | 10 +- 34 files changed, 357 insertions(+), 342 deletions(-) create mode 100644 attoparsec-aeson/LICENSE create mode 100644 attoparsec-aeson/attoparsec-aeson.cabal create mode 120000 attoparsec-aeson/src/Data/Aeson/Internal/ByteString.hs create mode 120000 attoparsec-aeson/src/Data/Aeson/Internal/Text.hs create mode 120000 attoparsec-aeson/src/Data/Aeson/Internal/Word8.hs rename {src => attoparsec-aeson/src}/Data/Aeson/Parser.hs (100%) rename {src => attoparsec-aeson/src}/Data/Aeson/Parser/Internal.hs (97%) create mode 100644 src/Data/Aeson/Decoding/Conversion.hs rename src-pure/Data/Aeson/Parser/UnescapePure.hs => src/Data/Aeson/Internal/Unescape.hs (99%) delete mode 100644 src/Data/Aeson/Parser/Unescape.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index f9f9515e4..1590e0310 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -213,6 +213,7 @@ jobs: touch cabal.project echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project echo "packages: $GITHUB_WORKSPACE/source/attoparsec-iso8601" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/attoparsec-aeson" >> cabal.project echo "packages: $GITHUB_WORKSPACE/source/text-iso8601" >> cabal.project echo "packages: $GITHUB_WORKSPACE/source/examples" >> cabal.project echo "packages: $GITHUB_WORKSPACE/source/benchmarks" >> cabal.project @@ -231,6 +232,8 @@ jobs: echo "PKGDIR_aeson=${PKGDIR_aeson}" >> "$GITHUB_ENV" PKGDIR_attoparsec_iso8601="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/attoparsec-iso8601-[0-9.]*')" echo "PKGDIR_attoparsec_iso8601=${PKGDIR_attoparsec_iso8601}" >> "$GITHUB_ENV" + PKGDIR_attoparsec_aeson="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/attoparsec-aeson-[0-9.]*')" + echo "PKGDIR_attoparsec_aeson=${PKGDIR_attoparsec_aeson}" >> "$GITHUB_ENV" PKGDIR_text_iso8601="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/text-iso8601-[0-9.]*')" echo "PKGDIR_text_iso8601=${PKGDIR_text_iso8601}" >> "$GITHUB_ENV" PKGDIR_aeson_examples="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/aeson-examples-[0-9.]*')" @@ -242,6 +245,7 @@ jobs: touch cabal.project.local echo "packages: ${PKGDIR_aeson}" >> cabal.project echo "packages: ${PKGDIR_attoparsec_iso8601}" >> cabal.project + echo "packages: ${PKGDIR_attoparsec_aeson}" >> cabal.project echo "packages: ${PKGDIR_text_iso8601}" >> cabal.project echo "packages: ${PKGDIR_aeson_examples}" >> cabal.project echo "packages: ${PKGDIR_aeson_benchmarks}" >> cabal.project @@ -249,6 +253,8 @@ jobs: echo " ghc-options: -Werror=missing-methods" >> cabal.project echo "package attoparsec-iso8601" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project + echo "package attoparsec-aeson" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project echo "package text-iso8601" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project echo "package aeson-examples" >> cabal.project @@ -258,7 +264,7 @@ jobs: cat >> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(aeson|aeson-benchmarks|aeson-examples|attoparsec-aeson|attoparsec-iso8601|text-iso8601)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -286,8 +292,9 @@ jobs: cabal-docspec $ARG_COMPILER - name: hlint run: | - if [ $((HCNUMVER >= 90200 && HCNUMVER < 90400)) -ne 0 ] ; then (cd ${PKGDIR_aeson} && hlint -h ${GITHUB_WORKSPACE}/source/.hlint.yaml -XHaskell2010 src attoparsec-iso8601/src src-pure) ; fi + if [ $((HCNUMVER >= 90200 && HCNUMVER < 90400)) -ne 0 ] ; then (cd ${PKGDIR_aeson} && hlint -h ${GITHUB_WORKSPACE}/source/.hlint.yaml -XHaskell2010 src) ; fi if [ $((HCNUMVER >= 90200 && HCNUMVER < 90400)) -ne 0 ] ; then (cd ${PKGDIR_attoparsec_iso8601} && hlint -h ${GITHUB_WORKSPACE}/source/.hlint.yaml -XHaskell2010 src) ; fi + if [ $((HCNUMVER >= 90200 && HCNUMVER < 90400)) -ne 0 ] ; then (cd ${PKGDIR_attoparsec_aeson} && hlint -h ${GITHUB_WORKSPACE}/source/.hlint.yaml -XHaskell2010 src) ; fi if [ $((HCNUMVER >= 90200 && HCNUMVER < 90400)) -ne 0 ] ; then (cd ${PKGDIR_text_iso8601} && hlint -h ${GITHUB_WORKSPACE}/source/.hlint.yaml -XHaskell2010 src) ; fi if [ $((HCNUMVER >= 90200 && HCNUMVER < 90400)) -ne 0 ] ; then (cd ${PKGDIR_aeson_examples} && hlint -h ${GITHUB_WORKSPACE}/source/.hlint.yaml -XHaskell2010 src/) ; fi if [ $((HCNUMVER >= 90200 && HCNUMVER < 90400)) -ne 0 ] ; then (cd ${PKGDIR_aeson_benchmarks} && hlint -h ${GITHUB_WORKSPACE}/source/.hlint.yaml -XHaskell2010 .) ; fi diff --git a/.hlint.yaml b/.hlint.yaml index ed1d6380a..52676c03d 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -30,6 +30,7 @@ - ignore: name: "Unused LANGUAGE pragma" within: + - Data.Aeson.Internal.ByteString - Data.Aeson.Internal.Text - Compare.JsonBench diff --git a/Makefile b/Makefile index f0ea6f42f..4de78a682 100644 --- a/Makefile +++ b/Makefile @@ -1,2 +1,2 @@ lint: - ./run-hlint.sh --cpp-include include/ src/ attoparsec-iso8601/ benchmarks/ examples/ src-pure/ tests/ text-iso8601/src text-iso8601/tests + ./run-hlint.sh --cpp-include include/ src/ attoparsec-iso8601/ benchmarks/ examples/ tests/ text-iso8601/src text-iso8601/tests attoparsec-aeson/src diff --git a/aeson.cabal b/aeson.cabal index cbef1836a..7726a11bb 100644 --- a/aeson.cabal +++ b/aeson.cabal @@ -40,7 +40,6 @@ extra-source-files: benchmarks/json-data/*.json changelog.md README.markdown - src-pure/Data/Aeson/Parser/*.hs tests/golden/*.expected tests/JSONTestSuite/results/*.tok tests/JSONTestSuite/results/*.txt @@ -54,7 +53,7 @@ flag ordered-keymap library default-language: Haskell2010 - hs-source-dirs: src attoparsec-iso8601/src + hs-source-dirs: src exposed-modules: Data.Aeson Data.Aeson.Decoding @@ -65,14 +64,13 @@ library Data.Aeson.Encoding.Internal Data.Aeson.Key Data.Aeson.KeyMap - Data.Aeson.Parser - Data.Aeson.Parser.Internal Data.Aeson.QQ.Simple Data.Aeson.Text Data.Aeson.TH Data.Aeson.Types other-modules: + Data.Aeson.Decoding.Conversion Data.Aeson.Decoding.Internal Data.Aeson.Encoding.Builder Data.Aeson.Internal.ByteString @@ -80,16 +78,14 @@ library Data.Aeson.Internal.Prelude Data.Aeson.Internal.Text Data.Aeson.Internal.TH + Data.Aeson.Internal.Unescape Data.Aeson.Internal.Word8 Data.Aeson.Parser.Time - Data.Aeson.Parser.Unescape Data.Aeson.Types.Class Data.Aeson.Types.FromJSON Data.Aeson.Types.Generic Data.Aeson.Types.Internal Data.Aeson.Types.ToJSON - Data.Attoparsec.Time - Data.Attoparsec.Time.Internal -- GHC bundled libs build-depends: @@ -138,8 +134,6 @@ library ghc-options: -Wall -- String unescaping - hs-source-dirs: src-pure - other-modules: Data.Aeson.Parser.UnescapePure if flag(ordered-keymap) cpp-options: -DUSE_ORDEREDMAP=1 diff --git a/attoparsec-aeson/LICENSE b/attoparsec-aeson/LICENSE new file mode 100644 index 000000000..a6fb08ada --- /dev/null +++ b/attoparsec-aeson/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2011, MailRank, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/attoparsec-aeson/attoparsec-aeson.cabal b/attoparsec-aeson/attoparsec-aeson.cabal new file mode 100644 index 000000000..2e6f8f65d --- /dev/null +++ b/attoparsec-aeson/attoparsec-aeson.cabal @@ -0,0 +1,59 @@ +cabal-version: 1.12 +name: attoparsec-aeson +version: 2.2 +synopsis: Parsing of aeson's Value with attoparsec +description: + Parsing of aeson's Value with attoparsec, originally from aeson. + +license: BSD3 +license-file: LICENSE +category: Parsing +copyright: + (c) 2011-2016 Bryan O'Sullivan + (c) 2011 MailRank, Inc. + +author: Bryan O'Sullivan +maintainer: Oleg Grenrus +stability: experimental +homepage: https://github.com/haskell/aeson +bug-reports: https://github.com/haskell/aeson/issues +build-type: Simple +tested-with: + GHC ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.8 + || ==9.4.5 + || ==9.6.2 + +library + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + exposed-modules: + Data.Aeson.Parser + Data.Aeson.Parser.Internal + + other-modules: + Data.Aeson.Internal.ByteString + Data.Aeson.Internal.Text + Data.Aeson.Internal.Word8 + + build-depends: + aeson >=2.2 && <2.3 + , attoparsec >=0.14.2 && <0.15 + , base >=4.10.0.0 && <5 + , bytestring >=0.10.8.2 && <0.12 + , integer-conversion >=0.1 && <0.2 + , primitive >=0.8.0.0 && <0.9 + , scientific >=0.3.7.0 && <0.4 + , text >=1.2.3.0 && <1.3 || >=2.0 && <2.1 + , vector >=0.12.0.1 && <0.14 + +source-repository head + type: git + location: git://github.com/haskell/aeson.git + subdir: attoparsec-aeson diff --git a/attoparsec-aeson/src/Data/Aeson/Internal/ByteString.hs b/attoparsec-aeson/src/Data/Aeson/Internal/ByteString.hs new file mode 120000 index 000000000..c5f186eff --- /dev/null +++ b/attoparsec-aeson/src/Data/Aeson/Internal/ByteString.hs @@ -0,0 +1 @@ +../../../../../src/Data/Aeson/Internal/ByteString.hs \ No newline at end of file diff --git a/attoparsec-aeson/src/Data/Aeson/Internal/Text.hs b/attoparsec-aeson/src/Data/Aeson/Internal/Text.hs new file mode 120000 index 000000000..38392677c --- /dev/null +++ b/attoparsec-aeson/src/Data/Aeson/Internal/Text.hs @@ -0,0 +1 @@ +../../../../../src/Data/Aeson/Internal/Text.hs \ No newline at end of file diff --git a/attoparsec-aeson/src/Data/Aeson/Internal/Word8.hs b/attoparsec-aeson/src/Data/Aeson/Internal/Word8.hs new file mode 120000 index 000000000..27c53780e --- /dev/null +++ b/attoparsec-aeson/src/Data/Aeson/Internal/Word8.hs @@ -0,0 +1 @@ +../../../../../src/Data/Aeson/Internal/Word8.hs \ No newline at end of file diff --git a/src/Data/Aeson/Parser.hs b/attoparsec-aeson/src/Data/Aeson/Parser.hs similarity index 100% rename from src/Data/Aeson/Parser.hs rename to attoparsec-aeson/src/Data/Aeson/Parser.hs diff --git a/src/Data/Aeson/Parser/Internal.hs b/attoparsec-aeson/src/Data/Aeson/Parser/Internal.hs similarity index 97% rename from src/Data/Aeson/Parser/Internal.hs rename to attoparsec-aeson/src/Data/Aeson/Parser/Internal.hs index ee58d45ff..c44f241e0 100644 --- a/src/Data/Aeson/Parser/Internal.hs +++ b/attoparsec-aeson/src/Data/Aeson/Parser/Internal.hs @@ -44,25 +44,36 @@ module Data.Aeson.Parser.Internal , unescapeText ) where -import Data.Aeson.Internal.Prelude - -import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..), Key) -import qualified Data.Aeson.KeyMap as KM -import qualified Data.Aeson.Key as Key +import Control.Applicative ((<|>)) +import Control.Monad (when, void) import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string) +import Data.Function (fix) +import Data.Functor (($>)) import Data.Integer.Conversion (byteStringToInteger) -import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse) +import Data.Scientific (Scientific) +import Data.Text (Text) +import Data.Vector (Vector) + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif + +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.Lazy as L import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as C -import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Unsafe as B import qualified Data.Scientific as Sci -import Data.Aeson.Parser.Unescape (unescapeText) +import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse) + +import Data.Aeson.Types (IResult(..), JSONPath, Object, Result(..), Value(..), Key) import Data.Aeson.Internal.Text +import Data.Aeson.Decoding (unescapeText) import Data.Aeson.Internal.Word8 -- $setup diff --git a/benchmarks/aeson-benchmarks.cabal b/benchmarks/aeson-benchmarks.cabal index 7fb1841d0..58b11212d 100644 --- a/benchmarks/aeson-benchmarks.cabal +++ b/benchmarks/aeson-benchmarks.cabal @@ -49,6 +49,7 @@ executable aeson-benchmark-suite build-depends: aeson , attoparsec + , attoparsec-aeson , base , base-compat-batteries , base16-bytestring diff --git a/benchmarks/bench/CompareWithJSON.hs b/benchmarks/bench/CompareWithJSON.hs index ee3c89243..2ef9c89e2 100644 --- a/benchmarks/bench/CompareWithJSON.hs +++ b/benchmarks/bench/CompareWithJSON.hs @@ -49,8 +49,8 @@ decode' s = fromMaybe (error "fail to parse via Aeson") $ A.decode' s decodeS :: BS.ByteString -> A.Value decodeS s = fromMaybe (error "fail to parse via Aeson") $ A.decodeStrict' s -decodeIP :: BL.ByteString -> A.Value -decodeIP s = fromMaybe (error "fail to parse via Parser.decodeWith") $ +decodeAtto :: BL.ByteString -> A.Value +decodeAtto s = fromMaybe (error "fail to parse via Parser.decodeWith") $ I.decodeWith I.jsonEOF A.fromJSON s encodeJ :: J.JSValue -> BL.ByteString @@ -73,11 +73,11 @@ benchmark = bgroup "compare-json" [ bgroup "decode" [ bgroup "en" [ - bench "aeson/lazy" $ nf decode enA - , bench "aeson/strict" $ nf decode' enA - , bench "aeson/stricter" $ nf decodeS enS - , bench "aeson/parser" $ nf decodeIP enA - , bench "json" $ nf decodeJ enJ + bench "aeson/lazy" $ nf decode enA + , bench "aeson/strict" $ nf decode' enA + , bench "aeson/stricter" $ nf decodeS enS + , bench "aeson/attoparsec" $ nf decodeAtto enA + , bench "json" $ nf decodeJ enJ ] , bgroup "jp" [ bench "aeson" $ nf decode jpA diff --git a/benchmarks/bench/Issue673.hs b/benchmarks/bench/Issue673.hs index d6fc2dc17..9a4d03301 100644 --- a/benchmarks/bench/Issue673.hs +++ b/benchmarks/bench/Issue673.hs @@ -1,16 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} - -module Issue673 where +module Issue673 (benchmark) where import Bench import Prelude.Compat import Data.Int (Int64) -import Data.Scientific (Scientific) -import Data.Aeson.Parser (scientific) -import qualified Data.Attoparsec.ByteString.Lazy as AttoL -import qualified Data.Attoparsec.ByteString.Char8 as Atto8 import qualified Data.Aeson as A import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS @@ -19,30 +14,14 @@ import qualified Data.ByteString.Lazy.Char8 as LBS8 decodeInt :: LBS.ByteString -> Maybe Int decodeInt = A.decode -decodeString :: LBS.ByteString -> Maybe String -decodeString = A.decode - -decodeScientific :: LBS.ByteString -> Maybe Scientific -decodeScientific = A.decode - -decodeViaRead :: LBS.ByteString -> Integer -decodeViaRead = read . LBS8.unpack +-- decodeString :: LBS.ByteString -> Maybe String +-- decodeString = A.decode -decodeAtto :: LBS.ByteString -> Maybe Scientific -decodeAtto - = parseOnly (scientific <* AttoL.endOfInput) - where - parseOnly p lbs = case AttoL.parse p lbs of - AttoL.Done _ r -> Just r - AttoL.Fail {} -> Nothing +-- decodeScientific :: LBS.ByteString -> Maybe Scientific +-- decodeScientific = A.decode -decodeAtto8 :: LBS.ByteString -> Maybe Scientific -decodeAtto8 - = parseOnly (Atto8.scientific <* AttoL.endOfInput) - where - parseOnly p lbs = case AttoL.parse p lbs of - AttoL.Done _ r -> Just r - AttoL.Fail {} -> Nothing +-- decodeViaRead :: LBS.ByteString -> Integer +-- decodeViaRead = read . LBS8.unpack generate :: Int64 -> LBS.ByteString generate n = LBS8.replicate n '1' @@ -50,31 +29,30 @@ generate n = LBS8.replicate n '1' input17 :: LBS.ByteString input17 = generate 17 -input32 :: LBS.ByteString -input32 = generate 32 +-- input32 :: LBS.ByteString +-- input32 = generate 32 -input64 :: LBS.ByteString -input64 = generate 64 +-- input64 :: LBS.ByteString +-- input64 = generate 64 -input128 :: LBS.ByteString -input128 = generate 128 +-- input128 :: LBS.ByteString +-- input128 = generate 128 -input256 :: LBS.ByteString -input256 = generate 256 +-- input256 :: LBS.ByteString +-- input256 = generate 256 input2048 :: LBS.ByteString input2048 = generate 2048 -input4096 :: LBS.ByteString -input4096 = generate 4096 +-- input4096 :: LBS.ByteString +-- input4096 = generate 4096 -input8192 :: LBS.ByteString -input8192 = generate 8192 +-- input8192 :: LBS.ByteString +-- input8192 = generate 8192 input16384 :: LBS.ByteString input16384 = generate 16384 - benchmark :: Benchmark benchmark = bgroup "Integer-decoder" -- works on 64bit @@ -106,50 +84,6 @@ benchmark = bgroup "Integer-decoder" -- better fromInteger ------------------------------------------------------------------------------- -bsToInteger :: BS.ByteString -> Integer -bsToInteger bs - | l > 40 = valInteger 10 l [ fromIntegral (w - 48) | w <- BS.unpack bs ] - | otherwise = bsToIntegerSimple bs - where - l = BS.length bs - bsToIntegerSimple :: BS.ByteString -> Integer bsToIntegerSimple = BS.foldl' step 0 where step a b = a * 10 + fromIntegral (b - 48) -- 48 = '0' - --- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b --- digits are combined into a single radix b^2 digit. This process is --- repeated until we are left with a single digit. This algorithm --- performs well only on large inputs, so we use the simple algorithm --- for smaller inputs. -valInteger :: Integer -> Int -> [Integer] -> Integer -valInteger = go - where - go :: Integer -> Int -> [Integer] -> Integer - go _ _ [] = 0 - go _ _ [d] = d - go b l ds - | l > 40 = b' `seq` go b' l' (combine b ds') - | otherwise = valSimple b ds - where - -- ensure that we have an even number of digits - -- before we call combine: - ds' = if even l then ds else 0 : ds - b' = b * b - l' = (l + 1) `quot` 2 - - combine b (d1 : d2 : ds) = d `seq` (d : combine b ds) - where - d = d1 * b + d2 - combine _ [] = [] - combine _ [_] = errorWithoutStackTrace "this should not happen" - --- The following algorithm is only linear for types whose Num operations --- are in constant time. -valSimple :: Integer -> [Integer] -> Integer -valSimple base = go 0 - where - go r [] = r - go r (d : ds) = r' `seq` go r' ds - where - r' = r * base + fromIntegral d diff --git a/benchmarks/bench/aeson-benchmark-suite.hs b/benchmarks/bench/aeson-benchmark-suite.hs index 2066aace0..13e4f8025 100644 --- a/benchmarks/bench/aeson-benchmark-suite.hs +++ b/benchmarks/bench/aeson-benchmark-suite.hs @@ -11,7 +11,7 @@ import Prelude.Compat import Bench (Benchmark, bench, bgroup, defaultMain, env, nf, whnf) import Control.DeepSeq (NFData) -import Data.Aeson.Parser.Internal (unescapeText) +import Data.Aeson.Decoding (unescapeText) import Data.Proxy (Proxy (..)) import Data.Vector (Vector) import qualified Data.Aeson.Decoding as Dec diff --git a/cabal.project b/cabal.project index ae5e47e8d..76d93db0f 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,7 @@ with-compiler: ghc packages: . packages: attoparsec-iso8601 +packages: attoparsec-aeson packages: text-iso8601 packages: examples packages: benchmarks diff --git a/changelog.md b/changelog.md index 99311492a..97503a81b 100644 --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,8 @@ For the latest version of this document, please see [https://github.com/haskell/ ### 2.2 +* Use `Data.Aeson.Decoding` parsing functions as default in `Data.Aeson`. +* Move `Data.Aeson.Parser` module into separate `attoparsec-aeson` package, as these parsers are not used by `aeson` itself anymore. * Remove `cffi` flag. Then the C implementation for string unescaping was used for `text <2` versions. The new native Haskell implementation introduced in version 2.0.3.0 is at least as fast. diff --git a/src/Data/Aeson.hs b/src/Data/Aeson.hs index de389f1d6..adb2fd283 100644 --- a/src/Data/Aeson.hs +++ b/src/Data/Aeson.hs @@ -153,19 +153,16 @@ module Data.Aeson , (.!=) , object -- * Parsing - , json - , json' , parseIndexedJSON ) where -import Control.Exception (Exception (..)) import Control.Monad.Catch (MonadThrow (..)) import Data.Aeson.Types.FromJSON (parseIndexedJSON) import Data.Aeson.Encoding (encodingToLazyByteString) -import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json') import Data.Aeson.Types import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import Data.Aeson.Decoding (decode, eitherDecode, throwDecode, decodeStrict, eitherDecodeStrict, throwDecodeStrict) -- $setup -- >>> :set -XOverloadedStrings @@ -180,32 +177,6 @@ encode = encodingToLazyByteString . toEncoding encodeFile :: (ToJSON a) => FilePath -> a -> IO () encodeFile fp = L.writeFile fp . encode --- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. --- If this fails due to incomplete or invalid input, 'Nothing' is --- returned. --- --- The input must consist solely of a JSON document, with no trailing --- data except for whitespace. --- --- This function parses immediately, but defers conversion. See --- 'json' for details. -decode :: (FromJSON a) => L.ByteString -> Maybe a -decode = decodeWith jsonEOF fromJSON -{-# INLINE decode #-} - --- | Efficiently deserialize a JSON value from a strict 'B.ByteString'. --- If this fails due to incomplete or invalid input, 'Nothing' is --- returned. --- --- The input must consist solely of a JSON document, with no trailing --- data except for whitespace. --- --- This function parses immediately, but defers conversion. See --- 'json' for details. -decodeStrict :: (FromJSON a) => B.ByteString -> Maybe a -decodeStrict = decodeStrictWith jsonEOF fromJSON -{-# INLINE decodeStrict #-} - -- | Efficiently deserialize a JSON value from a file. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. @@ -222,54 +193,28 @@ decodeFileStrict = fmap decodeStrict . B.readFile -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. -- --- The input must consist solely of a JSON document, with no trailing --- data except for whitespace. +-- Since @2.2.0.0@ an alias for 'decode'. -- --- This function parses and performs conversion immediately. See --- 'json'' for details. decode' :: (FromJSON a) => L.ByteString -> Maybe a -decode' = decodeWith jsonEOF' fromJSON +decode' = decode {-# INLINE decode' #-} -- | Efficiently deserialize a JSON value from a strict 'B.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. -- --- The input must consist solely of a JSON document, with no trailing --- data except for whitespace. +-- Since @2.2.0.0@ an alias for 'decodeStrict'. -- --- This function parses and performs conversion immediately. See --- 'json'' for details. decodeStrict' :: (FromJSON a) => B.ByteString -> Maybe a -decodeStrict' = decodeStrictWith jsonEOF' fromJSON +decodeStrict' = decodeStrict {-# INLINE decodeStrict' #-} -- | Efficiently deserialize a JSON value from a file. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned. -- --- The input file's content must consist solely of a JSON document, --- with no trailing data except for whitespace. --- --- This function parses and performs conversion immediately. See --- 'json'' for details. decodeFileStrict' :: (FromJSON a) => FilePath -> IO (Maybe a) -decodeFileStrict' = fmap decodeStrict' . B.readFile - -eitherFormatError :: Either (JSONPath, String) a -> Either String a -eitherFormatError = either (Left . uncurry formatError) Right -{-# INLINE eitherFormatError #-} - --- | Like 'decode' but returns an error message when decoding fails. -eitherDecode :: (FromJSON a) => L.ByteString -> Either String a -eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON -{-# INLINE eitherDecode #-} - --- | Like 'decodeStrict' but returns an error message when decoding fails. -eitherDecodeStrict :: (FromJSON a) => B.ByteString -> Either String a -eitherDecodeStrict = - eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON -{-# INLINE eitherDecodeStrict #-} +decodeFileStrict' = decodeFileStrict -- | Like 'decodeFileStrict' but returns an error message when decoding fails. eitherDecodeFileStrict :: (FromJSON a) => FilePath -> IO (Either String a) @@ -279,57 +224,25 @@ eitherDecodeFileStrict = -- | Like 'decode'' but returns an error message when decoding fails. eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a -eitherDecode' = eitherFormatError . eitherDecodeWith jsonEOF' ifromJSON +eitherDecode' = eitherDecode {-# INLINE eitherDecode' #-} -- | Like 'decodeStrict'' but returns an error message when decoding fails. eitherDecodeStrict' :: (FromJSON a) => B.ByteString -> Either String a -eitherDecodeStrict' = - eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON +eitherDecodeStrict' = eitherDecodeStrict {-# INLINE eitherDecodeStrict' #-} -- | Like 'decodeFileStrict'' but returns an error message when decoding fails. eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a) -eitherDecodeFileStrict' = - fmap eitherDecodeStrict' . B.readFile +eitherDecodeFileStrict' = eitherDecodeFileStrict {-# INLINE eitherDecodeFileStrict' #-} -throwFormatError :: MonadThrow m => Either (JSONPath, String) a -> m a -throwFormatError = either (throwM . AesonException . uncurry formatError) return -{-# INLINE throwFormatError #-} - --- | Like 'decode' but throws an 'AesonException' when decoding fails. --- --- >>> throwDecode "42" :: Maybe Int --- Just 42 --- --- >>> throwDecode "42" :: IO Int --- 42 --- --- >>> throwDecode "true" :: IO Int --- ...Exception: AesonException... --- --- @since 2.1.2.0 --- -throwDecode :: forall a m. (FromJSON a, MonadThrow m) => L.ByteString -> m a -throwDecode = throwFormatError . eitherDecodeWith jsonEOF ifromJSON -{-# INLINE throwDecode #-} - --- | Like 'decodeStrict' but throws an 'AesonException' when decoding fails. --- --- @since 2.1.2.0 --- -throwDecodeStrict :: forall a m. (FromJSON a, MonadThrow m) => B.ByteString -> m a -throwDecodeStrict = - throwFormatError . eitherDecodeStrictWith jsonEOF ifromJSON -{-# INLINE throwDecodeStrict #-} - -- | Like 'decode'' but throws an 'AesonException' when decoding fails. -- -- @since 2.1.2.0 -- throwDecode' :: forall a m. (FromJSON a, MonadThrow m) => L.ByteString -> m a -throwDecode' = throwFormatError . eitherDecodeWith jsonEOF' ifromJSON +throwDecode' = throwDecode {-# INLINE throwDecode' #-} -- | Like 'decodeStrict'' but throws an 'AesonException' when decoding fails. @@ -337,19 +250,9 @@ throwDecode' = throwFormatError . eitherDecodeWith jsonEOF' ifromJSON -- @since 2.1.2.0 -- throwDecodeStrict' :: forall a m. (FromJSON a, MonadThrow m) => B.ByteString -> m a -throwDecodeStrict' = - throwFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON +throwDecodeStrict' = throwDecodeStrict {-# INLINE throwDecodeStrict' #-} --- | Exception thrown by 'throwDecode' and variants. --- --- @since 2.1.2.0 -newtype AesonException = AesonException String - deriving (Show) - -instance Exception AesonException where - displayException (AesonException str) = "aeson: " ++ str - -- $use -- -- This section contains basic information on the different ways to diff --git a/src/Data/Aeson/Decoding.hs b/src/Data/Aeson/Decoding.hs index 10e25888b..d377025a6 100644 --- a/src/Data/Aeson/Decoding.hs +++ b/src/Data/Aeson/Decoding.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Convertion to and from @aeson@ 'A.Value'. @@ -10,23 +9,20 @@ module Data.Aeson.Decoding ( eitherDecodeStrict, throwDecodeStrict, toEitherValue, + unescapeText, ) where import Control.Monad.Catch (MonadThrow (..)) -import Data.Aeson.Key (Key) -import Data.Aeson.Types.Internal (formatError) -import Data.Scientific (Scientific) +import Data.Aeson.Types.Internal (AesonException (..), formatError) -import qualified Data.Aeson.KeyMap as KM import qualified Data.Aeson.Types as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import qualified Data.Vector as V -import Data.Aeson (AesonException (..)) import Data.Aeson.Decoding.ByteString import Data.Aeson.Decoding.ByteString.Lazy -import Data.Aeson.Decoding.Tokens +import Data.Aeson.Decoding.Conversion +import Data.Aeson.Internal.Unescape (unescapeText) ------------------------------------------------------------------------------- -- Decoding: strict bytestring @@ -81,71 +77,11 @@ eitherDecode bs = unResult (toResultValue (lbsToTokens bs)) Left $ \v bs' -> cas A.IError path msg -> Left $ formatError path msg -- | Like 'decode' but throws an 'AesonException' when decoding fails. +-- +-- 'throwDecode' is in @aeson@ since 2.1.2.0, but this variant is added later. throwDecode :: forall a m. (A.FromJSON a, MonadThrow m) => L.ByteString -> m a throwDecode bs = unResult (toResultValue (lbsToTokens bs)) (throwM . AesonException) $ \v bs' -> case A.ifromJSON v of A.ISuccess x | lbsSpace bs' -> pure x | otherwise -> throwM $ AesonException "Trailing garbage" A.IError path msg -> throwM $ AesonException $ formatError path msg - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - -bsSpace :: B.ByteString -> Bool -bsSpace = B.all (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09) - -lbsSpace :: L.ByteString -> Bool -lbsSpace = L.all (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09) - --- | Convert 'Tokens' to 'A.Value'. -toEitherValue - :: Tokens k e -- ^ tokens - -> Either e (A.Value, k) -- ^ either token error or value and leftover. -toEitherValue t = unResult (toResultValue t) Left $ \v k -> Right (v, k) - -toResultValue - :: Tokens k e -- ^ tokens - -> Result e k A.Value -- ^ either token error or value and leftover. -toResultValue t0 = Result (go t0) where - go :: Tokens k e -> (e -> r) -> (A.Value -> k -> r) -> r - go (TkLit l k) _ f = f (lit l) k - go (TkText t k) _ f = f (A.String t) k - go (TkNumber n k) _ f = f (A.Number (num n)) k - go (TkArrayOpen arr) g f = goA 0 id arr g $ \n xs k -> f (A.Array (V.fromListN n xs)) k - go (TkRecordOpen rec) g f = goR [] rec g $ \xs k -> f (A.Object (KM.fromList xs)) k - go (TkErr e) g _ = g e - - lit :: Lit -> A.Value - lit LitNull = A.Null - lit LitTrue = A.Bool True - lit LitFalse = A.Bool False - - num :: Number -> Scientific - num (NumInteger n) = fromInteger n - num (NumDecimal s) = s - num (NumScientific s) = s - - goA :: Int -- size accumulator - -> ([A.Value] -> [A.Value]) -- dlist accumulator - -> TkArray k e -- array tokens - -> (e -> r) -- error continuation - -> (Int -> [A.Value] -> k -> r) -- success continuation - -> r - goA !n !acc (TkItem toks) g f = go toks g $ \v k -> goA (succ n) (acc . (v :)) k g f - goA !n !acc (TkArrayEnd k) _ f = f n (acc []) k - goA !_ !_ (TkArrayErr e) g _ = g e - - -- we accumulate keys in reverse order - -- then the first duplicate key in objects wins (as KM.fromList picks last). - goR :: [(Key, A.Value)] - -> TkRecord k e - -> (e -> r) - -> ([(Key, A.Value)] -> k -> r) - -> r - goR !acc (TkPair t toks) g f = go toks g $ \v k -> goR ((t , v) : acc) k g f - goR !acc (TkRecordEnd k) _ f = f acc k - goR !_ (TkRecordErr e) g _ = g e - -newtype Result e k a = Result - { unResult :: forall r. (e -> r) -> (a -> k -> r) -> r } diff --git a/src/Data/Aeson/Decoding/ByteString.hs b/src/Data/Aeson/Decoding/ByteString.hs index 690babe57..d7a9582a5 100644 --- a/src/Data/Aeson/Decoding/ByteString.hs +++ b/src/Data/Aeson/Decoding/ByteString.hs @@ -22,8 +22,8 @@ import qualified Data.Scientific as Sci 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 -import Data.Aeson.Parser.Unescape (unescapeText) -- | Lex (and parse) strict 'ByteString' into 'Tokens' stream. -- diff --git a/src/Data/Aeson/Decoding/ByteString/Lazy.hs b/src/Data/Aeson/Decoding/ByteString/Lazy.hs index 24d2b91e5..0f9215936 100644 --- a/src/Data/Aeson/Decoding/ByteString/Lazy.hs +++ b/src/Data/Aeson/Decoding/ByteString/Lazy.hs @@ -22,8 +22,8 @@ import qualified Data.Scientific as Sci 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 -import Data.Aeson.Parser.Unescape (unescapeText) -- | Lex (and parse) lazy 'ByteString' into 'Tokens' stream. -- diff --git a/src/Data/Aeson/Decoding/Conversion.hs b/src/Data/Aeson/Decoding/Conversion.hs new file mode 100644 index 000000000..3eaa6937c --- /dev/null +++ b/src/Data/Aeson/Decoding/Conversion.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +module Data.Aeson.Decoding.Conversion ( + bsSpace, + lbsSpace, + toEitherValue, + toResultValue, + Result (..), +) where + +import Data.Aeson.Key (Key) +import Data.Scientific (Scientific) + +import qualified Data.Aeson.KeyMap as KM +import qualified Data.Aeson.Types.Internal as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector as V + +import Data.Aeson.Decoding.Tokens + +bsSpace :: B.ByteString -> Bool +bsSpace = B.all (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09) + +lbsSpace :: L.ByteString -> Bool +lbsSpace = L.all (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09) + +-- | Convert 'Tokens' to 'A.Value'. +toEitherValue + :: Tokens k e -- ^ tokens + -> Either e (A.Value, k) -- ^ either token error or value and leftover. +toEitherValue t = unResult (toResultValue t) Left $ \v k -> Right (v, k) + +toResultValue + :: Tokens k e -- ^ tokens + -> Result e k A.Value -- ^ either token error or value and leftover. +toResultValue t0 = Result (go t0) where + go :: Tokens k e -> (e -> r) -> (A.Value -> k -> r) -> r + go (TkLit l k) _ f = f (lit l) k + go (TkText t k) _ f = f (A.String t) k + go (TkNumber n k) _ f = f (A.Number (num n)) k + go (TkArrayOpen arr) g f = goA 0 id arr g $ \n xs k -> f (A.Array (V.fromListN n xs)) k + go (TkRecordOpen rec) g f = goR [] rec g $ \xs k -> f (A.Object (KM.fromList xs)) k + go (TkErr e) g _ = g e + + lit :: Lit -> A.Value + lit LitNull = A.Null + lit LitTrue = A.Bool True + lit LitFalse = A.Bool False + + num :: Number -> Scientific + num (NumInteger n) = fromInteger n + num (NumDecimal s) = s + num (NumScientific s) = s + + goA :: Int -- size accumulator + -> ([A.Value] -> [A.Value]) -- dlist accumulator + -> TkArray k e -- array tokens + -> (e -> r) -- error continuation + -> (Int -> [A.Value] -> k -> r) -- success continuation + -> r + goA !n !acc (TkItem toks) g f = go toks g $ \v k -> goA (succ n) (acc . (v :)) k g f + goA !n !acc (TkArrayEnd k) _ f = f n (acc []) k + goA !_ !_ (TkArrayErr e) g _ = g e + + -- we accumulate keys in reverse order + -- then the first duplicate key in objects wins (as KM.fromList picks last). + goR :: [(Key, A.Value)] + -> TkRecord k e + -> (e -> r) + -> ([(Key, A.Value)] -> k -> r) + -> r + goR !acc (TkPair t toks) g f = go toks g $ \v k -> goR ((t , v) : acc) k g f + goR !acc (TkRecordEnd k) _ f = f acc k + goR !_ (TkRecordErr e) g _ = g e + +newtype Result e k a = Result + { unResult :: forall r. (e -> r) -> (a -> k -> r) -> r } diff --git a/src/Data/Aeson/Encoding/Builder.hs b/src/Data/Aeson/Encoding/Builder.hs index 20ee5fde7..3b90685a7 100644 --- a/src/Data/Aeson/Encoding/Builder.hs +++ b/src/Data/Aeson/Encoding/Builder.hs @@ -39,7 +39,6 @@ module Data.Aeson.Encoding.Builder import Data.Aeson.Internal.Prelude -import Data.Attoparsec.Time.Internal import Data.Aeson.Types.Internal (Value (..), Key) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM @@ -49,6 +48,7 @@ import Data.ByteString.Builder.Prim ((>$<), (>*<)) import qualified Data.ByteString.Builder.Prim as BP import Data.ByteString.Builder.Scientific (scientificBuilder) import Data.Char (chr, ord) +import Data.Fixed (Fixed (..)) import Data.Scientific (base10Exponent, coefficient) import Data.Text.Encoding (encodeUtf8BuilderEscaped) import Data.Time (UTCTime(..)) @@ -56,6 +56,7 @@ import Data.Time.Calendar (Day(..), toGregorian) import Data.Time.Calendar.Month.Compat (Month, toYearMonth) import Data.Time.Calendar.Quarter.Compat (Quarter, toYearQuarter, QuarterOfYear (..)) import Data.Time.LocalTime (LocalTime (..), TimeZone (..), ZonedTime (..), TimeOfDay (..)) +import Data.Time.Clock.Compat (DiffTime, diffTimeToPicoseconds) import qualified Data.Text as T import qualified Data.Vector as V @@ -290,3 +291,28 @@ twoDigits a = T (digit hi) (digit lo) digit :: Int -> Char digit x = chr (x + 48) + +------------------------------------------------------------------------------- +-- TimeOfDay64 +------------------------------------------------------------------------------- + +-- | Like TimeOfDay, but using a fixed-width integer for seconds. +data TimeOfDay64 = TOD {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !Int64 + +toTimeOfDay64 :: TimeOfDay -> TimeOfDay64 +toTimeOfDay64 (TimeOfDay h m (MkFixed s)) = TOD h m (fromIntegral s) + +posixDayLength :: DiffTime +posixDayLength = 86400 + +diffTimeOfDay64 :: DiffTime -> TimeOfDay64 +diffTimeOfDay64 t + | t >= posixDayLength = TOD 23 59 (60000000000000 + pico (t - posixDayLength)) + | otherwise = TOD (fromIntegral h) (fromIntegral m) s + where (h,mp) = pico t `quotRem` 3600000000000000 + (m,s) = mp `quotRem` 60000000000000 + pico = fromIntegral . diffTimeToPicoseconds + + diff --git a/src/Data/Aeson/Internal/ByteString.hs b/src/Data/Aeson/Internal/ByteString.hs index a8a9324d4..611299176 100644 --- a/src/Data/Aeson/Internal/ByteString.hs +++ b/src/Data/Aeson/Internal/ByteString.hs @@ -5,27 +5,36 @@ module Data.Aeson.Internal.ByteString ( mkBS, withBS, +#ifdef MIN_VERSION_template_haskell liftSBS, +#endif ) where import Data.ByteString.Internal (ByteString (..)) import Data.Word (Word8) import Foreign.ForeignPtr (ForeignPtr) + +#if !MIN_VERSION_bytestring(0,11,0) +import GHC.ForeignPtr (plusForeignPtr) +#endif + +#ifdef MIN_VERSION_template_haskell import Data.ByteString.Short (ShortByteString, fromShort) -import GHC.Exts (Addr#, Ptr (Ptr)) import Data.ByteString.Short.Internal (createFromPtr) +import GHC.Exts (Addr#, Ptr (Ptr)) import System.IO.Unsafe (unsafeDupablePerformIO) import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH -#if !MIN_VERSION_bytestring(0,11,0) -import GHC.ForeignPtr (plusForeignPtr) -#endif - #if !MIN_VERSION_template_haskell(2,16,0) import qualified Data.ByteString as BS #endif +#endif + +------------------------------------------------------------------------------- +-- bytestring-0.11 compat +------------------------------------------------------------------------------- mkBS :: ForeignPtr Word8 -> Int -> ByteString #if MIN_VERSION_bytestring(0,11,0) @@ -43,6 +52,11 @@ withBS (PS !sfp !soff !slen) kont = kont (plusForeignPtr sfp soff) slen #endif {-# INLINE withBS #-} +------------------------------------------------------------------------------- +-- Template Haskell +------------------------------------------------------------------------------- + +#ifdef MIN_VERSION_template_haskell liftSBS :: ShortByteString -> TH.ExpQ #if MIN_VERSION_template_haskell(2,16,0) liftSBS sbs = withBS bs $ \ptr len -> [| unsafePackLenLiteral |] @@ -62,3 +76,4 @@ liftSBS sbs = withBS bs $ \_ len -> [| unsafePackLenLiteral |] unsafePackLenLiteral :: Int -> Addr# -> ShortByteString unsafePackLenLiteral len addr# = unsafeDupablePerformIO $ createFromPtr (Ptr addr#) len +#endif diff --git a/src-pure/Data/Aeson/Parser/UnescapePure.hs b/src/Data/Aeson/Internal/Unescape.hs similarity index 99% rename from src-pure/Data/Aeson/Parser/UnescapePure.hs rename to src/Data/Aeson/Internal/Unescape.hs index 45fc04884..3e64b6b84 100644 --- a/src-pure/Data/Aeson/Parser/UnescapePure.hs +++ b/src/Data/Aeson/Internal/Unescape.hs @@ -2,7 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} -module Data.Aeson.Parser.UnescapePure +module Data.Aeson.Internal.Unescape ( unescapeText ) where @@ -27,7 +27,9 @@ import Data.Aeson.Internal.ByteString import Data.Word (Word16) #endif - +-- | Unescape JSON text literal. +-- +-- This function is exporeted mostly for testing and benchmarking purposes. unescapeText :: ByteString -> Either UnicodeException Text unescapeText = unsafeDupablePerformIO . try . unescapeTextIO diff --git a/src/Data/Aeson/Parser/Unescape.hs b/src/Data/Aeson/Parser/Unescape.hs deleted file mode 100644 index 2d588a8b4..000000000 --- a/src/Data/Aeson/Parser/Unescape.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE CPP #-} -module Data.Aeson.Parser.Unescape - ( - unescapeText - ) where - -import Data.Aeson.Parser.UnescapePure (unescapeText) diff --git a/src/Data/Aeson/Types.hs b/src/Data/Aeson/Types.hs index 3306e3a6f..f4b935b95 100644 --- a/src/Data/Aeson/Types.hs +++ b/src/Data/Aeson/Types.hs @@ -149,6 +149,9 @@ module Data.Aeson.Types , keyModifier , defaultJSONKeyOptions + -- * Parsing exceptions + , AesonException (..) + -- * Parsing context , () , JSONPath diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index ce7bd092f..0af7ead04 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -79,9 +79,10 @@ import Data.Aeson.Internal.Prelude import Control.Monad (zipWithM) import Data.Aeson.Internal.Functions (mapKey, mapKeyO) -import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF) 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.Fixed (Fixed, HasResolution (resolution), Nano) import Data.Functor.Compose (Compose(..)) @@ -781,8 +782,14 @@ withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a withEmbeddedJSON _ innerParser (String txt) = either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt) where - eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON - eitherFormatError = either (Left . uncurry formatError) Right + -- TODO: decode from strict text + eitherDecode :: (FromJSON a) => L.ByteString -> Either String a + eitherDecode bs = unResult (toResultValue (lbsToTokens bs)) Left $ \v bs' -> case ifromJSON v of + ISuccess x + | lbsSpace bs' -> Right x + | otherwise -> Left "Trailing garbage" + IError path msg -> Left $ formatError path msg + withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v) -- | Convert a value from JSON, failing if the types do not match. diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs index ef756222a..cb164e819 100644 --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -73,6 +73,9 @@ module Data.Aeson.Types.Internal , camelTo , camelTo2 + -- * Aeson Exception + , AesonException (..) + -- * Other types , DotNetTime(..) ) where @@ -80,6 +83,7 @@ module Data.Aeson.Types.Internal import Data.Aeson.Internal.Prelude import Control.DeepSeq (NFData(..)) +import Control.Exception (Exception (..)) import Control.Monad (MonadPlus(..), ap) import Data.Char (isLower, isUpper, toLower, isAlpha, isAlphaNum) import Data.Aeson.Key (Key) @@ -936,3 +940,16 @@ camelTo2 c = map toLower . go2 . go1 go2 "" = "" go2 (l:u:xs) | isLower l && isUpper u = l : c : u : go2 xs go2 (x:xs) = x : go2 xs + +------------------------------------------------------------------------------- +-- AesonException +------------------------------------------------------------------------------- + +-- | Exception thrown by 'throwDecode' and variants. +-- +-- @since 2.1.2.0 +newtype AesonException = AesonException String + deriving (Show) + +instance Exception AesonException where + displayException (AesonException str) = "aeson: " ++ str diff --git a/tests/ErrorMessages.hs b/tests/ErrorMessages.hs index 2d4a50e0e..f2b6e9d66 100644 --- a/tests/ErrorMessages.hs +++ b/tests/ErrorMessages.hs @@ -9,9 +9,8 @@ module ErrorMessages import Prelude.Compat -import Data.Aeson (FromJSON(..), Value, json) -import Data.Aeson.Types (Parser, formatError, iparse) -import Data.Aeson.Parser (eitherDecodeWith) +import Data.Aeson (FromJSON(..), Value, eitherDecode) +import Data.Aeson.Types (Parser, parseEither) import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) import Data.Proxy (Proxy(..)) import Data.Semigroup ((<>)) @@ -209,8 +208,8 @@ testWith :: Show a => String -> (Value -> Parser a) -> [L.ByteString] -> Output testWith name parser ts = outputLine name <> foldMap (\s -> - case eitherDecodeWith json (iparse parser) s of - Left err -> outputLine $ uncurry formatError err + case eitherDecode s >>= parseEither parser of + Left err -> outputLine err Right a -> outputLine $ show a) ts testFor :: forall a proxy. (FromJSON a, Show a) diff --git a/tests/PropUtils.hs b/tests/PropUtils.hs index 43de85d7f..d685ea9e5 100644 --- a/tests/PropUtils.hs +++ b/tests/PropUtils.hs @@ -31,7 +31,6 @@ import Prelude.Compat import Data.Aeson (eitherDecode, encode) import Data.Aeson.Encoding (encodingToLazyByteString) -import Data.Aeson.Parser (value) import Data.Aeson.Types import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM @@ -43,7 +42,6 @@ import Instances () import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample) import Types import Text.Read (readMaybe) -import qualified Data.Attoparsec.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Vector as V import qualified Data.Aeson.Decoding as Dec @@ -80,10 +78,9 @@ toParseJSON1 parsejson1 tojson1 = toParseJSON parsejson tojson roundTripEnc :: (FromJSON a, ToJSON a, Show a) => (a -> a -> Property) -> a -> Property roundTripEnc eq i = - case fmap ifromJSON . L.parse value . encode $ i of - L.Done _ (ISuccess v) -> v `eq` i - L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i - L.Fail _ _ err -> failure "parse" err i + case eitherDecode . encode $ i of + Right v -> v `eq` i + Left err -> failure "parsing" err i roundTripDecEnc :: (FromJSON a, ToJSON a, Show a) => (a -> a -> Property) -> a -> Property diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index 7003c38db..c8fa4eef9 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -35,17 +35,13 @@ import Data.Aeson.Types (JSONPathElement(..), formatError) import Data.Aeson.QQ.Simple (aesonQQ) import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1) import Data.Aeson.Text (encodeToTextBuilder) -import Data.Aeson.Parser - ( json, jsonLast, jsonAccum, jsonNoDup - , json', jsonLast', jsonAccum', jsonNoDup') import Data.Aeson.Types ( Options(..), Result(Success, Error), ToJSON(..) - , Value(Array, Bool, Null, Number, Object, String), camelTo, camelTo2 + , Value(..), camelTo, camelTo2 , explicitParseField, liftParseJSON, listParser , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse, parseMaybe) import qualified Data.Aeson.Types import qualified Data.Aeson.KeyMap as KM -import Data.Attoparsec.ByteString (Parser, parseOnly) import Data.Char (toUpper, GeneralCategory(Control,Surrogate), generalCategory) import Data.Hashable (hash) import Data.HashMap.Strict (HashMap) @@ -64,14 +60,12 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertFailure, assertEqual, testCase, testCaseSteps, (@?=)) import Text.Printf (printf) import UnitTests.NullaryConstructors (nullaryConstructors) -import qualified Data.ByteString as S import qualified Data.ByteString.Base16.Lazy as LBase16 import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Lazy.Encoding as TLE -import qualified Data.Vector as Vector import qualified ErrorMessages import qualified SerializationFormatSpec import qualified Data.Map as Map -- Lazy! @@ -573,6 +567,7 @@ unknownFields = concat testsTagged :: String -> Value -> Result UnknownFieldsUnaryTagged -> [TestTree] testsTagged = testsBase fromJSON (parse (genericParseJSON taggedOpts)) +{- testParser :: (Eq a, Show a) => String -> Parser a -> S.ByteString -> Either String a -> TestTree testParser name json_ s expected = @@ -606,6 +601,7 @@ keyOrdering = "{\"k\":true,\"k\":false}" $ Left "Failed reading: found duplicate key: \"k\"" ] +-} ratioDenominator0 :: Assertion ratioDenominator0 = @@ -816,7 +812,7 @@ tests = testGroup "unit" [ , testCase "withEmbeddedJSON" withEmbeddedJSONTest , testCase "SingleFieldCon" singleFieldCon , testGroup "UnknownFields" unknownFields - , testGroup "Ordering of object keys" keyOrdering + -- , testGroup "Ordering of object keys" keyOrdering , testCase "Ratio with denominator 0" ratioDenominator0 , testCase "Rational parses number" rationalNumber , testCase "Big rational" bigRationalDecoding diff --git a/tests/golden/generic.expected b/tests/golden/generic.expected index 214d83a3c..2beea2ef1 100644 --- a/tests/golden/generic.expected +++ b/tests/golden/generic.expected @@ -19,9 +19,9 @@ Error in $: parsing Types.SomeType failed, expected an Object with a single pair Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 2 pairs Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 0 pairs Error in $: parsing Types.SomeType failed, expected Object, but encountered Array -Error in $: not enough input. Expecting ':' -Error in $: not enough input. Expecting object value -Error in $: not enough input. Expecting ',' or '}' +Unexpected end-of-input, expecting : +Unexpected end-of-input, expecting JSON value +Unexpected end-of-input, expecting , or } SomeType (two-element array) Error in $[1]: parsing Int failed, expected Number, but encountered Boolean Error in $[1]: parsing Types.SomeType(Record) failed, expected Object, but encountered Null @@ -29,8 +29,8 @@ Error in $[0]: parsing Types.SomeType failed, expected tag of the 2-element Arra Error in $[0]: parsing Types.SomeType failed, tag element is not a String Error in $: parsing Types.SomeType failed, expected a 2-element Array, but encountered an Array of length 0 Error in $: parsing Types.SomeType failed, expected Array, but encountered Object -Error in $: not enough input. Expecting ',' or ']' -Error in $: not enough input. Expecting json list value +Unexpected end-of-input, expecting , or ] +Unexpected end-of-input, expecting JSON value SomeType (reject unknown fields) Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testZero"] Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found diff --git a/tests/golden/th.expected b/tests/golden/th.expected index 7909b7bb3..4b7e6c57e 100644 --- a/tests/golden/th.expected +++ b/tests/golden/th.expected @@ -19,9 +19,9 @@ Error in $: When parsing Types.SomeType expected an Object with a single tag/con Error in $: When parsing Types.SomeType expected an Object with a single tag/contents pair but got 2 pairs. Error in $: When parsing Types.SomeType expected an Object with a single tag/contents pair but got 0 pairs. Error in $: When parsing Types.SomeType expected Object but got Array. -Error in $: not enough input. Expecting ':' -Error in $: not enough input. Expecting object value -Error in $: not enough input. Expecting ',' or '}' +Unexpected end-of-input, expecting : +Unexpected end-of-input, expecting JSON value +Unexpected end-of-input, expecting , or } SomeType (two-element array) Error in $: parsing Int failed, expected Number, but encountered Boolean Error in $: When parsing the constructor Record of type Types.SomeType expected Object but got Null. @@ -29,8 +29,8 @@ Error in $: When parsing Types.SomeType expected a 2-element Array with a tag an Error in $: When parsing Types.SomeType expected an Array of 2 elements where the first element is a String but got Null at the first element. Error in $: When parsing Types.SomeType expected an Array of 2 elements but got 0 elements Error in $: When parsing Types.SomeType expected Array but got Object. -Error in $: not enough input. Expecting ',' or ']' -Error in $: not enough input. Expecting json list value +Unexpected end-of-input, expecting , or ] +Unexpected end-of-input, expecting JSON value SomeType (reject unknown fields) Error in $: Unknown fields: ["testZero"] Error in $: key "tag" not found