diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 diff --git a/json-syntax.cabal b/json-syntax.cabal --- a/json-syntax.cabal +++ b/json-syntax.cabal @@ -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 diff --git a/src/Json.hs b/src/Json.hs --- a/src/Json.hs +++ b/src/Json.hs @@ -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 diff --git a/src/Json/Flatten.hs b/src/Json/Flatten.hs --- a/src/Json/Flatten.hs +++ b/src/Json/Flatten.hs @@ -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 diff --git a/src/Json/Smile.hs b/src/Json/Smile.hs --- a/src/Json/Smile.hs +++ b/src/Json/Smile.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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