json-syntax 0.2.7.2 → 0.3.0.2
raw patch · 7 files changed
+322/−211 lines, 7 filesdep −word-compatdep ~bytebuilddep ~bytesmithdep ~text
Dependencies removed: word-compat
Dependency ranges changed: bytebuild, bytesmith, text
Files
- CHANGELOG.md +8/−0
- bench/Main.hs +11/−0
- json-syntax.cabal +5/−6
- src/Json.hs +239/−150
- src/Json/Flatten.hs +30/−36
- src/Json/Smile.hs +18/−15
- test/Main.hs +11/−4
CHANGELOG.md view
@@ -1,5 +1,13 @@ # Revision history for json-syntax +## 0.3.0.2 -- 2025-07-14++* Switch from ShortText to Text. In many cases, this makes it possible for the+ resulting Value to share the input byte array instead of allocating additional+ memory.+* Get rid of word-compat. Require new GHC instead.+* Optimize decoding. Time for `json/twitter/100/decode` drops from 190us to 150us.+ ## 0.2.7.2 -- 2024-02-07 * Fix build with GHC 9.8.
bench/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -6,6 +7,7 @@ import Metrics1024 (encodedMetrics1024) import Twitter100 (byteStringTwitter100, encodedTwitter100) import Url100 (byteStringUrl100, encodedUrl100)+import Data.Bytes (Bytes) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as LBS@@ -29,6 +31,7 @@ aesonValueTwitter100 <- case Aeson.decodeStrict' byteStringTwitter100 of Nothing -> fail "aeson failed to decode twitter-100" Just (v :: Aeson.Value) -> pure v+ let !encodedCompactTwitter100 = Chunks.concat (BLDR.run 128 (J.encode valueTwitter100)) :: Bytes defaultMain [ bgroup "json"@@ -48,6 +51,14 @@ whnf (\v -> Chunks.length (BLDR.run 128 (Smile.encode v))) valueTwitter100+ ]+ ]+ , bgroup+ "twitter-compact"+ [ bgroup+ "100"+ [ bench "decode" $+ whnf J.decode encodedCompactTwitter100 ] ] , bgroup
json-syntax.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: json-syntax-version: 0.2.7.2+version: 0.3.0.2 synopsis: High-performance JSON parser and encoder description: This library parses JSON into a @Value@ type that is consistent with the@@ -28,7 +28,7 @@ CHANGELOG.md README.md -tested-with: GHC ==9.4.8 || ==9.6.3 || ==9.8.1+tested-with: GHC ==9.6.3 || ==9.8.1 common build-settings default-language: Haskell2010@@ -45,19 +45,18 @@ , array-builder >=0.1 && <0.2 , array-chunks >=0.1.3 && <0.2 , base >=4.15 && <5- , bytebuild >=0.3.10 && <0.4+ , bytebuild >=0.3.12 && <0.4 , byteslice >=0.2.9 && <0.3- , bytesmith >=0.3.8 && <0.4+ , bytesmith >=0.3.13 && <0.4 , bytestring >=0.10.8 && <0.12 , contiguous >=0.6 && <0.7 , natural-arithmetic >=0.1.2 && <0.3 , primitive >=0.7 && <0.10 , run-st >=0.1.1 && <0.2 , scientific-notation >=0.1.6 && <0.2- , text >=2.0.2 && <2.2+ , text >=2.1.2 && <2.2 , text-short >=0.1.3 && <0.2 , transformers >=0.5.6 && <0.7- , word-compat >=0.0.6 && <0.1 , zigzag >=0.0.1 && <0.1 hs-source-dirs: src
src/Json.hs view
@@ -1,12 +1,15 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedTuples #-} @@ -89,11 +92,14 @@ import Data.Foldable (foldlM) import Data.Number.Scientific (Scientific) import Data.Primitive (Array, ByteArray (ByteArray), MutableByteArray, Prim, PrimArray, SmallArray)-import Data.Text (Text)+import Data.Text.Internal (Text(Text)) import Data.Text.Short (ShortText)-import GHC.Exts (Char (C#), Int (I#), chr#, gtWord#, ltWord#, word2Int#)+import GHC.Exts (Char (C#), Int (I#), ltWord#, minusWord#)+import GHC.Exts (Int#, ByteArray#, word8ToWord#)+import GHC.Exts (RuntimeRep(IntRep,TupleRep,BoxedRep), Levity(Unlifted))+import GHC.Exts (and#, xor#) import GHC.Int (Int16, Int32, Int64, Int8)-import GHC.Word (Word16, Word32, Word64, Word8)+import GHC.Word (Word16, Word32, Word64, Word8(W8#), Word(W#)) import qualified Data.Builder.ST as B import qualified Data.ByteString.Short.Internal as BSS@@ -111,7 +117,6 @@ import qualified Data.Primitive.Contiguous as Contiguous import qualified Data.Text.Short as TS import qualified Data.Text.Short.Unsafe as TS-import qualified GHC.Word.Compat import qualified Prelude {- | The JSON syntax tree described by the ABNF in RFC 7159. Notable@@ -122,18 +127,11 @@ This improves performance when decoding the syntax tree to a @Bool@. * @Object@ uses an association list rather than a hash map. This is the data type that key-value pairs can be parsed into most cheaply.-* @Object@ and @Array@ both use 'Chunks' rather than using @SmallArray@- or cons-list directly. This a middle ground between those two types. We- get the efficent use of cache lines that @SmallArray@ offers, and we get- the worst-case @O(1)@ appends that cons-list offers. Users will typically- fold over the elements with the @Foldable@ instance of 'Chunks', although- there are functions in @Data.Chunks@ that efficently perform other- operations. -} data Value = Object !(SmallArray Member) | Array !(SmallArray Value)- | String {-# UNPACK #-} !ShortText+ | String {-# UNPACK #-} !Text | Number {-# UNPACK #-} !Scientific | Null | True@@ -170,7 +168,7 @@ taken from section 4 of RFC 7159. -} data Member = Member- { key :: {-# UNPACK #-} !ShortText+ { key :: {-# UNPACK #-} !Text , value :: !Value } deriving stock (Eq, Show)@@ -201,9 +199,9 @@ parser :: Parser SyntaxException s Value {-# INLINE parser #-} parser = do- P.skipWhile isSpace+ optimizedSkipSpace result <- Latin.any EmptyInput >>= parserStep- P.skipWhile isSpace+ optimizedSkipSpace P.endOfInput UnexpectedLeftovers pure result @@ -217,7 +215,7 @@ this here instead of having to reimplement it in a bunch of different applications. -Note: To protect against malicious input, this reject byte sequences with+Note: To protect against malicious input, this rejects byte sequences with more than 10 million newlines. If this is causing a problem for you, open an issue. @@ -278,7 +276,7 @@ True -> BLDR.ascii4 't' 'r' 'u' 'e' False -> BLDR.ascii5 'f' 'a' 'l' 's' 'e' Null -> BLDR.ascii4 'n' 'u' 'l' 'l'- String s -> BLDR.shortTextJsonString s+ String s -> BLDR.textJsonString s Number n -> SCI.builderUtf8 n Array ys -> case PM.sizeofSmallArray ys of 0 -> BLDR.ascii2 '[' ']'@@ -305,24 +303,25 @@ encodeMember :: Member -> BLDR.Builder encodeMember Member {key, value} =- BLDR.shortTextJsonString key+ BLDR.textJsonString key <> BLDR.ascii ':' <> encode value foldrTail :: (a -> b -> b) -> b -> PM.SmallArray a -> b {-# INLINE foldrTail #-}-foldrTail f z !ary = go 1+foldrTail f z !ary = goFoldrTail 1 where !sz = PM.sizeofSmallArray ary- go i+ goFoldrTail i | i == sz = z | (# x #) <- PM.indexSmallArray## ary i =- f x (go (i + 1))+ f x (goFoldrTail (i + 1)) -- Precondition: skip over all space before calling this. -- It will not skip leading space for you. It does not skip -- over trailing space either. parserStep :: Char -> Parser SyntaxException s Value+{-# NOINLINE parserStep #-} parserStep = \case '{' -> objectTrailedByBrace '[' -> arrayTrailedByBracket@@ -337,7 +336,7 @@ pure Null '"' -> do start <- Unsafe.cursor- string String start+ string start `P.bindFromByteArrayIntIntToLifted` \ !(# arr, off, len #) -> pure (String (Text (ByteArray arr) (I# off) (I# len))) '-' -> fmap Number (SCI.parserNegatedUtf8Bytes InvalidNumber) '0' -> Latin.trySatisfy (\c -> c >= '0' && c <= '9') >>= \case@@ -351,34 +350,55 @@ objectTrailedByBrace :: Parser SyntaxException s Value {-# INLINE objectTrailedByBrace #-} objectTrailedByBrace = do- P.skipWhile isSpace+ optimizedSkipSpace Latin.any IncompleteObject >>= \case '}' -> pure emptyObject '"' -> do start <- Unsafe.cursor- !theKey <- string id start- P.skipWhile isSpace- Latin.char ExpectedColon ':'- P.skipWhile isSpace- val <- Latin.any IncompleteObject >>= parserStep- let !mbr = Member theKey val- !b0 <- P.effect B.new- b1 <- P.effect (B.push mbr b0)- objectStep b1+ string start `P.bindFromByteArrayIntIntToLifted` \ !(# arr, off, len #) -> do+ let theKey = Text (ByteArray arr) (I# off) (I# len)+ optimizedSkipSpace+ Latin.char ExpectedColon ':'+ optimizedSkipSpace+ val <- Latin.any IncompleteObject >>= parserStep+ let !mbr = Member theKey val+ !b0 <- P.effect B.new+ b1 <- P.effect (B.push mbr b0)+ objectStep b1 _ -> P.fail ExpectedQuoteOrRightBrace +optimizedSkipSpace :: Parser SyntaxException s ()+{-# noinline optimizedSkipSpace #-}+optimizedSkipSpace = do+ let goOptimizedSkipSpace = do+ result <- Latin.trySatisfy+ (\c -> case c of+ ' ' -> Prelude.True+ _ -> if c > ' '+ then Prelude.False+ else case c of+ '\r' -> Prelude.True+ '\t' -> Prelude.True+ '\n' -> Prelude.True+ _ -> Prelude.False+ )+ case result of+ Prelude.True -> goOptimizedSkipSpace+ Prelude.False -> pure ()+ goOptimizedSkipSpace+ objectStep :: Builder s Member -> Parser SyntaxException s Value objectStep !b = do- P.skipWhile isSpace+ optimizedSkipSpace Latin.any IncompleteObject >>= \case ',' -> do- P.skipWhile isSpace+ optimizedSkipSpace Latin.char ExpectedQuote '"' start <- Unsafe.cursor- !theKey <- string id start- P.skipWhile isSpace+ !theKey <- P.bindFromByteArrayIntIntToLifted (string start) (\(# arr, off, len #) -> pure (Text (ByteArray arr) (I# off) (I# len)))+ optimizedSkipSpace Latin.char ExpectedColon ':'- P.skipWhile isSpace+ optimizedSkipSpace val <- Latin.any IncompleteObject >>= parserStep let !mbr = Member theKey val P.effect (B.push mbr b) >>= objectStep@@ -399,7 +419,7 @@ arrayTrailedByBracket :: Parser SyntaxException s Value {-# INLINE arrayTrailedByBracket #-} arrayTrailedByBracket = do- P.skipWhile isSpace+ optimizedSkipSpace Latin.any IncompleteArray >>= \case ']' -> pure emptyArray c -> do@@ -418,10 +438,10 @@ -- > *( value-separator value ) arrayStep :: Builder s Value -> Parser SyntaxException s Value arrayStep !b = do- P.skipWhile isSpace+ optimizedSkipSpace Latin.any IncompleteArray >>= \case ',' -> do- P.skipWhile isSpace+ optimizedSkipSpace val <- Latin.any IncompleteArray >>= parserStep P.effect (B.push val b) >>= arrayStep ']' -> do@@ -431,146 +451,210 @@ _ -> P.fail ExpectedCommaOrRightBracket c2w :: Char -> Word8+{-# INLINE c2w #-} c2w = fromIntegral . ord --- This is adapted from the function bearing the same name--- in json-tokens. If you find a problem with it, then--- something if wrong in json-tokens as well.------ TODO: Quit doing this CPS and inline nonsense. We should--- be able to unbox the resulting ShortText as ByteArray# and--- mark the function as NOINLINE. This would prevent the generated--- code from being needlessly duplicated in three different places.-string :: (ShortText -> a) -> Int -> Parser SyntaxException s a-{-# INLINE string #-}-string wrap !start = go 1+string :: forall s. Int -> Parser SyntaxException s (# ByteArray#, Int#, Int# #)+{-# NOINLINE string #-}+string !start@(I# start# ) = goShare where- go !canMemcpy = do- P.any IncompleteString >>= \case- 92 -> P.any InvalidEscapeSequence *> go 0 -- backslash- 34 -> do- -- double quote- !pos <- Unsafe.cursor- case canMemcpy of- 1 -> do- src <- Unsafe.expose- str <- P.effect $ do- let end = pos - 1- let len = end - start- dst <- PM.newByteArray len- PM.copyByteArray dst 0 src start len- PM.unsafeFreezeByteArray dst- pure (wrap (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str)))- _ -> do- Unsafe.unconsume (pos - start)- let end = pos - 1- let maxLen = end - start- copyAndEscape wrap maxLen- GHC.Word.Compat.W8# w -> go (canMemcpy .&. I# (ltWord# w 128##) .&. I# (gtWord# w 31##))+ goNoShare :: Parser SyntaxException s (# ByteArray#, Int#, Int# #)+ goNoShare = do+ P.any IncompleteString `P.bindFromLiftedToByteArrayIntInt` \theChar -> case theChar of+ 92 -> P.any InvalidEscapeSequence `P.bindFromLiftedToByteArrayIntInt` \_ -> goNoShare -- backslash+ 34 ->+ -- double quote (string is finished)+ Unsafe.cursor `P.bindFromLiftedToByteArrayIntInt` \ !pos ->+ Unsafe.unconsume (pos - start) `P.bindFromLiftedToByteArrayIntInt` \ !_ ->+ let end = pos - 1+ maxLen = end - start+ in copyAndEscape# maxLen+ _ -> goNoShare+ goShare :: Parser SyntaxException s (# ByteArray#, Int#, Int# #)+ goShare = do+ P.any IncompleteString `P.bindFromLiftedToByteArrayIntInt` \theChar -> case theChar of+ 92 -> P.any InvalidEscapeSequence `P.bindFromLiftedToByteArrayIntInt` \_ -> goNoShare -- backslash+ 34 ->+ -- double quote (string is finished)+ Unsafe.cursor `P.bindFromLiftedToByteArrayIntInt` \ !pos ->+ Unsafe.expose `P.bindFromLiftedToByteArrayIntInt` \ !(ByteArray src) ->+ let !end = pos - 1+ !(I# len) = end - start+ in P.pureByteArrayIntInt (# src, start#, len #)+ W8# w ->+ let !w' = minusWord# (word8ToWord# w) 32##+ in case ltWord# w' 96## of+ 1# -> goShare+ _ -> goNoShare -copyAndEscape :: (ShortText -> a) -> Int -> Parser SyntaxException s a-{-# INLINE copyAndEscape #-}-copyAndEscape wrap !maxLen = do- !dst <- P.effect (PM.newByteArray maxLen)- let go !ix =- Utf8.any# IncompleteString `P.bindFromCharToLifted` \c -> case c of- '\\'# ->- Latin.any IncompleteEscapeSequence >>= \case- '"' -> do- P.effect (PM.writeByteArray dst ix (c2w '"'))- go (ix + 1)- '\\' -> do- P.effect (PM.writeByteArray dst ix (c2w '\\'))- go (ix + 1)- 't' -> do- P.effect (PM.writeByteArray dst ix (c2w '\t'))- go (ix + 1)- 'n' -> do- P.effect (PM.writeByteArray dst ix (c2w '\n'))- go (ix + 1)- 'r' -> do- P.effect (PM.writeByteArray dst ix (c2w '\r'))- go (ix + 1)- '/' -> do- P.effect (PM.writeByteArray dst ix (c2w '/'))- go (ix + 1)- 'b' -> do- P.effect (PM.writeByteArray dst ix (c2w '\b'))- go (ix + 1)- 'f' -> do- P.effect (PM.writeByteArray dst ix (c2w '\f'))- go (ix + 1)- 'u' -> do- w <- Latin.hexFixedWord16 InvalidEscapeSequence- if w >= 0xD800 && w < 0xDFFF- then go =<< P.effect (encodeUtf8Char dst ix '\xFFFD')- else go =<< P.effect (encodeUtf8Char dst ix (w16ToChar w))- _ -> P.fail InvalidEscapeSequence- '"'# -> do- str <-- P.effect- (PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray dst ix)- pure (wrap (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str)))- _ -> go =<< P.effect (encodeUtf8Char dst ix (C# c))- go 0+copyAndEscape# :: forall s. Int -> Parser @('TupleRep '[ 'BoxedRep 'Unlifted, 'IntRep, 'IntRep ]) SyntaxException s (# ByteArray#, Int#, Int# #)+{-# noinline copyAndEscape# #-}+copyAndEscape# !maxLen =+ (P.effect (PM.newByteArray maxLen))+ `P.bindFromLiftedToByteArrayIntInt` \dst ->+ let goCopyAndEscape :: Int -> Parser @('TupleRep '[ 'BoxedRep 'Unlifted, 'IntRep, 'IntRep ]) SyntaxException s (# ByteArray#, Int#, Int# #)+ goCopyAndEscape !ix@(I# ix#) =+ P.any IncompleteString `P.bindFromLiftedToByteArrayIntInt` \theCharW -> case theCharW of+ -- Backslash+ 0x5C -> Latin.any IncompleteEscapeSequence `P.bindFromLiftedToByteArrayIntInt` \escapedChar -> case escapedChar of+ '"' ->+ (P.effect (PM.writeByteArray dst ix (c2w '"')))+ `P.bindFromLiftedToByteArrayIntInt` \_ ->+ goCopyAndEscape (ix + 1)+ '\\' ->+ (P.effect (PM.writeByteArray dst ix (c2w '\\')))+ `P.bindFromLiftedToByteArrayIntInt` \_ ->+ goCopyAndEscape (ix + 1)+ 't' ->+ (P.effect (PM.writeByteArray dst ix (c2w '\t')))+ `P.bindFromLiftedToByteArrayIntInt` \_ ->+ goCopyAndEscape (ix + 1)+ 'n' ->+ (P.effect (PM.writeByteArray dst ix (c2w '\n')))+ `P.bindFromLiftedToByteArrayIntInt` \_ ->+ goCopyAndEscape (ix + 1)+ 'r' ->+ (P.effect (PM.writeByteArray dst ix (c2w '\r')))+ `P.bindFromLiftedToByteArrayIntInt` \_ ->+ goCopyAndEscape (ix + 1)+ '/' ->+ (P.effect (PM.writeByteArray dst ix (c2w '/')))+ `P.bindFromLiftedToByteArrayIntInt` \_ ->+ goCopyAndEscape (ix + 1)+ 'b' ->+ (P.effect (PM.writeByteArray dst ix (c2w '\b')))+ `P.bindFromLiftedToByteArrayIntInt` \_ ->+ goCopyAndEscape (ix + 1)+ 'f' ->+ (P.effect (PM.writeByteArray dst ix (c2w '\f')))+ `P.bindFromLiftedToByteArrayIntInt` \_ ->+ goCopyAndEscape (ix + 1)+ 'u' ->+ Latin.hexFixedWord16# InvalidEscapeSequence+ `P.bindFromWordToByteArrayIntInt` \w ->+ ( case (w `and#` 0b1111_1000_0000_0000## ) `xor#` 0b1101_1000_0000_0000## of+ 0## -> P.bindFromLiftedToByteArrayIntInt+ ( P.effect $ do+ -- We replace anything in the range U+D800-U+DFFF with U+FFFD+ -- Note: UTF8 encoding of character U+FFFD is: 0xEF 0xBF 0xBD,+ -- so we just inline it directly.+ PM.writeByteArray dst ix (0xEF :: Word8)+ PM.writeByteArray dst (ix + 1) (0xBF :: Word8)+ PM.writeByteArray dst (ix + 2) (0xBD :: Word8)+ pure (ix + 3)+ ) goCopyAndEscape+ _ -> P.bindFromLiftedToByteArrayIntInt (P.effect (encodeUtf8CharBmp dst ix (W# w))) goCopyAndEscape+ )+ _ -> P.failByteArrayIntInt InvalidEscapeSequence+ -- Double quote (terminates string)+ 0x22 ->+ (P.effect (PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray dst ix))+ `P.bindFromLiftedToByteArrayIntInt` \str ->+ P.pureByteArrayIntInt+ ( case byteArrayToShortByteString str of+ BSS.SBS str' -> (# str', 0#, ix# #)+ )+ _ | theCharW >= 0x20, theCharW < 127 -> + (P.effect (PM.writeByteArray dst ix theCharW))+ `P.bindFromLiftedToByteArrayIntInt` \_ ->+ (goCopyAndEscape (ix + 1))+ _ ->+ (Unsafe.unconsume 1)+ `P.bindFromLiftedToByteArrayIntInt` \_ ->+ (Utf8.any# IncompleteString)+ `P.bindFromCharToByteArrayIntInt` \c -> + (P.bindFromLiftedToByteArrayIntInt (P.effect (encodeUtf8Char dst ix (fromIntegral (ord (C# c)) :: Word))) goCopyAndEscape)+ in goCopyAndEscape 0 -encodeUtf8Char :: MutableByteArray s -> Int -> Char -> ST s Int+-- This is copy of encodeUtf8Char that only expects characters in the basic+-- multilingual plane.+encodeUtf8CharBmp :: MutableByteArray s -> Int -> Word -> ST s Int+encodeUtf8CharBmp !marr !ix !c+ | c < 128 = do+ PM.writeByteArray marr ix (fromIntegral c :: Word8)+ pure (ix + 1)+ | c < 0x0800 = do+ PM.writeByteArray+ marr+ ix+ (fromIntegral @Word @Word8 (unsafeShiftR c 6 .|. 0b11000000))+ PM.writeByteArray+ marr+ (ix + 1)+ (0b10000000 .|. (0b00111111 .&. (fromIntegral @Word @Word8 c)))+ pure (ix + 2)+ | otherwise = do+ PM.writeByteArray+ marr+ ix+ (fromIntegral @Word @Word8 (unsafeShiftR c 12 .|. 0b11100000))+ PM.writeByteArray+ marr+ (ix + 1)+ (0b10000000 .|. (0b00111111 .&. (fromIntegral @Word @Word8 (unsafeShiftR c 6))))+ PM.writeByteArray+ marr+ (ix + 2)+ (0b10000000 .|. (0b00111111 .&. (fromIntegral @Word @Word8 c)))+ pure (ix + 3)++-- Note: the third argument is actually a character. This function used to+-- accept a Char argument, but it was rewritten to help get rid of chr#+-- and ord# in GHC core.+encodeUtf8Char :: MutableByteArray s -> Int -> Word -> ST s Int encodeUtf8Char !marr !ix !c- | c < '\128' = do- PM.writeByteArray marr ix (c2w c)+ | c < 128 = do+ PM.writeByteArray marr ix (fromIntegral c :: Word8) pure (ix + 1)- | c < '\x0800' = do+ | c < 0x0800 = do PM.writeByteArray marr ix- (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6 .|. 0b11000000))+ (fromIntegral @Word @Word8 (unsafeShiftR c 6 .|. 0b11000000)) PM.writeByteArray marr (ix + 1)- (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c))))+ (0b10000000 .|. (0b00111111 .&. (fromIntegral @Word @Word8 c))) pure (ix + 2)- | c <= '\xffff' = do+ | c <= 0xffff = do PM.writeByteArray marr ix- (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 12 .|. 0b11100000))+ (fromIntegral @Word @Word8 (unsafeShiftR c 12 .|. 0b11100000)) PM.writeByteArray marr (ix + 1)- (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6))))+ (0b10000000 .|. (0b00111111 .&. (fromIntegral @Word @Word8 (unsafeShiftR c 6)))) PM.writeByteArray marr (ix + 2)- (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c))))+ (0b10000000 .|. (0b00111111 .&. (fromIntegral @Word @Word8 c))) pure (ix + 3) | otherwise = do PM.writeByteArray marr ix- (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 18 .|. 0b11110000))+ (fromIntegral @Word @Word8 (unsafeShiftR c 18 .|. 0b11110000)) PM.writeByteArray marr (ix + 1)- (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 12))))+ (0b10000000 .|. (0b00111111 .&. (fromIntegral @Word @Word8 (unsafeShiftR c 12)))) PM.writeByteArray marr (ix + 2)- (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6))))+ (0b10000000 .|. (0b00111111 .&. (fromIntegral @Word @Word8 (unsafeShiftR c 6)))) PM.writeByteArray marr (ix + 3)- (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c))))+ (0b10000000 .|. (0b00111111 .&. (fromIntegral @Word @Word8 c))) pure (ix + 4) byteArrayToShortByteString :: ByteArray -> BSS.ShortByteString+{-# inline byteArrayToShortByteString #-} byteArrayToShortByteString (PM.ByteArray x) = BSS.SBS x --- Precondition: Not in the range [U+D800 .. U+DFFF]-w16ToChar :: Word16 -> Char-w16ToChar (GHC.Word.Compat.W16# w) = C# (chr# (word2Int# w))- -- | Infix pattern synonym for 'Member'.-pattern (:->) :: ShortText -> Value -> Member+pattern (:->) :: Text -> Value -> Member pattern key :-> value = Member {key, value} {- | Construct a JSON array from a list of JSON values.@@ -1051,11 +1135,11 @@ text :: Text -> Json.Value {-# INLINE text #-}-text = Json.String . TS.fromText+text = Json.String shortText :: ShortText -> Json.Value {-# INLINE shortText #-}-shortText = String+shortText = String . TS.toText bool :: Prelude.Bool -> Json.Value {-# INLINE bool #-}@@ -1086,18 +1170,23 @@ instance ToValue Word where toValue = word64 . fromIntegral @Word @Word64 +listToJsonValue :: ToValue a => [a] -> Value+{-# noinline listToJsonValue #-}+listToJsonValue xs = runST $ do+ let len = List.length xs+ dst <- PM.newSmallArray len Null+ let goListToJsonValue !ix ys = case ys of+ [] -> do+ dst' <- PM.unsafeFreezeSmallArray dst+ pure (Array dst')+ z : zs -> do+ PM.writeSmallArray dst ix $! toValue z+ goListToJsonValue (ix + 1) zs+ goListToJsonValue 0 xs+ instance (ToValue a) => ToValue [a] where- toValue !xs = runST $ do- let len = List.length xs- dst <- PM.newSmallArray len Null- let go !ix ys = case ys of- [] -> do- dst' <- PM.unsafeFreezeSmallArray dst- pure (Array dst')- z : zs -> do- PM.writeSmallArray dst ix $! toValue z- go (ix + 1) zs- go 0 xs+ {-# inline toValue #-}+ toValue = listToJsonValue instance (ToValue a) => ToValue (SmallArray a) where toValue !xs = Json.Array $! Contiguous.map' toValue xs
src/Json/Flatten.hs view
@@ -12,19 +12,21 @@ import Control.Monad.ST (ST) import Control.Monad.ST.Run (runByteArrayST) import Data.Builder.Catenable (Builder)-import qualified Data.Builder.Catenable as Builder import Data.ByteString.Short.Internal (ShortByteString (SBS))+import Data.Primitive (ByteArray (ByteArray), MutableByteArray, SmallArray)+import Data.Text.Short (ShortText)+import Data.Word (Word8)+import Json (Member (Member))+import Data.Text.Internal (Text(Text))++import qualified Data.Builder.Catenable as Builder import qualified Data.Bytes as Bytes import qualified Data.Bytes.Text.Utf8 as Utf8 import qualified Data.Chunks as Chunks-import Data.Primitive (ByteArray (ByteArray), MutableByteArray, SmallArray) import qualified Data.Primitive as PM import qualified Data.Primitive.Contiguous as C-import Data.Text.Short (ShortText) import qualified Data.Text.Short as TS import qualified Data.Text.Short.Unsafe as TS-import Data.Word (Word8)-import Json (Member (Member)) import qualified Json {- | Flatten a json value, recursively descending into objects and joining@@ -58,14 +60,14 @@ _ -> errorWithoutStackTrace "Json.Flatten.flatten: only period is supported" -- built backwards-data ShortTexts- = ShortTextsCons !ShortText !ShortTexts- | ShortTextsBase !ShortText+data Texts+ = TextsCons !Text !Texts+ | TextsBase !Text flattenPeriod :: Json.Value -> Json.Value flattenPeriod x = case x of Json.Object mbrs ->- let bldr = foldMap (\Member {key, value} -> flattenPrefix (ShortTextsBase key) value) mbrs+ let bldr = foldMap (\Member {key, value} -> flattenPrefix (TextsBase key) value) mbrs chunks = Builder.run bldr result = Chunks.concat chunks in Json.Object result@@ -73,53 +75,45 @@ _ -> x flattenPrefix ::- ShortTexts -> -- context accumulator+ Texts -> -- context accumulator Json.Value -> Builder Json.Member flattenPrefix !pre x = case x of Json.Object mbrs -> flattenObject pre mbrs _ -> let !a = flattenPeriod x- !k = runShortTexts pre+ !k = TS.toText $! runTexts pre !mbr = Json.Member {key = k, value = a} in Builder.Cons mbr Builder.Empty -flattenObject :: ShortTexts -> SmallArray Json.Member -> Builder Json.Member+flattenObject :: Texts -> SmallArray Json.Member -> Builder Json.Member flattenObject !pre !mbrs = foldMap- ( \Member {key, value} -> flattenPrefix (ShortTextsCons key pre) value+ ( \Member {key, value} -> flattenPrefix (TextsCons key pre) value ) mbrs -runShortTexts :: ShortTexts -> ShortText-runShortTexts !ts0 = go 0 ts0+runTexts :: Texts -> ShortText+runTexts !ts0 = go 0 ts0 where- paste :: MutableByteArray s -> Int -> ShortTexts -> ST s ByteArray- paste !dst !ix (ShortTextsBase t) =- let len = Bytes.length (Utf8.fromShortText t)- in case ix - len of- 0 -> do- PM.copyByteArray dst 0 (st2ba t) 0 len- PM.unsafeFreezeByteArray dst- _ -> errorWithoutStackTrace "Json.Flatten.runShortTexts: implementation mistake"- paste !dst !ix (ShortTextsCons t ts) = do- let !len = Bytes.length (Utf8.fromShortText t)+ paste :: MutableByteArray s -> Int -> Texts -> ST s ByteArray+ paste !dst !ix (TextsBase (Text arr off len)) = case ix - len of+ 0 -> do+ PM.copyByteArray dst 0 arr off len+ PM.unsafeFreezeByteArray dst+ _ -> errorWithoutStackTrace "Json.Flatten.runTexts: implementation mistake"+ paste !dst !ix (TextsCons (Text arr off len) ts) = do let !ixNext = ix - len- PM.copyByteArray dst ixNext (st2ba t) 0 len+ PM.copyByteArray dst ixNext arr off len let !ixPred = ixNext - 1 PM.writeByteArray dst ixPred (0x2E :: Word8) paste dst ixPred ts- go :: Int -> ShortTexts -> ShortText- go !byteLenAcc (ShortTextsCons t ts) =- go (Bytes.length (Utf8.fromShortText t) + byteLenAcc + 1) ts- go !byteLenAcc (ShortTextsBase t) =+ go :: Int -> Texts -> ShortText+ go !byteLenAcc (TextsCons t ts) =+ go (Bytes.length (Utf8.fromText t) + byteLenAcc + 1) ts+ go !byteLenAcc (TextsBase t) = let !(ByteArray r) = runByteArrayST $ do- let totalLen = Bytes.length (Utf8.fromShortText t) + byteLenAcc+ let totalLen = Bytes.length (Utf8.fromText t) + byteLenAcc dst <- PM.newByteArray totalLen paste dst totalLen ts0 in TS.fromShortByteStringUnsafe (SBS r)--st2ba :: ShortText -> ByteArray-{-# INLINE st2ba #-}-st2ba t = case TS.toShortByteString t of- SBS x -> ByteArray x
src/Json/Smile.hs view
@@ -59,10 +59,12 @@ import Json (Member (..), Value (..)) import Numeric.Natural (Natural) import System.IO.Unsafe (unsafeDupablePerformIO)+import Data.Text.Internal (Text(Text)) import qualified Arithmetic.Nat as Nat import qualified Data.ByteString.Short as SBS import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Text.Utf8 as Utf8 import qualified Data.Bytes.Builder as B import qualified Data.Bytes.Builder.Bounded as Bounded import qualified Data.Bytes.Builder.Bounded.Unsafe as Unsafe@@ -72,6 +74,7 @@ import qualified GHC.Num.BigNat as BN import qualified GHC.Num.Integer as Integer import qualified Prelude+import qualified Data.Text as Text {- | Encode a Json 'Value' to the Smile binary format. This encoder does not produce backreferences.@@ -261,31 +264,31 @@ n = SBS.length (TS.toShortByteString str) -- | Encode a string.-encodeString :: ShortText -> Builder-encodeString !str = case SBS.length (TS.toShortByteString str) of+encodeString :: Text -> Builder+encodeString str@(Text _ _ n) = case n of 0 -> B.word8 0x20- n -> case TS.isAscii str of+ _ -> case Text.isAscii str of Prelude.True- | n <= 64 -> B.copyCons (0x40 + fromIntegral (n - 1)) (Bytes.fromShortByteString (TS.toShortByteString str))- | otherwise -> B.word8 0xe0 <> B.shortTextUtf8 str <> B.word8 0xFC+ | n <= 64 -> B.copyCons (0x40 + fromIntegral (n - 1)) (Utf8.fromText str)+ | otherwise -> B.word8 0xe0 <> B.textUtf8 str <> B.word8 0xFC Prelude.False- | n <= 65 -> B.copyCons (0x80 + fromIntegral (n - 2)) (Bytes.fromShortByteString (TS.toShortByteString str))- | otherwise -> B.word8 0xE4 <> B.shortTextUtf8 str <> B.word8 0xFC+ | n <= 65 -> B.copyCons (0x80 + fromIntegral (n - 2)) (Utf8.fromText str)+ | otherwise -> B.word8 0xE4 <> B.textUtf8 str <> B.word8 0xFC -- | Encode a key.-encodeKey :: ShortText -> Builder-encodeKey !str = case SBS.length (TS.toShortByteString str) of+encodeKey :: Text -> Builder+encodeKey str@(Text _ _ n) = case n of 0 -> B.word8 0x20- n+ _ | n <= 64- && TS.isAscii str+ && Text.isAscii str , w8 <- fromIntegral @Int @Word8 (n - 1) ->- B.copyCons (0x80 + w8) (Bytes.fromShortByteString (TS.toShortByteString str))- n+ B.copyCons (0x80 + w8) (Utf8.fromText str)+ _ | n < 56 , w8 <- fromIntegral @Int @Word8 (n - 2) ->- B.copyCons (0xC0 + w8) (Bytes.fromShortByteString (TS.toShortByteString str))- | otherwise -> B.word8 0x34 <> B.shortTextUtf8 str <> B.word8 0xFC+ B.copyCons (0xC0 + w8) (Utf8.fromText str)+ | otherwise -> B.word8 0x34 <> B.textUtf8 str <> B.word8 0xFC {- | Encode a key in which all characters are ASCII. This precondition is not checked. Resulting output will be corrupt if this condition
test/Main.hs view
@@ -28,6 +28,7 @@ import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as M import qualified Data.Number.Scientific as SCI+import qualified Data.Text as T import qualified Data.Text.Short as TS import qualified GHC.Exts as Exts import qualified Json as J@@ -123,6 +124,12 @@ @=? BChunks.concat (Builder.run 4 (J.encode (J.String "It\2019s over now"))) ]+ , testGroup "decodeNewlineDelimited"+ [ THU.testCase "no-trailing-newline" $+ Right (Exts.fromList [J.emptyObject, J.emptyObject])+ @=?+ J.decodeNewlineDelimited (shortTextToBytes "{}\n{}")+ ] , testGroup "objectFromList" [ THU.testCase "empty object" $ J.objectFromList []@@ -250,10 +257,10 @@ ] jsonFromPrintableStrings :: [QC.PrintableString] -> J.Value-jsonFromPrintableStrings xs = J.Array (Exts.fromList (map (J.String . TS.pack . QC.getPrintableString) xs))+jsonFromPrintableStrings xs = J.Array (Exts.fromList (map (J.String . T.pack . QC.getPrintableString) xs)) jsonFromAsciiStrings :: [QC.ASCIIString] -> J.Value-jsonFromAsciiStrings xs = J.Array (Exts.fromList (map (J.String . TS.pack . QC.getASCIIString) xs))+jsonFromAsciiStrings xs = J.Array (Exts.fromList (map (J.String . T.pack . QC.getASCIIString) xs)) toBadSci :: SCI.Scientific -> Scientific toBadSci = SCI.withExposed@@ -265,10 +272,10 @@ J.True -> AE.Bool True J.False -> AE.Bool False J.Null -> AE.Null- J.String t -> AE.String (TS.toText t)+ J.String t -> AE.String t J.Number n -> AE.Number (toBadSci n) J.Object mbrs -> AE.Object $ foldr- (\(J.Member key val) hm -> M.insert (Key.fromShortText key) (toAesonValue val) hm)+ (\(J.Member key val) hm -> M.insert (Key.fromText key) (toAesonValue val) hm) M.empty mbrs J.Array vals -> AE.Array $ Exts.fromList $ foldr (\x xs -> toAesonValue x : xs) [] vals