Add encode function

Author: andrewthad

common/Twitter100.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 module Twitter100
   ( encodedTwitter100

json-syntax.cabal

@@ -31,12 +31,13 @@ library
     , 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
+    , bytesmith >=0.3.2 && <0.4
+    , bytestring >=0.10.8 && <0.11
+    , primitive >=0.7 && <0.8
     , scientific-notation >=0.1.1 && <0.2
     , text-short >=0.1.3 && <0.2
-    , primitive >=0.7 && <0.8
-    , bytestring >=0.10.8 && <0.11
   hs-source-dirs: src
   default-language: Haskell2010
   ghc-options: -Wall -O2
@@ -60,7 +61,7 @@ test-suite test
     , 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

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 @@ module Json
   , SyntaxException(..)
     -- * Functions
   , decode
+  , encode
   ) where
 
 import Prelude hiding (Bool(True,False))
@@ -25,7 +28,7 @@ import Data.Builder.ST (Builder)
 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 GHC.Word (Word8(W8#),Word16(W16#))
 
 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
@@ -123,6 +127,70 @@ decode = P.parseBytesEither do
   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
 parser :: Char -> Parser SyntaxException s Value

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 Twitter100 (encodedTwitter100,byteStringTwitter100)
 
 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 @@ tests = testGroup "Tests"
         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