aeson 2.2.0.0 → 2.2.1.0
raw patch · 17 files changed
+1644/−28 lines, 17 filesdep +integer-gmpdep ~bytestringdep ~deepseqdep ~ghc-primPVP ok
version bump matches the API change (PVP)
Dependencies added: integer-gmp
Dependency ranges changed: bytestring, deepseq, ghc-prim, integer-logarithms, primitive, template-haskell, text, th-abstraction
API changes (from Hackage documentation)
+ Data.Aeson: decodeStrictText :: FromJSON a => Text -> Maybe a
+ Data.Aeson: eitherDecodeStrictText :: FromJSON a => Text -> Either String a
+ Data.Aeson: throwDecodeStrictText :: forall a m. (FromJSON a, MonadThrow m) => Text -> m a
+ Data.Aeson.Decoding: decodeStrictText :: FromJSON a => Text -> Maybe a
+ Data.Aeson.Decoding: eitherDecodeStrictText :: FromJSON a => Text -> Either String a
+ Data.Aeson.Decoding: throwDecodeStrictText :: forall a m. (FromJSON a, MonadThrow m) => Text -> m a
+ Data.Aeson.Decoding.Text: textToTokens :: Text -> Tokens Text String
+ Data.Aeson.RFC8785: encodeCanonical :: ToJSON a => a -> ByteString
Files
- aeson.cabal +26/−11
- changelog.md +18/−0
- src/Data/Aeson.hs +6/−1
- src/Data/Aeson/Decoding.hs +51/−10
- src/Data/Aeson/Decoding/Conversion.hs +10/−0
- src/Data/Aeson/Decoding/Text.hs +304/−0
- src/Data/Aeson/Internal/Text.hs +2/−2
- src/Data/Aeson/Internal/UnescapeFromText.hs +532/−0
- src/Data/Aeson/Internal/Word16.hs +76/−0
- src/Data/Aeson/KeyMap.hs +2/−2
- src/Data/Aeson/RFC8785.hs +169/−0
- tests/CastFloat.hs +42/−0
- tests/DoubleToScientific.hs +223/−0
- tests/JSONTestSuite.hs +24/−0
- tests/RFC8785.hs +144/−0
- tests/Tests.hs +2/−1
- tests/Types.hs +13/−1
aeson.cabal view
@@ -1,5 +1,5 @@ name: aeson-version: 2.2.0.0+version: 2.2.1.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON@@ -18,8 +18,9 @@ || ==8.10.7 || ==9.0.2 || ==9.2.8- || ==9.4.5- || ==9.6.2+ || ==9.4.7+ || ==9.6.3+ || ==9.8.1 synopsis: Fast JSON parsing and encoding cabal-version: 1.12@@ -59,12 +60,14 @@ Data.Aeson.Decoding Data.Aeson.Decoding.ByteString Data.Aeson.Decoding.ByteString.Lazy+ Data.Aeson.Decoding.Text Data.Aeson.Decoding.Tokens Data.Aeson.Encoding Data.Aeson.Encoding.Internal Data.Aeson.Key Data.Aeson.KeyMap Data.Aeson.QQ.Simple+ Data.Aeson.RFC8785 Data.Aeson.Text Data.Aeson.TH Data.Aeson.Types@@ -80,7 +83,9 @@ Data.Aeson.Internal.Text 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@@ -91,13 +96,13 @@ -- GHC bundled libs build-depends: base >=4.10.0.0 && <5- , bytestring >=0.10.8.2 && <0.12+ , bytestring >=0.10.8.2 && <0.13 , containers >=0.5.10.2 && <0.7- , deepseq >=1.4.3.0 && <1.5+ , deepseq >=1.4.3.0 && <1.6 , exceptions >=0.10.4 && <0.11- , ghc-prim >=0.5.0.0 && <0.11- , template-haskell >=2.12.0.0 && <2.21- , text >=1.2.3.0 && <1.3 || >=2.0 && <2.1+ , ghc-prim >=0.5.0.0 && <0.12+ , template-haskell >=2.12.0.0 && <2.22+ , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2 , time >=1.8.0.2 && <1.13 -- Compat@@ -108,6 +113,9 @@ if !impl(ghc >=8.6) build-depends: contravariant >=1.4.1 && <1.6 + if !impl(ghc >=9.0)+ build-depends: integer-gmp+ -- Other dependencies build-depends: data-fix >=0.3.2 && <0.4@@ -115,6 +123,7 @@ , 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@@ -125,7 +134,7 @@ , 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.6+ , 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@@ -146,10 +155,12 @@ main-is: Tests.hs ghc-options: -Wall -threaded -rtsopts other-modules:+ CastFloat DataFamilies.Encoders DataFamilies.Instances DataFamilies.Properties DataFamilies.Types+ DoubleToScientific Encoders ErrorMessages Functions@@ -168,6 +179,7 @@ Regression.Issue571 Regression.Issue687 Regression.Issue967+ RFC8785 SerializationFormatSpec Types UnitTests@@ -175,6 +187,7 @@ UnitTests.Hashable UnitTests.KeyMapInsertWith UnitTests.MonadFix+ UnitTests.NoThunks UnitTests.NullaryConstructors UnitTests.OmitNothingFieldsNote UnitTests.OptionalFields@@ -183,18 +196,17 @@ UnitTests.OptionalFields.Manual UnitTests.OptionalFields.TH UnitTests.UTCTime- UnitTests.NoThunks build-depends: aeson , base , base-compat- , deepseq , base-orphans >=0.5.3 && <0.10 , base16-bytestring , bytestring , containers , data-fix+ , deepseq , Diff >=0.4 && <0.5 , directory , dlist@@ -226,6 +238,9 @@ , unordered-containers , uuid-types , vector++ if !impl(ghc >=9.0)+ build-depends: integer-gmp if impl(ghc >=9.2 && <9.7) build-depends: nothunks >=0.1.4 && <0.2
changelog.md view
@@ -1,5 +1,22 @@ 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.2.1.0++* Add `Data.Aeson.RFC8785`, a JSON Canonicalization Scheme implementation+ https://datatracker.ietf.org/doc/html/rfc8785+* Add Data.Aeson.Decoding.Text, decodeStrictText :: Text -> ...++ We avoid intermediate `ByteString` copy by not doing+ `decode . TE.encodeUtf8`, but instead working on `Text` value directly.+ As we know that the stream is valid Unicode (UTF8 or UTF16),+ we can also take some shortcuts.++ 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)+ then users might want to use `Data.Text.copy`.+ ### 2.2.0.0 * Rework how `omitNothingFields` works. Add `allowOmittedFields` as a parsing counterpart.@@ -38,6 +55,7 @@ - The space between time and timezone offset (in `UTCTime` and `ZonedTime`) is disallowed. ISO8601 explictly forbidds 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. * Remove `cffi` flag. Toggling the flag made `aeson` use a C implementation for string unescaping (used for `text <2` versions). The new native Haskell implementation (introduced in version 2.0.3.0) is at least as fast. * Drop instances for `Number` from `attoparsec` package.
src/Data/Aeson.hs view
@@ -55,10 +55,14 @@ , eitherDecodeFileStrict , eitherDecodeStrict' , eitherDecodeFileStrict'+ -- ** Variants for strict text+ , decodeStrictText+ , eitherDecodeStrictText -- ** Exception throwing variants , AesonException (..) , throwDecode , throwDecodeStrict+ , throwDecodeStrictText , throwDecode' , throwDecodeStrict' -- * Core JSON types@@ -171,6 +175,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Aeson.Decoding (decode, eitherDecode, throwDecode, decodeStrict, eitherDecodeStrict, throwDecodeStrict)+import Data.Aeson.Decoding (decodeStrictText, eitherDecodeStrictText, throwDecodeStrictText) -- $setup -- >>> :set -XOverloadedStrings@@ -281,7 +286,7 @@ -- -- The most common way to use the library is to define a data type, -- corresponding to some JSON data you want to work with, and then--- write either a 'FromJSON' instance, a to 'ToJSON' instance, or both+-- write either a 'FromJSON' instance, a 'ToJSON' instance, or both -- for that type. -- -- For example, given this JSON data:
src/Data/Aeson/Decoding.hs view
@@ -9,6 +9,9 @@ decodeStrict, eitherDecodeStrict, throwDecodeStrict,+ decodeStrictText,+ eitherDecodeStrictText,+ throwDecodeStrictText, toEitherValue, unescapeText, ) where@@ -17,11 +20,13 @@ import Data.Aeson.Types.Internal (AesonException (..), formatError) import qualified Data.Aeson.Types as A-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T import Data.Aeson.Decoding.ByteString import Data.Aeson.Decoding.ByteString.Lazy+import Data.Aeson.Decoding.Text import Data.Aeson.Decoding.Conversion import Data.Aeson.Internal.Unescape (unescapeText) @@ -32,7 +37,7 @@ -- | Efficiently deserialize a JSON value from a strict 'B.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned.-decodeStrict :: (A.FromJSON a) => B.ByteString -> Maybe a+decodeStrict :: (A.FromJSON a) => BS.ByteString -> Maybe a decodeStrict bs = unResult (toResultValue (bsToTokens bs)) (\_ -> Nothing) $ \v bs' -> case A.ifromJSON v of A.ISuccess x | bsSpace bs' -> Just x@@ -40,7 +45,7 @@ A.IError _ _ -> Nothing -- | Like 'decodeStrict' but returns an error message when decoding fails.-eitherDecodeStrict :: (A.FromJSON a) => B.ByteString -> Either String a+eitherDecodeStrict :: (A.FromJSON a) => BS.ByteString -> Either String a eitherDecodeStrict bs = unResult (toResultValue (bsToTokens bs)) Left $ \v bs' -> case A.ifromJSON v of A.ISuccess x | bsSpace bs' -> Right x@@ -48,7 +53,7 @@ A.IError path msg -> Left $ formatError path msg -- | Like 'decodeStrict' but throws an 'AesonException' when decoding fails.-throwDecodeStrict :: forall a m. (A.FromJSON a, MonadThrow m) => B.ByteString -> m a+throwDecodeStrict :: forall a m. (A.FromJSON a, MonadThrow m) => BS.ByteString -> m a throwDecodeStrict bs = unResult (toResultValue (bsToTokens bs)) (throwM . AesonException) $ \v bs' -> case A.ifromJSON v of A.ISuccess x | bsSpace bs' -> pure x@@ -59,18 +64,18 @@ -- Decoding: lazy bytestring ------------------------------------------------------------------------------- --- | Efficiently deserialize a JSON value from a strict 'B.ByteString'.+-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'. -- If this fails due to incomplete or invalid input, 'Nothing' is -- returned.-decode :: (A.FromJSON a) => L.ByteString -> Maybe a+decode :: (A.FromJSON a) => LBS.ByteString -> Maybe a decode bs = unResult (toResultValue (lbsToTokens bs)) (\_ -> Nothing) $ \v bs' -> case A.ifromJSON v of A.ISuccess x | lbsSpace bs' -> Just x | otherwise -> Nothing A.IError _ _ -> Nothing --- | Like 'decodeStrict' but returns an error message when decoding fails.-eitherDecode :: (A.FromJSON a) => L.ByteString -> Either String a+-- | Like 'decode' but returns an error message when decoding fails.+eitherDecode :: (A.FromJSON a) => LBS.ByteString -> Either String a eitherDecode bs = unResult (toResultValue (lbsToTokens bs)) Left $ \v bs' -> case A.ifromJSON v of A.ISuccess x | lbsSpace bs' -> Right x@@ -80,9 +85,45 @@ -- | 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 :: forall a m. (A.FromJSON a, MonadThrow m) => LBS.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++-------------------------------------------------------------------------------+-- Decoding: strict text+-------------------------------------------------------------------------------++-- | Efficiently deserialize a JSON value from a strict 'B.ByteString'.+-- If this fails due to incomplete or invalid input, 'Nothing' is+-- returned.+--+-- @since 2.2.1.0+decodeStrictText :: (A.FromJSON a) => T.Text -> Maybe a+decodeStrictText bs = unResult (toResultValue (textToTokens bs)) (\_ -> Nothing) $ \v bs' -> case A.ifromJSON v of+ A.ISuccess x+ | textSpace bs' -> Just x+ | otherwise -> Nothing+ A.IError _ _ -> Nothing++-- | Like 'decodeStrictText' but returns an error message when decoding fails.+--+-- @since 2.2.1.0+eitherDecodeStrictText :: (A.FromJSON a) => T.Text -> Either String a+eitherDecodeStrictText bs = unResult (toResultValue (textToTokens bs)) Left $ \v bs' -> case A.ifromJSON v of+ A.ISuccess x+ | textSpace bs' -> Right x+ | otherwise -> Left "Trailing garbage"+ A.IError path msg -> Left $ formatError path msg++-- | Like 'decodeStrictText' but throws an 'AesonException' when decoding fails.+--+-- @since 2.2.1.0+throwDecodeStrictText :: forall a m. (A.FromJSON a, MonadThrow m) => T.Text -> m a+throwDecodeStrictText bs = unResult (toResultValue (textToTokens bs)) (throwM . AesonException) $ \v bs' -> case A.ifromJSON v of+ A.ISuccess x+ | textSpace bs' -> pure x+ | otherwise -> throwM $ AesonException "Trailing garbage"+ A.IError path msg -> throwM $ AesonException $ formatError path msg
src/Data/Aeson/Decoding/Conversion.hs view
@@ -3,6 +3,8 @@ module Data.Aeson.Decoding.Conversion ( bsSpace, lbsSpace,+ textSpace,+ ltextSpace, toEitherValue, toResultValue, Result (..),@@ -16,6 +18,8 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Vector as V+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT import Data.Aeson.Decoding.Tokens @@ -24,6 +28,12 @@ lbsSpace :: L.ByteString -> Bool lbsSpace = L.all (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09)++textSpace :: T.Text -> Bool+textSpace = T.all (\c -> c == ' ' || c == '\r' || c == '\n' || c == '\t')++ltextSpace :: LT.Text -> Bool+ltextSpace = LT.all (\c -> c == ' ' || c == '\r' || c == '\n' || c == '\t') -- | Convert 'Tokens' to 'A.Value'. --
+ src/Data/Aeson/Decoding/Text.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -O2 #-}+-- | Parser from strict 'Text' to 'Tokens'.+module Data.Aeson.Decoding.Text (+ textToTokens,+) where++import Data.Char (chr)+import Data.Integer.Conversion (textToInteger)+import Data.Text.Internal (Text (..))++import qualified Data.Aeson.Key as Key+import qualified Data.Scientific as Sci+import qualified Data.Text as T+import qualified Data.Text.Array as A++import Data.Aeson.Decoding.Internal+import Data.Aeson.Decoding.Tokens+import Data.Aeson.Internal.Prelude+import Data.Aeson.Internal.UnescapeFromText (unescapeFromText)++#if MIN_VERSION_text(2,0,0)+import Data.Aeson.Internal.Word8+#else+import Data.Aeson.Internal.Word16+#endif++#if MIN_VERSION_text(2,0,0)+type Point = Word8+#else+type Point = Word16+#endif+++-- | Lex (and parse) strict 'ByteString' into 'Tokens' stream.+--+-- @since 2.2.1.0+--+textToTokens :: Text -> Tokens Text String+textToTokens bs0 = goT bs0 id where+ goT :: Parser Tokens k+ goT (skipSpace -> bs) k = case unconsPoint bs of+ Nothing -> tkErr "Unexpected end-of-input, expecting JSON value"+ Just (!w, !bs1) -> tokenCase w bs1 bs k++ tokenCase+ :: Point -- head+ -> Text -- tail+ -> 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 _ wbs k+ | W8_0 <= w, w <= W8_9 = scanNumberLiteral (\n bs' -> TkNumber n (k bs')) tkErr wbs+ tokenCase W8_n bs _ k+ | Just bs1 <- stripPrefix "ull" 3 bs = TkLit LitNull (k bs1)+ tokenCase W8_t bs _ k+ | Just bs1 <- stripPrefix "rue" 3 bs = TkLit LitTrue (k bs1)+ tokenCase W8_f bs _ k+ | Just bs1 <- stripPrefix "alse" 4 bs = TkLit LitFalse (k bs1)+ 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, !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+ _ -> 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 _ -> 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+ Nothing -> tkErrEOF "key literal"+ Just (W8_DOUBLE_QUOTE, !bs2) -> goRK bs2 k+ Just _ -> tkErrBS bs "key literal"+ Just (W8_CLOSE_CURLY, !bs1) -> TkRecordEnd (k bs1)+ _ -> tkErr $ "Unexpected " ++ showBeginning bs ++ ", expecting , or }"++ -- key of record (after double quote)+ goRK :: Parser TkRecord k+ goRK bs1 k = scanStringLiteral (\t bs -> goRK' t bs k) tkErr bs1++ -- after key of a record, expecting :+ goRK' :: Text -> Parser TkRecord k+ goRK' t (skipSpace -> bs) k = case T.uncons bs of+ Nothing -> tkErrEOF ":"+ Just (':', !bs3) -> TkPair (Key.fromText t) $ goT bs3 $ \bs4 -> goR1 bs4 k+ Just _ -> tkErrBS bs ":"++stripPrefix :: Text -> Int -> Text -> Maybe Text+stripPrefix pfx _ bs = T.stripPrefix pfx bs+{-# INLINE stripPrefix #-}++type Parser tk k = Text -> (Text -> k) -> tk k String++showBeginning :: Text -> String+showBeginning = show . T.take 30++-- | Strip leading (ASCII) space+skipSpace :: Text -> Text+skipSpace = T.dropWhile $ \w -> w == '\x20' || w == '\x0a' || w == '\x0d' || w == '\x09'+{-# INLINE skipSpace #-}++tkErrEOF :: AsError t => String -> t k String+tkErrEOF expected = tkErr $+ "Unexpected end-of-input, expecting " ++ expected+{-# INLINE tkErrEOF #-}++tkErrBS :: AsError t => Text -> String -> t k String+tkErrBS bs expected = tkErr $+ "Unexpected " ++ showBeginning bs ++ ", expecting " ++ expected+{-# INLINE tkErrBS #-}++-------------------------------------------------------------------------------+-- Text+-------------------------------------------------------------------------------++scanStringLiteral+ :: forall r. (Text -> Text -> r)+ -> (String -> r)+ -> Text+ -> r+scanStringLiteral ok err bs0 = go 0 bs0 where+ -- the length is counted in bytes.+ go :: Int -> Text -> r+ go !n !bs = case unconsPoint bs of+ Nothing -> errEnd+ Just (34, _) -> ok (unsafeTakePoints n bs0) (unsafeDropPoints (n + 1) bs0)+ Just (92, bs') -> goSlash (n + 1) bs'+ Just (w8, bs')+ | w8 < 0x20 -> errCC+ -- we don't need to check for @>= 0x80@ chars, as text is valid unicode.+ | otherwise -> go (n + 1) bs'++ -- in goEsc and goSlash we don't need to check for control characters as unescapeText verifies that.+ goEsc :: Int -> Text -> r+ goEsc !n !bs = case unconsPoint bs of+ Nothing -> errEnd+ Just (34, _) -> case unescapeFromText (unsafeTakePoints n bs0) of+ 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'++ goSlash :: Int -> Text -> r+ goSlash !n !bs = case unconsPoint bs of+ Nothing -> errEnd+ 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"++-------------------------------------------------------------------------------+-- Number+-------------------------------------------------------------------------------++--+-- number := integer fraction exponent+-- integer := 0 | [1-9][0-9]* | -0 | -[1-9][0-9]*+-- fraction := "" | . [0-9]++-- exponent := "" | E sign [0-9]+ | e sign [0-9]++-- sign := "" | - | ++--+-- This scanner doesn't recognize the leading minus sign, we recognize only integer := 0 | [1-9][0-9]*,+-- as the minus sign is recognized by outer scanner already.+--+scanNumberLiteral+ :: forall r. (Number -> Text -> r)+ -> (String -> r)+ -> Text+ -> r+scanNumberLiteral kont err bs0 = state_start bs0 where+ state_start :: Text -> r+ state_start !bs = case unconsPoint bs of+ Nothing -> errEnd+ Just (w8, bs')+ | W8_0 < w8, w8 <= W8_9 -> state_i1 1 bs'+ | W8_0 == w8 -> state_after0 bs'+ | otherwise -> errUnx w8++ state_after0 :: Text -> r+ state_after0 !bs = case unconsPoint 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++ state_i1 :: Int -> Text -> r+ state_i1 !n !bs = case unconsPoint 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+ where+ int = textToInteger (unsafeTakePoints n bs0)++ go_dec :: Integer -> Text -> r+ go_dec !int !bs1 = case unconsPoint bs1 of+ Nothing -> errEnd+ Just (w8, bs')+ | W8_0 <= w8, w8 <= W8_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+ 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+ where+ frac = textToInteger (unsafeTakePoints n bs1)+ coef = int * 10 ^ n + frac+ dec = Sci.scientific coef (negate n)++ go_sci :: Integer -> Int -> Text -> r+ go_sci !coef !exp10 !bs2 = case unconsPoint 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 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+ Just (w8', bs'')+ | W8_0 <= w8', w8' <= W8_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+ Just (w8, bs')+ | W8_0 <= w8, w8 <= W8_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+ Just (w8, bs')+ | W8_0 <= w8, w8 <= W8_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')++ errEnd = err "Unexpected end-of-input while parsing number literal"+ errUnx w8 = err $ "Unexpected " ++ show (chr (fromIntegral w8)) ++ " while parsing number literal"++-------------------------------------------------------------------------------+-- Unsafe primitives+-------------------------------------------------------------------------------++{-# INLINE unconsPoint #-}+-- Uncons a primitive unit of storage from text.+-- The left-over 'Text' value may be invalid.+unconsPoint :: Text -> Maybe (Point, Text)+unconsPoint (Text arr off len)+ | len <= 0 = Nothing+ | otherwise = Just (w8, Text arr (off + 1) (len - 1))+ where+ w8 = A.unsafeIndex arr off++unsafeTakePoints :: Int -> Text -> Text+unsafeTakePoints n (Text arr off _len) = Text arr off n+{-# INLINE unsafeTakePoints #-}++unsafeDropPoints :: Int -> Text -> Text+unsafeDropPoints n (Text arr off len) = Text arr (off + n) (len - n)+{-# INLINE unsafeDropPoints #-}
src/Data/Aeson/Internal/Text.hs view
@@ -8,7 +8,7 @@ import qualified Data.Text as T #if MIN_VERSION_text(2,0,0)-import Data.Text.Array (Array (..))+import qualified Data.Text.Array as A import qualified Data.Text.Internal as T (Text (..)) import qualified Data.ByteString.Short.Internal as SBS@@ -27,7 +27,7 @@ #if MIN_VERSION_text(2,0,0) unsafeDecodeASCII bs = withBS bs $ \_fp len -> if len == 0 then T.empty else- let !(SBS.SBS arr) = SBS.toShort bs in T.Text (ByteArray arr) 0 len+ let !(SBS.SBS arr) = SBS.toShort bs in T.Text (A.ByteArray arr) 0 len #else unsafeDecodeASCII = TE.decodeLatin1
+ src/Data/Aeson/Internal/UnescapeFromText.hs view
@@ -0,0 +1,532 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}++module Data.Aeson.Internal.UnescapeFromText+ ( unescapeFromText+ ) where++import Control.Exception (throwIO, try)+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import Data.Text.Encoding.Error (UnicodeException (..))+import Data.Text.Internal (Text (..))+import Data.Text.Unsafe (unsafeDupablePerformIO)++import Data.Aeson.Internal.Prelude++import qualified Data.Primitive as P+import qualified Data.Text.Array as A+import qualified Data.Text.Internal as T++#if !MIN_VERSION_text(2,0,0)+import Data.Word (Word16)+#endif++-- | Unescape JSON text literal.+--+-- This function is exporeted mostly for testing and benchmarking purposes.+unescapeFromText :: Text -> Either UnicodeException Text+unescapeFromText = unsafeDupablePerformIO . try . unescapeFromTextIO++throwDecodeError :: IO a+throwDecodeError =+ let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"+ in throwIO (DecodeError desc Nothing)++-------------------------------------------------------------------------------+-- unescapeTextIO+-------------------------------------------------------------------------------++type Offset = Int++unescapeFromTextIO :: Text -> IO Text++#if MIN_VERSION_text(2,0,0)++unescapeFromTextIO (Text src begin len) = do+ let end :: Offset+ end = begin + len++ arr <- P.newPrimArray len++ let write3bytes :: Int -> Word8 -> Word8 -> Word8 -> Offset -> IO Text+ write3bytes !out !b1 !b2 !b3 !inp = do+ P.writePrimArray arr out b1+ write2bytes (out + 1) b2 b3 inp++ write2bytes :: Int -> Word8 -> Word8 -> Offset -> IO Text+ write2bytes !out !b1 !b2 !inp = do+ P.writePrimArray arr out b1+ write1byte (out + 1) b2 inp++ write1byte :: Int -> Word8 -> Offset -> IO Text+ write1byte !out !b1 !inp = do+ P.writePrimArray arr out b1+ state_start (out + 1) inp++ writeCodePoint :: Int -> Offset -> Word32 -> IO Text+ writeCodePoint !out !inp !acc+ | acc <= 127 = do+ P.writePrimArray arr out (fromIntegral acc :: Word8)+ state_start (out + 1) (inp + 1)++ | acc <= 2047 = do+ let b1 = fromIntegral (shiftR acc 6 .|. 192) :: Word8+ let b2 = fromIntegral ((acc .&. 63) .|. 128) :: Word8+ P.writePrimArray arr out b1+ write1byte (out + 1) b2 (inp + 1)++ | acc <= 65535 = do+ let b1 = fromIntegral (shiftR acc 12 .|. 224) :: Word8+ let b2 = fromIntegral ((shiftR acc 6 .&. 63) .|. 128) :: Word8+ let b3 = fromIntegral ((acc .&. 63) .|. 128) :: Word8+ P.writePrimArray arr out b1+ write2bytes (out + 1) b2 b3 (inp + 1)++ | otherwise = do+ let b1 = fromIntegral (shiftR acc 18 .|. 240) :: Word8+ let b2 = fromIntegral ((shiftR acc 12 .&. 63) .|. 128) :: Word8+ let b3 = fromIntegral ((shiftR acc 6 .&. 63) .|. 128) :: Word8+ let b4 = fromIntegral ((acc .&. 63) .|. 128) :: Word8+ P.writePrimArray arr out b1+ write3bytes (out + 1) b2 b3 b4 (inp + 1)++ state_sudone :: Int -> Offset -> Word32 -> Word32 -> IO Text+ state_sudone !out !inp !hi !lo+ | 56320 <= lo, lo <= 57343+ = writeCodePoint out inp (65536 + (shiftL (hi - 55296) 10 .|. (lo - 56320)))++ | otherwise+ = throwDecodeError++ state_su4 :: Int -> Offset -> Word32 -> Word32 -> IO Text+ state_su4 !out !inp !hi !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_sudone out inp hi (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_su3 :: Int -> Offset -> Word32 -> Word32 -> IO Text+ state_su3 !out !inp !hi !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_su4 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_su4 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_su4 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_su2 :: Int -> Offset -> Word32 -> Word32 -> IO Text+ state_su2 !out !inp !hi !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_su3 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_su3 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_su3 out (inp + 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_su1 :: Int -> Offset -> Word32 -> IO Text+ state_su1 !out !inp !hi+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_su2 out (inp + 1) hi (fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_su2 out (inp + 1) hi (fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_su2 out (inp + 1) hi (fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_su :: Int -> Offset -> Word32 -> IO Text+ state_su !out !inp !hi+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ case w8 of+ 117 -> state_su1 out (inp + 1) hi+ _ -> throwDecodeError++ state_ss :: Int -> Offset -> Word32 -> IO Text+ state_ss !out !inp !hi+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ case w8 of+ 92 -> state_su out (inp + 1) hi+ _ -> throwDecodeError++ state_udone :: Int -> Offset -> Word32 -> IO Text+ state_udone !out !inp !acc+ | acc < 55296 || acc > 57343 =+ writeCodePoint out inp acc++ | acc < 56320 =+ state_ss out (inp + 1) acc++ | otherwise =+ throwDecodeError++ state_u4 :: Int -> Offset -> Word32 -> IO Text+ state_u4 !out !inp !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_u3 :: Int -> Offset -> Word32 -> IO Text+ state_u3 !out !inp !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_u2 :: Int -> Offset -> Word32 -> IO Text+ state_u2 !out !inp !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_u1 :: Int -> Offset -> IO Text+ state_u1 !out !inp+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_u2 out (inp + 1) (fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_u2 out (inp + 1) (fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_u2 out (inp + 1) (fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_escape :: Int -> Offset -> IO Text+ state_escape !out !inp+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ case w8 of+ 34 -> do+ P.writePrimArray arr out 34+ state_start (out + 1) (inp + 1)++ 92 -> do+ P.writePrimArray arr out 92+ state_start (out + 1) (inp + 1)++ 47 -> do+ P.writePrimArray arr out 47+ state_start (out + 1) (inp + 1)++ 98 -> do+ P.writePrimArray arr out 8+ state_start (out + 1) (inp + 1)++ 102 -> do+ P.writePrimArray arr out 12+ state_start (out + 1) (inp + 1)++ 110 -> do+ P.writePrimArray arr out 10+ state_start (out + 1) (inp + 1)++ 114 -> do+ P.writePrimArray arr out 13+ state_start (out + 1) (inp + 1)++ 116 -> do+ P.writePrimArray arr out 9+ state_start (out + 1) (inp + 1)++ 117 ->+ state_u1 out (inp + 1)++ _ -> throwDecodeError++ state_start :: Int -> Offset -> IO Text+ state_start !out !inp+ | inp == end = do+ P.shrinkMutablePrimArray arr out+ frozenArr <- P.unsafeFreezePrimArray arr+ return $ case frozenArr of+ P.PrimArray ba -> T.Text (A.ByteArray ba) 0 out++ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | w8 == 92 -> state_escape out (inp + 1)+ -- because we are deserialising __valid__ text,+ -- we can simply copy everything else.+ | otherwise -> do+ P.writePrimArray arr out w8+ state_start (out + 1) (inp + 1)++ -- start the state machine+ state_start (0 :: Int) begin+#else++unescapeFromTextIO (Text src begin len) = do+ let end :: Offset+ end = begin + len++ arr <- P.newPrimArray len++ let state_sudone :: Int -> Offset -> Word32 -> IO Text+ state_sudone !out !inp !lo+ | 56320 <= lo, lo <= 57343 = do+ P.writePrimArray arr out (fromIntegral lo)+ state_start (out + 1) (inp + 1)++ | otherwise =+ throwDecodeError++ state_su4 :: Int -> Offset -> Word32 -> IO Text+ state_su4 !out !inp !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_sudone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_su3 :: Int -> Offset -> Word32 -> IO Text+ state_su3 !out !inp !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_su4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_su4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_su4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise -> throwDecodeError++ state_su2 :: Int -> Offset -> Word32 -> IO Text+ state_su2 !out !inp !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_su3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_su3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_su3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_su1 :: Int -> Offset -> IO Text+ state_su1 !out !inp+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_su2 out (inp + 1) (fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_su2 out (inp + 1) (fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_su2 out (inp + 1) (fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ -- high surrogate u+ state_su :: Int -> Offset -> IO Text+ state_su !out !inp+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ case w8 of+ 117 -> state_su1 out (inp + 1)+ _ -> throwDecodeError++ -- high surrogate slash+ state_ss :: Int -> Offset -> IO Text+ state_ss !out !inp+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ case w8 of+ 92 -> state_su out (inp + 1)+ _ -> throwDecodeError++ state_udone :: Int -> Offset -> Word32 -> IO Text+ state_udone !out !inp !acc+ -- we know that codepoint in acc is in BMP+ | acc < 55296 || acc > 57343 = do+ P.writePrimArray arr out (fromIntegral acc)+ state_start (out + 1) (inp + 1)++ -- hi surrogate,+ -- we write it immediately (UTF16 as an output!)+ | acc < 56320 = do+ P.writePrimArray arr out (fromIntegral acc)+ state_ss (out + 1) (inp + 1)++ | otherwise =+ throwDecodeError++ state_u4 :: Int -> Offset -> Word32 -> IO Text+ state_u4 !out !inp !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_udone out inp (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_u3 :: Int -> Offset -> Word32 -> IO Text+ state_u3 !out !inp !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_u4 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_u2 :: Int -> Offset -> Word32 -> IO Text+ state_u2 !out !inp !acc+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_u3 out (inp + 1) (shiftL acc 4 .|. fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_u1 :: Int -> Offset -> IO Text+ state_u1 !out !inp+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | 48 <= w8, w8 <= 57 ->+ state_u2 out (inp + 1) (fromIntegral (w8 - 48))+ | 65 <= w8, w8 <= 70 ->+ state_u2 out (inp + 1) (fromIntegral (w8 - 55))+ | 97 <= w8, w8 <= 102 ->+ state_u2 out (inp + 1) (fromIntegral (w8 - 87))+ | otherwise ->+ throwDecodeError++ state_escape :: Int -> Offset -> IO Text+ state_escape out inp+ | inp == end = throwDecodeError+ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ case w8 of+ 34 -> do+ P.writePrimArray arr out 34+ state_start (out + 1) (inp + 1)++ 92 -> do+ P.writePrimArray arr out 92+ state_start (out + 1) (inp + 1)++ 47 -> do+ P.writePrimArray arr out 47+ state_start (out + 1) (inp + 1)++ 98 -> do+ P.writePrimArray arr out 8+ state_start (out + 1) (inp + 1)++ 102 -> do+ P.writePrimArray arr out 12+ state_start (out + 1) (inp + 1)++ 110 -> do+ P.writePrimArray arr out 10+ state_start (out + 1) (inp + 1)++ 114 -> do+ P.writePrimArray arr out 13+ state_start (out + 1) (inp + 1)++ 116 -> do+ P.writePrimArray arr out 9+ state_start (out + 1) (inp + 1)++ 117 ->+ state_u1 out (inp + 1)++ _ -> throwDecodeError++ state_start :: Int -> Offset -> IO Text+ state_start !out !inp+ | inp == end = do+ P.shrinkMutablePrimArray arr out+ frozenArr <- P.unsafeFreezePrimArray arr+ return $ case frozenArr of+ P.PrimArray ba -> T.Text (A.Array ba) 0 out++ | otherwise = do+ let !w8 = A.unsafeIndex src inp+ if | w8 == 92 -> state_escape out (inp + 1)+ -- because we are deserialising __valid__ text,+ -- we can simply copy everything else.+ | otherwise -> do+ P.writePrimArray arr out (fromIntegral w8 :: Word16)+ state_start (out + 1) (inp + 1)++ -- start the state machine+ state_start (0 :: Int) begin++#endif
+ src/Data/Aeson/Internal/Word16.hs view
@@ -0,0 +1,76 @@+{-# 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
src/Data/Aeson/KeyMap.hs view
@@ -268,7 +268,7 @@ difference :: KeyMap v -> KeyMap v' -> KeyMap v difference tm1 tm2 = KeyMap (M.difference (unKeyMap tm1) (unKeyMap tm2)) --- The (left-biased) union of two maps. It prefers the first map when duplicate+-- | The (left-biased) union of two maps. It prefers the first map when duplicate -- keys are encountered, i.e. ('union' == 'unionWith' 'const'). union :: KeyMap v -> KeyMap v -> KeyMap v union (KeyMap x) (KeyMap y) = KeyMap (M.union x y)@@ -477,7 +477,7 @@ difference :: KeyMap v -> KeyMap v' -> KeyMap v difference tm1 tm2 = KeyMap (H.difference (unKeyMap tm1) (unKeyMap tm2)) --- The (left-biased) union of two maps. It prefers the first map when duplicate+-- | The (left-biased) union of two maps. It prefers the first map when duplicate -- keys are encountered, i.e. ('union' == 'unionWith' 'const'). union :: KeyMap v -> KeyMap v -> KeyMap v union (KeyMap x) (KeyMap y) = KeyMap (H.union x y)
+ src/Data/Aeson/RFC8785.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE UnboxedTuples, BangPatterns #-}+-- | JSON Canonicalization Scheme https://datatracker.ietf.org/doc/html/rfc8785+module Data.Aeson.RFC8785 (+ encodeCanonical,+) where++import Data.List (sortBy)+import Data.Ord (comparing)+import GHC.Integer (quotRemInteger)+import Math.NumberTheory.Logarithms (integerLog10)++import Data.Aeson+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+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Prim as BP+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Scientific as Sci+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as V++-- $setup+-- >>> import Data.Aeson++-- | Encode to JSON according to RFC 8785 canonicalization scheme.+-- https://datatracker.ietf.org/doc/html/rfc8785+--+-- 'encodeCanonical' uses 'toJSON' to produce intermediate 'Value',+-- as 'toEncoding' may (and most likely) produces non-canonical JSON.+--+-- Note: @decode (encodeCanonical v) === Just v@ for all @v :: Value@,+-- i.e. 'encodeCanonical' doesn't lose any information.+--+-- However, the example in RFC8785 /loses/ information as the intermediate+-- number representation is 'Double', also current @toJSON :: Double -> Value@+-- sometimes produces too precise values. For example+--+-- >>> toJSON (1e23 :: Double)+-- Number 9.999999999999999e22+--+-- 'show' also behaves the same:+--+-- >>> 1e23 :: Double+-- 9.999999999999999e22+--+-- Note: RFC8785 is __not the same scheme__ as used in+-- [canonical-json](https://hackage.haskell.org/package/canonical-json) package+-- (https://wiki.laptop.org/go/Canonical_JSON).+-- That scheme produces /invalid/ JSON (e.g. control characters encoded as is, not escaped)+-- and cannot encode non-integral numbers.+--+-- @since 2.2.1.0+--+encodeCanonical :: ToJSON a => a -> LBS.ByteString+encodeCanonical = encodingToLazyByteString . toCanonical . toJSON++toCanonical :: Value -> Encoding+toCanonical Null = null_+toCanonical (Bool b) = bool b+toCanonical (Number n) = canonicalNumber n+toCanonical (String s) = canonicalString s+toCanonical (Array v) = list toCanonical (V.toList v)+toCanonical (Object m) = dict (canonicalString . Key.toText) toCanonical ifr $+ sortBy (\(k1, _) (k2, _) -> propertyCmp k1 k2) (KM.toList m)++ifr :: (k -> v -> a -> a) -> a -> [(k, v)] -> a+ifr f z = foldr (\(k, v) -> f k v) z+{-# INLINE ifr #-}++-- Property name strings to be sorted are formatted as arrays of UTF-16 code units.+propertyCmp :: Key -> Key -> Ordering+propertyCmp = comparing f where+ -- this is slow implementation, but it's obviously not wrong.+ f :: Key -> BS.ByteString+ f = TE.encodeUtf16BE . Key.toText++-- strings are already serialized canonically.+canonicalString :: Text -> Encoding' a+canonicalString = text++-- RFC 8785 is outsourcing number format to ECMA-262.+-- 10th edition, 7.1.12.1 NumberToString+-- https://262.ecma-international.org/10.0/#sec-tostring-applied-to-the-number-type+--+-- Note: this specification is not lossy+-- Given 'Scientific' we can choose n,k,s uniquely: 'nks'.+--+-- 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)))+ GT -> canonicalNumber' m++-- input: Positive number+canonicalNumber' :: Scientific -> Encoding+canonicalNumber' m+ | k <= n, n <= 21+ = Encoding $+ BP.primMapListFixed BP.word8 ds <>+ BP.primMapListFixed BP.word8 (replicate (n - k) W8_0)++ | 0 < n, n <= 21+ , let (pfx, sfx) = splitAt n ds+ = Encoding $+ BP.primMapListFixed BP.word8 pfx <>+ B.word8 W8_DOT <>+ 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) <>+ 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) <>+ BP.primMapListFixed BP.word8 (integerToDecimalDigits (abs (toInteger n - 1)))++ | (d:ds') <- ds+ = Encoding $+ B.word8 d <>+ B.word8 W8_DOT <>+ BP.primMapListFixed BP.word8 ds' <>+ B.word8 W8_e <>+ B.word8 (if (n - 1) >= 0 then W8_PLUS else W8_MINUS) <>+ BP.primMapListFixed BP.word8 (integerToDecimalDigits (abs (toInteger n - 1)))++ | otherwise+ = string "0" -- shouldn't happen, but we need a default case.++ where+ -- 5. Otherwise, let n, k, and s be integers such that+ -- k ≥ 1, 10k - 1 ≤ s < 10k, the Number value for s × 10n - k is m,+ -- and k is as small as possible.+ -- Note that k is the number of digits in the decimal representation of s,+ -- that s is not divisible by 10, and that the least significant digit of s+ -- is not necessarily uniquely determined by these criteria.+ (n, k, s) = nks m+ ds = integerToDecimalDigits s++-- 5. Otherwise, let n, k, and s be integers such that k ≥ 1, 10^(k - 1) ≤ s < 10^k,+-- the Number value for s × 10^(n - k) is m, and k is as small as possible.+-- Note that k is the number of digits in the decimal representation of s,+-- that s is not divisible by 10, and that the least significant digit of s+-- is not necessarily uniquely determined by these criteria.+nks :: Scientific -> (Int, Int, Integer)+nks m = (e + k, k, c)+ where+ m' = Sci.normalize m+ c = Sci.coefficient m'+ e = Sci.base10Exponent m'+ k = integerLog10 c + 1++integerToDecimalDigits :: Integer -> [Word8]+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
+ tests/CastFloat.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}+module CastFloat (+ castDoubleToWord64,+ castWord64ToDouble,+ castFloatTests,+) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck (testProperty, (===))++import Types (UniformWord64 (..))++#if MIN_VERSION_base(4,11,0)+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+#else++import Data.Word (Word64)+import Foreign.Storable (Storable (peek, poke))+import Foreign.Ptr (castPtr)+import Foreign.Marshal (alloca)+import System.IO.Unsafe (unsafeDupablePerformIO)++castDoubleToWord64 :: Double -> Word64+castDoubleToWord64 = reinterpretCast++castWord64ToDouble :: Word64 -> Double+castWord64ToDouble = reinterpretCast++reinterpretCast :: (Storable a, Storable b) => a -> b+reinterpretCast x = unsafeDupablePerformIO $ alloca $ \ptr -> do+ poke ptr x+ peek (castPtr ptr)++#endif++castFloatTests :: TestTree+castFloatTests = testGroup "castDoubleToWord64"+ [ testCase "5e-324" $ castDoubleToWord64 5e-324 @?= 1+ , testProperty "roundtrip1" $ \d -> castWord64ToDouble (castDoubleToWord64 d) === d+ , testProperty "roundtrip2" $ \(U64 w) -> castDoubleToWord64 (castWord64ToDouble w) === w+ ]
+ tests/DoubleToScientific.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE UnboxedTuples, BangPatterns, MultiWayIf #-}+module DoubleToScientific (+ doubleToScientific,+ doubleToScientificTests,+) where++-- import Debug.Trace+-- import Data.Ratio ((%))++import Data.Bits+import Data.Foldable (foldl')+import Data.Word (Word64)+import Data.Scientific (Scientific)+import GHC.Integer (quotRemInteger)++import qualified Data.Scientific as Sci++import CastFloat+import Types (UniformWord64 (..))++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty, counterexample, (===), (==>))++-------------------------------------------------------------------------------+-- tests+-------------------------------------------------------------------------------++-- note: RFC8785 has some special cases.+doubleToScientificTests :: TestTree+doubleToScientificTests = testGroup "doubleToScientific"+ [ testProperty "roundtrip1" $ \d ->+ Sci.toRealFloat (doubleToScientific d) === d+ , testProperty "roundtrip2" $ \(U64 w) ->+ let d = castWord64ToDouble w+ in counterexample (show d) $+ not (isInfinite d || isNaN d) ==>+ Sci.toRealFloat (doubleToScientific d) === d+ ]++-------------------------------------------------------------------------------+-- doubleToScientific+-------------------------------------------------------------------------------++{- Convert 'Double' to 'Scientific'++Based on double-conversion implementation+https://github.com/google/double-conversion++Copyright 2006-2011, the V8 project authors. All rights reserved.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * 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.+ * Neither the name of Google Inc. nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER 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.+-}+doubleToScientific :: Double -> Scientific+doubleToScientific v = case compare v 0 of+ EQ -> 0+ LT -> negate (doubleToScientific' (negate v))+ GT -> doubleToScientific' v++-------------------------------------------------------------------------------+-- doubleToScientific implementation+-------------------------------------------------------------------------------++data S = S+ { num :: !Integer+ , den :: !Integer+ , delta_m :: !Integer+ , delta_p :: !Integer+ , is_even :: !Bool+ }+ deriving Show++-- preconditions: v > 0+doubleToScientific' :: Double -> Scientific+doubleToScientific' v =+ let s1 = initialStartValues v+ (s2, pow10) = fixupMultiply10 s1+ ds = generateShortestDigits s2+ k = length ds+ in Sci.scientific (foldl' (\acc d -> 10 * acc + d) 0 ds) (pow10 - k + 1)+ -- error $ show (s1, s2, pow10, fromRational (num s2 % den s2), ds)++initialStartValues :: Double -> S+initialStartValues v = lowerBoundaryCloser' $ applyExponent e S+ { num = shiftL s 1+ , den = 2+ , delta_m = 1+ , delta_p = 1+ , is_even = evenInteger s+ }+ where+ (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.+--+-- GHC's decodeFloat does "weird" stuff to denormal doubles,+-- that messes up our delta calculation.+decodeFloat' :: Double -> (Integer, Int, Bool)+decodeFloat' d+ | denormal = (toInteger s, kDenormalExponent, False)+ | otherwise = (toInteger (s .|. kHiddenBit), fromIntegral e - kExponentBias, w64 .&. kSignificandMask == 0)+ where+ denormal = w64 .&. kExponentMask == 0++ s = w64 .&. kSignificandMask+ e = shiftR (w64 .&. kExponentMask) kPhysicalSignificandSize++ w64 = castDoubleToWord64 d++ kExponentMask = 0x7FF0000000000000 :: Word64+ kSignificandMask = 0x000FFFFFFFFFFFFF :: Word64+ kHiddenBit = 0x0010000000000000 :: Word64++ kPhysicalSignificandSize = 52 :: Int+ kExponentBias = 0x3FF + kPhysicalSignificandSize :: Int+ kDenormalExponent = -kExponentBias + 1 :: Int++lowerBoundaryCloser :: S -> S+lowerBoundaryCloser s = s+ { num = shiftL (num s) 1+ , den = shiftL (den s) 1+ , delta_p = shiftL (delta_p s) 1+ }++applyExponent :: Int -> S -> S+applyExponent e s = case compare e 0 of+ EQ -> s+ GT -> S+ { num = shiftL (num s) e+ , den = den s+ , delta_m = shiftL (delta_m s) e+ , delta_p = shiftL (delta_m s) e+ , is_even = is_even s+ }+ LT -> S+ { num = num s+ , den = shiftL (den s) (negate e)+ , delta_m = delta_m s+ , delta_p = delta_m s+ , is_even = is_even s+ }++-- This routine multiplies numerator/denominator so that its values lies in the+-- range 1-10. That is after a call to this function we have:+-- 1 <= (numerator + delta_plus) / denominator < 10.+fixupMultiply10 :: S -> (S, Int)+fixupMultiply10 = go 0 where+ go p s = case compare (den s) (num s + delta_p s) of+ GT -> go (p - 1) (times10 s)+ EQ -> (s, p) -- TODO: is_even check?+ LT -> case compare (num s + delta_p s) (10 * den s) of+ LT -> (s, p)+ _ -> go (p + 1) (div10 s)++times10 :: S -> S+times10 s = s { num = 10 * num s, delta_p = 10 * delta_p s, delta_m = 10 * delta_m s }++div10 :: S -> S+div10 s = s { den = 10 * den s }++generateShortestDigits :: S -> [Integer]+generateShortestDigits = go where+ go s = case quotRemInteger (num s) (den s) of+ (# d, r #) -> if+ | not in_delta_room_minus+ , not in_delta_room_plus+ -> d : go (times10 s { num = r })++ | in_delta_room_minus+ , in_delta_room_plus+ -- Let's see if 2*numerator < denominator.+ -- If yes, then the next digit would be < 5 and we can round down.+ -> case compare (2 * r) (den s) of+ -- Remaining digits are less than .5. -> Round down (== do nothing).+ LT -> [d]+ -- Remaining digits are more than .5 of denominator. -> Round up.+ GT -> [d+1]+ -- Halfway case.+ -- round towards even+ EQ -> if evenInteger d then [d] else [d+1]++ | in_delta_room_minus+ -- round down+ -> [d]++ | otherwise+ -- Round up.+ -> [d + 1]++ where+ in_delta_room_minus+ | is_even s = r <= delta_m s+ | otherwise = r < delta_m s++ in_delta_room_plus+ | is_even s = r + delta_p s >= den s+ | otherwise = r + delta_p s > den s++evenInteger :: Integer -> Bool+evenInteger i = not (testBit i 0)
tests/JSONTestSuite.hs view
@@ -13,12 +13,14 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LBS8 import qualified Data.HashSet as HashSet+import qualified Data.Text.Encoding as TE import Data.Aeson import qualified Data.Aeson.Decoding as D import Data.Aeson.Decoding.Tokens import qualified Data.Aeson.Decoding.ByteString as D import qualified Data.Aeson.Decoding.ByteString.Lazy as D+import qualified Data.Aeson.Decoding.Text as D jsonTestSuiteTest :: FilePath -> TestTree@@ -57,6 +59,13 @@ let result = D.lbsToTokens payload return (LBS8.pack (unlines (showTokens (const []) result))) + , goldenVsStringDiff "tokens text" diff ("tests" </> "JSONTestSuite" </> "results" </> fileName -<.> "tok") $ do+ payload' <- B.readFile path+ case TE.decodeUtf8' payload' of+ Left exc -> fail $ show exc -- successful test shouldn't fail.+ Right payload -> do + let result = D.textToTokens payload+ return (LBS8.pack (unlines (showTokens (const []) result))) ] negative = testGroup fileName@@ -74,6 +83,12 @@ let result3 = D.eitherDecode payloadL :: Either String Value assertBool ("lazy:" ++ show result3) (isLeft result3) + case TE.decodeUtf8' payload of+ Left _exc -> return ()+ Right payloadT -> do+ let result4 = D.eitherDecodeStrictText payloadT :: Either String Value+ assertBool ("text:" ++ show result4) (isLeft result4)+ , goldenVsStringDiff "tokens bs" diff ("tests" </> "JSONTestSuite" </> "results" </> fileName -<.> "tok") $ do payload <- B.readFile path let result = D.bsToTokens payload@@ -84,6 +99,15 @@ let result = D.lbsToTokens payload return (LBS8.pack (unlines (showTokens (const []) result))) + , goldenVsStringDiff "tokens text" diff ("tests" </> "JSONTestSuite" </> "results" </> fileName -<.> "ttok") $ do+ payload' <- B.readFile path+ case TE.decodeUtf8' payload' of+ Left _exc -> do+ -- some failing cases are invalid UTF8+ return (LBS8.pack "Invalid UTF8")+ Right payload -> do + let result = D.textToTokens payload+ return (LBS8.pack (unlines (showTokens (const []) result))) ] showTokens :: Show e => (k -> [String]) -> Tokens k e -> [String]
+ tests/RFC8785.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}+module RFC8785 (rfc8785Tests) where++import Data.Text (Text)+import Data.Word (Word64)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)+import Test.Tasty.QuickCheck (testProperty, (===))++import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS8+import qualified Data.Scientific as Sci++import Data.Aeson+import Data.Aeson.Decoding.ByteString.Lazy+import Data.Aeson.Decoding.Tokens+import Data.Aeson.QQ.Simple+import Data.Aeson.RFC8785++import CastFloat+import DoubleToScientific++rfc8785Tests :: TestTree+rfc8785Tests = testGroup "RFC8785"+ [ testCase "example" $ do+ encodeCanonical exampleValue @?= exampleBS++ , testCase "key-sort" $ do+ recordTextValues (encodeCanonical sortingValue) @?= sortingStrings++ , numberCases++ , testProperty "roundtrip" $ \v ->+ decode (encodeCanonical v) === Just (v :: Value)++ , castFloatTests+ , doubleToScientificTests+ ]++-------------------------------------------------------------------------------+-- Example+-------------------------------------------------------------------------------++exampleValue :: Value+exampleValue = mapNumbers (doubleToScientific . Sci.toRealFloat) [aesonQQ| {+ "numbers": [333333333.33333329, 1E30, 4.50,+ 2e-3, 0.000000000000000000000000001],+ "string": "\u20ac$\u000F\u000aA'\u0042\u0022\u005c\\\"\/",+ "literals": [null, true, false]+ } |]++mapNumbers :: (Sci.Scientific -> Sci.Scientific) -> Value -> Value+mapNumbers _ v@Null = v+mapNumbers _ v@(String _) = v+mapNumbers _ v@(Bool _) = v+mapNumbers f (Number x) = Number (f x)+mapNumbers f (Object xs) = Object (fmap (mapNumbers f) xs)+mapNumbers f (Array xs) = Array (fmap (mapNumbers f) xs)+++exampleBS :: LBS.ByteString+exampleBS = LBS.pack+ [ 0x7b, 0x22, 0x6c, 0x69, 0x74, 0x65, 0x72, 0x61, 0x6c, 0x73, 0x22, 0x3a, 0x5b, 0x6e, 0x75, 0x6c, 0x6c, 0x2c, 0x74, 0x72+ , 0x75, 0x65, 0x2c, 0x66, 0x61, 0x6c, 0x73, 0x65, 0x5d, 0x2c, 0x22, 0x6e, 0x75, 0x6d, 0x62, 0x65, 0x72, 0x73, 0x22, 0x3a+ , 0x5b, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x2e, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x33, 0x2c, 0x31+ , 0x65, 0x2b, 0x33, 0x30, 0x2c, 0x34, 0x2e, 0x35, 0x2c, 0x30, 0x2e, 0x30, 0x30, 0x32, 0x2c, 0x31, 0x65, 0x2d, 0x32, 0x37+ , 0x5d, 0x2c, 0x22, 0x73, 0x74, 0x72, 0x69, 0x6e, 0x67, 0x22, 0x3a, 0x22, 0xe2, 0x82, 0xac, 0x24, 0x5c, 0x75, 0x30, 0x30+ , 0x30, 0x66, 0x5c, 0x6e, 0x41, 0x27, 0x42, 0x5c, 0x22, 0x5c, 0x5c, 0x5c, 0x5c, 0x5c, 0x22, 0x2f, 0x22, 0x7d+ ]++-------------------------------------------------------------------------------+-- Key sorting+-------------------------------------------------------------------------------++sortingValue :: Value+sortingValue = [aesonQQ| {+ "\u20ac": "Euro Sign",+ "\r": "Carriage Return",+ "\ufb33": "Hebrew Letter Dalet With Dagesh",+ "1": "One",+ "\ud83d\ude00": "Emoji: Grinning Face",+ "\u0080": "Control",+ "\u00f6": "Latin Small Letter O With Diaeresis"+ } |]++sortingStrings :: [Text]+sortingStrings =+ [ "Carriage Return"+ , "One"+ , "Control"+ , "Latin Small Letter O With Diaeresis"+ , "Euro Sign"+ , "Emoji: Grinning Face"+ , "Hebrew Letter Dalet With Dagesh"+ ]++recordTextValues :: LBS.ByteString -> [Text]+recordTextValues lbs = case lbsToTokens lbs of+ TkRecordOpen r -> go r+ _ -> []+ where+ go (TkPair _ (TkText s ts)) = s : go ts+ go _ = []++-------------------------------------------------------------------------------+-- Numbers+-------------------------------------------------------------------------------++-- Appendix B. Number Serialization Samples+numbers :: [(Word64, LBS.ByteString)]+numbers =+ [ (0x0000000000000000, "0") -- Zero+ , (0x8000000000000000, "0") -- Minus zero+ , (0x0000000000000001, "5e-324") -- Min pos number+ , (0x8000000000000001, "-5e-324") -- Min neg number+ , (0x7fefffffffffffff, "1.7976931348623157e+308") -- Max pos number+ , (0xffefffffffffffff, "-1.7976931348623157e+308") -- Max neg number+ , (0x4340000000000000, "9007199254740992") -- Max pos int (1)+ , (0xc340000000000000, "-9007199254740992") -- Max neg int (1)+ , (0x4430000000000000, "295147905179352830000") -- ~2**68 (2)+ , (0x44b52d02c7e14af5, "9.999999999999997e+22")+ , (0x44b52d02c7e14af6, "1e+23")+ , (0x44b52d02c7e14af7, "1.0000000000000001e+23")+ , (0x444b1ae4d6e2ef4e, "999999999999999700000")+ , (0x444b1ae4d6e2ef4f, "999999999999999900000")+ , (0x444b1ae4d6e2ef50, "1e+21")+ , (0x3eb0c6f7a0b5ed8c, "9.999999999999997e-7")+ , (0x3eb0c6f7a0b5ed8d, "0.000001")+ , (0x41b3de4355555553, "333333333.3333332")+ , (0x41b3de4355555554, "333333333.33333325")+ , (0x41b3de4355555555, "333333333.3333333")+ , (0x41b3de4355555556, "333333333.3333334")+ , (0x41b3de4355555557, "333333333.33333343")+ , (0xbecbf647612f3696, "-0.0000033333333333333333")+ , (0x43143ff3c1cb0959, "1424953923781206.2") -- Round to even (4)+ ]++numberCases :: TestTree+numberCases = testGroup "numbers"+ [ testCase (LBS8.unpack lbs) $ do+ encodeCanonical (doubleToScientific d) @?= lbs+ | (w64, lbs) <- numbers+ , let d = castWord64ToDouble w64 :: Double+ ]
tests/Tests.hs view
@@ -9,10 +9,11 @@ import qualified Properties import qualified UnitTests import qualified JSONTestSuite+import RFC8785 main :: IO () main = do ioTests <- UnitTests.ioTests jsTests <- JSONTestSuite.tests- let allTests = DF.tests : Properties.tests : UnitTests.tests : jsTests : ioTests+ let allTests = DF.tests : rfc8785Tests : Properties.tests : UnitTests.tests : jsTests : ioTests defaultMain (testGroup "tests" allTests)
tests/Types.hs view
@@ -20,13 +20,15 @@ #if !MIN_VERSION_base(4,16,0) import Data.Semigroup (Option) #endif-import Data.Text+import Data.Text (Text) import Data.Time (Day (..), fromGregorian) import GHC.Generics import Test.QuickCheck (Arbitrary (..), Property, counterexample, scale)+import Test.QuickCheck.Gen (chooseUpTo) import qualified Data.Map as Map import Data.Aeson import Data.Aeson.Types+import Data.Word (Word64) type I = Identity type Compose3 f g h = Compose (Compose f g) h@@ -164,3 +166,13 @@ instance (FromJSONKey a) => FromJSONKey (LogScaled a) where fromJSONKey = fmap LogScaled fromJSONKey fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])++newtype UniformWord64 = U64 Word64+ deriving (Eq, Ord)++instance Show UniformWord64 where+ showsPrec d (U64 w) = showsPrec d w++instance Arbitrary UniformWord64 where+ arbitrary = U64 <$> chooseUpTo maxBound+ shrink (U64 w) = map U64 (shrink w)