diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for json-syntax +## 0.2.7.0 -- 2023-10-05 + +* Add `decodeNewlineDelimited`. +* Add `toChunks`, `toBytes`, `toText`, `toShortText`, `toByteArray`. + ## 0.2.6.1 -- 2023-07-28 * Correct implementations of `object15` and `object16`. 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.6.1 +version: 0.2.7.0 synopsis: High-performance JSON parser and encoder description: This library parses JSON into a @Value@ type that is consistent with the @@ -38,15 +38,16 @@ , byteslice >=0.2.9 && <0.3 , bytesmith >=0.3.8 && <0.4 , bytestring >=0.10.8 && <0.12 - , natural-arithmetic >=0.1.2 && <0.3 , 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 , text-short >=0.1.3 && <0.2 + , transformers >=0.5.6.2 , word-compat >=0.0.3 , zigzag >=0.0.1 - , text >=1.2 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -O2 diff --git a/src/Json.hs b/src/Json.hs --- a/src/Json.hs +++ b/src/Json.hs @@ -20,7 +20,13 @@ , ToValue(..) -- * Functions , decode + , decodeNewlineDelimited , encode + , toChunks + , toShortText + , toText + , toBytes + , toByteArray -- * Infix Synonyms , pattern (:->) -- * Constants @@ -72,15 +78,21 @@ import Data.Bytes.Types (Bytes(..)) import Data.Char (ord) import Data.Number.Scientific (Scientific) -import Data.Primitive (ByteArray,MutableByteArray,SmallArray,Array,PrimArray,Prim) +import Data.Primitive (ByteArray(ByteArray),MutableByteArray,SmallArray,Array,PrimArray,Prim) import Data.Text.Short (ShortText) import GHC.Exts (Char(C#),Int(I#),gtWord#,ltWord#,word2Int#,chr#) import GHC.Word (Word8,Word16,Word32,Word64) import GHC.Int (Int8,Int16,Int32,Int64) import Data.Text (Text) +import Data.Foldable (foldlM) +import Control.Monad.Trans.Except (runExceptT,except) +import Control.Monad.Trans.Class (lift) +import Data.Bytes.Chunks (Chunks) import qualified Prelude import qualified Data.Builder.ST as B +import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Chunks as ByteChunks import qualified Data.Bytes.Builder as BLDR import qualified Data.Bytes.Parser as P import qualified Data.Chunks as Chunks @@ -142,6 +154,7 @@ | InvalidNumber | LeadingZero | UnexpectedLeftovers + | PossibleOverflow deriving stock (Eq,Show) deriving anyclass (Exception) @@ -172,13 +185,78 @@ -- | Decode a JSON syntax tree from a byte sequence. decode :: Bytes -> Either SyntaxException Value -decode = P.parseBytesEither do +{-# noinline decode #-} +decode = P.parseBytesEither parser + +parser :: Parser SyntaxException s Value +{-# inline parser #-} +parser = do P.skipWhile isSpace - result <- Latin.any EmptyInput >>= parser + result <- Latin.any EmptyInput >>= parserStep P.skipWhile isSpace P.endOfInput UnexpectedLeftovers pure result +-- | Decode newline-delimited JSON. Both the LF and the CRLF conventions +-- are supported. The newline character (or character sequence) following +-- the final object may be omitted. This also allows blanks lines consisting +-- of only whitespace. +-- +-- It's not strictly necessary for this to be a part of this library, but +-- newline-delimited JSON is somewhat common in practice. It's nice to have +-- 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 +-- more than 10 million newlines. If this is causing a problem for you, open +-- an issue. +-- +-- Other note: in the future, this function might be changed transparently +-- to parallelize the decoding of large input (at least 1000 lines) with +-- GHC sparks. +decodeNewlineDelimited :: Bytes -> Either SyntaxException (SmallArray Value) +{-# noinline decodeNewlineDelimited #-} +decodeNewlineDelimited !everything = + let maxVals = Bytes.count 0x0A everything + 1 + in if maxVals > 10000000 + then Left PossibleOverflow + else runST $ runExceptT $ do + !dst <- PM.newSmallArray maxVals Null + !total <- foldlM + (\ !ix b -> + let clean = Bytes.dropWhile isSpace (Bytes.dropWhileEnd isSpace b) + in if Bytes.null clean + then pure ix + else do + v <- except (decode clean) + lift (PM.writeSmallArray dst ix v) + pure (ix + 1) + ) 0 (Bytes.split 0x0A everything) + lift $ PM.shrinkSmallMutableArray dst total + dst' <- lift $ PM.unsafeFreezeSmallArray dst + pure dst' + +toChunks :: Value -> Chunks +{-# inline toChunks #-} +toChunks = BLDR.run 512 . encode + +toBytes :: Value -> Bytes +{-# inline toBytes #-} +toBytes = ByteChunks.concat . toChunks + +toByteArray :: Value -> ByteArray +{-# inline toByteArray #-} +toByteArray = ByteChunks.concatU . toChunks + +toShortText :: Value -> ShortText +{-# inline toShortText #-} +toShortText v = case toByteArray v of + ByteArray x -> TS.fromShortByteStringUnsafe (BSS.SBS x) + +toText :: Value -> Text +{-# inline toText #-} +toText = TS.toText . toShortText + -- | Encode a JSON syntax tree. encode :: Value -> BLDR.Builder {-# noinline encode #-} @@ -229,9 +307,10 @@ = f x (go (i+1)) -- Precondition: skip over all space before calling this. --- It will not skip leading space for you. It does -parser :: Char -> Parser SyntaxException s Value -parser = \case +-- It will not skip leading space for you. It does not skip +-- over trailing space either. +parserStep :: Char -> Parser SyntaxException s Value +parserStep = \case '{' -> objectTrailedByBrace '[' -> arrayTrailedByBracket 't' -> do @@ -266,7 +345,7 @@ P.skipWhile isSpace Latin.char ExpectedColon ':' P.skipWhile isSpace - val <- Latin.any IncompleteObject >>= parser + val <- Latin.any IncompleteObject >>= parserStep let !mbr = Member theKey val !b0 <- P.effect B.new b1 <- P.effect (B.push mbr b0) @@ -285,7 +364,7 @@ P.skipWhile isSpace Latin.char ExpectedColon ':' P.skipWhile isSpace - val <- Latin.any IncompleteObject >>= parser + val <- Latin.any IncompleteObject >>= parserStep let !mbr = Member theKey val P.effect (B.push mbr b) >>= objectStep '}' -> do @@ -310,7 +389,7 @@ ']' -> pure emptyArray c -> do !b0 <- P.effect B.new - val <- parser c + val <- parserStep c b1 <- P.effect (B.push val b0) arrayStep b1 @@ -328,7 +407,7 @@ Latin.any IncompleteArray >>= \case ',' -> do P.skipWhile isSpace - val <- Latin.any IncompleteArray >>= parser + val <- Latin.any IncompleteArray >>= parserStep P.effect (B.push val b) >>= arrayStep ']' -> do !r <- P.effect (B.freeze b)