json-syntax 0.2.6.1 → 0.2.7.0
raw patch · 3 files changed
+98/−13 lines, 3 filesdep +transformersdep ~text
Dependencies added: transformers
Dependency ranges changed: text
Files
- CHANGELOG.md +5/−0
- json-syntax.cabal +4/−3
- src/Json.hs +89/−10
CHANGELOG.md view
@@ -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`.
json-syntax.cabal view
@@ -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
src/Json.hs view
@@ -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)