Add Json.Flatten

Author: andrewthad

CHANGELOG.md

@@ -1,5 +1,9 @@
 # Revision history for json-syntax
 
+## 0.2.3.0 -- 2022-??-??
+
+* Add `Json.Flatten` module.
+
 ## 0.2.2.0 -- 2022-07-15
 
 * Build with GHC 9.2.3.

common/Person.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Person
+  ( encodedPerson
+  , encodedFlattenedPerson
+  ) where
+
+import Data.ByteString (ByteString)
+import Data.ByteString.Short (ShortByteString,toShort)
+import Data.Primitive (ByteArray)
+import Data.Text.Encoding (encodeUtf8)
+import NeatInterpolation (text)
+
+import qualified Data.Primitive as PM
+import qualified Data.ByteString.Short.Internal as BSS
+
+shortByteStringToByteArray :: ShortByteString -> ByteArray 
+shortByteStringToByteArray (BSS.SBS x) = PM.ByteArray x
+
+encodedPerson :: ByteArray
+encodedPerson =
+  shortByteStringToByteArray (toShort byteStringPerson)
+
+encodedFlattenedPerson :: ByteArray
+encodedFlattenedPerson =
+  shortByteStringToByteArray (toShort byteStringFlattenedPerson)
+
+byteStringPerson :: ByteString
+byteStringPerson = encodeUtf8
+  [text|
+    { "name": "bilbo"
+    , "occupation":
+      { "name": "burglar"
+      , "start": "2022-05-30"
+      }
+    , "height": 124
+    , "favorites": ["adventures","lunch"]
+    }
+  |]
+
+byteStringFlattenedPerson :: ByteString
+byteStringFlattenedPerson = encodeUtf8
+  [text|
+    { "name": "bilbo"
+    , "occupation.name": "burglar"
+    , "occupation.start": "2022-05-30"
+    , "height": 124
+    , "favorites": ["adventures","lunch"]
+    }
+  |]
+

json-syntax.cabal

@@ -1,6 +1,6 @@
 cabal-version: 2.2
 name: json-syntax
-version: 0.2.2.0
+version: 0.2.3.0
 synopsis: High-performance JSON parser and encoder
 description:
   This library parses JSON into a @Value@ type that is consistent with the
@@ -28,13 +28,14 @@ extra-source-files: CHANGELOG.md
 library
   exposed-modules:
     Json
+    Json.Flatten
     Json.Smile
   build-depends:
     , array-builder >=0.1 && <0.2
     , array-chunks >=0.1.3 && <0.2
     , base >=4.12 && <5
     , bytebuild >=0.3.10 && <0.4
-    , byteslice >=0.1.3 && <0.3
+    , byteslice >=0.2.9 && <0.3
     , bytesmith >=0.3.8 && <0.4
     , bytestring >=0.10.8 && <0.12
     , integer-gmp >=1.0 && <1.2
@@ -57,6 +58,7 @@ test-suite test
   main-is: Main.hs
   other-modules:
     Twitter100
+    Person
   ghc-options: -Wall -O2
   build-depends:
     , QuickCheck >=2.14.2

src/Json/Flatten.hs

@@ -0,0 +1,121 @@
+{-# language BangPatterns #-}
+{-# language DuplicateRecordFields #-}
+{-# language NamedFieldPuns #-}
+
+-- | Flatten nested JSON objects into a single JSON object in which the keys
+-- have been joined by the separator.
+module Json.Flatten
+  ( flatten
+  ) where
+
+import Control.Monad.ST (ST)
+import Control.Monad.ST.Run (runByteArrayST)
+import Data.Builder.Catenable (Builder)
+import Data.ByteString.Short.Internal (ShortByteString(SBS))
+import Data.Text.Short (ShortText)
+import Data.Primitive (SmallArray,ByteArray(ByteArray),MutableByteArray)
+import Data.Word (Word8)
+import Json (Member(Member))
+import qualified Json
+import qualified Data.Chunks as Chunks
+import qualified Data.Primitive.Contiguous as C
+import qualified Data.Bytes as Bytes
+import qualified Data.Bytes.Text.Utf8 as Utf8
+import qualified Data.Primitive as PM
+import qualified Data.Builder.Catenable as Builder
+import qualified Data.Text.Short as TS
+import qualified Data.Text.Short.Unsafe as TS
+
+-- | Flatten a json value, recursively descending into objects and joining
+-- keys with the separator. For example:
+--
+-- > { "name": "bilbo"
+-- > , "occupation":
+-- >   { "name": "burglar"
+-- >   , "start": "2022-05-30"
+-- >   }
+-- > , "height": 124
+-- > , "favorites": ["adventures","lunch"]
+-- > }
+--
+-- Becomes:
+--
+-- > { "name": "bilbo"
+-- > , "occupation.name": "burglar"
+-- > , "occupation.start": "2022-05-30"
+-- > , "height": 124
+-- > , "favorites": ["adventures","lunch"]
+-- > }
+--
+-- Currently, the implementation of this function throws an exception if
+-- any separator other than period is used. This may be corrected in a future
+-- release.
+flatten :: Char -> Json.Value -> Json.Value
+flatten c v = case c of
+  '.' -> flattenPeriod v
+  _ -> errorWithoutStackTrace "Json.Flatten.flatten: only period is supported"
+
+-- built backwards
+data ShortTexts
+  = ShortTextsCons !ShortText !ShortTexts
+  | ShortTextsBase !ShortText
+
+flattenPeriod :: Json.Value -> Json.Value
+flattenPeriod x = case x of
+  Json.Object mbrs ->
+    let bldr = foldMap (\Member{key,value} -> flattenPrefix (ShortTextsBase key) value) mbrs
+        chunks = Builder.run bldr
+        result = Chunks.concat chunks
+     in Json.Object result
+  Json.Array ys -> Json.Array $! C.map' flattenPeriod ys
+  _ -> x
+
+flattenPrefix ::
+     ShortTexts -- 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
+        !mbr = Json.Member{key=k,value=a}
+     in Builder.Cons mbr Builder.Empty
+
+flattenObject :: ShortTexts -> SmallArray Json.Member -> Builder Json.Member
+flattenObject !pre !mbrs = foldMap
+  (\Member{key,value} -> flattenPrefix (ShortTextsCons key pre) value
+  ) mbrs
+
+runShortTexts :: ShortTexts -> ShortText
+runShortTexts !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)
+    let !ixNext = ix - len
+    PM.copyByteArray dst ixNext (st2ba t) 0 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) =
+    let !(ByteArray r) = runByteArrayST $ do
+          let totalLen = Bytes.length (Utf8.fromShortText 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

test/Main.hs

@@ -1,13 +1,16 @@
 {-# language LambdaCase #-}
+{-# language MultiWayIf #-}
 {-# language OverloadedStrings #-}
 {-# language ScopedTypeVariables #-}
 
 import Control.Monad (when)
-import Data.Bytes (Bytes)
 import Data.ByteString.Short.Internal (ShortByteString(SBS))
+import Data.Bytes (Bytes)
 import Data.Primitive (ByteArray(ByteArray))
 import Data.Scientific (Scientific,scientific)
 import Data.Text.Short (ShortText)
+import Json.Flatten (flatten)
+import Person (encodedPerson,encodedFlattenedPerson)
 import System.IO (withFile,IOMode(..))
 import Test.QuickCheck ((===))
 import Test.Tasty (defaultMain,testGroup,TestTree)
@@ -217,6 +220,13 @@ tests = testGroup "Tests"
         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")
+  , testGroup "flatten"
+      [ THU.testCase "Person" $ 
+          if | Right original <- J.decode (Bytes.fromByteArray encodedPerson)
+             , Right flattened <- J.decode (Bytes.fromByteArray encodedFlattenedPerson)
+               -> flattened @=? flatten '.' original
+             | otherwise -> fail "bad input from common/Person.hs"
+      ]
   ]
 
 jsonFromPrintableStrings :: [QC.PrintableString] -> J.Value