json-syntax 0.2.2.0 → 0.2.3.0

raw patch · 6 files changed

+225/−15 lines, 6 filesdep −integer-gmpdep ~basedep ~byteslicedep ~primitivePVP ok

version bump matches the API change (PVP)

Dependencies removed: integer-gmp

Dependency ranges changed: base, byteslice, primitive

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• common/Person.hs +51/−0
• json-syntax.cabal +6/−5
• src/Json/Flatten.hs +121/−0
• src/Json/Smile.hs +20/−9
• test/Main.hs +21/−1

@@ -1,5 +1,11 @@ # Revision history for json-syntax +## 0.2.3.0 -- 2022-03-22++* Add `Json.Flatten` module.+* Drop support for GHCs older than 9.0.+* Replace integer-gmp with ghc-bignum.+ ## 0.2.2.0 -- 2022-07-15  * Build with GHC 9.2.3.

@@ -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"]+    }+  |]+

@@ -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,19 +28,19 @@ 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+    , base >=4.15 && <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     , natural-arithmetic >=0.1.2 && <0.2     , contiguous >=0.6 && <0.7-    , primitive >=0.7 && <0.8+    , primitive >=0.7 && <0.10     , run-st >=0.1.1 && <0.2     , scientific-notation >=0.1.5 && <0.2     , text-short >=0.1.3 && <0.2@@ -57,6 +57,7 @@   main-is: Main.hs   other-modules:     Twitter100+    Person   ghc-options: -Wall -O2   build-depends:     , QuickCheck >=2.14.2

@@ -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

@@ -5,6 +5,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedTuples #-}  module Json.Smile   ( -- * Encode JSON Document@@ -35,6 +36,8 @@ import Data.Text.Short (ShortText) import Data.Word (Word8,Word32,Word64) import Data.Word.Zigzag (toZigzag32,toZigzag64)+import GHC.Exts (RealWorld,Word#,State#)+import GHC.IO (IO(IO)) import GHC.Word (Word(..)) import Json (Value(..), Member(..)) import Numeric.Natural (Natural)@@ -49,7 +52,8 @@ import qualified Data.Number.Scientific as Sci import qualified Data.Text.Short as TS import qualified GHC.Exts as Exts-import qualified GHC.Integer.GMP.Internals as GMP+import qualified GHC.Num.BigNat as BN+import qualified GHC.Num.Integer as Integer import qualified Prelude  -- | Encode a Json 'Value' to the Smile binary format.@@ -118,11 +122,11 @@ integerToBase256ByteArray c = if c == 0   then byteArrayFromListN 1 [0::Word8]   else case c of-    GMP.Jp# bn -> unsafeDupablePerformIO $ do-      let nDigits256 = fromIntegral @Word @Int (W# (GMP.sizeInBaseBigNat bn 256#))+    Integer.IP bn -> unsafeDupablePerformIO $ do+      let nDigits256 = fromIntegral @Word @Int (W# (BN.bigNatSizeInBase# 256## bn))       mut <- newByteArray nDigits256       let !(MutableByteArray mut#) = mut-      !_ <- GMP.exportBigNatToMutableByteArray bn mut# 0## 1#+      !_ <- liftWordIO (BN.bigNatToMutableByteArray# bn mut# 0## 1# )       -- This is safe because Jp cannot have zero inside it.       w0 :: Word8 <- readByteArray mut 0       if testBit w0 7@@ -134,17 +138,24 @@           copyMutableByteArray dst 1 mut 0 nDigits256           unsafeFreezeByteArray dst         else unsafeFreezeByteArray mut-    GMP.Jn# bn -> twosComplementBigNat bn-    GMP.S# i -> case i Exts.># 0# of+    Integer.IN bn -> twosComplementBigNat bn+    Integer.IS i -> case i Exts.># 0# of       1# -> encodePosWordBase256 (W# (Exts.int2Word# i))       _ -> encodeNegWordBase256 (W# (Exts.int2Word# i)) -twosComplementBigNat :: GMP.BigNat -> ByteArray+liftWordIO :: (State# RealWorld -> (# State# RealWorld, Word# #)) -> IO Word+{-# inline liftWordIO #-}+liftWordIO f = IO+  (\s -> case f s of+    (# s', w #) -> (# s', W# w #)+  )++twosComplementBigNat :: BN.BigNat# -> ByteArray twosComplementBigNat bn = unsafeDupablePerformIO $ do-  let nDigits256 = fromIntegral @Word @Int (W# (GMP.sizeInBaseBigNat bn 256#))+  let nDigits256 = fromIntegral @Word @Int (W# (BN.bigNatSizeInBase# 256## bn))   mut <- newByteArray nDigits256   let !(MutableByteArray mut#) = mut-  !_ <- GMP.exportBigNatToMutableByteArray bn mut# 0## 1#+  !_ <- liftWordIO (BN.bigNatToMutableByteArray# bn mut# 0## 1# )   -- First, complement   let goComplement !ix = if ix >= 0         then do

@@ -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)@@ -109,6 +112,16 @@         case J.decode enc of           Left e -> QC.counterexample (show e) False           Right val1 -> val0 === val1+    , THU.testCase "Q" $+        -- Test that Unicode <right single quotation mark> is decoded correctly.+        Right (J.String "It\2019s over now")+        @=?+        J.decode (shortTextToBytes "\"It\2019s over now\"")+    , THU.testCase "R" $+        -- Test that Unicode <right single quotation mark> is encoded correctly.+        shortTextToBytes "\"It\2019s over now\""+        @=?+        BChunks.concat (Builder.run 4 (J.encode (J.String "It\2019s over now")))     ]   , testGroup "smile-fragment"     [ THU.testCase "biginteger-65535" $@@ -207,6 +220,13 @@         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