json-syntax 0.2.7.0 → 0.2.7.1
raw patch · 11 files changed
+867/−634 lines, 11 filesdep ~textdep ~transformersdep ~word-compatsetup-changednew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: text, transformers, word-compat, zigzag
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−1
- Setup.hs +1/−0
- bench/Main.hs +79/−58
- common/Metrics1024.hs +7/−5
- common/Person.hs +10/−8
- common/Twitter100.hs +7/−6
- common/Url100.hs +7/−7
- json-syntax.cabal +66/−57
- src/Json.hs +478/−322
- src/Json/Flatten.hs +52/−48
- src/Json/Smile.hs +155/−122
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for json-syntax +## 0.2.7.1 -- 2024-01-29++* Update package metadata.+ ## 0.2.7.0 -- 2023-10-05 * Add `decodeNewlineDelimited`.@@ -19,7 +23,7 @@ * Add `ToValue` instances for `Word`, `Text`, `Value`, `Scientific`, list (i.e. `[]`), the unit type (i.e. `()`), * Add `text` and `shortText` for value construction.- + ## 0.2.4.0 -- 2023-06-27
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
bench/Main.hs view
@@ -1,20 +1,19 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -import Gauge.Main (defaultMain,bgroup,bench,whnf)+import Gauge.Main (bench, bgroup, defaultMain, whnf) import Metrics1024 (encodedMetrics1024)-import Twitter100 (encodedTwitter100,byteStringTwitter100)-import Url100 (encodedUrl100,byteStringUrl100)+import Twitter100 (byteStringTwitter100, encodedTwitter100)+import Url100 (byteStringUrl100, encodedUrl100) +import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as LBS import qualified Data.Bytes as Bytes import qualified Data.Bytes.Builder as BLDR import qualified Data.Bytes.Chunks as Chunks-import qualified Data.ByteString.Lazy as LBS import qualified Json as J import qualified Json.Smile as Smile-import qualified Data.Aeson as Aeson main :: IO () main = do@@ -31,58 +30,80 @@ Nothing -> fail "aeson failed to decode twitter-100" Just (v :: Aeson.Value) -> pure v defaultMain- [ bgroup "json"- [ bgroup "twitter"- [ bgroup "100"- [ bench "decode" $ whnf- (\b -> J.decode (Bytes.fromByteArray b))- encodedTwitter100- , bench "encode" $ whnf- (\v -> Chunks.length (BLDR.run 128 (J.encode v)))- valueTwitter100- , bench "encode-smile" $ whnf- (\v -> Chunks.length (BLDR.run 128 (Smile.encode v)))- valueTwitter100- ]- ]- , bgroup "url"- [ bgroup "100"- [ bench "decode" $ whnf- (\b -> J.decode (Bytes.fromByteArray b))- encodedUrl100- , bench "encode" $ whnf- (\v -> Chunks.length (BLDR.run 128 (J.encode v)))- valueUrl100- , bench "encode-smile" $ whnf- (\v -> Chunks.length (BLDR.run 128 (Smile.encode v)))- valueUrl100- ]- ]- , bgroup "metrics"- [ bgroup "1024"- [ bench "encode" $ whnf- (\v -> Chunks.length (BLDR.run 128 (J.encode v)))- valueMetrics1024- , bench "encode-smile" $ whnf- (\v -> Chunks.length (BLDR.run 128 (Smile.encode v)))- valueMetrics1024- ]- ]- ]- , bgroup "aeson"- [ bgroup "twitter"- [ bgroup "100"- [ bench "decode"- (whnf (Aeson.decodeStrict' @Aeson.Value) byteStringTwitter100)- , bench "encode" $ whnf- (\v -> LBS.length (Aeson.encode v))- aesonValueTwitter100- ]+ [ bgroup+ "json"+ [ bgroup+ "twitter"+ [ bgroup+ "100"+ [ bench "decode" $+ whnf+ (\b -> J.decode (Bytes.fromByteArray b))+ encodedTwitter100+ , bench "encode" $+ whnf+ (\v -> Chunks.length (BLDR.run 128 (J.encode v)))+ valueTwitter100+ , bench "encode-smile" $+ whnf+ (\v -> Chunks.length (BLDR.run 128 (Smile.encode v)))+ valueTwitter100+ ]+ ]+ , bgroup+ "url"+ [ bgroup+ "100"+ [ bench "decode" $+ whnf+ (\b -> J.decode (Bytes.fromByteArray b))+ encodedUrl100+ , bench "encode" $+ whnf+ (\v -> Chunks.length (BLDR.run 128 (J.encode v)))+ valueUrl100+ , bench "encode-smile" $+ whnf+ (\v -> Chunks.length (BLDR.run 128 (Smile.encode v)))+ valueUrl100+ ]+ ]+ , bgroup+ "metrics"+ [ bgroup+ "1024"+ [ bench "encode" $+ whnf+ (\v -> Chunks.length (BLDR.run 128 (J.encode v)))+ valueMetrics1024+ , bench "encode-smile" $+ whnf+ (\v -> Chunks.length (BLDR.run 128 (Smile.encode v)))+ valueMetrics1024+ ]+ ] ]- , bgroup "url"- [ bgroup "100"- [ bench "decode" (whnf (Aeson.decodeStrict' @Aeson.Value) byteStringUrl100)- ]+ , bgroup+ "aeson"+ [ bgroup+ "twitter"+ [ bgroup+ "100"+ [ bench+ "decode"+ (whnf (Aeson.decodeStrict' @Aeson.Value) byteStringTwitter100)+ , bench "encode" $+ whnf+ (\v -> LBS.length (Aeson.encode v))+ aesonValueTwitter100+ ]+ ]+ , bgroup+ "url"+ [ bgroup+ "100"+ [ bench "decode" (whnf (Aeson.decodeStrict' @Aeson.Value) byteStringUrl100)+ ]+ ] ]- ] ]
common/Metrics1024.hs view
@@ -1,20 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+ module Metrics1024 ( encodedMetrics1024 , byteStringMetrics1024 ) where import Data.ByteString (ByteString)-import Data.ByteString.Short (ShortByteString,toShort)+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+import qualified Data.Primitive as PM -shortByteStringToByteArray :: ShortByteString -> ByteArray +shortByteStringToByteArray :: ShortByteString -> ByteArray shortByteStringToByteArray (BSS.SBS x) = PM.ByteArray x encodedMetrics1024 :: ByteArray@@ -22,8 +23,9 @@ shortByteStringToByteArray (toShort byteStringMetrics1024) byteStringMetrics1024 :: ByteString-byteStringMetrics1024 = encodeUtf8- [text|+byteStringMetrics1024 =+ encodeUtf8+ [text| [ {"@id":"1E7nJ7Ki1ei1mSOuy","@service":"npm","@historical":false,"@timestamp":"2022-02-01T15:10:00Z","@row":"1","organization.acronym":"nyc","agent.type":"freight","host.address":"192.0.2.43","host.ip":"192.0.2.43","host.model":"unknown","host.model_oid":"1.3.6.1.4.1.14988.1","host.vendor":"mikrotik","component.cpu.utilization":0,"component.name":"","host.hostname":"NYC-S75-APT4215"} , {"@id":"1E7nJ7SponsUYpH9l","@service":"npm","@historical":false,"@timestamp":"2022-02-01T15:10:00Z","@row":"2","organization.acronym":"nyc","agent.type":"freight","host.address":"192.0.2.43","host.ip":"192.0.2.43","host.model":"unknown","host.model_oid":"1.3.6.1.4.1.14988.1","host.vendor":"mikrotik","component.cpu.utilization":0,"component.name":"","host.hostname":"NYC-S75-APT4215"} , {"@id":"1E7nJ7VyTvxK5KDVi","@service":"npm","@historical":false,"@timestamp":"2022-02-01T15:10:00Z","@row":"3","organization.acronym":"nyc","agent.type":"freight","host.address":"192.0.2.43","host.ip":"192.0.2.43","host.model":"unknown","host.model_oid":"1.3.6.1.4.1.14988.1","host.vendor":"mikrotik","component.cpu.utilization":0,"component.name":"","host.hostname":"NYC-S75-APT4215"}
common/Person.hs view
@@ -1,20 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+ module Person ( encodedPerson , encodedFlattenedPerson ) where import Data.ByteString (ByteString)-import Data.ByteString.Short (ShortByteString,toShort)+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+import qualified Data.Primitive as PM -shortByteStringToByteArray :: ShortByteString -> ByteArray +shortByteStringToByteArray :: ShortByteString -> ByteArray shortByteStringToByteArray (BSS.SBS x) = PM.ByteArray x encodedPerson :: ByteArray@@ -26,8 +27,9 @@ shortByteStringToByteArray (toShort byteStringFlattenedPerson) byteStringPerson :: ByteString-byteStringPerson = encodeUtf8- [text|+byteStringPerson =+ encodeUtf8+ [text| { "name": "bilbo" , "occupation": { "name": "burglar"@@ -39,8 +41,9 @@ |] byteStringFlattenedPerson :: ByteString-byteStringFlattenedPerson = encodeUtf8- [text|+byteStringFlattenedPerson =+ encodeUtf8+ [text| { "name": "bilbo" , "occupation.name": "burglar" , "occupation.start": "2022-05-30"@@ -48,4 +51,3 @@ , "favorites": ["adventures","lunch"] } |]-
common/Twitter100.hs view
@@ -1,20 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+ module Twitter100 ( encodedTwitter100 , byteStringTwitter100 ) where import Data.ByteString (ByteString)-import Data.ByteString.Short (ShortByteString,toShort)+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+import qualified Data.Primitive as PM -shortByteStringToByteArray :: ShortByteString -> ByteArray +shortByteStringToByteArray :: ShortByteString -> ByteArray shortByteStringToByteArray (BSS.SBS x) = PM.ByteArray x encodedTwitter100 :: ByteArray@@ -22,8 +23,9 @@ shortByteStringToByteArray (toShort byteStringTwitter100) byteStringTwitter100 :: ByteString-byteStringTwitter100 = encodeUtf8- [text|+byteStringTwitter100 =+ encodeUtf8+ [text| { "completed_in": 1.000000, "max_id": 30121530767708160,@@ -1864,4 +1866,3 @@ "since_id_str": "0" } |]-
common/Url100.hs view
@@ -1,20 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+ module Url100 ( encodedUrl100 , byteStringUrl100 ) where import Data.ByteString (ByteString)-import Data.ByteString.Short (ShortByteString,toShort)+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+import qualified Data.Primitive as PM -shortByteStringToByteArray :: ShortByteString -> ByteArray +shortByteStringToByteArray :: ShortByteString -> ByteArray shortByteStringToByteArray (BSS.SBS x) = PM.ByteArray x encodedUrl100 :: ByteArray@@ -22,8 +23,9 @@ shortByteStringToByteArray (toShort byteStringUrl100) byteStringUrl100 :: ByteString-byteStringUrl100 = encodeUtf8- [text|+byteStringUrl100 =+ encodeUtf8+ [text| [ "https://balance.example.com/aunt.htm" , "http://anger.example.com/" , "https://www.example.edu/basket/branch#boat"@@ -126,5 +128,3 @@ , "http://attack.example.org/" ] |]--
json-syntax.cabal view
@@ -1,7 +1,7 @@-cabal-version: 2.2-name: json-syntax-version: 0.2.7.0-synopsis: High-performance JSON parser and encoder+cabal-version: 2.2+name: json-syntax+version: 0.2.7.1+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,77 +14,81 @@ 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/byteverse/json-syntax-bug-reports: https://github.com/byteverse/json-syntax/issues-license: BSD-3-Clause-license-file: LICENSE-author: Andrew Martin-maintainer: andrew.thaddeus@gmail.com-copyright: 2019 Andrew Martin-category: Data-build-type: Simple-extra-source-files: CHANGELOG.md +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+maintainer: amartin@layer3com.com+copyright: 2019 Andrew Martin+category: Data+build-type: Simple+extra-doc-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.15 && <5- , bytebuild >=0.3.10 && <0.4- , byteslice >=0.2.9 && <0.3- , bytesmith >=0.3.8 && <0.4- , bytestring >=0.10.8 && <0.12- , 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- hs-source-dirs: src+ , array-builder >=0.1 && <0.2+ , array-chunks >=0.1.3 && <0.2+ , base >=4.15 && <5+ , bytebuild >=0.3.10 && <0.4+ , byteslice >=0.2.9 && <0.3+ , bytesmith >=0.3.8 && <0.4+ , bytestring >=0.10.8 && <0.12+ , 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.2 && <2.1+ , text-short >=0.1.3 && <0.2+ , transformers >=0.5.6 && <0.6+ , word-compat >=0.0.6 && <0.1+ , zigzag >=0.0.1 && <0.1++ hs-source-dirs: src default-language: Haskell2010- ghc-options: -Wall -O2+ ghc-options: -Wall -O2 test-suite test default-language: Haskell2010- type: exitcode-stdio-1.0- hs-source-dirs: test, common- main-is: Main.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test common+ main-is: Main.hs other-modules:- Twitter100 Person- ghc-options: -Wall -O2+ Twitter100++ ghc-options: -Wall -O2 build-depends:- , QuickCheck >=2.14.2- , aeson >=2.0.2+ , aeson >=2.0.2 , array-chunks- , base >=4.12.0.0 && <5+ , base >=4.12.0.0 && <5 , bytebuild- , byteslice >=0.1.3+ , byteslice >=0.1.3 , bytestring , containers , json-syntax- , neat-interpolation >=0.3.2+ , neat-interpolation >=0.3.2 , primitive+ , QuickCheck >=2.14.2 , scientific- , scientific-notation >=0.1.1- , tasty >=1.2.3 && <1.3- , tasty-hunit >=0.10.0.2 && <0.11- , tasty-golden >=2.0 && <2.4- , tasty-quickcheck >=0.10.1.2 && <0.11- , text >=1.2+ , scientific-notation >=0.1.1+ , tasty >=1.2.3 && <1.3+ , tasty-golden >=2.0 && <2.4+ , tasty-hunit >=0.10.0.2 && <0.11+ , tasty-quickcheck >=0.10.1.2 && <0.11+ , text >=2.0.2 && <2.1 , text-short , vector benchmark bench- type: exitcode-stdio-1.0+ type: exitcode-stdio-1.0 build-depends: , aeson , base@@ -93,15 +97,20 @@ , bytestring , gauge , json-syntax- , neat-interpolation >=0.3.2+ , neat-interpolation >=0.3.2 , primitive- , text >=1.2- , scientific-notation >=0.1.1- ghc-options: -Wall -O2+ , scientific-notation >=0.1.1+ , text >=2.0.2 && <2.1++ ghc-options: -Wall -O2 default-language: Haskell2010- hs-source-dirs: bench, common- main-is: Main.hs+ hs-source-dirs: bench common+ main-is: Main.hs other-modules:+ Metrics1024 Twitter100 Url100- Metrics1024++source-repository head+ type: git+ location: git://github.com/byteverse/json-syntax.git
src/Json.hs view
@@ -1,23 +1,24 @@-{-# language BangPatterns #-}-{-# language BinaryLiterals #-}-{-# language BlockArguments #-}-{-# language DerivingStrategies #-}-{-# language DeriveAnyClass #-}-{-# language LambdaCase #-}-{-# language MagicHash #-}-{-# language NamedFieldPuns #-}-{-# language PatternSynonyms #-}-{-# language TypeApplications #-}-{-# language UnboxedSums #-}-{-# language UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedTuples #-} module Json ( -- * Types- Value(..)- , Member(..)- , SyntaxException(..)+ Value (..)+ , Member (..)+ , SyntaxException (..)+ -- * Classes- , ToValue(..)+ , ToValue (..)+ -- * Functions , decode , decodeNewlineDelimited@@ -27,11 +28,14 @@ , toText , toBytes , toByteArray- -- * Infix Synonyms ++ -- * Infix Synonyms , pattern (:->)+ -- * Constants , emptyArray , emptyObject+ -- * Value Construction , int , int8@@ -45,8 +49,10 @@ , bool , text , shortText+ -- * Array Construction , arrayFromList+ -- * Object Construction , objectFromList , object1@@ -67,62 +73,63 @@ , object16 ) where -import Prelude hiding (Bool(True,False))+import Prelude hiding (Bool (False, True)) import Control.Exception (Exception)-import Control.Monad.ST (ST,runST)+import Control.Monad.ST (ST, runST) import Control.Monad.ST.Run (runSmallArrayST)-import Data.Bits ((.&.),(.|.),unsafeShiftR)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (except, runExceptT)+import Data.Bits (unsafeShiftR, (.&.), (.|.)) import Data.Builder.ST (Builder)+import Data.Bytes.Chunks (Chunks) import Data.Bytes.Parser (Parser)-import Data.Bytes.Types (Bytes(..))+import Data.Bytes.Types (Bytes (..)) import Data.Char (ord)+import Data.Foldable (foldlM) import Data.Number.Scientific (Scientific)-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.Primitive (Array, ByteArray (ByteArray), MutableByteArray, Prim, PrimArray, SmallArray) 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 Data.Text.Short (ShortText)+import GHC.Exts (Char (C#), Int (I#), chr#, gtWord#, ltWord#, word2Int#)+import GHC.Int (Int16, Int32, Int64, Int8)+import GHC.Word (Word16, Word32, Word64, Word8) -import qualified Prelude import qualified Data.Builder.ST as B+import qualified Data.ByteString.Short.Internal as BSS import qualified Data.Bytes as Bytes-import qualified Data.Bytes.Chunks as ByteChunks import qualified Data.Bytes.Builder as BLDR+import qualified Data.Bytes.Chunks as ByteChunks import qualified Data.Bytes.Parser as P+import qualified Data.Bytes.Parser.Latin as Latin+import qualified Data.Bytes.Parser.Unsafe as Unsafe+import qualified Data.Bytes.Parser.Utf8 as Utf8 import qualified Data.Chunks as Chunks-import qualified Data.Text.Short.Unsafe as TS+import qualified Data.List as List import qualified Data.Number.Scientific as SCI import qualified Data.Primitive as PM import qualified Data.Primitive.Contiguous as Contiguous-import qualified Data.Bytes.Parser.Utf8 as Utf8-import qualified Data.Bytes.Parser.Latin as Latin-import qualified Data.ByteString.Short.Internal as BSS-import qualified Data.Bytes.Parser.Unsafe as Unsafe import qualified Data.Text.Short as TS-import qualified Data.List as List+import qualified Data.Text.Short.Unsafe as TS import qualified GHC.Word.Compat+import qualified Prelude --- | The JSON syntax tree described by the ABNF in RFC 7159. Notable--- design decisions include:------ * @True@ and @False@ are their own data constructors rather than--- being lumped together under a data constructor for boolean values.--- This improves performance when decoding the syntax tree to a @Bool@.--- * @Object@ uses an association list rather than a hash map. This is--- the data type that key-value pairs can be parsed into most cheaply.--- * @Object@ and @Array@ both use 'Chunks' rather than using @SmallArray@--- or cons-list directly. This a middle ground between those two types. We--- get the efficent use of cache lines that @SmallArray@ offers, and we get--- the worst-case @O(1)@ appends that cons-list offers. Users will typically--- fold over the elements with the @Foldable@ instance of 'Chunks', although--- there are functions in @Data.Chunks@ that efficently perform other--- operations.+{- | The JSON syntax tree described by the ABNF in RFC 7159. Notable+design decisions include:++* @True@ and @False@ are their own data constructors rather than+ being lumped together under a data constructor for boolean values.+ This improves performance when decoding the syntax tree to a @Bool@.+* @Object@ uses an association list rather than a hash map. This is+ the data type that key-value pairs can be parsed into most cheaply.+* @Object@ and @Array@ both use 'Chunks' rather than using @SmallArray@+ or cons-list directly. This a middle ground between those two types. We+ get the efficent use of cache lines that @SmallArray@ offers, and we get+ the worst-case @O(1)@ appends that cons-list offers. Users will typically+ fold over the elements with the @Foldable@ instance of 'Chunks', although+ there are functions in @Data.Chunks@ that efficently perform other+ operations.+-} data Value = Object !(SmallArray Member) | Array !(SmallArray Value)@@ -131,11 +138,12 @@ | Null | True | False- deriving stock (Eq,Show)+ deriving stock (Eq, Show) --- | Exceptions that can happen while parsing JSON. Do not pattern--- match on values of this type. New data constructors may be added--- at any time without a major version bump.+{- | Exceptions that can happen while parsing JSON. Do not pattern+match on values of this type. New data constructors may be added+at any time without a major version bump.+-} data SyntaxException = EmptyInput | ExpectedColon@@ -155,41 +163,43 @@ | LeadingZero | UnexpectedLeftovers | PossibleOverflow- deriving stock (Eq,Show)+ deriving stock (Eq, Show) deriving anyclass (Exception) --- | A key-value pair in a JSON object. The name of this type is--- taken from section 4 of RFC 7159.+{- | A key-value pair in a JSON object. The name of this type is+taken from section 4 of RFC 7159.+-} data Member = Member { key :: {-# UNPACK #-} !ShortText , value :: !Value- } deriving stock (Eq,Show)+ }+ deriving stock (Eq, Show) -- | An array with no elements (i.e. @[]@) emptyArray :: Value-{-# noinline emptyArray #-}+{-# NOINLINE emptyArray #-} emptyArray = Array mempty -- | An object with no members (i.e. @{}@) emptyObject :: Value-{-# noinline emptyObject #-}+{-# NOINLINE emptyObject #-} emptyObject = Object mempty isSpace :: Word8 -> Prelude.Bool-{-# inline isSpace #-}+{-# INLINE isSpace #-} isSpace w =- w == c2w ' '- || w == c2w '\t'- || w == c2w '\r'- || w == c2w '\n'+ w == c2w ' '+ || w == c2w '\t'+ || w == c2w '\r'+ || w == c2w '\n' -- | Decode a JSON syntax tree from a byte sequence. decode :: Bytes -> Either SyntaxException Value-{-# noinline decode #-}+{-# NOINLINE decode #-} decode = P.parseBytesEither parser parser :: Parser SyntaxException s Value-{-# inline parser #-}+{-# INLINE parser #-} parser = do P.skipWhile isSpace result <- Latin.any EmptyInput >>= parserStep@@ -197,69 +207,73 @@ 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.+{- | 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 #-}+{-# 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)+ !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 #-}+{-# INLINE toChunks #-} toChunks = BLDR.run 512 . encode toBytes :: Value -> Bytes-{-# inline toBytes #-}+{-# INLINE toBytes #-} toBytes = ByteChunks.concat . toChunks toByteArray :: Value -> ByteArray-{-# inline toByteArray #-}+{-# INLINE toByteArray #-} toByteArray = ByteChunks.concatU . toChunks toShortText :: Value -> ShortText-{-# inline toShortText #-}+{-# INLINE toShortText #-} toShortText v = case toByteArray v of ByteArray x -> TS.fromShortByteStringUnsafe (BSS.SBS x) toText :: Value -> Text-{-# inline toText #-}+{-# INLINE toText #-} toText = TS.toText . toShortText -- | Encode a JSON syntax tree. encode :: Value -> BLDR.Builder-{-# noinline encode #-}+{-# NOINLINE encode #-} encode v0 = BLDR.rebuild $ case v0 of True -> BLDR.ascii4 't' 'r' 'u' 'e' False -> BLDR.ascii5 'f' 'a' 'l' 's' 'e'@@ -271,40 +285,39 @@ _ -> let !(# z #) = PM.indexSmallArray## ys 0 in BLDR.ascii '['- <>- encode z- <>- foldrTail- ( \v b -> BLDR.ascii ',' <> encode v <> b- ) (BLDR.ascii ']') ys+ <> encode z+ <> foldrTail+ ( \v b -> BLDR.ascii ',' <> encode v <> b+ )+ (BLDR.ascii ']')+ ys Object ys -> case PM.sizeofSmallArray ys of 0 -> BLDR.ascii2 '{' '}' _ -> let !(# z #) = PM.indexSmallArray## ys 0 in BLDR.ascii '{'- <>- encodeMember z- <>- foldrTail- ( \v b -> BLDR.ascii ',' <> encodeMember v <> b- ) (BLDR.ascii '}') ys+ <> encodeMember z+ <> foldrTail+ ( \v b -> BLDR.ascii ',' <> encodeMember v <> b+ )+ (BLDR.ascii '}')+ ys encodeMember :: Member -> BLDR.Builder-encodeMember Member{key,value} =+encodeMember Member {key, value} = BLDR.shortTextJsonString key- <>- BLDR.ascii ':'- <>- encode value+ <> BLDR.ascii ':'+ <> encode value foldrTail :: (a -> b -> b) -> b -> PM.SmallArray a -> b-{-# inline foldrTail #-}-foldrTail f z !ary = go 1 where+{-# 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))+ | (# x #) <- PM.indexSmallArray## ary i =+ f x (go (i + 1)) -- Precondition: skip over all space before calling this. -- It will not skip leading space for you. It does not skip@@ -326,15 +339,17 @@ start <- Unsafe.cursor string String start '-' -> fmap Number (SCI.parserNegatedUtf8Bytes InvalidNumber)- '0' -> Latin.trySatisfy (\c -> c >= '0' && c <= '9') >>= \case- Prelude.True -> P.fail LeadingZero- Prelude.False -> fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber 0)- c | c >= '1' && c <= '9' ->+ '0' ->+ Latin.trySatisfy (\c -> c >= '0' && c <= '9') >>= \case+ Prelude.True -> P.fail LeadingZero+ Prelude.False -> fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber 0)+ c+ | c >= '1' && c <= '9' -> fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber (ord c - 48)) _ -> P.fail InvalidLeader objectTrailedByBrace :: Parser SyntaxException s Value-{-# inline objectTrailedByBrace #-}+{-# INLINE objectTrailedByBrace #-} objectTrailedByBrace = do P.skipWhile isSpace Latin.any IncompleteObject >>= \case@@ -382,7 +397,7 @@ -- -- This parser handles everything after the LBRACKET character. arrayTrailedByBracket :: Parser SyntaxException s Value-{-# inline arrayTrailedByBracket #-}+{-# INLINE arrayTrailedByBracket #-} arrayTrailedByBracket = do P.skipWhile isSpace Latin.any IncompleteArray >>= \case@@ -395,7 +410,7 @@ -- From RFC 7159: ----- > value-separator = ws COMMA ws +-- > value-separator = ws COMMA ws -- > array = begin-array [ value *( value-separator value ) ] end-array -- -- This handles the all values after the first one. That is:@@ -427,12 +442,14 @@ -- mark the function as NOINLINE. This would prevent the generated -- code from being needlessly duplicated in three different places. string :: (ShortText -> a) -> Int -> Parser SyntaxException s a-{-# inline string #-}-string wrap !start = go 1 where+{-# INLINE string #-}+string wrap !start = go 1+ where go !canMemcpy = do P.any IncompleteString >>= \case 92 -> P.any InvalidEscapeSequence *> go 0 -- backslash- 34 -> do -- double quote+ 34 -> do+ -- double quote !pos <- Unsafe.cursor case canMemcpy of 1 -> do@@ -452,46 +469,49 @@ GHC.Word.Compat.W8# w -> go (canMemcpy .&. I# (ltWord# w 128##) .&. I# (gtWord# w 31##)) copyAndEscape :: (ShortText -> a) -> Int -> Parser SyntaxException s a-{-# inline copyAndEscape #-}+{-# INLINE copyAndEscape #-} copyAndEscape wrap !maxLen = do !dst <- P.effect (PM.newByteArray maxLen)- let go !ix = Utf8.any# IncompleteString `P.bindFromCharToLifted` \c -> case c of- '\\'# -> Latin.any IncompleteEscapeSequence >>= \case- '"' -> do- P.effect (PM.writeByteArray dst ix (c2w '"'))- go (ix + 1)- '\\' -> do- P.effect (PM.writeByteArray dst ix (c2w '\\'))- go (ix + 1)- 't' -> do- P.effect (PM.writeByteArray dst ix (c2w '\t'))- go (ix + 1)- 'n' -> do- P.effect (PM.writeByteArray dst ix (c2w '\n'))- go (ix + 1)- 'r' -> do- P.effect (PM.writeByteArray dst ix (c2w '\r'))- go (ix + 1)- '/' -> do- P.effect (PM.writeByteArray dst ix (c2w '/'))- go (ix + 1)- 'b' -> do- P.effect (PM.writeByteArray dst ix (c2w '\b'))- go (ix + 1)- 'f' -> do- P.effect (PM.writeByteArray dst ix (c2w '\f'))- go (ix + 1)- 'u' -> do- w <- Latin.hexFixedWord16 InvalidEscapeSequence- if w >= 0xD800 && w < 0xDFFF- then go =<< P.effect (encodeUtf8Char dst ix '\xFFFD')- else go =<< P.effect (encodeUtf8Char dst ix (w16ToChar w))- _ -> P.fail InvalidEscapeSequence- '"'# -> do- str <- P.effect- (PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray dst ix)- pure (wrap (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str)))- _ -> go =<< P.effect (encodeUtf8Char dst ix (C# c))+ let go !ix =+ Utf8.any# IncompleteString `P.bindFromCharToLifted` \c -> case c of+ '\\'# ->+ Latin.any IncompleteEscapeSequence >>= \case+ '"' -> do+ P.effect (PM.writeByteArray dst ix (c2w '"'))+ go (ix + 1)+ '\\' -> do+ P.effect (PM.writeByteArray dst ix (c2w '\\'))+ go (ix + 1)+ 't' -> do+ P.effect (PM.writeByteArray dst ix (c2w '\t'))+ go (ix + 1)+ 'n' -> do+ P.effect (PM.writeByteArray dst ix (c2w '\n'))+ go (ix + 1)+ 'r' -> do+ P.effect (PM.writeByteArray dst ix (c2w '\r'))+ go (ix + 1)+ '/' -> do+ P.effect (PM.writeByteArray dst ix (c2w '/'))+ go (ix + 1)+ 'b' -> do+ P.effect (PM.writeByteArray dst ix (c2w '\b'))+ go (ix + 1)+ 'f' -> do+ P.effect (PM.writeByteArray dst ix (c2w '\f'))+ go (ix + 1)+ 'u' -> do+ w <- Latin.hexFixedWord16 InvalidEscapeSequence+ if w >= 0xD800 && w < 0xDFFF+ then go =<< P.effect (encodeUtf8Char dst ix '\xFFFD')+ else go =<< P.effect (encodeUtf8Char dst ix (w16ToChar w))+ _ -> P.fail InvalidEscapeSequence+ '"'# -> do+ str <-+ P.effect+ (PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray dst ix)+ pure (wrap (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str)))+ _ -> go =<< P.effect (encodeUtf8Char dst ix (C# c)) go 0 encodeUtf8Char :: MutableByteArray s -> Int -> Char -> ST s Int@@ -500,27 +520,45 @@ PM.writeByteArray marr ix (c2w c) pure (ix + 1) | c < '\x0800' = do- PM.writeByteArray marr ix+ PM.writeByteArray+ marr+ ix (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6 .|. 0b11000000))- PM.writeByteArray marr (ix + 1)+ PM.writeByteArray+ marr+ (ix + 1) (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c)))) pure (ix + 2) | c <= '\xffff' = do- PM.writeByteArray marr ix+ PM.writeByteArray+ marr+ ix (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 12 .|. 0b11100000))- PM.writeByteArray marr (ix + 1)+ PM.writeByteArray+ marr+ (ix + 1) (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6))))- PM.writeByteArray marr (ix + 2)+ PM.writeByteArray+ marr+ (ix + 2) (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c)))) pure (ix + 3) | otherwise = do- PM.writeByteArray marr ix+ PM.writeByteArray+ marr+ ix (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 18 .|. 0b11110000))- PM.writeByteArray marr (ix + 1)+ PM.writeByteArray+ marr+ (ix + 1) (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 12))))- PM.writeByteArray marr (ix + 2)+ PM.writeByteArray+ marr+ (ix + 2) (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6))))- PM.writeByteArray marr (ix + 3)+ PM.writeByteArray+ marr+ (ix + 3) (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c)))) pure (ix + 4) @@ -533,100 +571,118 @@ -- | Infix pattern synonym for 'Member'. pattern (:->) :: ShortText -> Value -> Member-pattern key :-> value = Member{key,value}+pattern key :-> value = Member {key, value} --- | Construct a JSON array from a list of JSON values.------ Unlike 'objectFromList', this is not currently equipped with a--- rewrite rule.+{- | Construct a JSON array from a list of JSON values.++Unlike 'objectFromList', this is not currently equipped with a+rewrite rule.+-} arrayFromList :: [Value] -> Value arrayFromList ms = Array $ PM.smallArrayFromList ms --- | Construct a JSON object from a list of members.------ Note: When the argument is a list literal with 16 or fewer elements,--- a rewrite rule transforms this into the appropriate @objectN@ function.--- When the argument is not a list literal, this function just calls--- @smallArrayFromList@ on the members, which has poor performance.+{- | Construct a JSON object from a list of members.++Note: When the argument is a list literal with 16 or fewer elements,+a rewrite rule transforms this into the appropriate @objectN@ function.+When the argument is not a list literal, this function just calls+@smallArrayFromList@ on the members, which has poor performance.+-} objectFromList :: [Member] -> Value objectFromList ms = Object $ PM.smallArrayFromList ms- {-# NOINLINE objectFromList #-}-{-# RULES "objectFromList/1" forall a.- objectFromList (a : []) =- object1 a-#-}-{-# RULES "objectFromList/2" forall a b.- objectFromList (a : b : []) =- object2 a b-#-}-{-# RULES "objectFromList/3" forall a b c.- objectFromList (a : b : c : []) =- object3 a b c-#-}-{-# RULES "objectFromList/4" forall a b c d.- objectFromList (a : b : c : d : []) =- object4 a b c d-#-}-{-# RULES "objectFromList/5" forall a b c d e.- objectFromList (a : b : c : d : e : []) =- object5 a b c d e-#-}-{-# RULES "objectFromList/6" forall a b c d e f.- objectFromList (a : b : c : d : e : f : []) =- object6 a b c d e f-#-}-{-# RULES "objectFromList/7" forall a b c d e f g.- objectFromList (a : b : c : d : e : f : g : []) =- object7 a b c d e f g-#-}-{-# RULES "objectFromList/8" forall a b c d e f g h.- objectFromList (a : b : c : d : e : f : g : h : []) =- object8 a b c d e f g h-#-}-{-# RULES "objectFromList/9" forall a b c d e f g h i.- objectFromList (a : b : c : d : e : f : g : h : i : []) =- object9 a b c d e f g h i-#-}-{-# RULES "objectFromList/10" forall a b c d e f g h i j.- objectFromList (a : b : c : d : e : f : g : h : i : j : []) =- object10 a b c d e f g h i j-#-}-{-# RULES "objectFromList/11" forall a b c d e f g h i j k.- objectFromList (a : b : c : d : e : f : g : h : i : j : k : []) =- object11 a b c d e f g h i j k-#-}-{-# RULES "objectFromList/12" forall a b c d e f g h i j k l.- objectFromList (a : b : c : d : e : f : g : h : i : j : k : l : []) =- object12 a b c d e f g h i j k l-#-}-{-# RULES "objectFromList/13" forall a b c d e f g h i j k l m.- objectFromList (a : b : c : d : e : f : g : h : i : j : k : l : m : []) =- object13 a b c d e f g h i j k l m-#-}-{-# RULES "objectFromList/14" forall a b c d e f g h i j k l m n.- objectFromList (a : b : c : d : e : f : g : h : i : j : k : l : m : n : []) =- object14 a b c d e f g h i j k l m n-#-}-{-# RULES "objectFromList/15" forall a b c d e f g h i j k l m n o.- objectFromList (a : b : c : d : e : f : g : h : i : j : k : l : m : n : o : []) =- object15 a b c d e f g h i j k l m n o-#-}-{-# RULES "objectFromList/16" forall a b c d e f g h i j k l m n o p.- objectFromList (a : b : c : d : e : f : g : h : i : j : k : l : m : n : o : p : []) =- object16 a b c d e f g h i j k l m n o p-#-} +{-# RULES+"objectFromList/1" forall a.+ objectFromList (a : []) =+ object1 a+ #-}+{-# RULES+"objectFromList/2" forall a b.+ objectFromList (a : b : []) =+ object2 a b+ #-}+{-# RULES+"objectFromList/3" forall a b c.+ objectFromList (a : b : c : []) =+ object3 a b c+ #-}+{-# RULES+"objectFromList/4" forall a b c d.+ objectFromList (a : b : c : d : []) =+ object4 a b c d+ #-}+{-# RULES+"objectFromList/5" forall a b c d e.+ objectFromList (a : b : c : d : e : []) =+ object5 a b c d e+ #-}+{-# RULES+"objectFromList/6" forall a b c d e f.+ objectFromList (a : b : c : d : e : f : []) =+ object6 a b c d e f+ #-}+{-# RULES+"objectFromList/7" forall a b c d e f g.+ objectFromList (a : b : c : d : e : f : g : []) =+ object7 a b c d e f g+ #-}+{-# RULES+"objectFromList/8" forall a b c d e f g h.+ objectFromList (a : b : c : d : e : f : g : h : []) =+ object8 a b c d e f g h+ #-}+{-# RULES+"objectFromList/9" forall a b c d e f g h i.+ objectFromList (a : b : c : d : e : f : g : h : i : []) =+ object9 a b c d e f g h i+ #-}+{-# RULES+"objectFromList/10" forall a b c d e f g h i j.+ objectFromList (a : b : c : d : e : f : g : h : i : j : []) =+ object10 a b c d e f g h i j+ #-}+{-# RULES+"objectFromList/11" forall a b c d e f g h i j k.+ objectFromList (a : b : c : d : e : f : g : h : i : j : k : []) =+ object11 a b c d e f g h i j k+ #-}+{-# RULES+"objectFromList/12" forall a b c d e f g h i j k l.+ objectFromList (a : b : c : d : e : f : g : h : i : j : k : l : []) =+ object12 a b c d e f g h i j k l+ #-}+{-# RULES+"objectFromList/13" forall a b c d e f g h i j k l m.+ objectFromList (a : b : c : d : e : f : g : h : i : j : k : l : m : []) =+ object13 a b c d e f g h i j k l m+ #-}+{-# RULES+"objectFromList/14" forall a b c d e f g h i j k l m n.+ objectFromList (a : b : c : d : e : f : g : h : i : j : k : l : m : n : []) =+ object14 a b c d e f g h i j k l m n+ #-}+{-# RULES+"objectFromList/15" forall a b c d e f g h i j k l m n o.+ objectFromList (a : b : c : d : e : f : g : h : i : j : k : l : m : n : o : []) =+ object15 a b c d e f g h i j k l m n o+ #-}+{-# RULES+"objectFromList/16" forall a b c d e f g h i j k l m n o p.+ objectFromList (a : b : c : d : e : f : g : h : i : j : k : l : m : n : o : p : []) =+ object16 a b c d e f g h i j k l m n o p+ #-}+ -- | Construct a JSON object with one member. object1 :: Member -> Value-{-# inline object1 #-}+{-# INLINE object1 #-} object1 a = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 1 a PM.unsafeFreezeSmallArray dst -- | Construct a JSON object with two members. object2 :: Member -> Member -> Value-{-# inline object2 #-}+{-# INLINE object2 #-} object2 a b = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 2 a PM.writeSmallArray dst 1 b@@ -634,7 +690,7 @@ -- | Construct a JSON object with three members. object3 :: Member -> Member -> Member -> Value-{-# inline object3 #-}+{-# INLINE object3 #-} object3 a b c = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 3 a PM.writeSmallArray dst 1 b@@ -643,7 +699,7 @@ -- | Construct a JSON object with four members. object4 :: Member -> Member -> Member -> Member -> Value-{-# inline object4 #-}+{-# INLINE object4 #-} object4 a b c d = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 4 a PM.writeSmallArray dst 1 b@@ -653,7 +709,7 @@ -- | Construct a JSON object with five members. object5 :: Member -> Member -> Member -> Member -> Member -> Value-{-# inline object5 #-}+{-# INLINE object5 #-} object5 a b c d e = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 5 a PM.writeSmallArray dst 1 b@@ -664,7 +720,7 @@ -- | Construct a JSON object with six members. object6 :: Member -> Member -> Member -> Member -> Member -> Member -> Value-{-# inline object6 #-}+{-# INLINE object6 #-} object6 a b c d e f = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 6 a PM.writeSmallArray dst 1 b@@ -676,7 +732,7 @@ -- | Construct a JSON object with seven members. object7 :: Member -> Member -> Member -> Member -> Member -> Member -> Member -> Value-{-# inline object7 #-}+{-# INLINE object7 #-} object7 a b c d e f g = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 7 a PM.writeSmallArray dst 1 b@@ -689,7 +745,7 @@ -- | Construct a JSON object with nine members. object8 :: Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member -> Value-{-# inline object8 #-}+{-# INLINE object8 #-} object8 a b c d e f g h = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 8 a PM.writeSmallArray dst 1 b@@ -702,9 +758,18 @@ PM.unsafeFreezeSmallArray dst -- | Construct a JSON object with nine members.-object9 :: Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member- -> Value-{-# inline object9 #-}+object9 ::+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Value+{-# INLINE object9 #-} object9 a b c d e f g h i = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 9 a PM.writeSmallArray dst 1 b@@ -718,9 +783,19 @@ PM.unsafeFreezeSmallArray dst -- | Construct a JSON object with ten members.-object10 :: Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member - -> Member -> Member -> Value-{-# inline object10 #-}+object10 ::+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Value+{-# INLINE object10 #-} object10 a b c d e f g h i j = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 10 a PM.writeSmallArray dst 1 b@@ -735,9 +810,20 @@ PM.unsafeFreezeSmallArray dst -- | Construct a JSON object with eleven members.-object11 :: Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member- -> Member -> Member -> Member -> Value-{-# inline object11 #-}+object11 ::+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Value+{-# INLINE object11 #-} object11 a b c d e f g h i j k = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 11 a PM.writeSmallArray dst 1 b@@ -753,9 +839,21 @@ PM.unsafeFreezeSmallArray dst -- | Construct a JSON object with twelve members.-object12 :: Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member- -> Member -> Member -> Member -> Member -> Value-{-# inline object12 #-}+object12 ::+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Value+{-# INLINE object12 #-} object12 a b c d e f g h i j k l = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 12 a PM.writeSmallArray dst 1 b@@ -772,9 +870,22 @@ PM.unsafeFreezeSmallArray dst -- | Construct a JSON object with thirteen members.-object13 :: Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member- -> Member -> Member -> Member -> Member -> Member -> Value-{-# inline object13 #-}+object13 ::+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Value+{-# INLINE object13 #-} object13 a b c d e f g h i j k l m = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 13 a PM.writeSmallArray dst 1 b@@ -792,9 +903,23 @@ PM.unsafeFreezeSmallArray dst -- | Construct a JSON object with fourteen members.-object14 :: Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member- -> Member -> Member -> Member -> Member -> Member -> Member -> Value-{-# inline object14 #-}+object14 ::+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Value+{-# INLINE object14 #-} object14 a b c d e f g h i j k l m n = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 14 a PM.writeSmallArray dst 1 b@@ -813,9 +938,24 @@ PM.unsafeFreezeSmallArray dst -- | Construct a JSON object with fifteen members.-object15 :: Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member- -> Member -> Member -> Member -> Member -> Member -> Member -> Member -> Value-{-# inline object15 #-}+object15 ::+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Value+{-# INLINE object15 #-} object15 a b c d e f g h i j k l m n o = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 15 a PM.writeSmallArray dst 1 b@@ -835,10 +975,25 @@ PM.unsafeFreezeSmallArray dst -- | Construct a JSON object with sixteen members.-object16 :: Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member- -> Member -> Member -> Member -> Member -> Member -> Member -> Member -> Member- -> Value-{-# inline object16 #-}+object16 ::+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Member ->+ Value+{-# INLINE object16 #-} object16 a b c d e f g h i j k l m n o p = Object $ runSmallArrayST $ do dst <- PM.newSmallArray 16 a PM.writeSmallArray dst 1 b@@ -859,51 +1014,51 @@ PM.unsafeFreezeSmallArray dst word8 :: Word8 -> Json.Value-{-# inline word8 #-}+{-# INLINE word8 #-} word8 = Json.Number . SCI.fromWord8 word16 :: Word16 -> Json.Value-{-# inline word16 #-}+{-# INLINE word16 #-} word16 = Json.Number . SCI.fromWord16 word32 :: Word32 -> Json.Value-{-# inline word32 #-}+{-# INLINE word32 #-} word32 = Json.Number . SCI.fromWord32 word64 :: Word64 -> Json.Value-{-# inline word64 #-}+{-# INLINE word64 #-} word64 = Json.Number . SCI.fromWord64 int8 :: Int8 -> Json.Value-{-# inline int8 #-}+{-# INLINE int8 #-} int8 = Json.Number . SCI.fromInt8 int16 :: Int16 -> Json.Value-{-# inline int16 #-}+{-# INLINE int16 #-} int16 = Json.Number . SCI.fromInt16 int32 :: Int32 -> Json.Value-{-# inline int32 #-}+{-# INLINE int32 #-} int32 = Json.Number . SCI.fromInt32 int64 :: Int64 -> Json.Value-{-# inline int64 #-}+{-# INLINE int64 #-} int64 = Json.Number . SCI.fromInt64 int :: Int -> Json.Value-{-# inline int #-}+{-# INLINE int #-} int = Json.Number . SCI.fromInt text :: Text -> Json.Value-{-# inline text #-}+{-# INLINE text #-} text = Json.String . TS.fromText shortText :: ShortText -> Json.Value-{-# inline shortText #-}+{-# INLINE shortText #-} shortText = String bool :: Prelude.Bool -> Json.Value-{-# inline bool #-}+{-# INLINE bool #-} bool Prelude.True = True bool _ = False @@ -912,25 +1067,26 @@ toValue :: a -> Value -- | Encodes the unit value as JSON @null@.-instance ToValue () where {toValue _ = Null}-instance ToValue Value where {toValue = id}-instance ToValue Scientific where {toValue = Number}-instance ToValue Int where {toValue = int}-instance ToValue Int8 where {toValue = int8}-instance ToValue Int16 where {toValue = int16}-instance ToValue Int32 where {toValue = int32}-instance ToValue Int64 where {toValue = int64}-instance ToValue Word8 where {toValue = word8}-instance ToValue Word16 where {toValue = word16}-instance ToValue Word32 where {toValue = word32}-instance ToValue Word64 where {toValue = word64}-instance ToValue ShortText where {toValue = shortText}-instance ToValue Text where {toValue = text}-instance ToValue Prelude.Bool where {toValue = bool}+instance ToValue () where toValue _ = Null++instance ToValue Value where toValue = id+instance ToValue Scientific where toValue = Number+instance ToValue Int where toValue = int+instance ToValue Int8 where toValue = int8+instance ToValue Int16 where toValue = int16+instance ToValue Int32 where toValue = int32+instance ToValue Int64 where toValue = int64+instance ToValue Word8 where toValue = word8+instance ToValue Word16 where toValue = word16+instance ToValue Word32 where toValue = word32+instance ToValue Word64 where toValue = word64+instance ToValue ShortText where toValue = shortText+instance ToValue Text where toValue = text+instance ToValue Prelude.Bool where toValue = bool instance ToValue Word where- toValue = word64 . fromIntegral @Word @Word64+ toValue = word64 . fromIntegral @Word @Word64 -instance ToValue a => ToValue [a] where+instance (ToValue a) => ToValue [a] where toValue !xs = runST $ do let len = List.length xs dst <- PM.newSmallArray len Null@@ -943,10 +1099,10 @@ go (ix + 1) zs go 0 xs -instance ToValue a => ToValue (SmallArray a) where+instance (ToValue a) => ToValue (SmallArray a) where toValue !xs = Json.Array $! Contiguous.map' toValue xs -instance ToValue a => ToValue (Array a) where+instance (ToValue a) => ToValue (Array a) where toValue !xs = Json.Array $! Contiguous.map' toValue xs instance (Prim a, ToValue a) => ToValue (PrimArray a) where
src/Json/Flatten.hs view
@@ -1,9 +1,10 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language NamedFieldPuns #-}+{-# 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.+{- | Flatten nested JSON objects into a single JSON object in which the keys+have been joined by the separator.+-} module Json.Flatten ( flatten ) where@@ -11,45 +12,46 @@ 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.Builder.Catenable as Builder+import Data.ByteString.Short.Internal (ShortByteString (SBS)) import qualified Data.Bytes as Bytes import qualified Data.Bytes.Text.Utf8 as Utf8+import qualified Data.Chunks as Chunks+import Data.Primitive (ByteArray (ByteArray), MutableByteArray, SmallArray) import qualified Data.Primitive as PM-import qualified Data.Builder.Catenable as Builder+import qualified Data.Primitive.Contiguous as C+import Data.Text.Short (ShortText) import qualified Data.Text.Short as TS import qualified Data.Text.Short.Unsafe as TS+import Data.Word (Word8)+import Json (Member (Member))+import qualified Json --- | 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 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@@ -63,7 +65,7 @@ flattenPeriod :: Json.Value -> Json.Value flattenPeriod x = case x of Json.Object mbrs ->- let bldr = foldMap (\Member{key,value} -> flattenPrefix (ShortTextsBase key) value) mbrs+ let bldr = foldMap (\Member {key, value} -> flattenPrefix (ShortTextsBase key) value) mbrs chunks = Builder.run bldr result = Chunks.concat chunks in Json.Object result@@ -71,25 +73,27 @@ _ -> x flattenPrefix ::- ShortTexts -- context accumulator- -> Json.Value- -> Builder Json.Member+ 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}+ !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+flattenObject !pre !mbrs =+ foldMap+ ( \Member {key, value} -> flattenPrefix (ShortTextsCons key pre) value+ )+ mbrs runShortTexts :: ShortTexts -> ShortText runShortTexts !ts0 = go 0 ts0- where+ where paste :: MutableByteArray s -> Int -> ShortTexts -> ST s ByteArray paste !dst !ix (ShortTextsBase t) = let len = Bytes.length (Utf8.fromShortText t)@@ -116,6 +120,6 @@ in TS.fromShortByteStringUnsafe (SBS r) st2ba :: ShortText -> ByteArray-{-# inline st2ba #-}+{-# INLINE st2ba #-} st2ba t = case TS.toShortByteString t of SBS x -> ByteArray x
src/Json/Smile.hs view
@@ -10,45 +10,62 @@ module Json.Smile ( -- * Encode JSON Document encode+ -- * Encode JSON Atoms+ -- ** Integer , encodeBigInteger+ -- ** String , encodeString , encodeAsciiString+ -- ** Key , encodeKey , encodeAsciiKey ) where -import Prelude hiding (Bool(..))+import Prelude hiding (Bool (..)) import Control.Monad.ST (ST) import Control.Monad.ST.Run (runByteArrayST)-import Data.Bits (countLeadingZeros,complement,unsafeShiftR,(.&.),(.|.))-import Data.Bits (testBit)+import Data.Bits+ ( complement+ , countLeadingZeros+ , testBit+ , unsafeShiftR+ , (.&.)+ , (.|.)+ ) import Data.Bytes.Builder (Builder) import Data.Int (Int32)-import Data.Primitive (ByteArray,newByteArray)-import Data.Primitive (writeByteArray,byteArrayFromListN,sizeofByteArray)-import Data.Primitive (MutableByteArray(..),unsafeFreezeByteArray)-import Data.Primitive (readByteArray,copyMutableByteArray)+import Data.Primitive+ ( ByteArray+ , MutableByteArray (..)+ , byteArrayFromListN+ , copyMutableByteArray+ , newByteArray+ , readByteArray+ , sizeofByteArray+ , unsafeFreezeByteArray+ , writeByteArray+ ) 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 Data.Word (Word32, Word64, Word8)+import Data.Word.Zigzag (toZigzag32, toZigzag64)+import GHC.Exts (RealWorld, State#, Word#)+import GHC.IO (IO (IO))+import GHC.Word (Word (..))+import Json (Member (..), Value (..)) import Numeric.Natural (Natural) import System.IO.Unsafe (unsafeDupablePerformIO) import qualified Arithmetic.Nat as Nat+import qualified Data.ByteString.Short as SBS import qualified Data.Bytes as Bytes import qualified Data.Bytes.Builder as B import qualified Data.Bytes.Builder.Bounded as Bounded import qualified Data.Bytes.Builder.Bounded.Unsafe as Unsafe-import qualified Data.ByteString.Short as SBS import qualified Data.Number.Scientific as Sci import qualified Data.Text.Short as TS import qualified GHC.Exts as Exts@@ -56,10 +73,11 @@ import qualified GHC.Num.Integer as Integer import qualified Prelude --- | Encode a Json 'Value' to the Smile binary format.--- This encoder does not produce backreferences.+{- | Encode a Json 'Value' to the Smile binary format.+This encoder does not produce backreferences.+-} encode :: Value -> Builder-{-# inline encode #-}+{-# INLINE encode #-} encode v0 = B.ascii4 ':' ')' '\n' '\x00' <> encodeNoHeader v0 -- The "rebuild" trick was adapted from the fast-builder library. It@@ -67,25 +85,23 @@ -- This function is marked noinline to ensure that its performance is -- stable. encodeNoHeader :: Value -> Builder-{-# noinline encodeNoHeader #-}+{-# NOINLINE encodeNoHeader #-} encodeNoHeader val = B.rebuild $ case val of Object obj -> B.word8 0xFA- <>- foldMap (\Member{key,value} -> encodeKey key <> encodeNoHeader value) obj- <>- B.word8 0xFB+ <> foldMap (\Member {key, value} -> encodeKey key <> encodeNoHeader value) obj+ <> B.word8 0xFB Array arr -> B.word8 0xF8 <> foldMap encodeNoHeader arr <> B.word8 0xF9 String str -> encodeString str Number x | Just i32 <- Sci.toInt32 x , -16 <= i32 && i32 <= 15- , w5 <- fromIntegral @Word32 @Word8 (toZigzag32 i32)- -> B.word8 (0xC0 + w5)- | Just i32 <- Sci.toInt32 x- -> B.fromBounded Nat.constant (Bounded.word8 0x24 `Bounded.append` vlqSmile64 (fromIntegral @Word32 @Word64 (toZigzag32 i32)))- | Just i64 <- Sci.toInt64 x- -> B.fromBounded Nat.constant (Bounded.word8 0x25 `Bounded.append` vlqSmile64 (toZigzag64 i64))+ , w5 <- fromIntegral @Word32 @Word8 (toZigzag32 i32) ->+ B.word8 (0xC0 + w5)+ | Just i32 <- Sci.toInt32 x ->+ B.fromBounded Nat.constant (Bounded.word8 0x24 `Bounded.append` vlqSmile64 (fromIntegral @Word32 @Word64 (toZigzag32 i32)))+ | Just i64 <- Sci.toInt64 x ->+ B.fromBounded Nat.constant (Bounded.word8 0x25 `Bounded.append` vlqSmile64 (toZigzag64 i64)) | otherwise -> Sci.withExposed encodeSmallDecimal encodeBigDecimal x Null -> B.word8 0x21 False -> B.word8 0x22@@ -97,12 +113,15 @@ encodeBigDecimal :: Integer -> Integer -> Builder encodeBigDecimal c e = case e of 0 -> encodeBigInteger c- _ -> B.word8 0x2A -- bigdecimal token tag- <> vlqSmile ( fromIntegral @Word32 @Natural- $ toZigzag32 scale)- <> vlqSmile (fromIntegral @Int @Natural $ sizeofByteArray raw) -- size of byte digits- <> B.sevenEightSmile (Bytes.fromByteArray raw) -- 7/8 encoding of byte digits- where+ _ ->+ B.word8 0x2A -- bigdecimal token tag+ <> vlqSmile+ ( fromIntegral @Word32 @Natural $+ toZigzag32 scale+ )+ <> vlqSmile (fromIntegral @Int @Natural $ sizeofByteArray raw) -- size of byte digits+ <> B.sevenEightSmile (Bytes.fromByteArray raw) -- 7/8 encoding of byte digits+ where scale :: Int32 -- WARNING smile can't handle exponents outside int32_t, so this truncates -- WARNING "scale" is what Java BigDecimal thinks, which is@@ -112,68 +131,73 @@ -- | Encode a number using as SMILE @BigInteger@ token type (prefix @0x26@). encodeBigInteger :: Integer -> Builder-encodeBigInteger n = B.word8 0x26- <> vlqSmile (fromIntegral @Int @Natural $ sizeofByteArray raw) -- size of byte digits- <> B.sevenEightSmile (Bytes.fromByteArray raw) -- 7/8 encoding of byte digits- where+encodeBigInteger n =+ B.word8 0x26+ <> vlqSmile (fromIntegral @Int @Natural $ sizeofByteArray raw) -- size of byte digits+ <> B.sevenEightSmile (Bytes.fromByteArray raw) -- 7/8 encoding of byte digits+ where !raw = integerToBase256ByteArray n integerToBase256ByteArray :: Integer -> ByteArray-integerToBase256ByteArray c = if c == 0- then byteArrayFromListN 1 [0::Word8]- else case c of- Integer.IP bn -> unsafeDupablePerformIO $ do- let nDigits256 = fromIntegral @Word @Int (W# (BN.bigNatSizeInBase# 256## bn))- mut <- newByteArray nDigits256- let !(MutableByteArray mut#) = mut- !_ <- 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- then do- -- If the upper bit is 1, then we must introduce a leading- -- zero byte.- dst <- newByteArray (nDigits256 + 1)- writeByteArray dst 0 (0x00 :: Word8)- copyMutableByteArray dst 1 mut 0 nDigits256- unsafeFreezeByteArray dst- else unsafeFreezeByteArray mut- Integer.IN bn -> twosComplementBigNat bn- Integer.IS i -> case i Exts.># 0# of- 1# -> encodePosWordBase256 (W# (Exts.int2Word# i))- _ -> encodeNegWordBase256 (W# (Exts.int2Word# i))+integerToBase256ByteArray c =+ if c == 0+ then byteArrayFromListN 1 [0 :: Word8]+ else case c of+ Integer.IP bn -> unsafeDupablePerformIO $ do+ let nDigits256 = fromIntegral @Word @Int (W# (BN.bigNatSizeInBase# 256## bn))+ mut <- newByteArray nDigits256+ let !(MutableByteArray mut#) = mut+ !_ <- 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+ then do+ -- If the upper bit is 1, then we must introduce a leading+ -- zero byte.+ dst <- newByteArray (nDigits256 + 1)+ writeByteArray dst 0 (0x00 :: Word8)+ copyMutableByteArray dst 1 mut 0 nDigits256+ unsafeFreezeByteArray dst+ else unsafeFreezeByteArray mut+ Integer.IN bn -> twosComplementBigNat bn+ Integer.IS i -> case i Exts.># 0# of+ 1# -> encodePosWordBase256 (W# (Exts.int2Word# i))+ _ -> encodeNegWordBase256 (W# (Exts.int2Word# i)) liftWordIO :: (State# RealWorld -> (# State# RealWorld, Word# #)) -> IO Word-{-# inline liftWordIO #-}-liftWordIO f = IO- (\s -> case f s of- (# s', w #) -> (# s', W# w #)- )+{-# 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# (BN.bigNatSizeInBase# 256## bn)) mut <- newByteArray nDigits256 let !(MutableByteArray mut#) = mut- !_ <- liftWordIO (BN.bigNatToMutableByteArray# bn mut# 0## 1# )+ !_ <- liftWordIO (BN.bigNatToMutableByteArray# bn mut# 0## 1#) -- First, complement- let goComplement !ix = if ix >= 0- then do- w :: Word8 <- readByteArray mut ix- writeByteArray mut ix (complement w)- goComplement (ix - 1)- else pure ()+ let goComplement !ix =+ if ix >= 0+ then do+ w :: Word8 <- readByteArray mut ix+ writeByteArray mut ix (complement w)+ goComplement (ix - 1)+ else pure () goComplement (nDigits256 - 1) -- Second, add one- let goAddOne !ix = if ix >= 0- then do- w :: Word8 <- readByteArray mut ix- case w of- 0xFF -> do- writeByteArray mut ix (0 :: Word8)- goAddOne (ix - 1)- _ -> writeByteArray mut ix (w + 1)- else pure ()+ let goAddOne !ix =+ if ix >= 0+ then do+ w :: Word8 <- readByteArray mut ix+ case w of+ 0xFF -> do+ writeByteArray mut ix (0 :: Word8)+ goAddOne (ix - 1)+ _ -> writeByteArray mut ix (w + 1)+ else pure () goAddOne (nDigits256 - 1) leader :: Word8 <- readByteArray mut 0 if testBit leader 7@@ -201,11 +225,12 @@ -- Because the latter would be misinterpreted as a negative number. let !total = quot (72 - countLeadingZeros w) 8 dst <- newByteArray total- let go !ix !acc = if ix >= 0 - then do- writeByteArray dst ix (fromIntegral @Word @Word8 acc)- go (ix - 1) (unsafeShiftR acc 8)- else unsafeFreezeByteArray dst+ let go !ix !acc =+ if ix >= 0+ then do+ writeByteArray dst ix (fromIntegral @Word @Word8 acc)+ go (ix - 1) (unsafeShiftR acc 8)+ else unsafeFreezeByteArray dst go (total - 1) w -- Same deal as encodePosWordBase256.@@ -215,22 +240,24 @@ encodeNegWordBase256 !w = runByteArrayST $ do let !total = quot (72 - countLeadingZeros (complement w)) 8 dst <- newByteArray total- let go !ix !acc = if ix >= 0 - then do- writeByteArray dst ix (fromIntegral @Word @Word8 acc)- go (ix - 1) (unsafeShiftR acc 8)- else unsafeFreezeByteArray dst+ let go !ix !acc =+ if ix >= 0+ then do+ writeByteArray dst ix (fromIntegral @Word @Word8 acc)+ go (ix - 1) (unsafeShiftR acc 8)+ else unsafeFreezeByteArray dst go (total - 1) w --- | Encode a string in which all characters are ASCII. This precondition--- is not checked. Resulting output will be corrupt if this condition--- is not satisfied.+{- | Encode a string in which all characters are ASCII. This precondition+is not checked. Resulting output will be corrupt if this condition+is not satisfied.+-} encodeAsciiString :: ShortText -> Builder encodeAsciiString !str | n == 0 = B.word8 0x20 | n <= 64 = B.copyCons (0x40 + fromIntegral (n - 1)) (Bytes.fromShortByteString (TS.toShortByteString str)) | otherwise = B.word8 0xe0 <> B.shortTextUtf8 str <> B.word8 0xFC- where+ where n = SBS.length (TS.toShortByteString str) -- | Encode a string.@@ -249,35 +276,39 @@ encodeKey :: ShortText -> Builder encodeKey !str = case SBS.length (TS.toShortByteString str) of 0 -> B.word8 0x20- n | n <= 64- && TS.isAscii str- , w8 <- fromIntegral @Int @Word8 (n - 1)- -> B.copyCons (0x80 + w8) (Bytes.fromShortByteString (TS.toShortByteString str))- n | n < 56- , w8 <- fromIntegral @Int @Word8 (n - 2)- -> B.copyCons (0xC0 + w8) (Bytes.fromShortByteString (TS.toShortByteString str))+ n+ | n <= 64+ && TS.isAscii str+ , w8 <- fromIntegral @Int @Word8 (n - 1) ->+ B.copyCons (0x80 + w8) (Bytes.fromShortByteString (TS.toShortByteString str))+ n+ | n < 56+ , w8 <- fromIntegral @Int @Word8 (n - 2) ->+ B.copyCons (0xC0 + w8) (Bytes.fromShortByteString (TS.toShortByteString str)) | otherwise -> B.word8 0x34 <> B.shortTextUtf8 str <> B.word8 0xFC --- | Encode a key in which all characters are ASCII. This precondition--- is not checked. Resulting output will be corrupt if this condition--- is not satisfied.+{- | Encode a key in which all characters are ASCII. This precondition+is not checked. Resulting output will be corrupt if this condition+is not satisfied.+-} encodeAsciiKey :: ShortText -> Builder encodeAsciiKey str = case SBS.length (TS.toShortByteString str) of 0 -> B.word8 0x20- n | n <= 64- , w8 <- fromIntegral @Int @Word8 (n - 1)- -> B.word8 (0x80 + w8) <> B.shortTextUtf8 str+ n+ | n <= 64+ , w8 <- fromIntegral @Int @Word8 (n - 1) ->+ B.word8 (0x80 + w8) <> B.shortTextUtf8 str | otherwise -> B.word8 0x34 <> B.shortTextUtf8 str <> B.word8 0xFC vlqSmile :: Natural -> Builder vlqSmile n0 = let (rest, lastBits) = take6bits n0 in loop rest <> B.word8 (lastBits .|. 0x80)- where+ where loop n | n == 0 = mempty- | (rest, bits) <- take7bits n- = loop rest <> B.word8 bits+ | (rest, bits) <- take7bits n =+ loop rest <> B.word8 bits take7bits :: Natural -> (Natural, Word8) take7bits n = (n `unsafeShiftR` 7, fromIntegral @Natural @Word8 n .&. 0x7F) take6bits :: Natural -> (Natural, Word8)@@ -305,13 +336,15 @@ -- -- Copied from bytebuild reverseBytes :: MutableByteArray s -> Int -> Int -> ST s ()-{-# inline reverseBytes #-}-reverseBytes arr begin end = go begin end where- go ixA ixB = if ixA < ixB- then do- a :: Word8 <- readByteArray arr ixA- b :: Word8 <- readByteArray arr ixB- writeByteArray arr ixA b- writeByteArray arr ixB a- go (ixA + 1) (ixB - 1)- else pure ()+{-# INLINE reverseBytes #-}+reverseBytes arr begin end = go begin end+ where+ go ixA ixB =+ if ixA < ixB+ then do+ a :: Word8 <- readByteArray arr ixA+ b :: Word8 <- readByteArray arr ixB+ writeByteArray arr ixA b+ writeByteArray arr ixB a+ go (ixA + 1) (ixB - 1)+ else pure ()