diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,5 +1,5 @@ name: aeson -version: 2.0.2.0 +version: 2.0.3.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON @@ -45,13 +45,6 @@ tests/JSONTestSuite/test_parsing/*.json tests/JSONTestSuite/test_transform/*.json -flag bytestring-builder - description: - Depend on the bytestring-builder package for backwards compatibility. - - default: False - manual: False - flag cffi description: Controls whether to include c-ffi bits or pure haskell. Default to False for security. @@ -84,7 +77,10 @@ other-modules: Data.Aeson.Encoding.Builder + Data.Aeson.Internal.ByteString Data.Aeson.Internal.Functions + Data.Aeson.Internal.Text + Data.Aeson.Internal.TH Data.Aeson.Parser.Time Data.Aeson.Parser.Unescape Data.Aeson.Types.Class @@ -103,7 +99,7 @@ , deepseq >=1.4.2.0 && <1.5 , ghc-prim >=0.5.0.0 && <0.9 , template-haskell >=2.11.0.0 && <2.19 - , text >=1.2.3.0 && <1.3 + , text >=1.2.3.0 && <1.3 || >=2.0 && <2.1 , time >=1.6.0.1 && <1.13 -- Compat @@ -116,24 +112,25 @@ -- Other dependencies build-depends: - attoparsec >=0.13.2.2 && <0.15 - , data-fix >=0.3 && <0.4 + attoparsec >=0.14.2 && <0.15 + , data-fix >=0.3.2 && <0.4 , dlist >=0.8.0.4 && <1.1 , hashable >=1.3.5.0 && <1.5 - , indexed-traversable >=0.1.1 && <0.2 + , indexed-traversable >=0.1.2 && <0.2 , OneTuple >=0.3.1 && <0.4 - , primitive >=0.7.0.1 && <0.8 + , primitive >=0.7.3.0 && <0.8 + , QuickCheck >=2.14.2 && <2.15 , scientific >=0.3.7.0 && <0.4 , semialign >=1.2 && <1.3 , strict >=0.4 && <0.5 , tagged >=0.8.6 && <0.9 - , text-short >=0.1.4 && <0.2 + , text-short >=0.1.5 && <0.2 , th-abstraction >=0.3.0.0 && <0.5 - , these >=1.1 && <1.2 + , these >=1.1.1.1 && <1.2 , unordered-containers >=0.2.10.0 && <0.3 - , uuid-types >=1.0.3 && <1.1 + , uuid-types >=1.0.5 && <1.1 , vector >=0.12.0.1 && <0.13 - , witherable >=0.4.1 && <0.5 + , witherable >=0.4.2 && <0.5 ghc-options: -Wall @@ -146,6 +143,7 @@ cpp-options: -DCFFI hs-source-dirs: src-ffi other-modules: Data.Aeson.Parser.UnescapeFFI + build-depends: text <2.0 if flag(ordered-keymap) cpp-options: -DUSE_ORDEREDMAP=1 @@ -153,13 +151,10 @@ test-suite aeson-tests default-language: Haskell2010 type: exitcode-stdio-1.0 - hs-source-dirs: tests src-ffi src-pure + hs-source-dirs: tests main-is: Tests.hs - c-sources: cbits/unescape_string.c ghc-options: -Wall -threaded -rtsopts other-modules: - Data.Aeson.Parser.UnescapeFFI - Data.Aeson.Parser.UnescapePure DataFamilies.Encoders DataFamilies.Instances DataFamilies.Properties @@ -172,6 +167,7 @@ Properties PropertyGeneric PropertyKeys + PropertyQC PropertyRoundTrip PropertyRTFunctors PropertyTH @@ -188,6 +184,7 @@ , base-compat , base-orphans >=0.5.3 && <0.9 , base16-bytestring + , bytestring , containers , data-fix , Diff >=0.4 && <0.5 @@ -197,8 +194,10 @@ , generic-deriving >=1.10 && <1.15 , ghc-prim >=0.2 , hashable + , indexed-traversable , integer-logarithms >=1 && <1.1 , OneTuple + , primitive , QuickCheck >=2.14.2 && <2.15 , quickcheck-instances >=0.3.26.1 && <0.4 , scientific @@ -217,25 +216,6 @@ , unordered-containers , uuid-types , vector - - if flag(bytestring-builder) - build-depends: - bytestring >=0.9 && <0.10.4 - , bytestring-builder >=0.10.4 && <1 - - else - build-depends: bytestring >=0.10.4 - - if !impl(ghc >=8.0) - build-depends: - semigroups >=0.18.2 && <0.20 - , transformers >=0.2.2.0 - , transformers-compat >=0.3 - - if !impl(ghc >=7.10) - build-depends: - nats >=1 && <1.2 - , void >=0.7.2 && <0.8 source-repository head type: git diff --git a/attoparsec-iso8601/src/Data/Attoparsec/Time.hs b/attoparsec-iso8601/src/Data/Attoparsec/Time.hs --- a/attoparsec-iso8601/src/Data/Attoparsec/Time.hs +++ b/attoparsec-iso8601/src/Data/Attoparsec/Time.hs @@ -27,7 +27,7 @@ import Control.Applicative ((<|>)) import Control.Monad (void, when) -import Data.Attoparsec.Text as A +import Data.Attoparsec.Text (Parser, char, decimal, digit, option, anyChar, peekChar, peekChar', takeWhile1, satisfy) import Data.Attoparsec.Time.Internal (toPico) import Data.Bits ((.&.)) import Data.Char (isDigit, ord) diff --git a/attoparsec-iso8601/src/Data/Attoparsec/Time/Internal.hs b/attoparsec-iso8601/src/Data/Attoparsec/Time/Internal.hs --- a/attoparsec-iso8601/src/Data/Attoparsec/Time/Internal.hs +++ b/attoparsec-iso8601/src/Data/Attoparsec/Time/Internal.hs @@ -21,7 +21,7 @@ import Data.Fixed (Fixed(MkFixed), Pico) import Data.Int (Int64) import Data.Time (TimeOfDay(..)) -import Data.Time.Clock.Compat +import Data.Time.Clock.Compat (DiffTime, diffTimeToPicoseconds) toPico :: Integer -> Pico toPico = MkFixed diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,12 @@ 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.0.3.0 + +* `text-2.0` support +* `bytestring-0.11.2.0` support +* Rewrite pure text literal unescaper. +* Add `QuickCheck`'s `Arbitrary`, `CoArbitrary` and `Function` instances + ### 2.0.2.0 * Add `IsList (KeyMap v)` instance. diff --git a/src-pure/Data/Aeson/Parser/UnescapePure.hs b/src-pure/Data/Aeson/Parser/UnescapePure.hs --- a/src-pure/Data/Aeson/Parser/UnescapePure.hs +++ b/src-pure/Data/Aeson/Parser/UnescapePure.hs @@ -1,254 +1,719 @@ --- WARNING: This file is security sensitive as it uses unsafeWrite which does --- not check bounds. Any changes should be made with care and we would love to --- get informed about them, just cc us in any PR targetting this file: @eskimor @jprider63 --- We would be happy to review the changes! +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} --- The security check at the end (pos > length) only works if pos grows --- monotonously, if this condition does not hold, the check is flawed. module Data.Aeson.Parser.UnescapePure - ( - unescapeText - ) where + ( unescapeText + ) where -import Control.Exception (evaluate, throw, try) -import Control.Monad (when) -import Data.ByteString as B -import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.)) -import Data.Text (Text) -import qualified Data.Text.Array as A -import Data.Text.Encoding.Error (UnicodeException (..)) -import Data.Text.Internal.Private (runText) -import Data.Text.Unsafe (unsafeDupablePerformIO) -import Data.Word (Word8, Word16, Word32) -import GHC.ST (ST) +import Control.Exception (throwIO, try) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Encoding.Error (UnicodeException (..)) +import Data.Text.Unsafe (unsafeDupablePerformIO) +import Data.Word (Word32, Word8) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (peek) --- Different UTF states. -data Utf = - UtfGround - | UtfTail1 - | UtfU32e0 - | UtfTail2 - | UtfU32ed - | Utf843f0 - | UtfTail3 - | Utf843f4 - deriving (Eq) +import qualified Data.Primitive as P +import qualified Data.Text.Array as T +import qualified Data.Text.Internal as T -data State = - StateNone - | StateUtf !Utf !Word32 - | StateBackslash - | StateU0 - | StateU1 !Word16 - | StateU2 !Word16 - | StateU3 !Word16 - | StateS0 - | StateS1 - | StateSU0 - | StateSU1 !Word16 - | StateSU2 !Word16 - | StateSU3 !Word16 - deriving (Eq) +import Data.Aeson.Internal.ByteString --- References: --- http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ --- https://github.com/jwilm/vte/blob/master/utf8parse/src/table.rs.in +#if !MIN_VERSION_text(2,0,0) +import Data.Word (Word16) +#endif -setByte1 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte1 point word = point .|. fromIntegral (word .&. 0x3f) -{-# INLINE setByte1 #-} -setByte2 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte2 point word = point .|. (fromIntegral (word .&. 0x3f) `shiftL` 6) -{-# INLINE setByte2 #-} +unescapeText :: ByteString -> Either UnicodeException Text +unescapeText = unsafeDupablePerformIO . try . unescapeTextIO -setByte2Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte2Top point word = point .|. (fromIntegral (word .&. 0x1f) `shiftL` 6) -{-# INLINE setByte2Top #-} +throwDecodeError :: IO a +throwDecodeError = + let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" + in throwIO (DecodeError desc Nothing) -setByte3 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte3 point word = point .|. (fromIntegral (word .&. 0x3f) `shiftL` 12) -{-# INLINE setByte3 #-} +------------------------------------------------------------------------------- +-- unescapeTextIO +------------------------------------------------------------------------------- -setByte3Top :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte3Top point word = point .|. (fromIntegral (word .&. 0xf) `shiftL` 12) -{-# INLINE setByte3Top #-} +-- This function is generated using staged-streams +-- See: https://github.com/phadej/staged/blob/master/staged-streams-unicode/src/Unicode/JSON.hs +-- +-- Because @aeson@ better to not use template-haskell itself, +-- we dump the splice and prettify it by hand a bit. +-- +unescapeTextIO :: ByteString -> IO Text -setByte4 :: (Num a, Bits b, Bits a, Integral b) => a -> b -> a -setByte4 point word = point .|. (fromIntegral (word .&. 0x7) `shiftL` 18) -{-# INLINE setByte4 #-} +#if MIN_VERSION_text(2,0,0) -decode :: Utf -> Word32 -> Word8 -> (Utf, Word32) -decode UtfGround point word = case word of - w | 0x00 <= w && w <= 0x7f -> (UtfGround, fromIntegral word) - w | 0xc2 <= w && w <= 0xdf -> (UtfTail1, setByte2Top point word) - 0xe0 -> (UtfU32e0, setByte3Top point word) - w | 0xe1 <= w && w <= 0xec -> (UtfTail2, setByte3Top point word) - 0xed -> (UtfU32ed, setByte3Top point word) - w | 0xee <= w && w <= 0xef -> (UtfTail2, setByte3Top point word) - 0xf0 -> (Utf843f0, setByte4 point word) - w | 0xf1 <= w && w <= 0xf3 -> (UtfTail3, setByte4 point word) - 0xf4 -> (Utf843f4, setByte4 point word) - _ -> throwDecodeError +unescapeTextIO bs = withBS bs $ \fptr len -> + withForeignPtr fptr $ \begin -> do + let end :: Ptr Word8 + end = plusPtr begin len -decode UtfU32e0 point word = case word of - w | 0xa0 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word) - _ -> throwDecodeError + arr <- P.newPrimArray len -decode UtfU32ed point word = case word of - w | 0x80 <= w && w <= 0x9f -> (UtfTail1, setByte2 point word) - _ -> throwDecodeError + let write3bytes :: Int -> Word8 -> Word8 -> Word8 -> Ptr Word8 -> IO Text + write3bytes !out !b1 !b2 !b3 !inp = do + P.writePrimArray arr out b1 + write2bytes (out + 1) b2 b3 inp -decode Utf843f0 point word = case word of - w | 0x90 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word) - _ -> throwDecodeError + write2bytes :: Int -> Word8 -> Word8 -> Ptr Word8 -> IO Text + write2bytes !out !b1 !b2 !inp = do + P.writePrimArray arr out b1 + write1byte (out + 1) b2 inp -decode Utf843f4 point word = case word of - w | 0x80 <= w && w <= 0x8f -> (UtfTail2, setByte3 point word) - _ -> throwDecodeError + write1byte :: Int -> Word8 -> Ptr Word8 -> IO Text + write1byte !out !b1 !inp = do + P.writePrimArray arr out b1 + state_start (out + 1) inp -decode UtfTail3 point word = case word of - w | 0x80 <= w && w <= 0xbf -> (UtfTail2, setByte3 point word) - _ -> throwDecodeError + writeCodePoint :: Int -> Ptr Word8 -> Word32 -> IO Text + writeCodePoint !out !inp !acc + | acc <= 127 = do + P.writePrimArray arr out (fromIntegral acc :: Word8) + state_start (out + 1) (plusPtr inp 1) -decode UtfTail2 point word = case word of - w | 0x80 <= w && w <= 0xbf -> (UtfTail1, setByte2 point word) - _ -> throwDecodeError + | 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 (plusPtr inp 1) -decode UtfTail1 point word = case word of - w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word) - _ -> throwDecodeError + | 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 (plusPtr inp 1) -decodeHex :: Word8 -> Word16 -decodeHex x - | 48 <= x && x <= 57 = fromIntegral x - 48 -- 0-9 - | 65 <= x && x <= 70 = fromIntegral x - 55 -- A-F - | 97 <= x && x <= 102 = fromIntegral x - 87 -- a-f - | otherwise = throwDecodeError + | 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 (plusPtr inp 1) -unescapeText' :: ByteString -> Text -unescapeText' bs = runText $ \done -> do - dest <- A.new len + state_sudone :: Int -> Ptr Word8 -> 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 - (pos, finalState) <- loop dest (0, StateNone) 0 + state_su4 :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text + state_su4 !out !inp !hi !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek 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 - -- Check final state. Currently pos gets only increased over time, so this check should catch overflows. - when ( finalState /= StateNone || pos > len) - throwDecodeError + state_su3 :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text + state_su3 !out !inp !hi !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su4 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su4 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su4 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError - done dest pos -- TODO: pos, pos-1??? XXX + state_su2 :: Int -> Ptr Word8 -> Word32 -> Word32 -> IO Text + state_su2 !out !inp !hi !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su3 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su3 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su3 out (plusPtr inp 1) hi (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError - where - len = B.length bs + state_su1 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_su1 !out !inp !hi + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su2 out (plusPtr inp 1) hi (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su2 out (plusPtr inp 1) hi (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su2 out (plusPtr inp 1) hi (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError - runUtf dest pos st point c = case decode st point c of - (UtfGround, 92) -> -- Backslash - return (pos, StateBackslash) - (UtfGround, w) | w <= 0xffff -> - writeAndReturn dest pos (fromIntegral w) StateNone - (UtfGround, w) -> do - write dest pos (0xd7c0 + fromIntegral (w `shiftR` 10)) - writeAndReturn dest (pos + 1) (0xdc00 + fromIntegral (w .&. 0x3ff)) StateNone - (st', p) -> - return (pos, StateUtf st' p) + state_su :: Int -> Ptr Word8 -> Word32 -> IO Text + state_su !out !inp !hi + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 117 -> state_su1 out (plusPtr inp 1) hi + _ -> throwDecodeError - loop :: A.MArray s -> (Int, State) -> Int -> ST s (Int, State) - loop _ ps i | i >= len = return ps - loop dest ps i = do - let c = B.index bs i -- JP: We can use unsafe index once we prove bounds with Liquid Haskell. - ps' <- f dest ps c - loop dest ps' $ i+1 + state_ss :: Int -> Ptr Word8 -> Word32 -> IO Text + state_ss !out !inp !hi + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 92 -> state_su out (plusPtr inp 1) hi + _ -> throwDecodeError - -- No pending state. - f dest (pos, StateNone) c = runUtf dest pos UtfGround 0 c + state_udone :: Int -> Ptr Word8 -> Word32 -> IO Text + state_udone !out !inp !acc + | acc < 55296 || acc > 57343 = + writeCodePoint out inp acc - -- In the middle of parsing a UTF string. - f dest (pos, StateUtf st point) c = runUtf dest pos st point c + | acc < 56320 = + state_ss out (plusPtr inp 1) acc - -- In the middle of escaping a backslash. - f dest (pos, StateBackslash) 34 = writeAndReturn dest pos 34 StateNone -- " - f dest (pos, StateBackslash) 92 = writeAndReturn dest pos 92 StateNone -- Backslash - f dest (pos, StateBackslash) 47 = writeAndReturn dest pos 47 StateNone -- / - f dest (pos, StateBackslash) 98 = writeAndReturn dest pos 8 StateNone -- b - f dest (pos, StateBackslash) 102 = writeAndReturn dest pos 12 StateNone -- f - f dest (pos, StateBackslash) 110 = writeAndReturn dest pos 10 StateNone -- n - f dest (pos, StateBackslash) 114 = writeAndReturn dest pos 13 StateNone -- r - f dest (pos, StateBackslash) 116 = writeAndReturn dest pos 9 StateNone -- t - f _ (pos, StateBackslash) 117 = return (pos, StateU0) -- u - f _ ( _, StateBackslash) _ = throwDecodeError + | otherwise = + throwDecodeError - -- Processing '\u'. - f _ (pos, StateU0) c = - let w = decodeHex c in - return (pos, StateU1 (w `shiftL` 12)) + state_u4 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek 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 - f _ (pos, StateU1 w') c = - let w = decodeHex c in - return (pos, StateU2 (w' .|. (w `shiftL` 8))) + state_u3 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError - f _ (pos, StateU2 w') c = - let w = decodeHex c in - return (pos, StateU3 (w' .|. (w `shiftL` 4))) + state_u2 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError - f dest (pos, StateU3 w') c = - let w = decodeHex c in - let u = w' .|. w in + state_u1 :: Int -> Ptr Word8 -> IO Text + state_u1 !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError - -- Get next state based on surrogates. - let st - | u >= 0xd800 && u <= 0xdbff = -- High surrogate. - StateS0 - | u >= 0xdc00 && u <= 0xdfff = -- Low surrogate. - throwDecodeError - | otherwise = - StateNone - in - writeAndReturn dest pos u st + state_escape :: Int -> Ptr Word8 -> IO Text + state_escape !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 34 -> do + P.writePrimArray arr out 34 + state_start (out + 1) (plusPtr inp 1) - -- Handle surrogates. - f _ (pos, StateS0) 92 = return (pos, StateS1) -- Backslash - f _ ( _, StateS0) _ = throwDecodeError + 92 -> do + P.writePrimArray arr out 92 + state_start (out + 1) (plusPtr inp 1) - f _ (pos, StateS1) 117 = return (pos, StateSU0) -- u - f _ ( _, StateS1) _ = throwDecodeError + 47 -> do + P.writePrimArray arr out 47 + state_start (out + 1) (plusPtr inp 1) - f _ (pos, StateSU0) c = - let w = decodeHex c in - return (pos, StateSU1 (w `shiftL` 12)) + 98 -> do + P.writePrimArray arr out 8 + state_start (out + 1) (plusPtr inp 1) - f _ (pos, StateSU1 w') c = - let w = decodeHex c in - return (pos, StateSU2 (w' .|. (w `shiftL` 8))) + 102 -> do + P.writePrimArray arr out 12 + state_start (out + 1) (plusPtr inp 1) - f _ (pos, StateSU2 w') c = - let w = decodeHex c in - return (pos, StateSU3 (w' .|. (w `shiftL` 4))) + 110 -> do + P.writePrimArray arr out 10 + state_start (out + 1) (plusPtr inp 1) - f dest (pos, StateSU3 w') c = - let w = decodeHex c in - let u = w' .|. w in + 114 -> do + P.writePrimArray arr out 13 + state_start (out + 1) (plusPtr inp 1) - -- Check if not low surrogate. - if u < 0xdc00 || u > 0xdfff then - throwDecodeError - else - writeAndReturn dest pos u StateNone + 116 -> do + P.writePrimArray arr out 9 + state_start (out + 1) (plusPtr inp 1) -write :: A.MArray s -> Int -> Word16 -> ST s () -write dest pos char = - A.unsafeWrite dest pos char -{-# INLINE write #-} + 117 -> + state_u1 out (plusPtr inp 1) -writeAndReturn :: A.MArray s -> Int -> Word16 -> t -> ST s (Int, t) -writeAndReturn dest pos char res = do - write dest pos char - return (pos + 1, res) -{-# INLINE writeAndReturn #-} + _ -> throwDecodeError -throwDecodeError :: a -throwDecodeError = - let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in - throw (DecodeError desc Nothing) + state_input4c :: Int -> Ptr Word8 -> Word8 -> Word8 -> Word8 -> IO Text + state_input4c !out !inp !b1 !b2 !b3 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128 + , let acc = shiftL (fromIntegral (b1 .&. 7)) 18 + , let acc' = acc .|. shiftL (fromIntegral (b2 .&. 63)) 12 + , let acc'' = acc' .|. shiftL (fromIntegral (b3 .&. 63)) 6 + , let acc''' = acc'' .|. fromIntegral (w8 .&. 63) :: Word32 + , acc''' >= 65536 && acc''' < 1114112 -> do + P.writePrimArray arr out b1 + write3bytes (out + 1) b2 b3 w8 (plusPtr inp 1) -unescapeText :: ByteString -> Either UnicodeException Text -unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText' + | otherwise -> + throwDecodeError + + state_input4b :: Int -> Ptr Word8 -> Word8 -> Word8 -> IO Text + state_input4b !out !inp !b1 !b2 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128 -> + state_input4c out (plusPtr inp 1) b1 b2 w8 + + | otherwise -> + throwDecodeError + + state_input4 :: Int -> Ptr Word8 -> Word8 -> IO Text + state_input4 !out !inp !b1 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128 -> + state_input4b out (plusPtr inp 1) b1 w8 + + | otherwise -> + throwDecodeError + + state_input3b :: Int -> Ptr Word8 -> Word8 -> Word8 -> IO Text + state_input3b !out !inp !b1 !b2 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128 + , let acc = shiftL (fromIntegral (b1 .&. 15)) 12 + , let acc' = acc .|. shiftL (fromIntegral (b2 .&. 63)) 6 + , let acc'' = acc' .|. fromIntegral (w8 .&. 63) :: Word32 + , (acc'' >= 2048 && acc'' < 55296) || acc'' > 57343 -> do + P.writePrimArray arr out b1 + write2bytes (out + 1) b2 w8 (plusPtr inp 1) + + | otherwise -> + throwDecodeError + + state_input3 :: Int -> Ptr Word8 -> Word8 -> IO Text + state_input3 !out !inp !b1 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128 -> + state_input3b out (plusPtr inp 1) b1 w8 + + | otherwise -> + throwDecodeError + + state_input2 :: Int -> Ptr Word8 -> Word8 -> IO Text + state_input2 !out !inp !b1 + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 192) == 128, + let acc = shiftL (fromIntegral (b1 .&. 63)) 6 :: Word32 + acc' = acc .|. fromIntegral (w8 .&. 63) :: Word32 + , acc' >= 128 -> do + P.writePrimArray arr out b1 + write1byte (out + 1) w8 (plusPtr inp 1) + + | otherwise -> + throwDecodeError + + state_start :: Int -> Ptr Word8 -> 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 (T.ByteArray ba) 0 out + + | otherwise = do + w8 <- peek inp + if | w8 == 92 -> state_escape out (plusPtr inp 1) + | w8 < 128 -> do + P.writePrimArray arr out w8 + state_start (out + 1) (plusPtr inp 1) + + | w8 < 192 -> throwDecodeError + | w8 < 224 -> state_input2 out (plusPtr inp 1) w8 + | w8 < 240 -> state_input3 out (plusPtr inp 1) w8 + | w8 < 248 -> state_input4 out (plusPtr inp 1) w8 + + | otherwise -> throwDecodeError + + -- start the state machine + state_start (0 :: Int) begin +#else + +unescapeTextIO bs = withBS bs $ \fptr len -> + withForeignPtr fptr $ \begin -> do + let end :: Ptr Word8 + end = plusPtr begin len + + arr <- P.newPrimArray len + + let writeLowSurrogate :: Int -> Word16 -> Ptr Word8 -> IO Text + writeLowSurrogate !out !w16 !inp = do + P.writePrimArray arr out w16 + state_start (out + 1) inp + + state_sudone :: Int -> Ptr Word8 -> Word32 -> IO Text + state_sudone !out !inp !lo + | 56320 <= lo, lo <= 57343 = do + P.writePrimArray arr out (fromIntegral lo) + state_start (out + 1) (plusPtr inp 1) + + | otherwise = + throwDecodeError + + state_su4 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_su4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek 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 -> Ptr Word8 -> Word32 -> IO Text + state_su3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> throwDecodeError + + state_su2 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_su2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_su1 :: Int -> Ptr Word8 -> IO Text + state_su1 !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_su2 out (plusPtr inp 1) (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_su2 out (plusPtr inp 1) (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_su2 out (plusPtr inp 1) (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + -- high surrogate u + state_su :: Int -> Ptr Word8 -> IO Text + state_su !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 117 -> state_su1 out (plusPtr inp 1) + _ -> throwDecodeError + + -- high surrogate slash + state_ss :: Int -> Ptr Word8 -> IO Text + state_ss !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 92 -> state_su out (plusPtr inp 1) + _ -> throwDecodeError + + state_udone :: Int -> Ptr Word8 -> 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) (plusPtr 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) (plusPtr inp 1) + + | otherwise = + throwDecodeError + + state_u4 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek 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 -> Ptr Word8 -> Word32 -> IO Text + state_u3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u4 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u2 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_u2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u3 out (plusPtr inp 1) (shiftL acc 4 .|. fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_u1 :: Int -> Ptr Word8 -> IO Text + state_u1 !out !inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | 48 <= w8, w8 <= 57 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 48)) + | 65 <= w8, w8 <= 70 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 55)) + | 97 <= w8, w8 <= 102 -> + state_u2 out (plusPtr inp 1) (fromIntegral (w8 - 87)) + | otherwise -> + throwDecodeError + + state_escape :: Int -> Ptr Word8 -> IO Text + state_escape out inp + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + case w8 of + 34 -> do + P.writePrimArray arr out 34 + state_start (out + 1) (plusPtr inp 1) + + 92 -> do + P.writePrimArray arr out 92 + state_start (out + 1) (plusPtr inp 1) + + 47 -> do + P.writePrimArray arr out 47 + state_start (out + 1) (plusPtr inp 1) + + 98 -> do + P.writePrimArray arr out 8 + state_start (out + 1) (plusPtr inp 1) + + 102 -> do + P.writePrimArray arr out 12 + state_start (out + 1) (plusPtr inp 1) + + 110 -> do + P.writePrimArray arr out 10 + state_start (out + 1) (plusPtr inp 1) + + 114 -> do + P.writePrimArray arr out 13 + state_start (out + 1) (plusPtr inp 1) + + 116 -> do + P.writePrimArray arr out 9 + state_start (out + 1) (plusPtr inp 1) + + 117 -> + state_u1 out (plusPtr inp 1) + + _ -> throwDecodeError + + state_input4c :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input4c !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 + , let acc' = acc .|. fromIntegral (w8 .&. 63) + , acc' >= 65536 && acc' < 1114112 -> + if {- -- | acc' < 65536 -> do + -- P.writePrimArray arr out (fromIntegral acc' :: Word16) + -- state_start (out + 1) (plusPtr inp 1) -} + | otherwise -> do + let u = acc' - 65536 + hi = fromIntegral (55296 + shiftR u 10) :: Word16 + lo = fromIntegral (56320 + (u .&. 1023)) :: Word16 + P.writePrimArray arr out hi + writeLowSurrogate (out + 1) lo (plusPtr inp 1) + + | otherwise -> throwDecodeError + + state_input4b :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input4b !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 -> + state_input4c out (plusPtr inp 1) (acc .|. shiftL (fromIntegral (w8 .&. 63)) 6) + + | otherwise -> throwDecodeError + + state_input4 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input4 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 -> + state_input4b out (plusPtr inp 1) (acc .|. shiftL (fromIntegral (w8 .&. 63)) 12) + + | otherwise -> throwDecodeError + + state_input3b :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input3b !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 + , let acc' = acc .|. fromIntegral (w8 .&. 63) + , (acc' >= 2048 && acc' < 55296) || acc' > 57343 -> + if | acc' < 65536 -> do + P.writePrimArray arr out (fromIntegral acc') + state_start (out + 1) (plusPtr inp 1) + + | otherwise -> do + let u = acc' - 65536 + hi = fromIntegral (55296 + shiftR u 10) :: Word16 + lo = fromIntegral (56320 + (u .&. 1023)) :: Word16 + P.writePrimArray arr out hi + writeLowSurrogate (out + 1) lo (plusPtr inp 1) + + | otherwise -> throwDecodeError + + state_input3 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input3 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 -> + state_input3b out (plusPtr inp 1) (acc .|. shiftL (fromIntegral (w8 .&. 63)) 6) + | otherwise -> throwDecodeError + + state_input2 :: Int -> Ptr Word8 -> Word32 -> IO Text + state_input2 !out !inp !acc + | inp == end = throwDecodeError + | otherwise = do + w8 <- peek inp + if | (w8 .&. 0xc0) == 0x80 + , let acc' = acc .|. fromIntegral (w8 .&. 63) + , acc' >= 0x80 -> do + P.writePrimArray arr out (fromIntegral acc' :: Word16) + state_start (out + 1) (plusPtr inp 1) + + | otherwise -> throwDecodeError + + state_start :: Int -> Ptr Word8 -> 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 (T.Array ba) 0 out + + | otherwise = do + w8 <- peek inp + if | w8 == 92 -> state_escape out (plusPtr inp 1) + | w8 < 0x80 -> do + P.writePrimArray arr out (fromIntegral w8 :: Word16) + state_start (out + 1) (plusPtr inp 1) + + | w8 < 0xc0 -> throwDecodeError + | w8 < 224 -> state_input2 out (plusPtr inp 1) (shiftL (fromIntegral (w8 .&. 63)) 6) + | w8 < 240 -> state_input3 out (plusPtr inp 1) (shiftL (fromIntegral (w8 .&. 15)) 12) + | w8 < 248 -> state_input4 out (plusPtr inp 1) (shiftL (fromIntegral (w8 .&. 7)) 18) + | otherwise -> throwDecodeError + + -- start the state machine + state_start (0 :: Int) begin + +#endif diff --git a/src/Data/Aeson/Encoding/Builder.hs b/src/Data/Aeson/Encoding/Builder.hs --- a/src/Data/Aeson/Encoding/Builder.hs +++ b/src/Data/Aeson/Encoding/Builder.hs @@ -44,8 +44,10 @@ import Data.Aeson.Types.Internal (Value (..), Key) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM -import Data.ByteString.Builder as B -import Data.ByteString.Builder.Prim as BP +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as B +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.Scientific (Scientific, base10Exponent, coefficient) @@ -54,7 +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 +import Data.Time.LocalTime (LocalTime (..), TimeZone (..), ZonedTime (..), TimeOfDay (..)) import Data.Word (Word8) import qualified Data.Text as T import qualified Data.Vector as V diff --git a/src/Data/Aeson/Encoding/Internal.hs b/src/Data/Aeson/Encoding/Internal.hs --- a/src/Data/Aeson/Encoding/Internal.hs +++ b/src/Data/Aeson/Encoding/Internal.hs @@ -16,6 +16,7 @@ , pairs , pair , pairStr + , unsafePairSBS , pair' -- * Predicates , nullEncoding @@ -65,15 +66,16 @@ import Data.Aeson.Types.Internal (Value, Key) import Data.ByteString.Builder (Builder, char7, toLazyByteString) +import Data.ByteString.Short (ShortByteString) import qualified Data.Aeson.Key as Key -import Data.Int +import Data.Int (Int8, Int16, Int32, Int64) import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime) import Data.Time.Calendar.Month.Compat (Month) import Data.Time.Calendar.Quarter.Compat (Quarter) import Data.Typeable (Typeable) -import Data.Word +import Data.Word (Word8, Word16, Word32, Word64) import qualified Data.Aeson.Encoding.Builder as EB import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BSL @@ -141,6 +143,19 @@ pair' :: Encoding' Key -> Encoding -> Series pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val + +-- | A variant of a 'pair' where key is already encoded +-- including the quotes and colon. +-- +-- @ +-- 'pair' "foo" v = 'unsafePair' "\\"foo\\":" v +-- @ +-- +-- @since 2.0.3.0 +-- +unsafePairSBS :: ShortByteString -> Encoding -> Series +unsafePairSBS k v = Value $ retagEncoding $ Encoding (B.shortByteString k) >< v +{-# INLINE unsafePairSBS #-} instance Semigroup Series where Empty <> a = a diff --git a/src/Data/Aeson/Internal/ByteString.hs b/src/Data/Aeson/Internal/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Internal/ByteString.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +module Data.Aeson.Internal.ByteString ( + mkBS, + withBS, + liftSBS, +) where + +import Data.ByteString.Internal (ByteString (..)) +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr) +import Data.ByteString.Short (ShortByteString, fromShort) +import GHC.Exts (Addr#, Ptr (Ptr)) +import Data.ByteString.Internal (accursedUnutterablePerformIO) +import Data.ByteString.Short.Internal (createFromPtr) + +import qualified Data.ByteString as BS +import qualified Language.Haskell.TH.Lib as TH +import qualified Language.Haskell.TH.Syntax as TH + +#if !MIN_VERSION_bytestring(0,11,0) +#if MIN_VERSION_base(4,10,0) +import GHC.ForeignPtr (plusForeignPtr) +#else +import GHC.ForeignPtr (ForeignPtr(ForeignPtr)) +import GHC.Types (Int (..)) +import GHC.Prim (plusAddr#) +#endif +#endif + +mkBS :: ForeignPtr Word8 -> Int -> ByteString +#if MIN_VERSION_bytestring(0,11,0) +mkBS dfp n = BS dfp n +#else +mkBS dfp n = PS dfp 0 n +#endif +{-# INLINE mkBS #-} + +withBS :: ByteString -> (ForeignPtr Word8 -> Int -> r) -> r +#if MIN_VERSION_bytestring(0,11,0) +withBS (BS !sfp !slen) kont = kont sfp slen +#else +withBS (PS !sfp !soff !slen) kont = kont (plusForeignPtr sfp soff) slen +#endif +{-# INLINE withBS #-} + +#if !MIN_VERSION_bytestring(0,11,0) +#if !MIN_VERSION_base(4,10,0) +-- |Advances the given address by the given offset in bytes. +-- +-- The new 'ForeignPtr' shares the finalizer of the original, +-- equivalent from a finalization standpoint to just creating another +-- reference to the original. That is, the finalizer will not be +-- called before the new 'ForeignPtr' is unreachable, nor will it be +-- called an additional time due to this call, and the finalizer will +-- be called with the same address that it would have had this call +-- not happened, *not* the new address. +plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b +plusForeignPtr (ForeignPtr addr guts) (I# offset) = ForeignPtr (plusAddr# addr offset) guts +{-# INLINE [0] plusForeignPtr #-} +{-# RULES +"ByteString plusForeignPtr/0" forall fp . + plusForeignPtr fp 0 = fp + #-} +#endif +#endif + +liftSBS :: ShortByteString -> TH.ExpQ +#if MIN_VERSION_template_haskell(2,16,0) +liftSBS sbs = withBS bs $ \ptr len -> [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.BytesPrimL $ TH.Bytes ptr 0 (fromIntegral len)) + where + bs = fromShort sbs +#else +liftSBS sbs = withBS bs $ \_ len -> [| unsafePackLenLiteral |] + `TH.appE` TH.litE (TH.integerL (fromIntegral len)) + `TH.appE` TH.litE (TH.StringPrimL $ BS.unpack bs) + where + bs = fromShort sbs +#endif + +unsafePackLenLiteral :: Int -> Addr# -> ShortByteString +unsafePackLenLiteral len addr# = + accursedUnutterablePerformIO $ createFromPtr (Ptr addr#) len diff --git a/src/Data/Aeson/Internal/TH.hs b/src/Data/Aeson/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Internal/TH.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +module Data.Aeson.Internal.TH ( + letrecE, + autoletE, +) where + +import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Language.Haskell.TH (varE, ExpQ, Name, Q, newName, runIO) +import System.IO.Unsafe (unsafeInterleaveIO) + +import qualified Data.Map as Map +import qualified Language.Haskell.TH.Syntax as TH + +letrecE + :: forall a. Ord a + => ((a -> ExpQ) -> (a -> ExpQ)) + -> ((a -> ExpQ) -> ExpQ) + -> ExpQ +letrecE f g = do + ref <- runIO $ newIORef Map.empty + expr <- g (loop ref) + bindings <- runIO $ readIORef ref + mkLet bindings expr + where + mkLet :: Map.Map a (Name, TH.Exp) -> TH.Exp -> ExpQ + mkLet bindings expr = do + return $ TH.LetE + [ TH.ValD (TH.VarP name) (TH.NormalB code) [] + | (_, (name, code)) <- Map.toList bindings + ] + expr + + loop :: IORef (Map.Map a (Name, TH.Exp)) -> a -> ExpQ + loop ref y = do + memo <- runIO $ readIORef ref + case Map.lookup y memo of + Nothing -> do + name <- newName $ "_let" ++ show (Map.size memo) + _ <- mfix_ $ \yCode -> do + runIO $ atomicModifyIORef ref $ \m -> (Map.insert y (name, yCode) m, ()) + f (loop ref) y + varE name + + Just (name, _) -> + varE name + +-- | Better 'letE'. +autoletE + :: Ord a + => (a -> ExpQ) -- ^ what bindings are + -> ((a -> ExpQ) -> ExpQ) -- ^ expression with a function to generate bindings + -> ExpQ +autoletE f = letrecE (const f) + +------------------------------------------------------------------------------- +-- MonadFix Q is not always there +------------------------------------------------------------------------------- + +class MonadFix_ m where + mfix_ :: (a -> m a) -> m a + +instance MonadFix_ Q where + mfix_ k = do + m <- runIO newEmptyMVar + ans <- runIO (unsafeInterleaveIO (takeMVar m)) + result <- k ans + runIO (putMVar m result) + pure result + {-# INLINE mfix_ #-} diff --git a/src/Data/Aeson/Internal/Text.hs b/src/Data/Aeson/Internal/Text.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Internal/Text.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +module Data.Aeson.Internal.Text ( + unsafeDecodeASCII, +) where + +import Data.ByteString (ByteString) +import qualified Data.Text as T + +#if MIN_VERSION_text(2,0,0) +import Data.Text.Array (Array (..)) +import qualified Data.Text.Internal as T (Text (..)) + +import qualified Data.ByteString.Short.Internal as SBS + +import Data.Aeson.Internal.ByteString + +#else +import qualified Data.Text.Encoding as TE + +#endif + +-- | The input is assumed to contain only 7bit ASCII characters (i.e. @< 0x80@). +-- We use TE.decodeLatin1 here because TE.decodeASCII is currently (text-1.2.4.0) +-- deprecated and equal to TE.decodeUtf8, which is slower than TE.decodeLatin1. +unsafeDecodeASCII :: ByteString -> T.Text + +#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 + +#else +unsafeDecodeASCII = TE.decodeLatin1 +#endif diff --git a/src/Data/Aeson/Key.hs b/src/Data/Aeson/Key.hs --- a/src/Data/Aeson/Key.hs +++ b/src/Data/Aeson/Key.hs @@ -31,6 +31,7 @@ import qualified Data.Text as T import qualified Data.Text.Short as ST import qualified Language.Haskell.TH.Syntax as TH +import qualified Test.QuickCheck as QC newtype Key = Key { unKey :: Text } deriving (Eq, Ord, Typeable, Data) @@ -103,3 +104,16 @@ #elif MIN_VERSION_template_haskell(2,16,0) liftTyped = TH.unsafeTExpCoerce . TH.lift #endif + +-- | @since 2.0.3.0 +instance QC.Arbitrary Key where + arbitrary = fromString <$> QC.arbitrary + shrink k = fromString <$> QC.shrink (toString k) + +-- | @since 2.0.3.0 +instance QC.CoArbitrary Key where + coarbitrary = QC.coarbitrary . toString + +-- | @since 2.0.3.0 +instance QC.Function Key where + function = QC.functionMap toString fromString diff --git a/src/Data/Aeson/KeyMap.hs b/src/Data/Aeson/KeyMap.hs --- a/src/Data/Aeson/KeyMap.hs +++ b/src/Data/Aeson/KeyMap.hs @@ -48,6 +48,7 @@ fromListWith, toList, toAscList, + elems, -- * Maps fromHashMap, @@ -121,6 +122,7 @@ import qualified Data.Semialign as SA import qualified Data.Semialign.Indexed as SAI import qualified GHC.Exts +import qualified Test.QuickCheck as QC import qualified Witherable as W #ifdef USE_ORDEREDMAP @@ -235,12 +237,18 @@ fromList :: [(Key, v)] -> KeyMap v fromList = KeyMap . M.fromList --- | Return a list of this map's elements. +-- | Return a list of this map's keys and elements. -- -- The order is not stable. Use 'toAscList' for stable ordering. toList :: KeyMap v -> [(Key, v)] toList = M.toList . unKeyMap +-- | Return a list of this map' elements. +-- +-- @since 2.0.2.0 +elems :: KeyMap v -> [v] +elems = M.elems . unKeyMap + -- | Return a list of this map's elements in ascending order -- based of the textual key. toAscList :: KeyMap v -> [(Key, v)] @@ -292,7 +300,7 @@ toMap :: KeyMap v -> Map Key v toMap = unKeyMap --- | Convert a 'HashMap' to a 'Map'. +-- | Convert a 'Map' to a 'KeyMap'. fromMap :: Map Key v -> KeyMap v fromMap = KeyMap @@ -436,6 +444,12 @@ toList :: KeyMap v -> [(Key, v)] toList = H.toList . unKeyMap +-- | Return a list of this map' elements. +-- +-- @since 2.0.2.0 +elems :: KeyMap v -> [v] +elems = H.elems . unKeyMap + -- | Return a list of this map's elements in ascending order -- based of the textual key. toAscList :: KeyMap v -> [(Key, v)] @@ -487,7 +501,7 @@ toMap :: KeyMap v -> Map Key v toMap = M.fromList . toList --- | Convert a 'HashMap' to a 'Map'. +-- | Convert a 'Map' to a 'KeyMap'. fromMap :: Map Key v -> KeyMap v fromMap = fromList . M.toList @@ -679,3 +693,25 @@ imapMaybe = mapMaybeWithKey instance W.WitherableWithIndex Key KeyMap where + +------------------------------------------------------------------------------- +-- QuickCheck +------------------------------------------------------------------------------- + +-- | @since 2.0.3.0 +instance QC.Arbitrary1 KeyMap where + liftArbitrary a = fmap fromList (QC.liftArbitrary (QC.liftArbitrary a)) + liftShrink shr m = fmap fromList (QC.liftShrink (QC.liftShrink shr) (toList m)) + +-- | @since 2.0.3.0 +instance QC.Arbitrary v => QC.Arbitrary (KeyMap v) where + arbitrary = QC.arbitrary1 + shrink = QC.shrink1 + +-- | @since 2.0.3.0 +instance QC.CoArbitrary v => QC.CoArbitrary (KeyMap v) where + coarbitrary = QC.coarbitrary . toList + +-- | @since 2.0.3.0 +instance QC.Function v => QC.Function (KeyMap v) where + function = QC.functionMap toList fromList diff --git a/src/Data/Aeson/Parser/Internal.hs b/src/Data/Aeson/Parser/Internal.hs --- a/src/Data/Aeson/Parser/Internal.hs +++ b/src/Data/Aeson/Parser/Internal.hs @@ -59,7 +59,6 @@ import Data.Functor.Compat (($>)) import Data.Scientific (Scientific) import Data.Text (Text) -import qualified Data.Text.Encoding as TE import Data.Vector (Vector) import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse) import qualified Data.Attoparsec.ByteString as A @@ -72,6 +71,7 @@ import qualified Data.ByteString.Builder as B import qualified Data.Scientific as Sci import Data.Aeson.Parser.Unescape (unescapeText) +import Data.Aeson.Internal.Text -- $setup -- >>> :set -XOverloadedStrings @@ -341,12 +341,6 @@ Just DOUBLE_QUOTE -> A.anyWord8 $> txt Just w | w < 0x20 -> fail "unescaped control character" _ -> jstringSlow s - --- | The input is assumed to contain only 7bit ASCII characters (i.e. @< 0x80@). --- We use TE.decodeLatin1 here because TE.decodeASCII is currently (text-1.2.4.0) --- deprecated and equal to TE.decodeUtf8, which is slower than TE.decodeLatin1. -unsafeDecodeASCII :: B.ByteString -> Text -unsafeDecodeASCII = TE.decodeLatin1 jstringSlow :: B.ByteString -> Parser Text {-# INLINE jstringSlow #-} diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -113,6 +113,7 @@ import Prelude (fail) import Control.Applicative ((<|>)) +import Data.Char (ord) import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..)) import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject) import Data.Aeson.Types.Internal ((), JSONPathElement(Key)) @@ -149,6 +150,10 @@ import qualified Data.Text as T (pack, unpack) import qualified Data.Vector as V (unsafeIndex, null, length, create, empty) import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite) +import qualified Data.Text.Short as ST +import Data.ByteString.Short (ShortByteString) +import Data.Aeson.Internal.ByteString +import Data.Aeson.Internal.TH -------------------------------------------------------------------------------- -- Convenience @@ -305,6 +310,8 @@ -> Q Exp mkToEncodingCommon = mkFunCommon (\jc _ -> consToValue Encoding jc) +type LetInsert = ShortByteString -> ExpQ + -- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates -- code to generate a 'Value' or 'Encoding' of a number of constructors. All -- constructors must be from the same type. @@ -323,7 +330,7 @@ consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: " ++ "Not a single constructor given!" -consToValue target jc opts instTys cons = do +consToValue target jc opts instTys cons = autoletE liftSBS $ \letInsert -> do value <- newName "value" tjs <- newNameList "_tj" $ arityInt jc tjls <- newNameList "_tjl" $ arityInt jc @@ -332,18 +339,18 @@ lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys tvMap = M.fromList $ zip lastTyVars zippedTJs lamE (map varP $ interleavedTJs ++ [value]) $ - caseE (varE value) (matches tvMap) + caseE (varE value) (matches letInsert tvMap) where - matches tvMap = case cons of + matches letInsert tvMap = case cons of -- A single constructor is directly encoded. The constructor itself may be -- forgotten. - [con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con] + [con] | not (tagSingleConstructors opts) -> [argsToValue letInsert target jc tvMap opts False con] _ | allNullaryToStringTag opts && all isNullary cons -> [ match (conP conName []) (normalB $ conStr target opts conName) [] | con <- cons , let conName = constructorName con ] - | otherwise -> [argsToValue target jc tvMap opts True con | con <- cons] + | otherwise -> [argsToValue letInsert target jc tvMap opts True con | con <- cons] -- | Name of the constructor as a quoted 'Value' or 'Encoding'. conStr :: ToJSONFun -> Options -> Name -> Q Exp @@ -365,24 +372,26 @@ isNullary _ = False -- | Wrap fields of a non-record constructor. See 'sumToValue'. -opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ -opaqueSumToValue target opts multiCons nullary conName value = - sumToValue target opts multiCons nullary conName +opaqueSumToValue :: LetInsert -> ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ +opaqueSumToValue letInsert target opts multiCons nullary conName value = + sumToValue letInsert target opts multiCons nullary conName value pairs where - pairs contentsFieldName = pairE contentsFieldName value + pairs contentsFieldName = pairE letInsert target contentsFieldName value -- | Wrap fields of a record constructor. See 'sumToValue'. -recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ -recordSumToValue target opts multiCons nullary conName pairs = - sumToValue target opts multiCons nullary conName - (fromPairsE pairs) +recordSumToValue :: LetInsert -> ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ +recordSumToValue letInsert target opts multiCons nullary conName pairs = + sumToValue letInsert target opts multiCons nullary conName + (fromPairsE target pairs) (const pairs) -- | Wrap fields of a constructor. sumToValue - :: ToJSONFun + :: LetInsert + -- ^ Let insertion + -> ToJSONFun -- ^ The method being derived. -> Options -- ^ Deriving options. @@ -404,7 +413,7 @@ -- - For records, produces the list of pairs corresponding to fields of the -- encoded value (ignores the argument). See 'recordSumToValue'. -> ExpQ -sumToValue target opts multiCons nullary conName value pairs +sumToValue letInsert target opts multiCons nullary conName value pairs | multiCons = case sumEncoding opts of TwoElemArray -> @@ -412,21 +421,21 @@ TaggedObject{tagFieldName, contentsFieldName} -> -- TODO: Maybe throw an error in case -- tagFieldName overwrites a field in pairs. - let tag = pairE tagFieldName (conStr target opts conName) + let tag = pairE letInsert target tagFieldName (conStr target opts conName) content = pairs contentsFieldName - in fromPairsE $ + in fromPairsE target $ if nullary then tag else infixApp tag [|(Monoid.<>)|] content ObjectWithSingleField -> - objectE [(conString opts conName, value)] + objectE letInsert target [(conString opts conName, value)] UntaggedValue | nullary -> conStr target opts conName UntaggedValue -> value | otherwise = value -- | Generates code to generate the JSON encoding of a single constructor. -argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match +argsToValue :: LetInsert -> ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match -- Polyadic constructors with special case for unary constructors. -argsToValue target jc tvMap opts multiCons +argsToValue letInsert target jc tvMap opts multiCons ConstructorInfo { constructorName = conName , constructorVariant = NormalConstructor , constructorFields = argTys } = do @@ -443,16 +452,16 @@ es -> array target es match (conP conName $ map varP args) - (normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js) + (normalB $ opaqueSumToValue letInsert target opts multiCons (null argTys') conName js) [] -- Records. -argsToValue target jc tvMap opts multiCons +argsToValue letInsert target jc tvMap opts multiCons info@ConstructorInfo { constructorName = conName , constructorVariant = RecordConstructor fields , constructorFields = argTys } = case (unwrapUnaryRecords opts, not multiCons, argTys) of - (True,True,[_]) -> argsToValue target jc tvMap opts multiCons + (True,True,[_]) -> argsToValue letInsert target jc tvMap opts multiCons (info{constructorVariant = NormalConstructor}) _ -> do argTys' <- mapM resolveTypeSynonyms argTys @@ -483,7 +492,7 @@ toPairLifted lifted (arg, argTy, field) = let toValue = dispatchToJSON target jc conName tvMap argTy fieldName = fieldLabel opts field - e arg' = pairE fieldName (toValue `appE` arg') + e arg' = pairE letInsert target fieldName (toValue `appE` arg') in if lifted then do x <- newName "x" @@ -491,11 +500,11 @@ else e arg match (conP conName $ map varP args) - (normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs) + (normalB $ recordSumToValue letInsert target opts multiCons (null argTys) conName pairs) [] -- Infix constructors. -argsToValue target jc tvMap opts multiCons +argsToValue letInsert target jc tvMap opts multiCons ConstructorInfo { constructorName = conName , constructorVariant = InfixConstructor , constructorFields = argTys } = do @@ -504,7 +513,7 @@ ar <- newName "argR" match (infixP (varP al) conName (varP ar)) ( normalB - $ opaqueSumToValue target opts multiCons False conName + $ opaqueSumToValue letInsert target opts multiCons False conName $ array target [ dispatchToJSON target jc conName tvMap aTy `appE` varE a @@ -557,8 +566,8 @@ doE (newMV:stmts++[ret])) -- | Wrap an associative list of keys and quoted values in a quoted 'Object'. -objectE :: [(String, ExpQ)] -> ExpQ -objectE = fromPairsE . mconcatE . fmap (uncurry pairE) +objectE :: LetInsert -> ToJSONFun -> [(String, ExpQ)] -> ExpQ +objectE letInsert target = fromPairsE target . mconcatE . fmap (uncurry (pairE letInsert target)) -- | 'mconcat' a list of fixed length. -- @@ -568,14 +577,28 @@ mconcatE [x] = x mconcatE (x : xs) = infixApp x [|(Monoid.<>)|] (mconcatE xs) -fromPairsE :: ExpQ -> ExpQ -fromPairsE = ([|fromPairs|] `appE`) +fromPairsE :: ToJSONFun -> ExpQ -> ExpQ +fromPairsE _ = ([|fromPairs|] `appE`) -- | Create (an encoding of) a key-value pair. -- --- > pairE "k" [|v|] = [|pair "k" v|] -pairE :: String -> ExpQ -> ExpQ -pairE k v = [|pair (Key.fromString k)|] `appE` v +-- > pairE "k" [|v|] = [| pair "k" v |] +-- +pairE :: LetInsert -> ToJSONFun -> String -> ExpQ -> ExpQ +pairE letInsert Encoding k v = [| E.unsafePairSBS |] `appE` letInsert k' `appE` v + where + k' = ST.toShortByteString $ ST.pack $ "\"" ++ concatMap escapeAscii k ++ "\":" + + escapeAscii '\\' = "\\\\" + escapeAscii '\"' = "\\\"" + escapeAscii '\n' = "\\n" + escapeAscii '\r' = "\\r" + escapeAscii '\t' = "\\t" + escapeAscii c + | ord c < 0x20 = "\\u" ++ printf "%04x" (ord c) + escapeAscii c = [c] + +pairE _letInsert Value k v = [| pair (Key.fromString k) |] `appE` v -------------------------------------------------------------------------------- -- FromJSON diff --git a/src/Data/Aeson/Text.hs b/src/Data/Aeson/Text.hs --- a/src/Data/Aeson/Text.hs +++ b/src/Data/Aeson/Text.hs @@ -28,7 +28,8 @@ import Data.Aeson.Encoding (encodingToLazyByteString) import qualified Data.Aeson.KeyMap as KM import Data.Scientific (FPFormat(..), Scientific, base10Exponent) -import Data.Text.Lazy.Builder +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as TB import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder) import Numeric (showHex) import qualified Data.Aeson.Key as Key @@ -62,23 +63,23 @@ go (Array v) | V.null v = {-# SCC "go/Array" #-} "[]" | otherwise = {-# SCC "go/Array" #-} - singleton '[' <> + TB.singleton '[' <> go (V.unsafeHead v) <> - V.foldr f (singleton ']') (V.unsafeTail v) - where f a z = singleton ',' <> go a <> z + V.foldr f (TB.singleton ']') (V.unsafeTail v) + where f a z = TB.singleton ',' <> go a <> z go (Object m) = {-# SCC "go/Object" #-} case KM.toList m of - (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs + (x:xs) -> TB.singleton '{' <> one x <> foldr f (TB.singleton '}') xs _ -> "{}" - where f a z = singleton ',' <> one a <> z - one (k,v) = string (Key.toText k) <> singleton ':' <> go v + where f a z = TB.singleton ',' <> one a <> z + one (k,v) = string (Key.toText k) <> TB.singleton ':' <> go v string :: T.Text -> Builder -string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"' +string s = {-# SCC "string" #-} TB.singleton '"' <> quote s <> TB.singleton '"' where quote q = case T.uncons t of - Nothing -> fromText h - Just (!c,t') -> fromText h <> escape c <> quote t' + Nothing -> TB.fromText h + Just (!c,t') -> TB.fromText h <> escape c <> quote t' where (h,t) = {-# SCC "break" #-} T.break isEscape q isEscape c = c == '\"' || c == '\\' || @@ -90,8 +91,8 @@ escape '\t' = "\\t" escape c - | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h - | otherwise = singleton c + | c < '\x20' = TB.fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h + | otherwise = TB.singleton c where h = showHex (fromEnum c) "" fromScientific :: Scientific -> Builder diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -110,6 +110,10 @@ import qualified Language.Haskell.TH.Syntax as TH import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM +import qualified Data.Scientific as Sci +import qualified Data.Text as T +import qualified Test.QuickCheck as QC +import Witherable (ordNub) -- | Elements of a JSON path used to describe the location of an -- error. @@ -388,6 +392,93 @@ . showsPrec 11 (KM.toAscList xs) . showChar ')' +-- | @since 2.0.3.0 +instance QC.Arbitrary Value where + arbitrary = QC.sized arbValue + + shrink = ordNub . go where + go Null = [] + go (Bool b) = Null : map Bool (QC.shrink b) + go (String x) = Null : map (String . T.pack) (QC.shrink (T.unpack x)) + go (Number x) = Null : map Number (shrScientific x) + go (Array x) = Null : V.toList x ++ map (Array . V.fromList) (QC.liftShrink go (V.toList x)) + go (Object x) = Null : KM.elems x ++ map (Object . KM.fromList) (QC.liftShrink (QC.liftShrink go) (KM.toList x)) + +-- | @since 2.0.3.0 +instance QC.CoArbitrary Value where + coarbitrary Null = QC.variant (0 :: Int) + coarbitrary (Bool b) = QC.variant (1 :: Int) . QC.coarbitrary b + coarbitrary (String x) = QC.variant (2 :: Int) . QC.coarbitrary (T.unpack x) + coarbitrary (Number x) = QC.variant (3 :: Int) . QC.coarbitrary (Sci.coefficient x) . QC.coarbitrary (Sci.base10Exponent x) + coarbitrary (Array x) = QC.variant (4 :: Int) . QC.coarbitrary (V.toList x) + coarbitrary (Object x) = QC.variant (5 :: Int) . QC.coarbitrary (KM.toList x) + +-- | @since 2.0.3.0 +instance QC.Function Value where + function = QC.functionMap fwd bwd where + fwd :: Value -> RepValue + fwd Null = Left Nothing + fwd (Bool b) = Left (Just b) + fwd (String x) = Right (Left (Left (T.unpack x))) + fwd (Number x) = Right (Left (Right (Sci.coefficient x, Sci.base10Exponent x))) + fwd (Array x) = Right (Right (Left (V.toList x))) + fwd (Object x) = Right (Right (Right (KM.toList x))) + + bwd :: RepValue -> Value + bwd (Left Nothing) = Null + bwd (Left (Just b)) = Bool b + bwd (Right (Left (Left x))) = String (T.pack x) + bwd (Right (Left (Right (x, y)))) = Number (Sci.scientific x y) + bwd (Right (Right (Left x))) = Array (V.fromList x) + bwd (Right (Right (Right x))) = Object (KM.fromList x) + +-- Used to implement QC.Function Value instance +type RepValue + = Either (Maybe Bool) (Either (Either String (Integer, Int)) (Either [Value] [(Key, Value)])) + +arbValue :: Int -> QC.Gen Value +arbValue n + | n <= 0 = QC.oneof + [ pure Null + , Bool <$> QC.arbitrary + , String <$> arbText + , Number <$> arbScientific + ] + + | otherwise = QC.oneof + [ Object <$> arbObject n + , Array <$> arbArray n + ] + +arbText :: QC.Gen Text +arbText = T.pack <$> QC.arbitrary + +arbScientific :: QC.Gen Scientific +arbScientific = Sci.scientific <$> QC.arbitrary <*> QC.arbitrary + +shrScientific :: Scientific -> [Scientific] +shrScientific s = map (uncurry Sci.scientific) $ + QC.shrink (Sci.coefficient s, Sci.base10Exponent s) + +arbObject :: Int -> QC.Gen Object +arbObject n = do + p <- arbPartition (n - 1) + KM.fromList <$> traverse (\m -> (,) <$> QC.arbitrary <*> arbValue m) p + +arbArray :: Int -> QC.Gen Array +arbArray n = do + p <- arbPartition (n - 1) + V.fromList <$> traverse arbValue p + +arbPartition :: Int -> QC.Gen [Int] +arbPartition k = case compare k 1 of + LT -> pure [] + EQ -> pure [1] + GT -> do + first <- QC.chooseInt (1, k) + rest <- arbPartition $ k - first + QC.shuffle (first : rest) + -- | -- -- The ordering is total, consistent with 'Eq' instance. @@ -830,8 +921,8 @@ -- | Better version of 'camelTo'. Example where it works better: -- --- > camelTo '_' 'CamelAPICase' == "camel_apicase" --- > camelTo2 '_' 'CamelAPICase' == "camel_api_case" +-- > camelTo '_' "CamelAPICase" == "camel_apicase" +-- > camelTo2 '_' "CamelAPICase" == "camel_api_case" camelTo2 :: Char -> String -> String camelTo2 c = map toLower . go2 . go1 where go1 "" = "" diff --git a/tests/Instances.hs b/tests/Instances.hs --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -14,19 +14,15 @@ import Control.Applicative (empty) import Control.Monad import Data.Aeson.Types -import qualified Data.Aeson.KeyMap as KM import Data.Function (on) import Data.Time (ZonedTime(..), TimeZone(..)) import Data.Time.Clock (UTCTime(..)) import Functions -import Test.QuickCheck (Arbitrary(..), elements, oneof, sized, Gen, chooseInt, shuffle) +import Test.QuickCheck (Arbitrary(..), elements, oneof) import Types -import qualified Data.Aeson.Key as Key import qualified Data.DList as DList -import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM - import Data.Orphans () import Test.QuickCheck.Instances () @@ -171,41 +167,3 @@ instance Arbitrary a => Arbitrary (DList.DList a) where arbitrary = DList.fromList <$> arbitrary - -instance Arbitrary Key where - arbitrary = Key.fromText <$> arbitrary - -instance Arbitrary Value where - arbitrary = sized arb where - arb :: Int -> Gen Value - arb n - | n <= 1 = oneof - [ return Null - , fmap Bool arbitrary - , fmap String arbitrary - , fmap Number arbitrary - ] - - | otherwise = oneof [arr n, obj n] - - arr n = do - pars <- arbPartition (n - 1) - fmap (Array . V.fromList) (traverse arb pars) - - obj n = do - pars <- arbPartition (n - 1) - fmap (Object . KM.fromList) (traverse pair pars) - - pair n = do - k <- arbitrary - v <- arb n - return (k, v) - - arbPartition :: Int -> Gen [Int] - arbPartition k = case compare k 1 of - LT -> pure [] - EQ -> pure [1] - GT -> do - first <- chooseInt (1, k) - rest <- arbPartition $ k - first - shuffle (first : rest) diff --git a/tests/PropUtils.hs b/tests/PropUtils.hs --- a/tests/PropUtils.hs +++ b/tests/PropUtils.hs @@ -26,7 +26,6 @@ import Text.Read (readMaybe) import qualified Data.Attoparsec.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.HashMap.Strict as H import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Vector as V diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -11,14 +11,15 @@ import PropUtils import PropertyGeneric import PropertyKeys +import PropertyQC import PropertyRoundTrip import PropertyTH tests :: TestTree tests = testGroup "properties" [ - testGroup "encode" [ - testProperty "encodeDouble" encodeDouble + testGroup "encode" + [ testProperty "encodeDouble" encodeDouble , testProperty "encodeInteger" encodeInteger ] , testProperty "read . show = id" roundtripReadShow @@ -38,4 +39,5 @@ ] , genericTests , templateHaskellTests + , quickcheckTests ] diff --git a/tests/PropertyQC.hs b/tests/PropertyQC.hs new file mode 100644 --- /dev/null +++ b/tests/PropertyQC.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeApplications #-} +module PropertyQC (quickcheckTests) where + +import Prelude.Compat + +import Instances () +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Arbitrary, Property, testProperty, counterexample, property) +import Test.QuickCheck (shrink) +import Data.Char (isLower, isUpper, isDigit, isSpace) +import Data.Foldable (foldl') +import Data.Foldable.WithIndex (ifoldl') + +import qualified Data.Text as T +import qualified Data.Aeson.Key as K +import qualified Data.Scientific as Sci + +import Data.Aeson (Value (..)) + +quickcheckTests :: TestTree +quickcheckTests = testGroup "QuickCheck" + [ testGroup "shrink terminates" + [ testProperty "Int" $ shrink_prop @Int + , testProperty "Bool" $ shrink_prop @Int + , testProperty "Integer" $ shrink_prop @Integer + , testProperty "Char" $ shrink_prop @Char + , testProperty "Text" $ shrink_prop @T.Text + , testProperty "(Int,Int)" $ shrink_prop @(Integer, Int) + , testProperty "Scientific" $ shrink_prop @Sci.Scientific + , testProperty "Value" $ shrink_prop @Value + ] + ] + +shrink_prop :: (Show a, ShrinkMetric a) => a -> Property +shrink_prop v = case vs' of + [] -> property True + v' : _ -> counterexample (show vs') $ + counterexample (show (metric v, metric v', v)) False + where + vs = shrink v + + -- we check only 50 first ones, otherwise it would take too long. + vs' = filter (not . predicate) $ take 50 vs + + -- shrunk v's should be smaller. + predicate v' = metric v' < metric v + +class Arbitrary a => ShrinkMetric a where + metric :: a -> Integer + +instance (ShrinkMetric a, ShrinkMetric b) => ShrinkMetric (a, b) where + metric (a, b) = (1 + metric a) * (1 + metric b) + +instance ShrinkMetric Bool where + metric b = if b then 1 else 0 + +instance ShrinkMetric Int where + metric = metric . toInteger + +instance ShrinkMetric Integer where + metric i = if i < 0 then 1 + negate i else i + +-- Char shrinking is tricky. +-- See: https://hackage.haskell.org/package/QuickCheck-2.14.2/docs/src/Test.QuickCheck.Arbitrary.html#line-664 +instance ShrinkMetric Char where + metric c = toInteger $ foldl' (+) 0 + [ if not $ isLower c then 0x2000000 else 0 + , if not $ isUpper c then 0x1000000 else 0 + , if not $ isDigit c then 0x0800000 else 0 + , if not $ c == ' ' then 0x0400000 else 0 + , if not $ isSpace c then 0x0200000 else 0 + , fromEnum c + ] + +instance ShrinkMetric T.Text where + metric = foldl' (\acc c -> acc + 1 + metric c) 0 . T.unpack + +instance ShrinkMetric K.Key where + metric = metric . K.toText + +instance ShrinkMetric Sci.Scientific where + metric s = metric (Sci.coefficient s, Sci.base10Exponent s) + +instance ShrinkMetric Value where + metric Null = 0 + metric (Bool b) = 1 + metric b + metric (String t) = 1 + metric t + metric (Number n) = 1 + metric n + metric (Array xs) = foldl' (\acc x -> acc + 1 + metric x) 1 xs + metric (Object xs) = ifoldl' (\k acc x -> acc + metric (k, x)) 1 xs diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -25,7 +25,7 @@ import Prelude.Compat import Control.Applicative (Const) -import Control.Monad (forM, forM_) +import Control.Monad (forM, forM_, when) import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON) import Data.Aeson.Internal (JSONPathElement(..), formatError) import Data.Aeson.QQ.Simple (aesonQQ) @@ -40,7 +40,7 @@ , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse) import qualified Data.Aeson.KeyMap as KM import Data.Attoparsec.ByteString (Parser, parseOnly) -import Data.Char (toUpper) +import Data.Char (toUpper, GeneralCategory(Control,Surrogate), generalCategory) import Data.Either.Compat (isLeft, isRight) import Data.Hashable (hash) import Data.HashMap.Strict (HashMap) @@ -72,12 +72,6 @@ import qualified ErrorMessages import qualified SerializationFormatSpec --- Asserts that we can use both modules at once in the test suite. -import Data.Aeson.Parser.UnescapeFFI () -import Data.Aeson.Parser.UnescapePure () - - - roundTripCamel :: String -> Assertion roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name) @@ -386,10 +380,14 @@ (Right ("\" / \\ \b \f \n \r \t" :: String)) (eitherDecode "\"\\\" \\/ \\\\ \\b \\f \\n \\r \\t\"") - forM_ [minBound .. maxBound :: Char] $ \ c -> - let s = LT.pack [c] in - assertEqual (printf "UTF-16 encoded '\\x%X'" c) - (Right s) (eitherDecode $ utf16Char s) + forM_ [minBound .. maxBound :: Char] $ \ c -> do + let s = LT.pack [c] + + assertEqual (printf "UTF-16 encoded '\\x%X'" c) (Right s) (eitherDecode $ utf16Char s) + + when (notEscapeControlOrSurrogate c) $ + assertEqual (printf "UTF-8 encode '\\x%X'" c) (Right s) (eitherDecode $ utf8Char s) + where utf16Char = formatString . LBase16.encode . LT.encodeUtf16BE formatString s @@ -397,6 +395,15 @@ | L.length s == 8 = L.concat ["\"\\u", L.take 4 s, "\\u", L.drop 4 s, "\""] | otherwise = error "unescapeString: can't happen" + + utf8Char s = L.concat ["\"", LT.encodeUtf8 s, "\""] + + notEscapeControlOrSurrogate '"' = False + notEscapeControlOrSurrogate '\\' = False + notEscapeControlOrSurrogate c = case generalCategory c of + Control -> False + Surrogate -> False + _ -> True -- JSONTestSuite