diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for json-syntax +## 0.1.1.0 -- 2020-05-01 + +* Add `encode`. + ## 0.1.0.0 -- 2020-01-20 * Initial release. diff --git a/common/Twitter100.hs b/common/Twitter100.hs --- a/common/Twitter100.hs +++ b/common/Twitter100.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Twitter100 ( encodedTwitter100 diff --git a/json-syntax.cabal b/json-syntax.cabal --- a/json-syntax.cabal +++ b/json-syntax.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: json-syntax -version: 0.1.0.0 -synopsis: High-performance JSON parser +version: 0.1.1.0 +synopsis: High-performance JSON parser and encoder description: This library parses JSON into a @Value@ type that is consistent with the ABNF described in [RFC 7159](https://tools.ietf.org/html/rfc7159). The @@ -14,8 +14,8 @@ and typeclasses are outside the scope of this library. If anyone writes a library that offers users these conveniences open a issue so that the @json-syntax@ documentation can point users to it. -homepage: https://github.com/andrewthad/json-syntax -bug-reports: https://github.com/andrewthad/json-syntax/issues +homepage: https://github.com/byteverse/json-syntax +bug-reports: https://github.com/byteverse/json-syntax/issues license: BSD-3-Clause license-file: LICENSE author: Andrew Martin @@ -31,12 +31,13 @@ , array-builder >=0.1 && <0.2 , array-chunks >=0.1.1 && <0.2 , base >=4.12 && <5 - , bytesmith >=0.3.2 && <0.4 + , bytebuild >=0.3.4 && <0.4 , byteslice >=0.1.3 && <0.3 - , scientific-notation >=0.1.1 && <0.2 - , text-short >=0.1.3 && <0.2 - , primitive >=0.7 && <0.8 + , bytesmith >=0.3.2 && <0.4 , bytestring >=0.10.8 && <0.11 + , primitive >=0.7 && <0.8 + , scientific-notation >=0.1.2 && <0.2 + , text-short >=0.1.3 && <0.2 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -O2 @@ -60,7 +61,7 @@ , primitive , scientific , scientific-notation >=0.1.1 - , small-bytearray-builder + , bytebuild , tasty >=1.2.3 && <1.3 , tasty-hunit >=0.10.0.2 && <0.11 , text >=1.2 diff --git a/src/Json.hs b/src/Json.hs --- a/src/Json.hs +++ b/src/Json.hs @@ -5,7 +5,9 @@ {-# language DeriveAnyClass #-} {-# language LambdaCase #-} {-# language MagicHash #-} +{-# language NamedFieldPuns #-} {-# language TypeApplications #-} +{-# language UnboxedTuples #-} module Json ( -- * Types @@ -14,6 +16,7 @@ , SyntaxException(..) -- * Functions , decode + , encode ) where import Prelude hiding (Bool(True,False)) @@ -25,7 +28,7 @@ import Data.Bytes.Parser (Parser) import Data.Bytes.Types (Bytes(..)) import Data.Char (ord) -import Data.Chunks (Chunks(ChunksNil)) +import Data.Chunks (Chunks(ChunksNil,ChunksCons)) import Data.Number.Scientific (Scientific) import Data.Primitive (ByteArray,MutableByteArray) import Data.Text.Short (ShortText) @@ -34,6 +37,7 @@ import qualified Prelude import qualified Data.Builder.ST as B +import qualified Data.Bytes.Builder as BLDR import qualified Data.Bytes.Parser as P import qualified Data.Text.Short.Unsafe as TS import qualified Data.Number.Scientific as SCI @@ -122,6 +126,70 @@ P.skipWhile isSpace P.endOfInput UnexpectedLeftovers pure result + +encode :: Value -> BLDR.Builder +encode = \case + 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 + Number n -> SCI.builderUtf8 n + Array ys -> case unconsNonempty ys of + Nothing -> BLDR.ascii2 '[' ']' + Just (x,xs) -> + BLDR.ascii '[' + <> + encode (PM.indexSmallArray x 0) + <> + foldrTail + ( \v b -> BLDR.ascii ',' <> encode v <> b + ) + ( foldr + ( \v b -> BLDR.ascii ',' <> encode v <> b + ) (BLDR.ascii ']') xs + ) + x + Object ys -> case unconsNonempty ys of + Nothing -> BLDR.ascii2 '{' '}' + Just (x,xs) -> + BLDR.ascii '{' + <> + encodeMember (PM.indexSmallArray x 0) + <> + foldrTail + ( \mbr b -> BLDR.ascii ',' <> encodeMember mbr <> b + ) + ( foldr + ( \mbr b -> BLDR.ascii ',' <> encodeMember mbr <> b + ) (BLDR.ascii '}') xs + ) + x + +encodeMember :: Member -> BLDR.Builder +encodeMember Member{key,value} = + BLDR.shortTextJsonString key + <> + BLDR.ascii ':' + <> + encode value + +foldrTail :: (a -> b -> b) -> b -> PM.SmallArray a -> b +{-# inline foldrTail #-} +foldrTail f z !ary = go 1 where + !sz = PM.sizeofSmallArray ary + go i + | i == sz = z + | (# x #) <- PM.indexSmallArray## ary i + = f x (go (i+1)) + +-- Get the first non-empty SmallArray from the Chunks. +unconsNonempty :: Chunks a -> Maybe (PM.SmallArray a, Chunks a) +{-# inline unconsNonempty #-} +unconsNonempty = go where + go ChunksNil = Nothing + go (ChunksCons x xs) = case PM.sizeofSmallArray x of + 0 -> go xs + _ -> Just (x,xs) -- Precondition: skip over all space before calling this. -- It will not skip leading space for you. It does diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,7 @@ {-# language LambdaCase #-} {-# language OverloadedStrings #-} +import Control.Monad (when) import Data.ByteString.Short.Internal (ShortByteString(SBS)) import Data.Bytes (Bytes) import Data.Primitive (ByteArray(ByteArray)) @@ -12,6 +13,8 @@ import qualified Data.Aeson as AE import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Builder as Builder +import qualified Data.Bytes.Chunks as BChunks import qualified Data.Chunks as Chunks import qualified Data.HashMap.Strict as HM import qualified Data.Number.Scientific as SCI @@ -65,7 +68,12 @@ Right j -> case AE.decodeStrict byteStringTwitter100 of Nothing -> fail "aeson is messed up" Just ae -> ae @=? toAesonValue j - + , THU.testCase "Twitter100-roundtrip" $ + case J.decode (Bytes.fromByteArray encodedTwitter100) of + Left _ -> fail "nope, Twitter100 test will be failing too" + Right j -> case J.decode (BChunks.concat (Builder.run 1 (J.encode j))) of + Left _ -> fail "encode did not produce a document that could be decoded" + Right j' -> when (j /= j') (fail "document was not the same after roundtrip") ] toBadSci :: SCI.Scientific -> Scientific