rhi/bytebuild
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Prepare 0.3.16.1 release

Browse source 
Reformatted.
Added workflows.
Updated package metadata.
This commit is contained in:
Brian McKeon 2024-02-02 21:37:18 -05:00 • committed by GitHub
parent 0a79b2d0e9
commit 277d03b475
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
26 changed files with 2394 additions and 1912 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.github/CODEOWNERS vendored Normal file
View file

@ -0,0 +1 @@
@byteverse/l3c

12
.github/workflows/build.yaml vendored Normal file
View file

@ -0,0 +1,12 @@
name: build
on:
pull_request:
branches:
- "*"
jobs:
call-workflow:
uses: byteverse/.github/.github/workflows/build.yaml@main
secrets: inherit
with:
release: false

12
.github/workflows/release.yaml vendored Normal file
View file

@ -0,0 +1,12 @@
name: release
on:
push:
tags:
- "*"
jobs:
call-workflow:
uses: byteverse/.github/.github/workflows/build.yaml@main
secrets: inherit
with:
release: true

2
.gitignore vendored
View file

@ -1,3 +1,4 @@
.vscode/
dist dist
dist-* dist-*
cabal-dev cabal-dev
@ -11,6 +12,7 @@ cabal-dev
.hsenv .hsenv
.cabal-sandbox/ .cabal-sandbox/
cabal.sandbox.config cabal.sandbox.config
cabal.project.local
*.prof *.prof
*.aux *.aux
*.hp *.hp

2
CHANGELOG.md
View file

@ -5,7 +5,7 @@ Note: Prior to version 0.3.4.0, this library was named
`small-bytearray-builder` is now just a compatibility shim `small-bytearray-builder` is now just a compatibility shim
to ease the migration process. to ease the migration process.
## 0.3.16.1 -- 2024-??-?? ## 0.3.16.1 -- 2024-02-02
* Remove all CPP * Remove all CPP
* Drop support for GHC < 9.4 * Drop support for GHC < 9.4

2
Setup.hs
View file

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

31
bench/Cell.hs
View file

@ -1,14 +1,14 @@
{-# language OverloadedLists #-} {-# LANGUAGE OverloadedLists #-}
{-# language OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Cell module Cell
( Cell(..) ( Cell (..)
, cells , cells
) where ) where
import Data.Word (Word32)
import Data.Text.Short (ShortText)
import Data.Primitive (SmallArray) import Data.Primitive (SmallArray)
import Data.Text.Short (ShortText)
import Data.Word (Word32)
-- A cell in a CSV file -- A cell in a CSV file
data Cell data Cell
@ -18,15 +18,14 @@ data Cell
-- Some sample data to encode as a CSV -- Some sample data to encode as a CSV
cells :: SmallArray (SmallArray Cell) cells :: SmallArray (SmallArray Cell)
cells = cells =
[ [ CellString "Randy", CellString "Gutiérrez", CellNumber 41, CellNumber 343 ] [ [CellString "Randy", CellString "Gutiérrez", CellNumber 41, CellNumber 343]
, [ CellString "Édith", CellString "Piaf", CellNumber 63, CellNumber 453 ] , [CellString "Édith", CellString "Piaf", CellNumber 63, CellNumber 453]
, [ CellString "Martha", CellString "Washington", CellNumber 51, CellNumber 634 ] , [CellString "Martha", CellString "Washington", CellNumber 51, CellNumber 634]
, [ CellString "Julius", CellString "Caesar", CellNumber 1, CellNumber 6922 ] , [CellString "Julius", CellString "Caesar", CellNumber 1, CellNumber 6922]
, [ CellString "Robert", CellString "Redford", CellNumber 24, CellNumber 617 ] , [CellString "Robert", CellString "Redford", CellNumber 24, CellNumber 617]
, [ CellString "Violet", CellString "Crawley", CellNumber 71, CellNumber 150 ] , [CellString "Violet", CellString "Crawley", CellNumber 71, CellNumber 150]
, [ CellString "Lázaro", CellString "Cárdenas", CellNumber 58, CellNumber 299 ] , [CellString "Lázaro", CellString "Cárdenas", CellNumber 58, CellNumber 299]
, [ CellString "Anastasia", CellString "San Martin", CellNumber 103, CellNumber 3214 ] , [CellString "Anastasia", CellString "San Martin", CellNumber 103, CellNumber 3214]
, [ CellString "Mad", CellString "Max", CellNumber 37, CellNumber 918 ] , [CellString "Mad", CellString "Max", CellNumber 37, CellNumber 918]
, [ CellString "Sidonie-Gabrielle", CellString "Collette", CellNumber 25, CellNumber 904 ] , [CellString "Sidonie-Gabrielle", CellString "Collette", CellNumber 25, CellNumber 904]
] ]

132
bench/Main.hs
View file

@ -1,9 +1,8 @@
{-# language LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}
{-# language OverloadedStrings #-}
import Data.Primitive (ByteArray) import Data.Primitive (ByteArray)
import Data.Word (Word64) import Data.Word (Word64)
import Gauge (bgroup,bench,whnf) import Gauge (bench, bgroup, whnf)
import Gauge.Main (defaultMain) import Gauge.Main (defaultMain)
import qualified Arithmetic.Nat as Nat import qualified Arithmetic.Nat as Nat
@ -11,70 +10,87 @@ import qualified Data.Bytes.Builder as B
import qualified Data.Bytes.Builder.Bounded as U import qualified Data.Bytes.Builder.Bounded as U
import qualified Cell import qualified Cell
import qualified SimpleCsv
import qualified HexWord64 import qualified HexWord64
import qualified SimpleCsv
import qualified Word16Tree import qualified Word16Tree
main :: IO () main :: IO ()
main = defaultMain main =
[ bgroup "w64" defaultMain
[ bgroup "hex" [ bgroup
[ bench "library" (whnf encodeHexWord64s w64s) "w64"
, bench "loop" (whnf encodeHexWord64sLoop w64s) [ bgroup
] "hex"
[ bench "library" (whnf encodeHexWord64s w64s)
, bench "loop" (whnf encodeHexWord64sLoop w64s)
]
]
, bgroup
"unbounded"
[ bench "csv-no-escape" $
whnf
(\x -> B.run 4080 (SimpleCsv.encodeRows x))
Cell.cells
, bench "word-16-tree-small" $
whnf
(\x -> B.run 4080 (Word16Tree.encode x))
Word16Tree.exampleSmall
, bench "word-16-tree-2000" $
whnf
(\x -> B.run ((4096 * 16) - 16) (Word16Tree.encode x))
Word16Tree.example2000
, bench "word-16-tree-9000" $
whnf
(\x -> B.run ((4096 * 64) - 16) (Word16Tree.encode x))
Word16Tree.example9000
]
] ]
, bgroup "unbounded"
[ bench "csv-no-escape" $ whnf
(\x -> B.run 4080 (SimpleCsv.encodeRows x))
Cell.cells
, bench "word-16-tree-small" $ whnf
(\x -> B.run 4080 (Word16Tree.encode x))
Word16Tree.exampleSmall
, bench "word-16-tree-2000" $ whnf
(\x -> B.run ((4096 * 16) - 16) (Word16Tree.encode x))
Word16Tree.example2000
, bench "word-16-tree-9000" $ whnf
(\x -> B.run ((4096 * 64) - 16) (Word16Tree.encode x))
Word16Tree.example9000
]
]
w64s :: Word64s w64s :: Word64s
w64s = Word64s w64s =
0xde2b8a480cf77113 Word64s
0x48f1668ca2a68b45 0xde2b8a480cf77113
0xd262fbaa0b2f473c 0x48f1668ca2a68b45
0xbab20547f4919d9f 0xd262fbaa0b2f473c
0xb7ec16121704db43 0xbab20547f4919d9f
0x9c259f5bfa90e1eb 0xb7ec16121704db43
0xd451eca11d9873ad 0x9c259f5bfa90e1eb
0xbd927e8d4c879d02 0xd451eca11d9873ad
0xbd927e8d4c879d02
data Word64s = Word64s data Word64s
!Word64 !Word64 !Word64 !Word64 = Word64s
!Word64 !Word64 !Word64 !Word64 !Word64
!Word64
!Word64
!Word64
!Word64
!Word64
!Word64
!Word64
encodeHexWord64s :: Word64s -> ByteArray encodeHexWord64s :: Word64s -> ByteArray
{-# noinline encodeHexWord64s #-} {-# NOINLINE encodeHexWord64s #-}
encodeHexWord64s (Word64s a b c d e f g h) = U.run Nat.constant $ encodeHexWord64s (Word64s a b c d e f g h) =
U.word64PaddedUpperHex a `U.append` U.run Nat.constant $
U.word64PaddedUpperHex b `U.append` U.word64PaddedUpperHex a
U.word64PaddedUpperHex c `U.append` `U.append` U.word64PaddedUpperHex b
U.word64PaddedUpperHex d `U.append` `U.append` U.word64PaddedUpperHex c
U.word64PaddedUpperHex e `U.append` `U.append` U.word64PaddedUpperHex d
U.word64PaddedUpperHex f `U.append` `U.append` U.word64PaddedUpperHex e
U.word64PaddedUpperHex g `U.append` `U.append` U.word64PaddedUpperHex f
U.word64PaddedUpperHex h `U.append` U.word64PaddedUpperHex g
`U.append` U.word64PaddedUpperHex h
encodeHexWord64sLoop :: Word64s -> ByteArray encodeHexWord64sLoop :: Word64s -> ByteArray
{-# noinline encodeHexWord64sLoop #-} {-# NOINLINE encodeHexWord64sLoop #-}
encodeHexWord64sLoop (Word64s a b c d e f g h) = U.run Nat.constant $ encodeHexWord64sLoop (Word64s a b c d e f g h) =
HexWord64.word64PaddedUpperHex a `U.append` U.run Nat.constant $
HexWord64.word64PaddedUpperHex b `U.append` HexWord64.word64PaddedUpperHex a
HexWord64.word64PaddedUpperHex c `U.append` `U.append` HexWord64.word64PaddedUpperHex b
HexWord64.word64PaddedUpperHex d `U.append` `U.append` HexWord64.word64PaddedUpperHex c
HexWord64.word64PaddedUpperHex e `U.append` `U.append` HexWord64.word64PaddedUpperHex d
HexWord64.word64PaddedUpperHex f `U.append` `U.append` HexWord64.word64PaddedUpperHex e
HexWord64.word64PaddedUpperHex g `U.append` `U.append` HexWord64.word64PaddedUpperHex f
HexWord64.word64PaddedUpperHex h `U.append` HexWord64.word64PaddedUpperHex g
`U.append` HexWord64.word64PaddedUpperHex h

22
bench/SimpleCsv.hs
View file

@ -1,4 +1,4 @@
{-# language LambdaCase #-} {-# LANGUAGE LambdaCase #-}
-- A variant of CSV encoding that does not perform -- A variant of CSV encoding that does not perform
-- any escaping or quoting. This is in its own module -- any escaping or quoting. This is in its own module
@ -8,22 +8,24 @@ module SimpleCsv
( encodeRows ( encodeRows
) where ) where
import Cell (Cell(..)) import Cell (Cell (..))
import Data.Primitive (SmallArray) import Data.Primitive (SmallArray)
import qualified Data.Foldable as F
import qualified Data.Bytes.Builder as B import qualified Data.Bytes.Builder as B
import qualified Data.Foldable as F
encodeRows :: SmallArray (SmallArray Cell) -> B.Builder encodeRows :: SmallArray (SmallArray Cell) -> B.Builder
encodeRows = F.foldr encodeRows =
(\r x -> encodeSimpleCsvRow r (B.ascii '\n' <> x)) F.foldr
mempty (\r x -> encodeSimpleCsvRow r (B.ascii '\n' <> x))
mempty
encodeSimpleCsvRow :: SmallArray Cell -> B.Builder -> B.Builder encodeSimpleCsvRow :: SmallArray Cell -> B.Builder -> B.Builder
encodeSimpleCsvRow cs b = F.foldr encodeSimpleCsvRow cs b =
(\c x -> encodeSimpleCsvCell c <> B.ascii ',' <> x) F.foldr
b (\c x -> encodeSimpleCsvCell c <> B.ascii ',' <> x)
cs b
cs
encodeSimpleCsvCell :: Cell -> B.Builder encodeSimpleCsvCell :: Cell -> B.Builder
encodeSimpleCsvCell = \case encodeSimpleCsvCell = \case

143
bytebuild.cabal
View file

@ -1,17 +1,17 @@
cabal-version: 2.2 cabal-version: 2.2
name: bytebuild name: bytebuild
version: 0.3.16.1 version: 0.3.16.1
synopsis: Build byte arrays synopsis: Build byte arrays
description: description:
This is similar to the builder facilities provided by This is similar to the builder facilities provided by
`Data.ByteString.Builder`. It is intended to be used in `Data.ByteString.Builder`. It is intended to be used in
situations where the following apply: situations where the following apply:
. .
* An individual entity will be serialized as a small * An individual entity will be serialized as a small
number of bytes (less than 512). number of bytes (less than 512).
. .
* A large number (more than 32) of entities will be serialized * A large number (more than 32) of entities will be serialized
one after another without anything between them. one after another without anything between them.
. .
Unlike builders from the `bytestring` package, these builders Unlike builders from the `bytestring` package, these builders
do not track their state when they run out of space. A builder do not track their state when they run out of space. A builder
@ -19,110 +19,123 @@ description:
of the next chunk. This strategy for building is suitable for most of the next chunk. This strategy for building is suitable for most
CSVs and several line protocols (carbon, InfluxDB, etc.). CSVs and several line protocols (carbon, InfluxDB, etc.).
homepage: https://github.com/byteverse/bytebuild homepage: https://github.com/byteverse/bytebuild
bug-reports: https://github.com/byteverse/bytebuild/issues bug-reports: https://github.com/byteverse/bytebuild/issues
license: BSD-3-Clause license: BSD-3-Clause
license-file: LICENSE license-file: LICENSE
author: Andrew Martin author: Andrew Martin
maintainer: andrew.thaddeus@gmail.com maintainer: amartin@layer3com.com
copyright: 2019 Andrew Martin copyright: 2019 Andrew Martin
category: Data category: Data
extra-source-files: CHANGELOG.md extra-doc-files: CHANGELOG.md
common build-settings
default-language: Haskell2010
ghc-options: -Wall -Wunused-packages
flag checked flag checked
manual: True manual: True
description: Add bounds-checking to primitive array operations description: Add bounds-checking to primitive array operations
default: False default: False
library library
import: build-settings
exposed-modules: exposed-modules:
Data.Bytes.Builder Data.Bytes.Builder
Data.Bytes.Builder.Avro Data.Bytes.Builder.Avro
Data.Bytes.Builder.Class
Data.Bytes.Builder.Template
Data.Bytes.Builder.Unsafe
Data.Bytes.Builder.Bounded Data.Bytes.Builder.Bounded
Data.Bytes.Builder.Bounded.Class Data.Bytes.Builder.Bounded.Class
Data.Bytes.Builder.Bounded.Unsafe Data.Bytes.Builder.Bounded.Unsafe
Data.Bytes.Builder.Class
Data.Bytes.Builder.Template
Data.Bytes.Builder.Unsafe
other-modules: other-modules:
Compat Compat
Op Op
reexported-modules:
Data.Bytes.Chunks reexported-modules: Data.Bytes.Chunks
build-depends: build-depends:
, base >=4.17.0.0 && <4.20 , base >=4.17.0.0 && <4.20
, byteslice >=0.2.6 && <0.3 , byteslice >=0.2.6 && <0.3
, bytestring >=0.10.8.2 && <0.13 , bytestring >=0.10.8.2 && <0.13
, haskell-src-meta >=0.8.13 , haskell-src-meta >=0.8.13
, integer-logarithms >=1.0.3 && <1.1 , integer-logarithms >=1.0.3 && <1.1
, natural-arithmetic >=0.1 && <0.3 , natural-arithmetic >=0.1 && <0.3
, primitive-offset >=0.2 && <0.3 , primitive-offset >=0.2 && <0.3
, run-st >=0.1.2 && <0.2 , run-st >=0.1.2 && <0.2
, template-haskell >=2.16 , template-haskell >=2.16
, text >=2.0 && <2.2 , text >=2.0 && <2.2
, text-short >=0.1.3 && <0.2 , text-short >=0.1.3 && <0.2
, wide-word >=0.1.0.9 && <0.2 , wide-word >=0.1.0.9 && <0.2
, zigzag , zigzag
if impl(ghc >= 9.2)
if impl(ghc >=9.2)
hs-source-dirs: src-9.2 hs-source-dirs: src-9.2
else else
if impl(ghc >= 8.10) if impl(ghc >=8.10)
hs-source-dirs: src-9.0 hs-source-dirs: src-9.0
if flag(checked) if flag(checked)
build-depends: primitive-checked >= 0.7 && <0.10 build-depends: primitive-checked >=0.7 && <0.10
hs-source-dirs: src-checked hs-source-dirs: src-checked
else else
build-depends: primitive >= 0.7 && <0.10 build-depends: primitive >=0.7 && <0.10
hs-source-dirs: src-unchecked hs-source-dirs: src-unchecked
ghc-options: -Wall -O2
hs-source-dirs: src ghc-options: -O2
default-language: Haskell2010 hs-source-dirs: src
c-sources: cbits/bytebuild_custom.c c-sources: cbits/bytebuild_custom.c
test-suite test test-suite test
default-language: Haskell2010 import: build-settings
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
hs-source-dirs: test, common hs-source-dirs: test common
main-is: Main.hs main-is: Main.hs
ghc-options: -O2 -Wall ghc-options: -O2
other-modules: other-modules:
HexWord64 HexWord64
Word16Tree Word16Tree
build-depends: build-depends:
, QuickCheck >=2.13.1 && <2.15 , base >=4.12.0.0 && <5
, base >=4.12.0.0 && <5
, bytebuild , bytebuild
, byteslice , byteslice
, bytestring , bytestring
, natural-arithmetic , natural-arithmetic
, primitive , primitive
, primitive-unlifted >=0.1.2 , QuickCheck >=2.13.1 && <2.15
, quickcheck-classes >=0.6.4 , quickcheck-instances >=0.3.22
, quickcheck-instances >=0.3.22 , tasty >=1.2.3 && <1.6
, tasty-hunit >=0.10.0.2 && <0.11
, tasty-quickcheck >=0.10.1 && <0.11
, text >=2.0 && <2.2
, text-short , text-short
, tasty >=1.2.3 && <1.6 , wide-word >=0.1.0.9 && <0.2
, tasty-hunit >=0.10.0.2 && <0.11
, tasty-quickcheck >=0.10.1 && <0.11
, text >=2.0 && <2.2
, vector
, wide-word >=0.1.0.9 && <0.2
benchmark bench benchmark bench
type: exitcode-stdio-1.0 import: build-settings
type: exitcode-stdio-1.0
build-depends: build-depends:
, base , base
, bytebuild , bytebuild
, gauge >= 0.2.4 , byteslice
, gauge >=0.2.4
, natural-arithmetic , natural-arithmetic
, primitive , primitive
, text-short , text-short
, byteslice
ghc-options: -Wall -O2 ghc-options: -O2
default-language: Haskell2010 hs-source-dirs: bench common
hs-source-dirs: bench, common main-is: Main.hs
main-is: Main.hs
other-modules: other-modules:
Cell Cell
HexWord64 HexWord64
SimpleCsv SimpleCsv
Word16Tree Word16Tree
source-repository head
type: git
location: git://github.com/byteverse/bytebuild.git

45
common/HexWord64.hs
View file

@ -1,10 +1,10 @@
{-# language BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# language ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-}
{-# language DataKinds #-} {-# LANGUAGE MagicHash #-}
{-# language UnboxedTuples #-} {-# LANGUAGE PolyKinds #-}
{-# language MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# language PolyKinds #-} {-# LANGUAGE TypeApplications #-}
{-# language TypeApplications #-} {-# LANGUAGE UnboxedTuples #-}
module HexWord64 module HexWord64
( word64PaddedUpperHex ( word64PaddedUpperHex
@ -15,34 +15,37 @@ module HexWord64
-- the hoop jumping, the explicit loop used here is still outperformed -- the hoop jumping, the explicit loop used here is still outperformed
-- by just inlining the loop. -- by just inlining the loop.
import GHC.ST (ST(ST))
import Data.Bits import Data.Bits
import Data.Bytes.Builder.Bounded.Unsafe (Builder,construct) import Data.Bytes.Builder.Bounded.Unsafe (Builder, construct)
import Data.Primitive import Data.Primitive
import Data.Word import Data.Word
import GHC.Exts import GHC.Exts
import GHC.ST (ST (ST))
import qualified Control.Monad.Primitive as PM import qualified Control.Monad.Primitive as PM
type ST# s (a :: TYPE (r :: RuntimeRep)) = State# s -> (# State# s, a #) type ST# s (a :: TYPE (r :: RuntimeRep)) = State# s -> (# State# s, a #)
word64PaddedUpperHex :: Word64 -> Builder 16 word64PaddedUpperHex :: Word64 -> Builder 16
word64PaddedUpperHex w = construct $ \a b -> ST word64PaddedUpperHex w = construct $ \a b ->
(\s0 -> case word64PaddedUpperHexLoop w 60 a b s0 of ST
(# s1, i #) -> (# s1, I# i #) ( \s0 -> case word64PaddedUpperHexLoop w 60 a b s0 of
) (# s1, i #) -> (# s1, I# i #)
)
word64PaddedUpperHexLoop :: forall s. Word64 -> Int -> MutableByteArray s -> Int -> ST# s Int# word64PaddedUpperHexLoop :: forall s. Word64 -> Int -> MutableByteArray s -> Int -> ST# s Int#
word64PaddedUpperHexLoop !w !shiftAmount !arr !i@(I# i#) s0 = if shiftAmount >= 0 word64PaddedUpperHexLoop !w !shiftAmount !arr !i@(I# i#) s0 =
then case PM.internal @(ST s) (writeByteArray arr i (toHexUpper (unsafeShiftR w shiftAmount))) s0 of if shiftAmount >= 0
(# s1, (_ :: ()) #) -> word64PaddedUpperHexLoop w (shiftAmount - 4) arr (i + 1) s1 then case PM.internal @(ST s) (writeByteArray arr i (toHexUpper (unsafeShiftR w shiftAmount))) s0 of
else (# s0, i# #) (# s1, (_ :: ()) #) -> word64PaddedUpperHexLoop w (shiftAmount - 4) arr (i + 1) s1
else (# s0, i# #)
toHexUpper :: Word64 -> Word8 toHexUpper :: Word64 -> Word8
toHexUpper w' = fromIntegral toHexUpper w' =
$ (complement theMask .&. loSolved) fromIntegral $
.|. (theMask .&. hiSolved) (complement theMask .&. loSolved)
where .|. (theMask .&. hiSolved)
where
w = w' .&. 0xF w = w' .&. 0xF
-- This is all ones if the value was >= 10 -- This is all ones if the value was >= 10
theMask = (1 .&. unsafeShiftR (w - 10) 63) - 1 theMask = (1 .&. unsafeShiftR (w - 10) 63) - 1

93
common/Word16Tree.hs
View file

@ -1,4 +1,4 @@
{-# language BangPatterns #-} {-# LANGUAGE BangPatterns #-}
module Word16Tree module Word16Tree
( Word16Tree ( Word16Tree
@ -9,11 +9,11 @@ module Word16Tree
, expectedSmall , expectedSmall
) where ) where
import Data.Bytes.Builder as B
import Data.Word (Word16)
import Data.Primitive (ByteArray)
import qualified Data.Bytes as Bytes import qualified Data.Bytes as Bytes
import Data.Bytes.Builder as B
import qualified Data.Bytes.Text.Ascii import qualified Data.Bytes.Text.Ascii
import Data.Primitive (ByteArray)
import Data.Word (Word16)
data Word16Tree data Word16Tree
= Branch !Word16Tree !Word16Tree = Branch !Word16Tree !Word16Tree
@ -23,63 +23,62 @@ encode :: Word16Tree -> Builder
encode (Leaf w) = B.word16PaddedUpperHex w encode (Leaf w) = B.word16PaddedUpperHex w
encode (Branch a b) = encode (Branch a b) =
B.ascii '(' B.ascii '('
<> <> encode a
encode a <> B.ascii ','
<> <> encode b
B.ascii ',' <> B.ascii ')'
<>
encode b
<>
B.ascii ')'
expectedSmall :: ByteArray expectedSmall :: ByteArray
expectedSmall = Bytes.toByteArray $ Data.Bytes.Text.Ascii.fromString expectedSmall =
"((AB59,(1F33,2E71)),((((FA9A,247B),890C),(0F13,((55BF,7CF1),389B))),1205))" Bytes.toByteArray $
Data.Bytes.Text.Ascii.fromString
"((AB59,(1F33,2E71)),((((FA9A,247B),890C),(0F13,((55BF,7CF1),389B))),1205))"
exampleSmall :: Word16Tree exampleSmall :: Word16Tree
exampleSmall = Branch exampleSmall =
(Branch Branch
(Leaf 0xAB59) ( Branch
(Branch (Leaf 0xAB59)
(Leaf 0x1F33) ( Branch
(Leaf 0x2E71) (Leaf 0x1F33)
) (Leaf 0x2E71)
)
(Branch
(Branch
(Branch
(Branch
(Leaf 0xFA9A)
(Leaf 0x247B)
) )
(Leaf 0x890C)
)
(Branch
(Leaf 0x0F13)
(Branch
(Branch
(Leaf 0x55BF)
(Leaf 0x7CF1)
)
(Leaf 0x389B)
)
)
) )
(Leaf 0x1205) ( Branch
) ( Branch
( Branch
( Branch
(Leaf 0xFA9A)
(Leaf 0x247B)
)
(Leaf 0x890C)
)
( Branch
(Leaf 0x0F13)
( Branch
( Branch
(Leaf 0x55BF)
(Leaf 0x7CF1)
)
(Leaf 0x389B)
)
)
)
(Leaf 0x1205)
)
example2000 :: Word16Tree example2000 :: Word16Tree
{-# noinline example2000 #-} {-# NOINLINE example2000 #-}
example2000 = balanced 0 2000 example2000 = balanced 0 2000
example9000 :: Word16Tree example9000 :: Word16Tree
{-# noinline example9000 #-} {-# NOINLINE example9000 #-}
example9000 = balanced 0 9000 example9000 = balanced 0 9000
balanced :: Word16 -> Word16 -> Word16Tree balanced :: Word16 -> Word16 -> Word16Tree
balanced !off !n balanced !off !n
| n == 0 = Leaf off | n == 0 = Leaf off
| n == 1 = Leaf (off + 1) | n == 1 = Leaf (off + 1)
| otherwise = let x = div n 2 in | otherwise =
Branch (balanced off x) (balanced (off + x) (n - x)) let x = div n 2
in Branch (balanced off x) (balanced (off + x) (n - x))

51
fourmolu.yaml Normal file
View file

@ -0,0 +1,51 @@
# Number of spaces per indentation step
indentation: 2
# Max line length for automatic line breaking
column-limit: 200
# Styling of arrows in type signatures (choices: trailing, leading, or leading-args)
function-arrows: trailing
# How to place commas in multi-line lists, records, etc. (choices: leading or trailing)
comma-style: leading
# Styling of import/export lists (choices: leading, trailing, or diff-friendly)
import-export-style: leading
# Whether to full-indent or half-indent 'where' bindings past the preceding body
indent-wheres: false
# Whether to leave a space before an opening record brace
record-brace-space: true
# Number of spaces between top-level declarations
newlines-between-decls: 1
# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact)
haddock-style: multi-line
# How to print module docstring
haddock-style-module: null
# Styling of let blocks (choices: auto, inline, newline, or mixed)
let-style: auto
# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space)
in-style: right-align
# Whether to put parentheses around a single constraint (choices: auto, always, or never)
single-constraint-parens: always
# Output Unicode syntax (choices: detect, always, or never)
unicode: never
# Give the programmer more choice on where to insert blank lines
respectful: true
# Fixity information for operators
fixities: []
# Module reexports Fourmolu should know about
reexports: []

24
src-9.0/Compat.hs
View file

@ -1,4 +1,4 @@
{-# language MagicHash #-} {-# LANGUAGE MagicHash #-}
-- This is actually used with both GHC 8.10 and with GHC 9.0. -- This is actually used with both GHC 8.10 and with GHC 9.0.
-- The name of the directory is a little misleading. -- The name of the directory is a little misleading.
@ -14,40 +14,40 @@ module Compat
, word32ToWord# , word32ToWord#
) where ) where
import GHC.Exts (Int#,Word#) import GHC.Exts (Int#, Word#)
int8ToInt# :: Int# -> Int# int8ToInt# :: Int# -> Int#
{-# inline int8ToInt# #-} {-# INLINE int8ToInt# #-}
int8ToInt# x = x int8ToInt# x = x
int16ToInt# :: Int# -> Int# int16ToInt# :: Int# -> Int#
{-# inline int16ToInt# #-} {-# INLINE int16ToInt# #-}
int16ToInt# x = x int16ToInt# x = x
int32ToInt# :: Int# -> Int# int32ToInt# :: Int# -> Int#
{-# inline int32ToInt# #-} {-# INLINE int32ToInt# #-}
int32ToInt# x = x int32ToInt# x = x
wordToWord8# :: Word# -> Word# wordToWord8# :: Word# -> Word#
{-# inline wordToWord8# #-} {-# INLINE wordToWord8# #-}
wordToWord8# x = x wordToWord8# x = x
wordToWord16# :: Word# -> Word# wordToWord16# :: Word# -> Word#
{-# inline wordToWord16# #-} {-# INLINE wordToWord16# #-}
wordToWord16# x = x wordToWord16# x = x
wordToWord32# :: Word# -> Word# wordToWord32# :: Word# -> Word#
{-# inline wordToWord32# #-} {-# INLINE wordToWord32# #-}
wordToWord32# x = x wordToWord32# x = x
word8ToWord# :: Word# -> Word# word8ToWord# :: Word# -> Word#
{-# inline word8ToWord# #-} {-# INLINE word8ToWord# #-}
word8ToWord# x = x word8ToWord# x = x
word16ToWord# :: Word# -> Word# word16ToWord# :: Word# -> Word#
{-# inline word16ToWord# #-} {-# INLINE word16ToWord# #-}
word16ToWord# x = x word16ToWord# x = x
word32ToWord# :: Word# -> Word# word32ToWord# :: Word# -> Word#
{-# inline word32ToWord# #-} {-# INLINE word32ToWord# #-}
word32ToWord# x = x word32ToWord# x = x

2
src-9.2/Compat.hs
View file

@ -1,4 +1,4 @@
{-# language MagicHash #-} {-# LANGUAGE MagicHash #-}
module Compat module Compat
( int8ToInt# ( int8ToInt#

16
src-checked/Op.hs
View file

@ -1,5 +1,5 @@
{-# language MagicHash #-} {-# LANGUAGE MagicHash #-}
{-# language UnboxedTuples #-} {-# LANGUAGE UnboxedTuples #-}
module Op module Op
( writeCharArray# ( writeCharArray#
@ -7,9 +7,9 @@ module Op
, copyMutableByteArray# , copyMutableByteArray#
) where ) where
import GHC.Exts ((<#),(>=#),State#,Int#,MutableByteArray#,ByteArray#,Char#) import GHC.Exts (ByteArray#, Char#, Int#, MutableByteArray#, State#, (<#), (>=#))
import GHC.Int (Int(I#))
import qualified GHC.Exts as Exts import qualified GHC.Exts as Exts
import GHC.Int (Int (I#))
writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
writeCharArray# arr i v st = case i <# 0# of writeCharArray# arr i v st = case i <# 0# of
@ -27,8 +27,8 @@ copyByteArray# src soff dst doff len s0 =
, I# doff >= 0 , I# doff >= 0
, I# len >= 0 , I# len >= 0
, I# doff + I# len <= I# sz , I# doff + I# len <= I# sz
, I# soff + I# len <= I# (Exts.sizeofByteArray# src) , I# soff + I# len <= I# (Exts.sizeofByteArray# src) ->
-> Exts.copyByteArray# src soff dst doff len s1 Exts.copyByteArray# src soff dst doff len s1
| otherwise -> error "copyByteArray#: index range out of bounds" | otherwise -> error "copyByteArray#: index range out of bounds"
copyMutableByteArray# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s copyMutableByteArray# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
@ -40,6 +40,6 @@ copyMutableByteArray# src soff dst doff len s0 =
, I# doff >= 0 , I# doff >= 0
, I# len >= 0 , I# len >= 0
, I# doff + I# len <= I# szDst , I# doff + I# len <= I# szDst
, I# soff + I# len <= I# szSrc , I# soff + I# len <= I# szSrc ->
-> Exts.copyMutableByteArray# src soff dst doff len s2 Exts.copyMutableByteArray# src soff dst doff len s2
| otherwise -> error "copyMutableByteArray#: index range out of bounds" | otherwise -> error "copyMutableByteArray#: index range out of bounds"

4
src-unchecked/Op.hs
View file

@ -1,4 +1,4 @@
{-# language MagicHash #-} {-# LANGUAGE MagicHash #-}
module Op module Op
( writeCharArray# ( writeCharArray#
@ -6,4 +6,4 @@ module Op
, copyMutableByteArray# , copyMutableByteArray#
) where ) where
import GHC.Exts (copyMutableByteArray#,writeCharArray#,copyByteArray#,copyMutableByteArray#) import GHC.Exts (copyByteArray#, copyMutableByteArray#, writeCharArray#)

1447
src/Data/Bytes/Builder.hs
View file

File diff suppressed because it is too large Load diff

62
src/Data/Bytes/Builder/Avro.hs
View file

@ -1,8 +1,9 @@
{-# language BangPatterns #-} {-# LANGUAGE BangPatterns #-}
-- | Builders for encoding data with Apache Avro. Most functions in this {- | Builders for encoding data with Apache Avro. Most functions in this
-- module are just aliases for other functions. Avro uses zig-zag LEB128 module are just aliases for other functions. Avro uses zig-zag LEB128
-- for all integral types. for all integral types.
-}
module Data.Bytes.Builder.Avro module Data.Bytes.Builder.Avro
( int ( int
, int32 , int32
@ -13,21 +14,22 @@ module Data.Bytes.Builder.Avro
, bytes , bytes
, chunks , chunks
, text , text
-- * Maps -- * Maps
, map2 , map2
) where ) where
import Data.Int
import Data.Word
import Data.Bytes.Builder (Builder)
import Data.Text (Text)
import Data.Bytes (Bytes) import Data.Bytes (Bytes)
import Data.WideWord (Word128) import Data.Bytes.Builder (Builder)
import Data.Bytes.Chunks (Chunks) import Data.Bytes.Chunks (Chunks)
import Data.Int
import Data.Text (Text)
import Data.WideWord (Word128)
import Data.Word
import qualified Data.Bytes as Bytes import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Chunks as Chunks
import qualified Data.Bytes.Builder as B import qualified Data.Bytes.Builder as B
import qualified Data.Bytes.Chunks as Chunks
import qualified Data.Bytes.Text.Utf8 as Utf8 import qualified Data.Bytes.Text.Utf8 as Utf8
int32 :: Int32 -> Builder int32 :: Int32 -> Builder
@ -39,19 +41,22 @@ int64 = B.int64LEB128
int :: Int -> Builder int :: Int -> Builder
int = B.intLEB128 int = B.intLEB128
-- | Note: This results in a zigzag encoded number. Avro does not have {- | Note: This results in a zigzag encoded number. Avro does not have
-- unsigned types. unsigned types.
-}
word16 :: Word16 -> Builder word16 :: Word16 -> Builder
word16 = B.int32LEB128 . fromIntegral word16 = B.int32LEB128 . fromIntegral
-- | Note: This results in a zigzag encoded number. Avro does not have {- | Note: This results in a zigzag encoded number. Avro does not have
-- unsigned types. unsigned types.
-}
word32 :: Word32 -> Builder word32 :: Word32 -> Builder
word32 = B.int64LEB128 . fromIntegral word32 = B.int64LEB128 . fromIntegral
-- | Note: This results in a @fixed@ encoded value of length 16. In the {- | Note: This results in a @fixed@ encoded value of length 16. In the
-- schema, the type must be @{"type": "fixed", "name": "...", "size": 16}@. schema, the type must be @{"type": "fixed", "name": "...", "size": 16}@.
-- A big-endian encoding is used. A big-endian encoding is used.
-}
word128 :: Word128 -> Builder word128 :: Word128 -> Builder
word128 = B.word128BE word128 = B.word128BE
@ -64,14 +69,19 @@ chunks !b = int (Chunks.length b) <> B.chunks b
text :: Text -> Builder text :: Text -> Builder
text = bytes . Utf8.fromText text = bytes . Utf8.fromText
-- | Encode a map with exactly two key-value pairs. The keys are text. {- | Encode a map with exactly two key-value pairs. The keys are text.
-- This is commonly used to encode the header in an avro file, which has This is commonly used to encode the header in an avro file, which has
-- a map with two keys: @avro.schema@ and @avro.codec@. a map with two keys: @avro.schema@ and @avro.codec@.
-}
map2 :: map2 ::
Text -- ^ First key -- | First key
-> Builder -- ^ First value (already encoded) Text ->
-> Text -- ^ Second key -- | First value (already encoded)
-> Builder -- ^ Second value (already encoded) Builder ->
-> Builder -- | Second key
{-# inline map2 #-} Text ->
-- | Second value (already encoded)
Builder ->
Builder
{-# INLINE map2 #-}
map2 k1 v1 k2 v2 = B.word8 0x04 <> text k1 <> v1 <> text k2 <> v2 <> B.word8 0x00 map2 k1 v1 k2 v2 = B.word8 0x04 <> text k1 <> v1 <> text k2 <> v2 <> B.word8 0x00

899
src/Data/Bytes/Builder/Bounded.hs
View file

File diff suppressed because it is too large Load diff

23
src/Data/Bytes/Builder/Bounded/Class.hs
View file

@ -1,8 +1,8 @@
{-# language DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# language TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Data.Bytes.Builder.Bounded.Class module Data.Bytes.Builder.Bounded.Class
( ToBoundedBuilder(..) ( ToBoundedBuilder (..)
) where ) where
import Data.Int import Data.Int
@ -11,14 +11,15 @@ import Data.Word
import qualified Data.Bytes.Builder.Bounded as Bounded import qualified Data.Bytes.Builder.Bounded as Bounded
import qualified GHC.TypeNats as GHC import qualified GHC.TypeNats as GHC
-- | Variant of To that can be encoded as a builder. Human-readable encodings {- | Variant of To that can be encoded as a builder. Human-readable encodings
-- are used when possible. For example, numbers are encoded an ascii-encoded are used when possible. For example, numbers are encoded an ascii-encoded
-- decimal characters. UTF-8 is preferred for textual types. For types decimal characters. UTF-8 is preferred for textual types. For types
-- that represent arbitrary bytes (e.g. Bytes, ByteString), the bytes that represent arbitrary bytes (e.g. Bytes, ByteString), the bytes
-- are preserved. are preserved.
--
-- The goal of this typeclass is to reduce the size of builders produced The goal of this typeclass is to reduce the size of builders produced
-- by quasiquotation. by quasiquotation.
-}
class ToBoundedBuilder a where class ToBoundedBuilder a where
type BoundedBuilderLength a :: GHC.Nat type BoundedBuilderLength a :: GHC.Nat
toBuilder :: a -> Bounded.Builder (BoundedBuilderLength a) toBuilder :: a -> Bounded.Builder (BoundedBuilderLength a)

68
src/Data/Bytes/Builder/Bounded/Unsafe.hs
View file

@ -1,62 +1,66 @@
{-# language DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# language GADTSyntax #-} {-# LANGUAGE GADTSyntax #-}
{-# language KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# language MagicHash #-} {-# LANGUAGE MagicHash #-}
{-# language RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# language ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# language UnboxedTuples #-} {-# LANGUAGE UnboxedTuples #-}
module Data.Bytes.Builder.Bounded.Unsafe module Data.Bytes.Builder.Bounded.Unsafe
( -- * Types ( -- * Types
Builder(..) Builder (..)
-- * Construct -- * Construct
, construct , construct
-- * Run -- * Run
, pasteST , pasteST
, pasteIO , pasteIO
) where ) where
import Data.Kind (Type) import Data.Kind (Type)
import Data.Primitive (MutableByteArray(..)) import Data.Primitive (MutableByteArray (..))
import GHC.Exts (Int(I#),RealWorld,Int#,State#,MutableByteArray#) import GHC.Exts (Int (I#), Int#, MutableByteArray#, RealWorld, State#)
import GHC.IO (stToIO) import GHC.IO (stToIO)
import GHC.ST (ST(ST)) import GHC.ST (ST (ST))
import GHC.TypeLits (Nat) import GHC.TypeLits (Nat)
-- | A builder parameterized by the maximum number of bytes it uses {- | A builder parameterized by the maximum number of bytes it uses
-- when executed. when executed.
-}
newtype Builder :: Nat -> Type where newtype Builder :: Nat -> Type where
Builder :: Builder ::
(forall s. MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)) -- | This function takes a buffer, an offset, and a number of remaining bytes.
-- ^ This function takes a buffer, an offset, and a number of remaining bytes. -- It returns the new offset.
-- It returns the new offset. (forall s. MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)) ->
-> Builder n Builder n
{- | Constructor for 'Builder' that works on a function with lifted
-- | Constructor for 'Builder' that works on a function with lifted arguments instead of unlifted ones. This is just as unsafe as the
-- arguments instead of unlifted ones. This is just as unsafe as the actual constructor.
-- actual constructor. -}
construct :: (forall s. MutableByteArray s -> Int -> ST s Int) -> Builder n construct :: (forall s. MutableByteArray s -> Int -> ST s Int) -> Builder n
{-# inline construct #-} {-# INLINE construct #-}
construct f = Builder construct f = Builder $
$ \arr off s0 -> \arr off s0 ->
case unST (f (MutableByteArray arr) (I# off)) s0 of case unST (f (MutableByteArray arr) (I# off)) s0 of
(# s1, (I# n) #) -> (# s1, n #) (# s1, (I# n) #) -> (# s1, n #)
-- | This function does not enforce the known upper bound on the {- | This function does not enforce the known upper bound on the
-- size. It is up to the user to do this. size. It is up to the user to do this.
-}
pasteST :: Builder n -> MutableByteArray s -> Int -> ST s Int pasteST :: Builder n -> MutableByteArray s -> Int -> ST s Int
{-# inline pasteST #-} {-# INLINE pasteST #-}
pasteST (Builder f) (MutableByteArray arr) (I# off) = pasteST (Builder f) (MutableByteArray arr) (I# off) =
ST $ \s0 -> case f arr off s0 of ST $ \s0 -> case f arr off s0 of
(# s1, r #) -> (# s1, (I# r) #) (# s1, r #) -> (# s1, (I# r) #)
-- | This function does not enforce the known upper bound on the {- | This function does not enforce the known upper bound on the
-- size. It is up to the user to do this. size. It is up to the user to do this.
-}
pasteIO :: Builder n -> MutableByteArray RealWorld -> Int -> IO Int pasteIO :: Builder n -> MutableByteArray RealWorld -> Int -> IO Int
{-# inline pasteIO #-} {-# INLINE pasteIO #-}
pasteIO b m off = stToIO (pasteST b m off) pasteIO b m off = stToIO (pasteST b m off)
unST :: ST s a -> State# s -> (# State# s, a #) unST :: ST s a -> State# s -> (# State# s, a #)
unST (ST f) = f unST (ST f) = f

22
src/Data/Bytes/Builder/Class.hs
View file

@ -1,13 +1,12 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Data.Bytes.Builder.Class module Data.Bytes.Builder.Class
( ToBuilder(..) ( ToBuilder (..)
) where ) where
import Data.ByteString.Short (ShortByteString)
import Data.Bytes (Bytes) import Data.Bytes (Bytes)
import Data.Bytes.Builder (Builder) import Data.Bytes.Builder (Builder)
import Data.ByteString.Short (ShortByteString)
import Data.Int import Data.Int
import Data.Primitive.ByteArray (ByteArray) import Data.Primitive.ByteArray (ByteArray)
import Data.Text.Short (ShortText) import Data.Text.Short (ShortText)
@ -15,14 +14,15 @@ import Data.Word
import qualified Data.Bytes.Builder as Builder import qualified Data.Bytes.Builder as Builder
-- | Types that can be encoded as a builder. Human-readable encodings {- | Types that can be encoded as a builder. Human-readable encodings
-- are used when possible. For example, numbers are encoded an ascii-encoded are used when possible. For example, numbers are encoded an ascii-encoded
-- decimal characters. UTF-8 is preferred for textual types. For types decimal characters. UTF-8 is preferred for textual types. For types
-- that represent arbitrary bytes (e.g. Bytes, ByteString), the bytes that represent arbitrary bytes (e.g. Bytes, ByteString), the bytes
-- are preserved. are preserved.
--
-- The goal of this typeclass is to reduce the size of builders produced The goal of this typeclass is to reduce the size of builders produced
-- by quasiquotation. by quasiquotation.
-}
class ToBuilder a where class ToBuilder a where
toBuilder :: a -> Builder toBuilder :: a -> Builder

125
src/Data/Bytes/Builder/Template.hs
View file

@ -9,50 +9,53 @@ module Data.Bytes.Builder.Template
import Control.Monad (when) import Control.Monad (when)
import Data.Bytes.Builder.Class (toBuilder) import Data.Bytes.Builder.Class (toBuilder)
import GHC.Ptr (Ptr(Ptr)) import GHC.Ptr (Ptr (Ptr))
import Language.Haskell.Meta.Parse (parseExp) import Language.Haskell.Meta.Parse (parseExp)
import Language.Haskell.TH (Q,Exp) import Language.Haskell.TH (Exp, Q)
import Language.Haskell.TH.Lib (integerL,stringPrimL,litE) import Language.Haskell.TH.Lib (integerL, litE, stringPrimL)
import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Haskell.TH.Quote (QuasiQuoter (..))
import qualified Data.Bytes.Builder as Builder
import qualified Data.ByteString.Short as SBS import qualified Data.ByteString.Short as SBS
import qualified Data.Bytes.Builder as Builder
import qualified Data.Text.Short as TS import qualified Data.Text.Short as TS
import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH as TH
-- | A quasiquoter for builders. Haskell expressions are interpolated {- | A quasiquoter for builders. Haskell expressions are interpolated
-- with backticks, and the @ToBuilder@ class is used to convert them with backticks, and the @ToBuilder@ class is used to convert them
-- to builders. Several common escape sequences for whitespace and to builders. Several common escape sequences for whitespace and
-- control characters are recongized. Consider the following expression, control characters are recongized. Consider the following expression,
-- where the binding @partition@ has type @Word32@: where the binding @partition@ has type @Word32@:
--
-- > [templ|[WARN] Partition `partition` has invalid data.\n|] > [templ|[WARN] Partition `partition` has invalid data.\n|]
--
-- This expression has type @Builder@ and expands to: This expression has type @Builder@ and expands to:
--
-- > Builder.cstringLen (Ptr "[WARN] Partition "#, 17) <> > Builder.cstringLen (Ptr "[WARN] Partition "#, 17) <>
-- > Builder.toBuilder partition <> > Builder.toBuilder partition <>
-- > Builder.cstringLen (Ptr " has invalid data.\n"#, 19) > Builder.cstringLen (Ptr " has invalid data.\n"#, 19)
--
-- The @ToBuilder@ instance for @Word32@ uses decimal encoding, so this The @ToBuilder@ instance for @Word32@ uses decimal encoding, so this
-- would result in the following if @partition@ was 42 (with a newline would result in the following if @partition@ was 42 (with a newline
-- character at the end): character at the end):
--
-- > [WARN] Partition 42 has invalid data. > [WARN] Partition 42 has invalid data.
--
-- In the future, a more sophisticated @bbldr@ variant will be added In the future, a more sophisticated @bbldr@ variant will be added
-- that will support expressions where the maximum length of the entire that will support expressions where the maximum length of the entire
-- builder can be computed at compile time. builder can be computed at compile time.
-}
bldr :: QuasiQuoter bldr :: QuasiQuoter
bldr = QuasiQuoter bldr =
{ quoteExp = templExp QuasiQuoter
, quotePat = notHandled "patterns" { quoteExp = templExp
, quoteType = notHandled "types" , quotePat = notHandled "patterns"
, quoteDec = notHandled "declarations" , quoteType = notHandled "types"
} , quoteDec = notHandled "declarations"
where }
notHandled things _ = fail $ where
things ++ "are not handled by the byte template quasiquoter" notHandled things _ =
fail $
things ++ "are not handled by the byte template quasiquoter"
templExp :: String -> Q Exp templExp :: String -> Q Exp
templExp inp = do templExp inp = do
@ -62,7 +65,7 @@ templExp inp = do
Right [] -> fail "empty template" Right [] -> fail "empty template"
Right v -> pure v Right v -> pure v
let expParts = compile <$> rawParts let expParts = compile <$> rawParts
foldl1 (\e1 e2 -> [| $e1 <> $e2 |]) expParts foldl1 (\e1 e2 -> [|$e1 <> $e2|]) expParts
checkOverloadedStrings :: Q () checkOverloadedStrings :: Q ()
checkOverloadedStrings = do checkOverloadedStrings = do
@ -87,40 +90,40 @@ compile (Splice str) = case parseExp str of
parse :: String -> Either String Template parse :: String -> Either String Template
parse = partsLoop parse = partsLoop
where where
partsLoop "" = do partsLoop "" = do
pure [] pure []
partsLoop ('`':inp) = do partsLoop ('`' : inp) = do
(!spl, !rest) <- spliceLoop inp (!spl, !rest) <- spliceLoop inp
(Splice spl:) <$> partsLoop rest (Splice spl :) <$> partsLoop rest
partsLoop inp = do partsLoop inp = do
(!lit, !rest) <- litLoop "" inp (!lit, !rest) <- litLoop "" inp
(Literal lit:) <$> partsLoop rest (Literal lit :) <$> partsLoop rest
litLoop :: String -> String -> Either String (String, String) litLoop :: String -> String -> Either String (String, String)
litLoop !acc rest@"" = pure (reverse acc, rest) litLoop !acc rest@"" = pure (reverse acc, rest)
litLoop !acc rest@('`':_) = pure (reverse acc, rest) litLoop !acc rest@('`' : _) = pure (reverse acc, rest)
litLoop !acc ('\\':next) = do litLoop !acc ('\\' : next) = do
(c, rest) <- parseEscape next (c, rest) <- parseEscape next
litLoop (c:acc) rest litLoop (c : acc) rest
litLoop !acc (c:rest) = litLoop (c:acc) rest litLoop !acc (c : rest) = litLoop (c : acc) rest
spliceLoop :: String -> Either String (String, String) spliceLoop :: String -> Either String (String, String)
spliceLoop inp = case break (== '`') inp of spliceLoop inp = case break (== '`') inp of
([], _) -> Left "internal error" ([], _) -> Left "internal error"
(hs, '`':rest) -> pure (hs, rest) (hs, '`' : rest) -> pure (hs, rest)
(_, _:_) -> Left "internal error" (_, _ : _) -> Left "internal error"
(_, []) -> Left "unterminated interpolation" (_, []) -> Left "unterminated interpolation"
parseEscape :: String -> Either String (Char, String) parseEscape :: String -> Either String (Char, String)
parseEscape "" = Left "incomplete escape" parseEscape "" = Left "incomplete escape"
parseEscape ('\\':rest) = pure ('\\', rest) parseEscape ('\\' : rest) = pure ('\\', rest)
parseEscape ('`':rest) = pure ('`', rest) parseEscape ('`' : rest) = pure ('`', rest)
parseEscape ('\'':rest) = pure ('\'', rest) parseEscape ('\'' : rest) = pure ('\'', rest)
parseEscape ('\"':rest) = pure ('\"', rest) parseEscape ('\"' : rest) = pure ('\"', rest)
parseEscape ('0':rest) = pure ('\0', rest) parseEscape ('0' : rest) = pure ('\0', rest)
parseEscape ('a':rest) = pure ('\a', rest) parseEscape ('a' : rest) = pure ('\a', rest)
parseEscape ('b':rest) = pure ('\b', rest) parseEscape ('b' : rest) = pure ('\b', rest)
parseEscape ('f':rest) = pure ('\f', rest) parseEscape ('f' : rest) = pure ('\f', rest)
parseEscape ('n':rest) = pure ('\n', rest) parseEscape ('n' : rest) = pure ('\n', rest)
parseEscape ('r':rest) = pure ('\r', rest) parseEscape ('r' : rest) = pure ('\r', rest)
parseEscape ('t':rest) = pure ('\t', rest) parseEscape ('t' : rest) = pure ('\t', rest)
parseEscape ('v':rest) = pure ('\v', rest) parseEscape ('v' : rest) = pure ('\v', rest)
parseEscape (c:_) = Left $ "unrecognized escape: \\" ++ [c] parseEscape (c : _) = Left $ "unrecognized escape: \\" ++ [c]

409
src/Data/Bytes/Builder/Unsafe.hs
View file

@ -1,55 +1,60 @@
{-# language BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# language DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# language LambdaCase #-} {-# LANGUAGE MagicHash #-}
{-# language MagicHash #-} {-# LANGUAGE RankNTypes #-}
{-# language RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# language ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-}
{-# language UnboxedTuples #-}
module Data.Bytes.Builder.Unsafe module Data.Bytes.Builder.Unsafe
( -- * Types ( -- * Types
Builder(..) Builder (..)
, BuilderState(..) , BuilderState (..)
, Commits(..) , Commits (..)
-- * Execution -- * Execution
, pasteST , pasteST
, pasteIO , pasteIO
-- * Construction -- * Construction
, fromEffect , fromEffect
-- * Builder State -- * Builder State
, newBuilderState , newBuilderState
, closeBuilderState , closeBuilderState
-- * Finalization -- * Finalization
, reverseCommitsOntoChunks , reverseCommitsOntoChunks
, commitsOntoChunks , commitsOntoChunks
, copyReverseCommits , copyReverseCommits
, addCommitsLength , addCommitsLength
-- * Commit Distance -- * Commit Distance
, commitDistance , commitDistance
, commitDistance1 , commitDistance1
-- * Safe Functions -- * Safe Functions
-- | These functions are actually completely safe, but they are defined -- | These functions are actually completely safe, but they are defined
-- here because they are used by typeclass instances. Import them from -- here because they are used by typeclass instances. Import them from
-- @Data.Bytes.Builder@ instead. -- @Data.Bytes.Builder@ instead.
, stringUtf8 , stringUtf8
, cstring , cstring
-- * Pasting with Preconditions -- * Pasting with Preconditions
, pasteUtf8TextJson# , pasteUtf8TextJson#
) where ) where
import Control.Monad.Primitive (primitive_) import Control.Monad.Primitive (primitive_)
import Data.Bytes.Chunks (Chunks(ChunksCons)) import Data.Bytes.Chunks (Chunks (ChunksCons))
import Data.Bytes.Types (Bytes(Bytes)) import Data.Bytes.Types (Bytes (Bytes))
import Data.Char (ord) import Data.Char (ord)
import Data.Primitive (MutableByteArray(..),ByteArray(..)) import Data.Primitive (ByteArray (..), MutableByteArray (..))
import Data.Word (Word8) import Data.Word (Word8)
import Foreign.C.String (CString) import Foreign.C.String (CString)
import GHC.Base (unpackCString#,unpackCStringUtf8#) import GHC.Base (unpackCString#, unpackCStringUtf8#)
import GHC.Exts ((-#),(+#),(>#),(>=#),Char(C#)) import GHC.Exts (Addr#, ByteArray#, Char (C#), Int (I#), Int#, IsString, MutableByteArray#, Ptr (Ptr), RealWorld, State#, (+#), (-#), (>#), (>=#))
import GHC.Exts (Addr#,ByteArray#,MutableByteArray#,Int(I#),Ptr(Ptr))
import GHC.Exts (RealWorld,IsString,Int#,State#)
import GHC.IO (stToIO) import GHC.IO (stToIO)
import GHC.ST (ST(ST)) import GHC.ST (ST (ST))
import qualified Compat as C import qualified Compat as C
import qualified Data.Bytes.Builder.Bounded as Bounded import qualified Data.Bytes.Builder.Bounded as Bounded
@ -58,46 +63,52 @@ import qualified Data.Primitive as PM
import qualified GHC.Exts as Exts import qualified GHC.Exts as Exts
import qualified Op import qualified Op
-- | An unmaterialized sequence of bytes that may be pasted {- | An unmaterialized sequence of bytes that may be pasted
-- into a mutable byte array. into a mutable byte array.
-}
newtype Builder newtype Builder
= Builder (forall s. = Builder
MutableByteArray# s -> -- buffer we are currently writing to ( forall s.
Int# -> -- offset into the current buffer MutableByteArray# s -> -- buffer we are currently writing to
Int# -> -- number of bytes remaining in the current buffer Int# -> -- offset into the current buffer
Commits s -> -- buffers and immutable byte slices that we have already committed Int# -> -- number of bytes remaining in the current buffer
State# s -> Commits s -> -- buffers and immutable byte slices that we have already committed
(# State# s, MutableByteArray# s, Int#, Int#, Commits s #) -- all the same things State# s ->
) (# State# s, MutableByteArray# s, Int#, Int#, Commits s #) -- all the same things
)
-- | A list of committed chunks along with the chunk currently being {- | A list of committed chunks along with the chunk currently being
-- written to. This is kind of like a non-empty variant of 'Commmits' written to. This is kind of like a non-empty variant of 'Commmits'
-- but with the additional invariant that the head chunk is a mutable but with the additional invariant that the head chunk is a mutable
-- byte array. byte array.
data BuilderState s = BuilderState -}
(MutableByteArray# s) -- buffer we are currently writing to data BuilderState s
Int# -- offset into the current buffer = BuilderState
Int# -- number of bytes remaining in the current buffer (MutableByteArray# s) -- buffer we are currently writing to
!(Commits s) -- buffers and immutable byte slices that are already committed Int# -- offset into the current buffer
Int# -- number of bytes remaining in the current buffer
!(Commits s) -- buffers and immutable byte slices that are already committed
-- | Create an empty 'BuilderState' with a buffer of the given size. -- | Create an empty 'BuilderState' with a buffer of the given size.
newBuilderState :: Int -> ST s (BuilderState s) newBuilderState :: Int -> ST s (BuilderState s)
{-# inline newBuilderState #-} {-# INLINE newBuilderState #-}
newBuilderState n@(I# n# ) = do newBuilderState n@(I# n#) = do
MutableByteArray buf <- PM.newByteArray n MutableByteArray buf <- PM.newByteArray n
pure (BuilderState buf 0# n# Initial) pure (BuilderState buf 0# n# Initial)
-- | Push the active chunk onto the top of the commits. {- | Push the active chunk onto the top of the commits.
-- The @BuilderState@ argument must not be reused after being passed The @BuilderState@ argument must not be reused after being passed
-- to this function. That is, its use must be affine. to this function. That is, its use must be affine.
-}
closeBuilderState :: BuilderState s -> Commits s closeBuilderState :: BuilderState s -> Commits s
closeBuilderState (BuilderState dst off _ cmts) = Mutable dst off cmts closeBuilderState (BuilderState dst off _ cmts) = Mutable dst off cmts
-- | Run a builder, performing an in-place update on the state. {- | Run a builder, performing an in-place update on the state.
-- The @BuilderState@ argument must not be reused after being passed The @BuilderState@ argument must not be reused after being passed
-- to this function. That is, its use must be affine. to this function. That is, its use must be affine.
-}
pasteST :: Builder -> BuilderState s -> ST s (BuilderState s) pasteST :: Builder -> BuilderState s -> ST s (BuilderState s)
{-# inline pasteST #-} {-# INLINE pasteST #-}
pasteST (Builder f) (BuilderState buf off len cmts) = ST $ \s0 -> pasteST (Builder f) (BuilderState buf off len cmts) = ST $ \s0 ->
case f buf off len cmts s0 of case f buf off len cmts s0 of
(# s1, buf1, off1, len1, cmts1 #) -> (# s1, buf1, off1, len1, cmts1 #) ->
@ -105,48 +116,54 @@ pasteST (Builder f) (BuilderState buf off len cmts) = ST $ \s0 ->
-- | Variant of 'pasteST' that runs in 'IO'. -- | Variant of 'pasteST' that runs in 'IO'.
pasteIO :: Builder -> BuilderState RealWorld -> IO (BuilderState RealWorld) pasteIO :: Builder -> BuilderState RealWorld -> IO (BuilderState RealWorld)
{-# inline pasteIO #-} {-# INLINE pasteIO #-}
pasteIO b st = stToIO (pasteST b st) pasteIO b st = stToIO (pasteST b st)
instance IsString Builder where instance IsString Builder where
{-# inline fromString #-} {-# INLINE fromString #-}
fromString = stringUtf8 fromString = stringUtf8
instance Semigroup Builder where instance Semigroup Builder where
{-# inline (<>) #-} {-# INLINE (<>) #-}
Builder f <> Builder g = Builder $ \buf0 off0 len0 cs0 s0 -> case f buf0 off0 len0 cs0 s0 of Builder f <> Builder g = Builder $ \buf0 off0 len0 cs0 s0 -> case f buf0 off0 len0 cs0 s0 of
(# s1, buf1, off1, len1, cs1 #) -> g buf1 off1 len1 cs1 s1 (# s1, buf1, off1, len1, cs1 #) -> g buf1 off1 len1 cs1 s1
instance Monoid Builder where instance Monoid Builder where
{-# inline mempty #-} {-# INLINE mempty #-}
mempty = Builder $ \buf0 off0 len0 cs0 s0 -> (# s0, buf0, off0, len0, cs0 #) mempty = Builder $ \buf0 off0 len0 cs0 s0 -> (# s0, buf0, off0, len0, cs0 #)
data Commits s data Commits s
= Mutable = Mutable
-- | Mutable buffer, start index implicitly zero
(MutableByteArray# s) (MutableByteArray# s)
-- ^ Mutable buffer, start index implicitly zero -- | Length (may be smaller than actual length)
Int# -- ^ Length (may be smaller than actual length) Int#
!(Commits s) !(Commits s)
| Immutable | Immutable
ByteArray# -- ^ Immutable chunk -- | Immutable chunk
Int# -- ^ Offset into chunk, not necessarily zero ByteArray#
Int# -- ^ Length (may be smaller than actual length) -- | Offset into chunk, not necessarily zero
Int#
-- | Length (may be smaller than actual length)
Int#
!(Commits s) !(Commits s)
| Initial | Initial
-- | Add the total number of bytes in the commits to first {- | Add the total number of bytes in the commits to first
-- argument. argument.
-}
addCommitsLength :: Int -> Commits s -> Int addCommitsLength :: Int -> Commits s -> Int
addCommitsLength !acc Initial = acc addCommitsLength !acc Initial = acc
addCommitsLength !acc (Immutable _ _ x cs) = addCommitsLength (acc + I# x) cs addCommitsLength !acc (Immutable _ _ x cs) = addCommitsLength (acc + I# x) cs
addCommitsLength !acc (Mutable _ x cs) = addCommitsLength (acc + I# x) cs addCommitsLength !acc (Mutable _ x cs) = addCommitsLength (acc + I# x) cs
-- | Cons the chunks from a list of @Commits@ onto an initial {- | Cons the chunks from a list of @Commits@ onto an initial
-- @Chunks@ list (this argument is often @ChunksNil@). This reverses @Chunks@ list (this argument is often @ChunksNil@). This reverses
-- the order of the chunks, which is desirable since builders assemble the order of the chunks, which is desirable since builders assemble
-- @Commits@ with the chunks backwards. This performs an in-place shrink @Commits@ with the chunks backwards. This performs an in-place shrink
-- and freezes any mutable byte arrays it encounters. Consequently, and freezes any mutable byte arrays it encounters. Consequently,
-- these must not be reused. these must not be reused.
-}
reverseCommitsOntoChunks :: Chunks -> Commits s -> ST s Chunks reverseCommitsOntoChunks :: Chunks -> Commits s -> ST s Chunks
reverseCommitsOntoChunks !xs Initial = pure xs reverseCommitsOntoChunks !xs Initial = pure xs
reverseCommitsOntoChunks !xs (Immutable arr off len cs) = reverseCommitsOntoChunks !xs (Immutable arr off len cs) =
@ -159,17 +176,18 @@ reverseCommitsOntoChunks !xs (Mutable buf len cs) = case len of
arr <- PM.unsafeFreezeByteArray (MutableByteArray buf) arr <- PM.unsafeFreezeByteArray (MutableByteArray buf)
reverseCommitsOntoChunks (ChunksCons (Bytes arr 0 (I# len)) xs) cs reverseCommitsOntoChunks (ChunksCons (Bytes arr 0 (I# len)) xs) cs
-- | Variant of 'reverseCommitsOntoChunks' that does not reverse {- | Variant of 'reverseCommitsOntoChunks' that does not reverse
-- the order of the commits. Since commits are built backwards by the order of the commits. Since commits are built backwards by
-- consing, this means that the chunks appended to the front will consing, this means that the chunks appended to the front will
-- be backwards. Within each chunk, however, the bytes will be in be backwards. Within each chunk, however, the bytes will be in
-- the correct order. the correct order.
--
-- Unlike 'reverseCommitsOntoChunks', this function is not tail Unlike 'reverseCommitsOntoChunks', this function is not tail
-- recursive. recursive.
-}
commitsOntoChunks :: Chunks -> Commits s -> ST s Chunks commitsOntoChunks :: Chunks -> Commits s -> ST s Chunks
commitsOntoChunks !xs0 cs0 = go cs0 commitsOntoChunks !xs0 cs0 = go cs0
where where
go Initial = pure xs0 go Initial = pure xs0
go (Immutable arr off len cs) = do go (Immutable arr off len cs) = do
xs <- go cs xs <- go cs
@ -183,53 +201,65 @@ commitsOntoChunks !xs0 cs0 = go cs0
xs <- go cs xs <- go cs
pure $! ChunksCons (Bytes arr 0 (I# len)) xs pure $! ChunksCons (Bytes arr 0 (I# len)) xs
-- | Copy the contents of the chunks into a mutable array, reversing {- | Copy the contents of the chunks into a mutable array, reversing
-- the order of the chunks. the order of the chunks.
-- Precondition: The destination must have enough space to house the Precondition: The destination must have enough space to house the
-- contents. This is not checked. contents. This is not checked.
-}
copyReverseCommits :: copyReverseCommits ::
MutableByteArray s -- ^ Destination -- | Destination
-> Int -- ^ Destination range successor MutableByteArray s ->
-> Commits s -- ^ Source -- | Destination range successor
-> ST s Int Int ->
{-# inline copyReverseCommits #-} -- | Source
copyReverseCommits (MutableByteArray dst) (I# off) cs = ST Commits s ->
(\s0 -> case copyReverseCommits# dst off cs s0 of ST s Int
(# s1, nextOff #) -> (# s1, I# nextOff #) {-# INLINE copyReverseCommits #-}
) copyReverseCommits (MutableByteArray dst) (I# off) cs =
ST
( \s0 -> case copyReverseCommits# dst off cs s0 of
(# s1, nextOff #) -> (# s1, I# nextOff #)
)
copyReverseCommits# :: copyReverseCommits# ::
MutableByteArray# s MutableByteArray# s ->
-> Int# Int# ->
-> Commits s Commits s ->
-> State# s State# s ->
-> (# State# s, Int# #) (# State# s, Int# #)
copyReverseCommits# _ off Initial s0 = (# s0, off #) copyReverseCommits# _ off Initial s0 = (# s0, off #)
copyReverseCommits# marr prevOff (Mutable arr sz cs) s0 = copyReverseCommits# marr prevOff (Mutable arr sz cs) s0 =
let !off = prevOff -# sz in let !off = prevOff -# sz
case Op.copyMutableByteArray# arr 0# marr off sz s0 of in case Op.copyMutableByteArray# arr 0# marr off sz s0 of
s1 -> copyReverseCommits# marr off cs s1 s1 -> copyReverseCommits# marr off cs s1
copyReverseCommits# marr prevOff (Immutable arr soff sz cs) s0 = copyReverseCommits# marr prevOff (Immutable arr soff sz cs) s0 =
let !off = prevOff -# sz in let !off = prevOff -# sz
case Op.copyByteArray# arr soff marr off sz s0 of in case Op.copyByteArray# arr soff marr off sz s0 of
s1 -> copyReverseCommits# marr off cs s1 s1 -> copyReverseCommits# marr off cs s1
-- | Create a builder from a cons-list of 'Char'. These {- | Create a builder from a cons-list of 'Char'. These
-- must be UTF-8 encoded. must be UTF-8 encoded.
-}
stringUtf8 :: String -> Builder stringUtf8 :: String -> Builder
{-# inline stringUtf8 #-} {-# INLINE stringUtf8 #-}
stringUtf8 cs = Builder (goString cs) stringUtf8 cs = Builder (goString cs)
-- | Create a builder from a @NUL@-terminated 'CString'. This ignores any {- | Create a builder from a @NUL@-terminated 'CString'. This ignores any
-- textual encoding, copying bytes until @NUL@ is reached. textual encoding, copying bytes until @NUL@ is reached.
-}
cstring :: CString -> Builder cstring :: CString -> Builder
{-# inline cstring #-} {-# INLINE cstring #-}
cstring (Ptr cs) = Builder (goCString cs) cstring (Ptr cs) = Builder (goCString cs)
goString :: String goString ::
-> MutableByteArray# s -> Int# -> Int# -> Commits s String ->
-> State# s -> (# State# s, MutableByteArray# s, Int#, Int#, Commits s #) MutableByteArray# s ->
{-# noinline goString #-} Int# ->
Int# ->
Commits s ->
State# s ->
(# State# s, MutableByteArray# s, Int#, Int#, Commits s #)
{-# NOINLINE goString #-}
goString [] buf0 off0 len0 cs0 s0 = (# s0, buf0, off0, len0, cs0 #) goString [] buf0 off0 len0 cs0 s0 = (# s0, buf0, off0, len0, cs0 #)
goString (c : cs) buf0 off0 len0 cs0 s0 = case len0 ># 3# of goString (c : cs) buf0 off0 len0 cs0 s0 = case len0 ># 3# of
1# -> case unST (UnsafeBounded.pasteST (Bounded.char c) (MutableByteArray buf0) (I# off0)) s0 of 1# -> case unST (UnsafeBounded.pasteST (Bounded.char c) (MutableByteArray buf0) (I# off0)) s0 of
@ -245,39 +275,53 @@ goString (c : cs) buf0 off0 len0 cs0 s0 = case len0 ># 3# of
-- used Modified UTF-8. -- used Modified UTF-8.
{-# RULES {-# RULES
"Builder stringUtf8/cstring" forall s a b c d e. "Builder stringUtf8/cstring" forall s a b c d e.
goString (unpackCString# s) a b c d e = goCString s a b c d e goString (unpackCString# s) a b c d e =
goCString s a b c d e
"Builder stringUtf8/cstring-utf8" forall s a b c d e. "Builder stringUtf8/cstring-utf8" forall s a b c d e.
goString (unpackCStringUtf8# s) a b c d e = goCString s a b c d e goString (unpackCStringUtf8# s) a b c d e =
#-} goCString s a b c d e
#-}
goCString :: Addr# -> MutableByteArray# s -> Int# -> Int# -> Commits s goCString ::
-> State# s -> (# State# s, MutableByteArray# s, Int#, Int#, Commits s #) Addr# ->
MutableByteArray# s ->
Int# ->
Int# ->
Commits s ->
State# s ->
(# State# s, MutableByteArray# s, Int#, Int#, Commits s #)
goCString addr buf0 off0 len0 cs0 s0 = case C.word8ToWord# (Exts.indexWord8OffAddr# addr 0#) of goCString addr buf0 off0 len0 cs0 s0 = case C.word8ToWord# (Exts.indexWord8OffAddr# addr 0#) of
0## -> (# s0, buf0, off0, len0, cs0 #) 0## -> (# s0, buf0, off0, len0, cs0 #)
w -> case len0 of w -> case len0 of
0# -> case Exts.newByteArray# 4080# s0 of 0# -> case Exts.newByteArray# 4080# s0 of
(# s1, buf1 #) -> case Exts.writeWord8Array# buf1 0# (C.wordToWord8# w) s1 of (# s1, buf1 #) -> case Exts.writeWord8Array# buf1 0# (C.wordToWord8# w) s1 of
s2 -> goCString s2 ->
(Exts.plusAddr# addr 1# ) buf1 1# (4080# -# 1# ) goCString
(Mutable buf0 off0 cs0) (Exts.plusAddr# addr 1#)
s2 buf1
1#
(4080# -# 1#)
(Mutable buf0 off0 cs0)
s2
_ -> case Exts.writeWord8Array# buf0 off0 (C.wordToWord8# w) s0 of _ -> case Exts.writeWord8Array# buf0 off0 (C.wordToWord8# w) s0 of
s1 -> goCString (Exts.plusAddr# addr 1# ) buf0 (off0 +# 1# ) (len0 -# 1# ) cs0 s1 s1 -> goCString (Exts.plusAddr# addr 1#) buf0 (off0 +# 1#) (len0 -# 1#) cs0 s1
fromEffect :: fromEffect ::
Int -- ^ Maximum number of bytes the paste function needs -- | Maximum number of bytes the paste function needs
-> (forall s. MutableByteArray s -> Int -> ST s Int) Int ->
-- ^ Paste function. Takes a byte array and an offset and returns -- | Paste function. Takes a byte array and an offset and returns
-- the new offset and having pasted into the buffer. -- the new offset and having pasted into the buffer.
-> Builder (forall s. MutableByteArray s -> Int -> ST s Int) ->
{-# inline fromEffect #-} Builder
{-# INLINE fromEffect #-}
fromEffect (I# req) f = Builder $ \buf0 off0 len0 cs0 s0 -> fromEffect (I# req) f = Builder $ \buf0 off0 len0 cs0 s0 ->
let !(# s1, buf1, off1, len1, cs1 #) = case len0 >=# req of let !(# s1, buf1, off1, len1, cs1 #) = case len0 >=# req of
1# -> (# s0, buf0, off0, len0, cs0 #) 1# -> (# s0, buf0, off0, len0, cs0 #)
_ -> let !(I# lenX) = max 4080 (I# req) in _ ->
case Exts.newByteArray# lenX s0 of let !(I# lenX) = max 4080 (I# req)
(# sX, bufX #) -> in case Exts.newByteArray# lenX s0 of
(# sX, bufX, 0#, lenX, Mutable buf0 off0 cs0 #) (# sX, bufX #) ->
(# sX, bufX, 0#, lenX, Mutable buf0 off0 cs0 #)
in case unST (f (MutableByteArray buf1) (I# off1)) s1 of in case unST (f (MutableByteArray buf1) (I# off1)) s1 of
(# s2, I# off2 #) -> (# s2, buf1, off2, len1 -# (off2 -# off1), cs1 #) (# s2, I# off2 #) -> (# s2, buf1, off2, len1 -# (off2 -# off1), cs1 #)
@ -288,24 +332,26 @@ shrinkMutableByteArray :: MutableByteArray s -> Int -> ST s ()
shrinkMutableByteArray (MutableByteArray arr) (I# sz) = shrinkMutableByteArray (MutableByteArray arr) (I# sz) =
primitive_ (Exts.shrinkMutableByteArray# arr sz) primitive_ (Exts.shrinkMutableByteArray# arr sz)
-- | Variant of commitDistance where you get to supply a {- | Variant of commitDistance where you get to supply a
-- head of the commit list that has not yet been committed. head of the commit list that has not yet been committed.
-}
commitDistance1 :: commitDistance1 ::
MutableByteArray# s -- target MutableByteArray# s -> -- target
-> Int# -- offset into target Int# -> -- offset into target
-> MutableByteArray# s -- head of array MutableByteArray# s -> -- head of array
-> Int# -- offset into head of array Int# -> -- offset into head of array
-> Commits s Commits s ->
-> Int# Int#
commitDistance1 target offTarget buf0 offBuf cs = commitDistance1 target offTarget buf0 offBuf cs =
case Exts.sameMutableByteArray# target buf0 of case Exts.sameMutableByteArray# target buf0 of
1# -> offBuf -# offTarget 1# -> offBuf -# offTarget
_ -> commitDistance target offBuf cs -# offTarget _ -> commitDistance target offBuf cs -# offTarget
-- | Compute the number of bytes between the last byte and the offset {- | Compute the number of bytes between the last byte and the offset
-- specified in a chunk. Precondition: the chunk must exist in the specified in a chunk. Precondition: the chunk must exist in the
-- list of committed chunks. This relies on mutable byte arrays having list of committed chunks. This relies on mutable byte arrays having
-- identity (e.g. it uses @sameMutableByteArray#@). identity (e.g. it uses @sameMutableByteArray#@).
-}
commitDistance :: MutableByteArray# s -> Int# -> Commits s -> Int# commitDistance :: MutableByteArray# s -> Int# -> Commits s -> Int#
commitDistance !_ !_ Initial = errorWithoutStackTrace "chunkDistance: chunk not found" commitDistance !_ !_ Initial = errorWithoutStackTrace "chunkDistance: chunk not found"
commitDistance target !n (Immutable _ _ len cs) = commitDistance target !n (Immutable _ _ len cs) =
@ -315,48 +361,59 @@ commitDistance target !n (Mutable buf len cs) =
1# -> n +# len 1# -> n +# len
_ -> commitDistance target (n +# len) cs _ -> commitDistance target (n +# len) cs
-- | Encode (UTF-8 encoded) text as a JSON string, wrapping it in double quotes. {- | Encode (UTF-8 encoded) text as a JSON string, wrapping it in double quotes.
-- This escapes all characters with code points below @0x20@. This escapes all characters with code points below @0x20@.
--
-- * Precondition: The slice of the byte argument is UTF-8 encoded text. * Precondition: The slice of the byte argument is UTF-8 encoded text.
-- * Precondition: There is enough space in the buffer for the result * Precondition: There is enough space in the buffer for the result
-- to be written to. A simple way to ensure enough space is to allocate to be written to. A simple way to ensure enough space is to allocate
-- @6N + 2@ bytes, where N is the length of the argument. However, the @6N + 2@ bytes, where N is the length of the argument. However, the
-- caller may use clever heuristics to find a lower upper bound. caller may use clever heuristics to find a lower upper bound.
-- * Result: The next offset in the destination buffer * Result: The next offset in the destination buffer
-}
pasteUtf8TextJson# :: pasteUtf8TextJson# ::
ByteArray# -- ^ source -- | source
-> Int# -- ^ source offset ByteArray# ->
-> Int# -- ^ source length -- | source offset
-> MutableByteArray# s -- ^ destination buffer Int# ->
-> Int# -- ^ offset into destination buffer -- | source length
-> State# s -- ^ state token Int# ->
-> (# State# s, Int# #) -- returns next destination offset -- | destination buffer
{-# noinline pasteUtf8TextJson# #-} MutableByteArray# s ->
-- | offset into destination buffer
Int# ->
-- | state token
State# s ->
(# State# s, Int# #) -- returns next destination offset
{-# NOINLINE pasteUtf8TextJson# #-}
pasteUtf8TextJson# src# soff0# slen0# dst# doff0# s0# = pasteUtf8TextJson# src# soff0# slen0# dst# doff0# s0# =
let ST f = do let ST f = do
let dst = MutableByteArray dst# let dst = MutableByteArray dst#
let doff0 = I# doff0# let doff0 = I# doff0#
PM.writeByteArray dst doff0 (c2w '"') PM.writeByteArray dst doff0 (c2w '"')
let go !soff !slen !doff = if slen > 0 let go !soff !slen !doff =
then case indexChar8Array (ByteArray src#) soff of if slen > 0
'\\' -> write2 dst doff '\\' '\\' *> go (soff + 1) (slen - 1) (doff + 2) then case indexChar8Array (ByteArray src#) soff of
'\"' -> write2 dst doff '\\' '\"' *> go (soff + 1) (slen - 1) (doff + 2) '\\' -> write2 dst doff '\\' '\\' *> go (soff + 1) (slen - 1) (doff + 2)
c -> if c >= '\x20' '\"' -> write2 dst doff '\\' '\"' *> go (soff + 1) (slen - 1) (doff + 2)
then PM.writeByteArray dst doff (c2w c) *> go (soff + 1) (slen - 1) (doff + 1) c ->
else case c of if c >= '\x20'
'\n' -> write2 dst doff '\\' 'n' *> go (soff + 1) (slen - 1) (doff + 2) then PM.writeByteArray dst doff (c2w c) *> go (soff + 1) (slen - 1) (doff + 1)
'\r' -> write2 dst doff '\\' 'r' *> go (soff + 1) (slen - 1) (doff + 2) else case c of
'\t' -> write2 dst doff '\\' 't' *> go (soff + 1) (slen - 1) (doff + 2) '\n' -> write2 dst doff '\\' 'n' *> go (soff + 1) (slen - 1) (doff + 2)
'\b' -> write2 dst doff '\\' 'b' *> go (soff + 1) (slen - 1) (doff + 2) '\r' -> write2 dst doff '\\' 'r' *> go (soff + 1) (slen - 1) (doff + 2)
'\f' -> write2 dst doff '\\' 'f' *> go (soff + 1) (slen - 1) (doff + 2) '\t' -> write2 dst doff '\\' 't' *> go (soff + 1) (slen - 1) (doff + 2)
_ -> do '\b' -> write2 dst doff '\\' 'b' *> go (soff + 1) (slen - 1) (doff + 2)
write2 dst doff '\\' 'u' '\f' -> write2 dst doff '\\' 'f' *> go (soff + 1) (slen - 1) (doff + 2)
doff' <- UnsafeBounded.pasteST _ -> do
(Bounded.word16PaddedUpperHex (fromIntegral (c2w c))) write2 dst doff '\\' 'u'
dst (doff + 2) doff' <-
go (soff + 1) (slen - 1) doff' UnsafeBounded.pasteST
else pure doff (Bounded.word16PaddedUpperHex (fromIntegral (c2w c)))
dst
(doff + 2)
go (soff + 1) (slen - 1) doff'
else pure doff
doffRes <- go (I# soff0#) (I# slen0#) (doff0 + 1) doffRes <- go (I# soff0#) (I# slen0#) (doff0 + 1)
PM.writeByteArray dst doffRes (c2w '"') PM.writeByteArray dst doffRes (c2w '"')
pure (doffRes + 1) pure (doffRes + 1)
@ -364,7 +421,7 @@ pasteUtf8TextJson# src# soff0# slen0# dst# doff0# s0# =
in (# s1, dstFinal #) in (# s1, dstFinal #)
c2w :: Char -> Word8 c2w :: Char -> Word8
{-# inline c2w #-} {-# INLINE c2w #-}
c2w = fromIntegral . ord c2w = fromIntegral . ord
-- Internal. Write two characters in the ASCII plane to a byte array. -- Internal. Write two characters in the ASCII plane to a byte array.
@ -374,5 +431,5 @@ write2 marr ix a b = do
PM.writeByteArray marr (ix + 1) (c2w b) PM.writeByteArray marr (ix + 1) (c2w b)
indexChar8Array :: ByteArray -> Int -> Char indexChar8Array :: ByteArray -> Int -> Char
{-# inline indexChar8Array #-} {-# INLINE indexChar8Array #-}
indexChar8Array (ByteArray b) (I# i) = C# (Exts.indexCharArray# b i) indexChar8Array (ByteArray b) (I# i) = C# (Exts.indexCharArray# b i)

647
test/Main.hs
View file

@ -1,53 +1,50 @@
{-# language BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# language NumericUnderscores #-} {-# LANGUAGE NumericUnderscores #-}
{-# language OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# language QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# language ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# language TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
import Prelude hiding (replicate) import Prelude hiding (replicate)
import Control.Applicative (liftA2)
import Control.Monad.ST (runST) import Control.Monad.ST (runST)
import Data.Bytes.Builder import Data.Bytes.Builder
import Data.Bytes.Builder.Template (bldr) import Data.Bytes.Builder.Template (bldr)
import Data.Bytes.Types (MutableBytes(MutableBytes)) import Data.Bytes.Types (MutableBytes (MutableBytes))
import Data.Char (ord,chr) import Data.Char (chr, ord)
import Data.IORef (IORef,newIORef,readIORef,writeIORef) import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Primitive (ByteArray) import Data.Primitive (ByteArray, PrimArray)
import Data.Primitive (PrimArray)
import Data.Text.Short (ShortText) import Data.Text.Short (ShortText)
import Data.WideWord (Word128(Word128),Word256(Word256)) import Data.WideWord (Word128 (Word128), Word256 (Word256))
import Data.Word import Data.Word
import Numeric.Natural (Natural) import Numeric.Natural (Natural)
import Test.QuickCheck ((===),Arbitrary) import Test.QuickCheck (Arbitrary, (===))
import Test.QuickCheck.Instances.Natural () import Test.QuickCheck.Instances.Natural ()
import Test.Tasty (defaultMain,testGroup,TestTree) import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit ((@=?)) import Test.Tasty.HUnit ((@=?))
import Text.Printf (printf) import Text.Printf (printf)
import qualified Arithmetic.Nat as Nat import qualified Arithmetic.Nat as Nat
import qualified Data.Bits as Bits import qualified Data.Bits as Bits
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.Bytes as Bytes import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Builder as Builder import qualified Data.Bytes.Builder as Builder
import qualified Data.Bytes.Builder.Bounded as Bounded import qualified Data.Bytes.Builder.Bounded as Bounded
import qualified Data.Bytes.Chunks as Chunks import qualified Data.Bytes.Chunks as Chunks
import qualified Data.Bytes.Text.Ascii as Ascii import qualified Data.Bytes.Text.Ascii as Ascii
import qualified Data.Bytes.Text.Latin1 as Latin1 import qualified Data.Bytes.Text.Latin1 as Latin1
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.List as L import qualified Data.List as L
import qualified Data.Primitive as PM import qualified Data.Primitive as PM
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import qualified GHC.Exts as Exts import qualified GHC.Exts as Exts
import qualified Prelude
import qualified Test.Tasty.HUnit as THU import qualified Test.Tasty.HUnit as THU
import qualified Test.Tasty.QuickCheck as TQC import qualified Test.Tasty.QuickCheck as TQC
import qualified Prelude
import qualified HexWord64 import qualified HexWord64
import qualified Word16Tree import qualified Word16Tree
@ -56,299 +53,309 @@ main :: IO ()
main = defaultMain tests main = defaultMain tests
tests :: TestTree tests :: TestTree
tests = testGroup "Tests" tests =
[ testGroup "live" testGroup
[ TQC.testProperty "word64Dec" $ \w -> "Tests"
runConcat 1 (word64Dec w) === pack (show w) [ testGroup
, TQC.testProperty "word64Dec-x3" $ \x y z -> "live"
runConcat 1 (word64Dec x <> word64Dec y <> word64Dec z) [ TQC.testProperty "word64Dec" $ \w ->
=== runConcat 1 (word64Dec w) === pack (show w)
pack (show x ++ show y ++ show z) , TQC.testProperty "word64Dec-x3" $ \x y z ->
, TQC.testProperty "int64Dec-x3" $ \x y z -> runConcat 1 (word64Dec x <> word64Dec y <> word64Dec z)
runConcat 1 (int64Dec x <> int64Dec y <> int64Dec z) === pack (show x ++ show y ++ show z)
=== , TQC.testProperty "int64Dec-x3" $ \x y z ->
pack (show x ++ show y ++ show z) runConcat 1 (int64Dec x <> int64Dec y <> int64Dec z)
, TQC.testProperty "word64BE-x3" $ \x y z -> === pack (show x ++ show y ++ show z)
runConcat 1 (word64BE x <> word64BE y <> word64BE z) , TQC.testProperty "word64BE-x3" $ \x y z ->
=== runConcat 1 (word64BE x <> word64BE y <> word64BE z)
pack (LB.unpack (BB.toLazyByteString (BB.word64BE x <> BB.word64BE y <> BB.word64BE z))) === pack (LB.unpack (BB.toLazyByteString (BB.word64BE x <> BB.word64BE y <> BB.word64BE z)))
, TQC.testProperty "word256PaddedLowerHex" $ \w -> , TQC.testProperty "word256PaddedLowerHex" $ \w ->
Bounded.run Nat.constant (Bounded.word256PaddedLowerHex w) Bounded.run Nat.constant (Bounded.word256PaddedLowerHex w)
=== === pack (showWord256PaddedLowerHex w)
pack (showWord256PaddedLowerHex w) , TQC.testProperty "word128PaddedUpperHex" $ \w ->
, TQC.testProperty "word128PaddedUpperHex" $ \w -> Bounded.run Nat.constant (Bounded.word128PaddedUpperHex w)
Bounded.run Nat.constant (Bounded.word128PaddedUpperHex w) === pack (showWord128PaddedUpperHex w)
=== , TQC.testProperty "word64PaddedUpperHex" $ \w ->
pack (showWord128PaddedUpperHex w) runConcat 1 (word64PaddedUpperHex w)
, TQC.testProperty "word64PaddedUpperHex" $ \w -> === pack (showWord64PaddedUpperHex w)
runConcat 1 (word64PaddedUpperHex w) , TQC.testProperty "word16PaddedLowerHex" $ \w ->
=== runConcat 1 (word16PaddedLowerHex w)
pack (showWord64PaddedUpperHex w) === pack (showWord16PaddedLowerHex w)
, TQC.testProperty "word16PaddedLowerHex" $ \w -> , TQC.testProperty "wordPaddedDec2" $ TQC.forAll (TQC.choose (0, 99)) $ \w ->
runConcat 1 (word16PaddedLowerHex w) Bounded.run Nat.two (Bounded.wordPaddedDec2 w)
=== === pack (zeroPadL 2 (show w))
pack (showWord16PaddedLowerHex w) , TQC.testProperty "wordPaddedDec4" $ TQC.forAll (TQC.choose (0, 9999)) $ \w ->
, TQC.testProperty "wordPaddedDec2" $ TQC.forAll (TQC.choose (0,99)) $ \w -> Bounded.run Nat.constant (Bounded.wordPaddedDec4 w)
Bounded.run Nat.two (Bounded.wordPaddedDec2 w) === pack (zeroPadL 4 (show w))
=== , TQC.testProperty "wordPaddedDec9" $ TQC.forAll (TQC.choose (0, 999999999)) $ \w ->
pack (zeroPadL 2 (show w)) Bounded.run Nat.constant (Bounded.wordPaddedDec9 w)
, TQC.testProperty "wordPaddedDec4" $ TQC.forAll (TQC.choose (0,9999)) $ \w -> === pack (zeroPadL 9 (show w))
Bounded.run Nat.constant (Bounded.wordPaddedDec4 w) , TQC.testProperty "word8Dec" $ \w ->
=== runConcat 1 (word8Dec w)
pack (zeroPadL 4 (show w)) === pack (show w)
, TQC.testProperty "wordPaddedDec9" $ TQC.forAll (TQC.choose (0,999999999)) $ \w -> , TQC.testProperty "consLength32BE" $ \w ->
Bounded.run Nat.constant (Bounded.wordPaddedDec9 w) runConcat 1 (consLength32BE (word8Dec w))
=== === pack ('\x00' : '\x00' : '\x00' : chr (L.length (show w)) : show w)
pack (zeroPadL 9 (show w)) , TQC.testProperty "consLength64BE-uni" $ \w ->
, TQC.testProperty "word8Dec" $ \w -> pack
runConcat 1 (word8Dec w) ( '\x00'
=== : '\x00'
pack (show w) : '\x00'
, TQC.testProperty "consLength32BE" $ \w -> : '\x00'
runConcat 1 (consLength32BE (word8Dec w)) : '\x00'
=== : '\x00'
pack ('\x00' : '\x00' : '\x00' : chr (L.length (show w)) : show w) : '\x00'
, TQC.testProperty "consLength64BE-uni" $ \w -> : chr (L.length (show w))
pack : show w
( '\x00' : '\x00' : '\x00' : '\x00'
: '\x00' : '\x00' : '\x00' : chr (L.length (show w))
: show w
)
===
runConcat 1 (consLength64BE (word16Dec w))
, TQC.testProperty "consLength64BE-multi" $ \w ->
pack
( '\x00' : '\x00' : '\x00' : '\x00'
: '\x00' : '\x00' : '\x00' : chr (1 + L.length (show w))
: '\x42' : show w
)
===
runConcat 1 (consLength64BE (word8 0x42 <> flush 2 <> word16Dec w))
, THU.testCase "stringUtf8" $
packUtf8 "¿Cómo estás? I am doing well." @=?
runConcat 1 (stringUtf8 "¿Cómo estás? I am doing well.")
, THU.testCase "doubleDec-A" $
pack (show (2 :: Int)) @=? runConcat 1 (doubleDec 2.0)
, THU.testCase "doubleDec-B" $
pack (show (2.5 :: Double)) @=? runConcat 1 (doubleDec 2.5)
, THU.testCase "doubleDec-C" $
pack ("1e+15") @=? runConcat 1 (doubleDec 1e15)
, THU.testCase "doubleDec-D" $
pack ("-42") @=? runConcat 1 (doubleDec (-42))
, THU.testCase "doubleDec-E" $
AsciiByteArray (pack ("-8.8888888888889e+14")) @=? AsciiByteArray (runConcat 1 (doubleDec (-888888888888888.8888888)))
, THU.testCase "doubleDec-F" $
pack ("42") @=? runConcat 1 (doubleDec 42)
, THU.testCase "doubleDec-G" $
pack ("0") @=? runConcat 1 (doubleDec 0)
, THU.testCase "doubleDec-H" $
pack ("0.5") @=? runConcat 1 (doubleDec 0.5)
, THU.testCase "doubleDec-I" $
pack ("-0.5") @=? runConcat 1 (doubleDec (-0.5))
, THU.testCase "doubleDec-J" $
pack ("999999999") @=? runConcat 1 (doubleDec 999999999)
, THU.testCase "doubleDec-K" $
pack ("-99999999") @=? runConcat 1 (doubleDec (-99999999))
, THU.testCase "doubleDec-L" $
AsciiByteArray (pack ("6.6666666666667e-12")) @=? AsciiByteArray (runConcat 1 (doubleDec (2 / 300_000_000_000)))
, THU.testCase "doubleDec-M" $
AsciiByteArray (pack ("6.6666666666667e-10")) @=? AsciiByteArray (runConcat 1 (doubleDec 6.666666666666667e-10))
, THU.testCase "doubleDec-N" $
AsciiByteArray (pack ("5e-10")) @=? AsciiByteArray (runConcat 1 (doubleDec 5.0e-10))
, THU.testCase "doubleDec-O" $
AsciiByteArray (pack ("1.6666666666667e-10")) @=? AsciiByteArray (runConcat 1 (doubleDec 1.6666666666666669e-10))
, THU.testCase "doubleDec-P" $
AsciiByteArray (pack ("1e-09")) @=? AsciiByteArray (runConcat 1 (doubleDec 1.0e-9))
, THU.testCase "doubleDec-Q" $
AsciiByteArray (pack ("1e-08")) @=? AsciiByteArray (runConcat 1 (doubleDec 1.0e-8))
, THU.testCase "shortTextJsonString-A" $
pack ("\"hello\"") @=? runConcat 1 (shortTextJsonString "hello")
, THU.testCase "shortTextJsonString-B" $
pack ("\"\\\\_\\\"_/\"") @=? runConcat 1 (shortTextJsonString "\\_\"_/")
, THU.testCase "shortTextJsonString-C" $
pack ("\"Hi\\r\\nLo\"") @=? runConcat 1 (shortTextJsonString "Hi\r\nLo")
, THU.testCase "shortTextJsonString-D" $
pack ("\"Hi\\u001BLo\"") @=? runConcat 1 (shortTextJsonString "Hi\ESCLo")
, THU.testCase "word-16-tree" $
Word16Tree.expectedSmall @=? runConcat 1
(Word16Tree.encode Word16Tree.exampleSmall)
, THU.testCase "byteArray-small" $
let a = replicateByte 3 0x50
b = replicateByte 5 0x51
in mconcat [a,b] @=? runConcat 1
( byteArray a <> byteArray b )
, THU.testCase "byteArray-big" $
let a = replicateByte 2105 0x50
b = replicateByte 725 0x51
c = replicateByte 900 0x52
d = replicateByte 800 0x53
e = replicateByte 700 0x54
f = replicateByte 950 0x55
g = replicateByte 975 0x56
h = replicateByte 3000 0x57
i = replicateByte 125 0x58
in mconcat [a,b,c,d,e,f,g,h,i] @=? runConcat 1
( byteArray a <> byteArray b <> byteArray c <>
byteArray d <> byteArray e <> byteArray f <>
byteArray g <> byteArray h <> byteArray i
) )
, TQC.testProperty "word16ArrayLE" $ \(xs :: [Word16]) -> === runConcat 1 (consLength64BE (word16Dec w))
let ys = Exts.fromList xs :: PrimArray Word16 , TQC.testProperty "consLength64BE-multi" $ \w ->
in runConcat 1 (foldMap word16LE xs) pack
=== ( '\x00'
runConcat 1 (word16ArrayLE ys 0 (Prelude.length xs)) : '\x00'
, TQC.testProperty "word16ArrayBE" $ \(xs :: [Word16]) -> : '\x00'
let ys = Exts.fromList xs :: PrimArray Word16 : '\x00'
in runConcat 1 (foldMap word16BE xs) : '\x00'
=== : '\x00'
runConcat 1 (word16ArrayBE ys 0 (Prelude.length xs)) : '\x00'
, TQC.testProperty "word32ArrayLE" $ \(xs :: [Word32]) -> : chr (1 + L.length (show w))
let ys = Exts.fromList xs :: PrimArray Word32 : '\x42'
in runConcat 1 (foldMap word32LE xs) : show w
=== )
runConcat 1 (word32ArrayLE ys 0 (Prelude.length xs)) === runConcat 1 (consLength64BE (word8 0x42 <> flush 2 <> word16Dec w))
, TQC.testProperty "word32ArrayBE" $ \(xs :: [Word32]) -> , THU.testCase "stringUtf8" $
let ys = Exts.fromList xs :: PrimArray Word32 packUtf8 "¿Cómo estás? I am doing well."
in runConcat 1 (foldMap word32BE xs) @=? runConcat 1 (stringUtf8 "¿Cómo estás? I am doing well.")
=== , THU.testCase "doubleDec-A" $
runConcat 1 (word32ArrayBE ys 0 (Prelude.length xs)) pack (show (2 :: Int)) @=? runConcat 1 (doubleDec 2.0)
, TQC.testProperty "word64ArrayLE" $ \(xs :: [Word64]) -> , THU.testCase "doubleDec-B" $
let ys = Exts.fromList xs :: PrimArray Word64 pack (show (2.5 :: Double)) @=? runConcat 1 (doubleDec 2.5)
in runConcat 1 (foldMap word64LE xs) , THU.testCase "doubleDec-C" $
=== pack ("1e+15") @=? runConcat 1 (doubleDec 1e15)
runConcat 1 (word64ArrayLE ys 0 (Prelude.length xs)) , THU.testCase "doubleDec-D" $
, TQC.testProperty "word64ArrayBE" $ \(xs :: [Word64]) -> pack ("-42") @=? runConcat 1 (doubleDec (-42))
let ys = Exts.fromList xs :: PrimArray Word64 , THU.testCase "doubleDec-E" $
in runConcat 1 (foldMap word64BE xs) AsciiByteArray (pack ("-8.8888888888889e+14")) @=? AsciiByteArray (runConcat 1 (doubleDec (-888888888888888.8888888)))
=== , THU.testCase "doubleDec-F" $
runConcat 1 (word64ArrayBE ys 0 (Prelude.length xs)) pack ("42") @=? runConcat 1 (doubleDec 42)
, TQC.testProperty "word128ArrayLE" $ \(xs :: [Word128]) -> , THU.testCase "doubleDec-G" $
let ys = Exts.fromList xs :: PrimArray Word128 pack ("0") @=? runConcat 1 (doubleDec 0)
in runConcat 1 (foldMap word128LE xs) , THU.testCase "doubleDec-H" $
=== pack ("0.5") @=? runConcat 1 (doubleDec 0.5)
runConcat 1 (word128ArrayLE ys 0 (Prelude.length xs)) , THU.testCase "doubleDec-I" $
, TQC.testProperty "word128ArrayBE" $ \(xs :: [Word128]) -> pack ("-0.5") @=? runConcat 1 (doubleDec (-0.5))
let ys = Exts.fromList xs :: PrimArray Word128 , THU.testCase "doubleDec-J" $
in runConcat 1 (foldMap word128BE xs) pack ("999999999") @=? runConcat 1 (doubleDec 999999999)
=== , THU.testCase "doubleDec-K" $
runConcat 1 (word128ArrayBE ys 0 (Prelude.length xs)) pack ("-99999999") @=? runConcat 1 (doubleDec (-99999999))
, TQC.testProperty "word256ArrayLE" $ \(xs :: [Word256]) -> , THU.testCase "doubleDec-L" $
let ys = Exts.fromList xs :: PrimArray Word256 AsciiByteArray (pack ("6.6666666666667e-12")) @=? AsciiByteArray (runConcat 1 (doubleDec (2 / 300_000_000_000)))
in runConcat 1 (foldMap word256LE xs) , THU.testCase "doubleDec-M" $
=== AsciiByteArray (pack ("6.6666666666667e-10")) @=? AsciiByteArray (runConcat 1 (doubleDec 6.666666666666667e-10))
runConcat 1 (word256ArrayLE ys 0 (Prelude.length xs)) , THU.testCase "doubleDec-N" $
, TQC.testProperty "word256ArrayBE" $ \(xs :: [Word256]) -> AsciiByteArray (pack ("5e-10")) @=? AsciiByteArray (runConcat 1 (doubleDec 5.0e-10))
let ys = Exts.fromList xs :: PrimArray Word256 , THU.testCase "doubleDec-O" $
in runConcat 1 (foldMap word256BE xs) AsciiByteArray (pack ("1.6666666666667e-10")) @=? AsciiByteArray (runConcat 1 (doubleDec 1.6666666666666669e-10))
=== , THU.testCase "doubleDec-P" $
runConcat 1 (word256ArrayBE ys 0 (Prelude.length xs)) AsciiByteArray (pack ("1e-09")) @=? AsciiByteArray (runConcat 1 (doubleDec 1.0e-9))
, TQC.testProperty "word64Vlq" $ \(x :: Word64) -> , THU.testCase "doubleDec-Q" $
runConcat 1 (word64Vlq x) AsciiByteArray (pack ("1e-08")) @=? AsciiByteArray (runConcat 1 (doubleDec 1.0e-8))
=== , THU.testCase "shortTextJsonString-A" $
naiveVlq (fromIntegral x) pack ("\"hello\"") @=? runConcat 1 (shortTextJsonString "hello")
, TQC.testProperty "word64LEB128" $ \(x :: Word64) -> , THU.testCase "shortTextJsonString-B" $
runConcat 1 (word64LEB128 x) pack ("\"\\\\_\\\"_/\"") @=? runConcat 1 (shortTextJsonString "\\_\"_/")
=== , THU.testCase "shortTextJsonString-C" $
naiveLeb128 (fromIntegral x) pack ("\"Hi\\r\\nLo\"") @=? runConcat 1 (shortTextJsonString "Hi\r\nLo")
, TQC.testProperty "naturalDec-A" $ \(x :: Natural) -> , THU.testCase "shortTextJsonString-D" $
runConcat 1 (naturalDec x) pack ("\"Hi\\u001BLo\"") @=? runConcat 1 (shortTextJsonString "Hi\ESCLo")
=== , THU.testCase "word-16-tree" $
pack (show x) Word16Tree.expectedSmall
, TQC.testProperty "naturalDec-B" $ \(x :: Natural) -> @=? runConcat
let y = 1234567892345678934678987654321 * x in 1
runConcat 1 (naturalDec y) (Word16Tree.encode Word16Tree.exampleSmall)
=== , THU.testCase "byteArray-small" $
pack (show y) let a = replicateByte 3 0x50
, testGroup "leb128-encoding" b = replicateByte 5 0x51
[ THU.testCase "16" $ in mconcat [a, b]
Chunks.concat (run 16 (word64LEB128 16)) @=? runConcat
@=? 1
Latin1.fromString "\x10" (byteArray a <> byteArray b)
, THU.testCase "1000000" $ , THU.testCase "byteArray-big" $
Chunks.concat (run 16 (word64LEB128 1000000)) let a = replicateByte 2105 0x50
@=? b = replicateByte 725 0x51
Exts.fromList [0xc0,0x84,0x3d] c = replicateByte 900 0x52
, THU.testCase "deadbeef-smile" $ do d = replicateByte 800 0x53
let inp = Latin1.fromString "\xDE\xAD\xBE\xEF" e = replicateByte 700 0x54
(Chunks.concat . run 16) (sevenEightSmile inp) f = replicateByte 950 0x55
@=?Latin1.fromString "\x6F\x2B\x37\x6E\x0F" g = replicateByte 975 0x56
] h = replicateByte 3000 0x57
, testGroup "seven/eight encoding" i = replicateByte 125 0x58
[ THU.testCase "deadbeef" $ do in mconcat [a, b, c, d, e, f, g, h, i]
let inp = Latin1.fromString "\xDE\xAD\xBE\xEF" @=? runConcat
(Chunks.concat . run 16) (sevenEightRight inp) 1
@=? Latin1.fromString "\x6F\x2B\x37\x6E\x78" ( byteArray a
, THU.testCase "deadbeef-smile" $ do <> byteArray b
let inp = Latin1.fromString "\xDE\xAD\xBE\xEF" <> byteArray c
(Chunks.concat . run 16) (sevenEightSmile inp) <> byteArray d
@=?Latin1.fromString "\x6F\x2B\x37\x6E\x0F" <> byteArray e
] <> byteArray f
<> byteArray g
<> byteArray h
<> byteArray i
)
, TQC.testProperty "word16ArrayLE" $ \(xs :: [Word16]) ->
let ys = Exts.fromList xs :: PrimArray Word16
in runConcat 1 (foldMap word16LE xs)
=== runConcat 1 (word16ArrayLE ys 0 (Prelude.length xs))
, TQC.testProperty "word16ArrayBE" $ \(xs :: [Word16]) ->
let ys = Exts.fromList xs :: PrimArray Word16
in runConcat 1 (foldMap word16BE xs)
=== runConcat 1 (word16ArrayBE ys 0 (Prelude.length xs))
, TQC.testProperty "word32ArrayLE" $ \(xs :: [Word32]) ->
let ys = Exts.fromList xs :: PrimArray Word32
in runConcat 1 (foldMap word32LE xs)
=== runConcat 1 (word32ArrayLE ys 0 (Prelude.length xs))
, TQC.testProperty "word32ArrayBE" $ \(xs :: [Word32]) ->
let ys = Exts.fromList xs :: PrimArray Word32
in runConcat 1 (foldMap word32BE xs)
=== runConcat 1 (word32ArrayBE ys 0 (Prelude.length xs))
, TQC.testProperty "word64ArrayLE" $ \(xs :: [Word64]) ->
let ys = Exts.fromList xs :: PrimArray Word64
in runConcat 1 (foldMap word64LE xs)
=== runConcat 1 (word64ArrayLE ys 0 (Prelude.length xs))
, TQC.testProperty "word64ArrayBE" $ \(xs :: [Word64]) ->
let ys = Exts.fromList xs :: PrimArray Word64
in runConcat 1 (foldMap word64BE xs)
=== runConcat 1 (word64ArrayBE ys 0 (Prelude.length xs))
, TQC.testProperty "word128ArrayLE" $ \(xs :: [Word128]) ->
let ys = Exts.fromList xs :: PrimArray Word128
in runConcat 1 (foldMap word128LE xs)
=== runConcat 1 (word128ArrayLE ys 0 (Prelude.length xs))
, TQC.testProperty "word128ArrayBE" $ \(xs :: [Word128]) ->
let ys = Exts.fromList xs :: PrimArray Word128
in runConcat 1 (foldMap word128BE xs)
=== runConcat 1 (word128ArrayBE ys 0 (Prelude.length xs))
, TQC.testProperty "word256ArrayLE" $ \(xs :: [Word256]) ->
let ys = Exts.fromList xs :: PrimArray Word256
in runConcat 1 (foldMap word256LE xs)
=== runConcat 1 (word256ArrayLE ys 0 (Prelude.length xs))
, TQC.testProperty "word256ArrayBE" $ \(xs :: [Word256]) ->
let ys = Exts.fromList xs :: PrimArray Word256
in runConcat 1 (foldMap word256BE xs)
=== runConcat 1 (word256ArrayBE ys 0 (Prelude.length xs))
, TQC.testProperty "word64Vlq" $ \(x :: Word64) ->
runConcat 1 (word64Vlq x)
=== naiveVlq (fromIntegral x)
, TQC.testProperty "word64LEB128" $ \(x :: Word64) ->
runConcat 1 (word64LEB128 x)
=== naiveLeb128 (fromIntegral x)
, TQC.testProperty "naturalDec-A" $ \(x :: Natural) ->
runConcat 1 (naturalDec x)
=== pack (show x)
, TQC.testProperty "naturalDec-B" $ \(x :: Natural) ->
let y = 1234567892345678934678987654321 * x
in runConcat 1 (naturalDec y)
=== pack (show y)
, testGroup
"leb128-encoding"
[ THU.testCase "16" $
Chunks.concat (run 16 (word64LEB128 16))
@=? Latin1.fromString "\x10"
, THU.testCase "1000000" $
Chunks.concat (run 16 (word64LEB128 1000000))
@=? Exts.fromList [0xc0, 0x84, 0x3d]
, THU.testCase "deadbeef-smile" $ do
let inp = Latin1.fromString "\xDE\xAD\xBE\xEF"
(Chunks.concat . run 16) (sevenEightSmile inp)
@=? Latin1.fromString "\x6F\x2B\x37\x6E\x0F"
]
, testGroup
"seven/eight encoding"
[ THU.testCase "deadbeef" $ do
let inp = Latin1.fromString "\xDE\xAD\xBE\xEF"
(Chunks.concat . run 16) (sevenEightRight inp)
@=? Latin1.fromString "\x6F\x2B\x37\x6E\x78"
, THU.testCase "deadbeef-smile" $ do
let inp = Latin1.fromString "\xDE\xAD\xBE\xEF"
(Chunks.concat . run 16) (sevenEightSmile inp)
@=? Latin1.fromString "\x6F\x2B\x37\x6E\x0F"
]
]
, testGroup
"alternate"
[ TQC.testProperty "HexWord64" $ \x y ->
runConcat
1
( fromBounded Nat.constant (HexWord64.word64PaddedUpperHex x)
<> fromBounded Nat.constant (HexWord64.word64PaddedUpperHex y)
)
=== pack (showWord64PaddedUpperHex x <> showWord64PaddedUpperHex y)
]
, testGroup
"putMany"
[ THU.testCase "A" $ do
ref <- newIORef []
let txt = "hello_world_are_you_listening" :: [Char]
putMany 7 ascii txt (bytesOntoRef ref)
res <- readIORef ref
id $
[ map c2w "hello_"
, map c2w "world_"
, map c2w "are_yo"
, map c2w "u_list"
, map c2w "ening"
]
@=? map Exts.toList (Exts.toList res)
]
, testGroup
"putManyConsLength"
[ THU.testCase "A" $ do
ref <- newIORef []
let txt = "hello_world_are_you_listening" :: [Char]
putManyConsLength
Nat.constant
(\n -> Bounded.word16BE (fromIntegral n))
16
ascii
txt
(bytesOntoRef ref)
res <- readIORef ref
id $
[ 0x00 : 0x0A : map c2w "hello_worl"
, 0x00 : 0x0A : map c2w "d_are_you_"
, 0x00 : 0x09 : map c2w "listening"
]
@=? map Exts.toList (Exts.toList res)
]
, testGroup
"bytes templates"
[ THU.testCase "A" $ do
let name = Just ("foo" :: ShortText)
msgBuilder = [bldr|Hello `fromMaybe "World" name`!\n|]
msg = Chunks.concat . Builder.run 200 $ msgBuilder
in Ascii.fromString "Hello foo!\n" @=? msg
, THU.testCase "B" $ do
let one = "foo" :: ShortText
two = "bar" :: String
msgBuilder = [bldr|`one``two`|]
msg = Chunks.concat . Builder.run 200 $ msgBuilder
in Ascii.fromString "foobar" @=? msg
, THU.testCase "C" $ do
let msgBuilder = [bldr|a backtick for you: \`|]
msg = Chunks.concat . Builder.run 200 $ msgBuilder
in Ascii.fromString "a backtick for you: `" @=? msg
, THU.testCase "D" $ do
let i = 137 :: Int
msgBuilder = [bldr|there are `i` lights!|]
msg = Chunks.concat . Builder.run 200 $ msgBuilder
in Ascii.fromString "there are 137 lights!" @=? msg
]
] ]
, testGroup "alternate"
[ TQC.testProperty "HexWord64" $ \x y ->
runConcat 1
( fromBounded Nat.constant (HexWord64.word64PaddedUpperHex x)
<> fromBounded Nat.constant (HexWord64.word64PaddedUpperHex y)
)
===
pack (showWord64PaddedUpperHex x <> showWord64PaddedUpperHex y)
]
, testGroup "putMany"
[ THU.testCase "A" $ do
ref <- newIORef []
let txt = "hello_world_are_you_listening" :: [Char]
putMany 7 ascii txt (bytesOntoRef ref)
res <- readIORef ref
id $
[ map c2w "hello_"
, map c2w "world_"
, map c2w "are_yo"
, map c2w "u_list"
, map c2w "ening"
] @=? map Exts.toList (Exts.toList res)
]
, testGroup "putManyConsLength"
[ THU.testCase "A" $ do
ref <- newIORef []
let txt = "hello_world_are_you_listening" :: [Char]
putManyConsLength Nat.constant
(\n -> Bounded.word16BE (fromIntegral n))
16 ascii txt (bytesOntoRef ref)
res <- readIORef ref
id $
[ 0x00 : 0x0A : map c2w "hello_worl"
, 0x00 : 0x0A : map c2w "d_are_you_"
, 0x00 : 0x09 : map c2w "listening"
] @=? map Exts.toList (Exts.toList res)
]
, testGroup "bytes templates"
[ THU.testCase "A" $ do
let name = Just ("foo" :: ShortText)
msgBuilder = [bldr|Hello `fromMaybe "World" name`!\n|]
msg = Chunks.concat . Builder.run 200 $ msgBuilder
in Ascii.fromString "Hello foo!\n" @=? msg
, THU.testCase "B" $ do
let one = "foo" :: ShortText
two = "bar" :: String
msgBuilder = [bldr|`one``two`|]
msg = Chunks.concat . Builder.run 200 $ msgBuilder
in Ascii.fromString "foobar" @=? msg
, THU.testCase "C" $ do
let msgBuilder = [bldr|a backtick for you: \`|]
msg = Chunks.concat . Builder.run 200 $ msgBuilder
in Ascii.fromString "a backtick for you: `" @=? msg
, THU.testCase "D" $ do
let i = 137 :: Int
msgBuilder = [bldr|there are `i` lights!|]
msg = Chunks.concat . Builder.run 200 $ msgBuilder
in Ascii.fromString "there are 137 lights!" @=? msg
]
]
bytesOntoRef :: bytesOntoRef ::
IORef [PM.ByteArray] IORef [PM.ByteArray] ->
-> MutableBytes Exts.RealWorld MutableBytes Exts.RealWorld ->
-> IO () IO ()
bytesOntoRef !ref (MutableBytes buf off len) = do bytesOntoRef !ref (MutableBytes buf off len) = do
rs <- readIORef ref rs <- readIORef ref
dst <- PM.newByteArray len dst <- PM.newByteArray len
@ -391,9 +398,10 @@ newtype AsciiByteArray = AsciiByteArray ByteArray
deriving (Eq) deriving (Eq)
instance Show AsciiByteArray where instance Show AsciiByteArray where
show (AsciiByteArray b) = if Bytes.all (\w -> w >= 32 && w < 127) (Bytes.fromByteArray b) show (AsciiByteArray b) =
then Latin1.toString (Bytes.fromByteArray b) if Bytes.all (\w -> w >= 32 && w < 127) (Bytes.fromByteArray b)
else show (show b) then Latin1.toString (Bytes.fromByteArray b)
else show (show b)
instance Arbitrary Word128 where instance Arbitrary Word128 where
arbitrary = liftA2 Word128 TQC.arbitrary TQC.arbitrary arbitrary = liftA2 Word128 TQC.arbitrary TQC.arbitrary
@ -409,13 +417,14 @@ zeroPadL n s
naiveLeb128 :: Natural -> ByteArray naiveLeb128 :: Natural -> ByteArray
naiveLeb128 x = naiveLeb128 x =
Bytes.toByteArray (Bytes.unsafeDrop 1 (Exts.fromList (0xFF : go [] x))) Bytes.toByteArray (Bytes.unsafeDrop 1 (Exts.fromList (0xFF : go [] x)))
where where
go !xs !n = go !xs !n =
let (q,r) = quotRem n 128 let (q, r) = quotRem n 128
r' = fromIntegral @Natural @Word8 r r' = fromIntegral @Natural @Word8 r
w = if q == 0 w =
then r' if q == 0
else Bits.setBit r' 7 then r'
else Bits.setBit r' 7
xs' = w : xs xs' = w : xs
in if q == 0 in if q == 0
then L.reverse xs' then L.reverse xs'
@ -424,9 +433,9 @@ naiveLeb128 x =
naiveVlq :: Natural -> ByteArray naiveVlq :: Natural -> ByteArray
naiveVlq x = naiveVlq x =
Bytes.toByteArray (Bytes.unsafeDrop 1 (Exts.fromList (0xFF : go [] x))) Bytes.toByteArray (Bytes.unsafeDrop 1 (Exts.fromList (0xFF : go [] x)))
where where
go !xs !n = go !xs !n =
let (q,r) = quotRem n 128 let (q, r) = quotRem n 128
r' = fromIntegral @Natural @Word8 r r' = fromIntegral @Natural @Word8 r
w = case xs of w = case xs of
[] -> r' [] -> r'