aeson 2.0.2.0 → 2.0.3.0
raw patch · 21 files changed
+1249/−370 lines, 21 filesdep −bytestring-builderdep −natsdep −semigroupsdep ~attoparsecdep ~bytestringdep ~data-fixPVP ok
version bump matches the API change (PVP)
Dependencies removed: bytestring-builder, nats, semigroups, transformers, transformers-compat, void
Dependency ranges changed: attoparsec, bytestring, data-fix, indexed-traversable, primitive, text, text-short, these, uuid-types, vector, witherable
API changes (from Hackage documentation)
+ Data.Aeson.Encoding.Internal: unsafePairSBS :: ShortByteString -> Encoding -> Series
+ Data.Aeson.Key: instance Test.QuickCheck.Arbitrary.Arbitrary Data.Aeson.Key.Key
+ Data.Aeson.Key: instance Test.QuickCheck.Arbitrary.CoArbitrary Data.Aeson.Key.Key
+ Data.Aeson.Key: instance Test.QuickCheck.Function.Function Data.Aeson.Key.Key
+ Data.Aeson.KeyMap: elems :: KeyMap v -> [v]
+ Data.Aeson.KeyMap: instance Test.QuickCheck.Arbitrary.Arbitrary v => Test.QuickCheck.Arbitrary.Arbitrary (Data.Aeson.KeyMap.KeyMap v)
+ Data.Aeson.KeyMap: instance Test.QuickCheck.Arbitrary.Arbitrary1 Data.Aeson.KeyMap.KeyMap
+ Data.Aeson.KeyMap: instance Test.QuickCheck.Arbitrary.CoArbitrary v => Test.QuickCheck.Arbitrary.CoArbitrary (Data.Aeson.KeyMap.KeyMap v)
+ Data.Aeson.KeyMap: instance Test.QuickCheck.Function.Function v => Test.QuickCheck.Function.Function (Data.Aeson.KeyMap.KeyMap v)
Files
- aeson.cabal +20/−40
- attoparsec-iso8601/src/Data/Attoparsec/Time.hs +1/−1
- attoparsec-iso8601/src/Data/Attoparsec/Time/Internal.hs +1/−1
- changelog.md +7/−0
- src-pure/Data/Aeson/Parser/UnescapePure.hs +672/−207
- src/Data/Aeson/Encoding/Builder.hs +5/−3
- src/Data/Aeson/Encoding/Internal.hs +17/−2
- src/Data/Aeson/Internal/ByteString.hs +87/−0
- src/Data/Aeson/Internal/TH.hs +71/−0
- src/Data/Aeson/Internal/Text.hs +34/−0
- src/Data/Aeson/Key.hs +14/−0
- src/Data/Aeson/KeyMap.hs +39/−3
- src/Data/Aeson/Parser/Internal.hs +1/−7
- src/Data/Aeson/TH.hs +57/−34
- src/Data/Aeson/Text.hs +13/−12
- src/Data/Aeson/Types/Internal.hs +93/−2
- tests/Instances.hs +1/−43
- tests/PropUtils.hs +0/−1
- tests/Properties.hs +4/−2
- tests/PropertyQC.hs +93/−0
- tests/UnitTests.hs +19/−12
aeson.cabal view
@@ -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
attoparsec-iso8601/src/Data/Attoparsec/Time.hs view
@@ -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)
attoparsec-iso8601/src/Data/Attoparsec/Time/Internal.hs view
@@ -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
changelog.md view
@@ -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.
src-pure/Data/Aeson/Parser/UnescapePure.hs view
@@ -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
src/Data/Aeson/Encoding/Builder.hs view
@@ -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
src/Data/Aeson/Encoding/Internal.hs view
@@ -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
+ src/Data/Aeson/Internal/ByteString.hs view
@@ -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
+ src/Data/Aeson/Internal/TH.hs view
@@ -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_ #-}
+ src/Data/Aeson/Internal/Text.hs view
@@ -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
src/Data/Aeson/Key.hs view
@@ -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
src/Data/Aeson/KeyMap.hs view
@@ -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
src/Data/Aeson/Parser/Internal.hs view
@@ -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 #-}
src/Data/Aeson/TH.hs view
@@ -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
src/Data/Aeson/Text.hs view
@@ -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
src/Data/Aeson/Types/Internal.hs view
@@ -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 "" = ""
tests/Instances.hs view
@@ -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)
tests/PropUtils.hs view
@@ -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
tests/Properties.hs view
@@ -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 ]
+ tests/PropertyQC.hs view
@@ -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
tests/UnitTests.hs view
@@ -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