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
Show stats 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-*
cabal-dev
@ -11,6 +12,7 @@ cabal-dev
.hsenv
.cabal-sandbox/
cabal.sandbox.config
cabal.project.local
*.prof
*.aux
*.hp

4
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
to ease the migration process.
## 0.3.16.1 -- 2024-??-??
## 0.3.16.1 -- 2024-02-02
* Remove all CPP
* Drop support for GHC < 9.4
@ -141,7 +141,7 @@ to ease the migration process.
* Add `flush`, `copy`, and `insert` for better control when
converting byte sequences to builders.
* Add `shortByteString` to improve interoperability with the
`bytestring` library.
`bytestring` library.
## 0.2.1.0 -- 2019-09-05

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 OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module Cell
( Cell(..)
( Cell (..)
, cells
) where
import Data.Word (Word32)
import Data.Text.Short (ShortText)
import Data.Primitive (SmallArray)
import Data.Text.Short (ShortText)
import Data.Word (Word32)
-- A cell in a CSV file
data Cell
@ -18,15 +18,14 @@ data Cell
-- Some sample data to encode as a CSV
cells :: SmallArray (SmallArray Cell)
cells =
[ [ CellString "Randy", CellString "Gutiérrez", CellNumber 41, CellNumber 343 ]
, [ CellString "Édith", CellString "Piaf", CellNumber 63, CellNumber 453 ]
, [ CellString "Martha", CellString "Washington", CellNumber 51, CellNumber 634 ]
, [ CellString "Julius", CellString "Caesar", CellNumber 1, CellNumber 6922 ]
, [ CellString "Robert", CellString "Redford", CellNumber 24, CellNumber 617 ]
, [ CellString "Violet", CellString "Crawley", CellNumber 71, CellNumber 150 ]
, [ CellString "Lázaro", CellString "Cárdenas", CellNumber 58, CellNumber 299 ]
, [ CellString "Anastasia", CellString "San Martin", CellNumber 103, CellNumber 3214 ]
, [ CellString "Mad", CellString "Max", CellNumber 37, CellNumber 918 ]
, [ CellString "Sidonie-Gabrielle", CellString "Collette", CellNumber 25, CellNumber 904 ]
[ [CellString "Randy", CellString "Gutiérrez", CellNumber 41, CellNumber 343]
, [CellString "Édith", CellString "Piaf", CellNumber 63, CellNumber 453]
, [CellString "Martha", CellString "Washington", CellNumber 51, CellNumber 634]
, [CellString "Julius", CellString "Caesar", CellNumber 1, CellNumber 6922]
, [CellString "Robert", CellString "Redford", CellNumber 24, CellNumber 617]
, [CellString "Violet", CellString "Crawley", CellNumber 71, CellNumber 150]
, [CellString "Lázaro", CellString "Cárdenas", CellNumber 58, CellNumber 299]
, [CellString "Anastasia", CellString "San Martin", CellNumber 103, CellNumber 3214]
, [CellString "Mad", CellString "Max", CellNumber 37, CellNumber 918]
, [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.Word (Word64)
import Gauge (bgroup,bench,whnf)
import Gauge (bench, bgroup, whnf)
import Gauge.Main (defaultMain)
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 Cell
import qualified SimpleCsv
import qualified HexWord64
import qualified SimpleCsv
import qualified Word16Tree
main :: IO ()
main = defaultMain
[ bgroup "w64"
[ bgroup "hex"
[ bench "library" (whnf encodeHexWord64s w64s)
, bench "loop" (whnf encodeHexWord64sLoop w64s)
]
main =
defaultMain
[ bgroup
"w64"
[ 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
0xde2b8a480cf77113
0x48f1668ca2a68b45
0xd262fbaa0b2f473c
0xbab20547f4919d9f
0xb7ec16121704db43
0x9c259f5bfa90e1eb
0xd451eca11d9873ad
0xbd927e8d4c879d02
w64s =
Word64s
0xde2b8a480cf77113
0x48f1668ca2a68b45
0xd262fbaa0b2f473c
0xbab20547f4919d9f
0xb7ec16121704db43
0x9c259f5bfa90e1eb
0xd451eca11d9873ad
0xbd927e8d4c879d02
data Word64s = Word64s
!Word64 !Word64 !Word64 !Word64
!Word64 !Word64 !Word64 !Word64
data Word64s
= Word64s
!Word64
!Word64
!Word64
!Word64
!Word64
!Word64
!Word64
!Word64
encodeHexWord64s :: Word64s -> ByteArray
{-# noinline encodeHexWord64s #-}
encodeHexWord64s (Word64s a b c d e f g h) = U.run Nat.constant $
U.word64PaddedUpperHex a `U.append`
U.word64PaddedUpperHex b `U.append`
U.word64PaddedUpperHex c `U.append`
U.word64PaddedUpperHex d `U.append`
U.word64PaddedUpperHex e `U.append`
U.word64PaddedUpperHex f `U.append`
U.word64PaddedUpperHex g `U.append`
U.word64PaddedUpperHex h
{-# NOINLINE encodeHexWord64s #-}
encodeHexWord64s (Word64s a b c d e f g h) =
U.run Nat.constant $
U.word64PaddedUpperHex a
`U.append` U.word64PaddedUpperHex b
`U.append` U.word64PaddedUpperHex c
`U.append` U.word64PaddedUpperHex d
`U.append` U.word64PaddedUpperHex e
`U.append` U.word64PaddedUpperHex f
`U.append` U.word64PaddedUpperHex g
`U.append` U.word64PaddedUpperHex h
encodeHexWord64sLoop :: Word64s -> ByteArray
{-# noinline encodeHexWord64sLoop #-}
encodeHexWord64sLoop (Word64s a b c d e f g h) = U.run Nat.constant $
HexWord64.word64PaddedUpperHex a `U.append`
HexWord64.word64PaddedUpperHex b `U.append`
HexWord64.word64PaddedUpperHex c `U.append`
HexWord64.word64PaddedUpperHex d `U.append`
HexWord64.word64PaddedUpperHex e `U.append`
HexWord64.word64PaddedUpperHex f `U.append`
HexWord64.word64PaddedUpperHex g `U.append`
HexWord64.word64PaddedUpperHex h
{-# NOINLINE encodeHexWord64sLoop #-}
encodeHexWord64sLoop (Word64s a b c d e f g h) =
U.run Nat.constant $
HexWord64.word64PaddedUpperHex a
`U.append` HexWord64.word64PaddedUpperHex b
`U.append` HexWord64.word64PaddedUpperHex c
`U.append` HexWord64.word64PaddedUpperHex d
`U.append` HexWord64.word64PaddedUpperHex e
`U.append` HexWord64.word64PaddedUpperHex f
`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
-- any escaping or quoting. This is in its own module
@ -8,22 +8,24 @@ module SimpleCsv
( encodeRows
) where
import Cell (Cell(..))
import Cell (Cell (..))
import Data.Primitive (SmallArray)
import qualified Data.Foldable as F
import qualified Data.Bytes.Builder as B
import qualified Data.Foldable as F
encodeRows :: SmallArray (SmallArray Cell) -> B.Builder
encodeRows = F.foldr
(\r x -> encodeSimpleCsvRow r (B.ascii '\n' <> x))
mempty
encodeRows =
F.foldr
(\r x -> encodeSimpleCsvRow r (B.ascii '\n' <> x))
mempty
encodeSimpleCsvRow :: SmallArray Cell -> B.Builder -> B.Builder
encodeSimpleCsvRow cs b = F.foldr
(\c x -> encodeSimpleCsvCell c <> B.ascii ',' <> x)
b
cs
encodeSimpleCsvRow cs b =
F.foldr
(\c x -> encodeSimpleCsvCell c <> B.ascii ',' <> x)
b
cs
encodeSimpleCsvCell :: Cell -> B.Builder
encodeSimpleCsvCell = \case

143
bytebuild.cabal
View file

@ -1,17 +1,17 @@
cabal-version: 2.2
name: bytebuild
version: 0.3.16.1
synopsis: Build byte arrays
cabal-version: 2.2
name: bytebuild
version: 0.3.16.1
synopsis: Build byte arrays
description:
This is similar to the builder facilities provided by
`Data.ByteString.Builder`. It is intended to be used in
situations where the following apply:
.
* 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
one after another without anything between them.
one after another without anything between them.
.
Unlike builders from the `bytestring` package, these builders
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
CSVs and several line protocols (carbon, InfluxDB, etc.).
homepage: https://github.com/byteverse/bytebuild
bug-reports: https://github.com/byteverse/bytebuild/issues
license: BSD-3-Clause
license-file: LICENSE
author: Andrew Martin
maintainer: andrew.thaddeus@gmail.com
copyright: 2019 Andrew Martin
category: Data
extra-source-files: CHANGELOG.md
homepage: https://github.com/byteverse/bytebuild
bug-reports: https://github.com/byteverse/bytebuild/issues
license: BSD-3-Clause
license-file: LICENSE
author: Andrew Martin
maintainer: amartin@layer3com.com
copyright: 2019 Andrew Martin
category: Data
extra-doc-files: CHANGELOG.md
common build-settings
default-language: Haskell2010
ghc-options: -Wall -Wunused-packages
flag checked
manual: True
manual: True
description: Add bounds-checking to primitive array operations
default: False
default: False
library
import: build-settings
exposed-modules:
Data.Bytes.Builder
Data.Bytes.Builder.Avro
Data.Bytes.Builder.Class
Data.Bytes.Builder.Template
Data.Bytes.Builder.Unsafe
Data.Bytes.Builder.Bounded
Data.Bytes.Builder.Bounded.Class
Data.Bytes.Builder.Bounded.Unsafe
Data.Bytes.Builder.Class
Data.Bytes.Builder.Template
Data.Bytes.Builder.Unsafe
other-modules:
Compat
Op
reexported-modules:
Data.Bytes.Chunks
reexported-modules: Data.Bytes.Chunks
build-depends:
, base >=4.17.0.0 && <4.20
, byteslice >=0.2.6 && <0.3
, bytestring >=0.10.8.2 && <0.13
, haskell-src-meta >=0.8.13
, integer-logarithms >=1.0.3 && <1.1
, natural-arithmetic >=0.1 && <0.3
, primitive-offset >=0.2 && <0.3
, run-st >=0.1.2 && <0.2
, template-haskell >=2.16
, text >=2.0 && <2.2
, text-short >=0.1.3 && <0.2
, wide-word >=0.1.0.9 && <0.2
, base >=4.17.0.0 && <4.20
, byteslice >=0.2.6 && <0.3
, bytestring >=0.10.8.2 && <0.13
, haskell-src-meta >=0.8.13
, integer-logarithms >=1.0.3 && <1.1
, natural-arithmetic >=0.1 && <0.3
, primitive-offset >=0.2 && <0.3
, run-st >=0.1.2 && <0.2
, template-haskell >=2.16
, text >=2.0 && <2.2
, text-short >=0.1.3 && <0.2
, wide-word >=0.1.0.9 && <0.2
, zigzag
if impl(ghc >= 9.2)
if impl(ghc >=9.2)
hs-source-dirs: src-9.2
else
if impl(ghc >= 8.10)
if impl(ghc >=8.10)
hs-source-dirs: src-9.0
if flag(checked)
build-depends: primitive-checked >= 0.7 && <0.10
build-depends: primitive-checked >=0.7 && <0.10
hs-source-dirs: src-checked
else
build-depends: primitive >= 0.7 && <0.10
build-depends: primitive >=0.7 && <0.10
hs-source-dirs: src-unchecked
ghc-options: -Wall -O2
hs-source-dirs: src
default-language: Haskell2010
c-sources: cbits/bytebuild_custom.c
ghc-options: -O2
hs-source-dirs: src
c-sources: cbits/bytebuild_custom.c
test-suite test
default-language: Haskell2010
type: exitcode-stdio-1.0
hs-source-dirs: test, common
main-is: Main.hs
ghc-options: -O2 -Wall
import: build-settings
type: exitcode-stdio-1.0
hs-source-dirs: test common
main-is: Main.hs
ghc-options: -O2
other-modules:
HexWord64
Word16Tree
build-depends:
, QuickCheck >=2.13.1 && <2.15
, base >=4.12.0.0 && <5
, base >=4.12.0.0 && <5
, bytebuild
, byteslice
, bytestring
, natural-arithmetic
, primitive
, primitive-unlifted >=0.1.2
, quickcheck-classes >=0.6.4
, quickcheck-instances >=0.3.22
, QuickCheck >=2.13.1 && <2.15
, 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
, 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
, vector
, wide-word >=0.1.0.9 && <0.2
, wide-word >=0.1.0.9 && <0.2
benchmark bench
type: exitcode-stdio-1.0
import: build-settings
type: exitcode-stdio-1.0
build-depends:
, base
, bytebuild
, gauge >= 0.2.4
, byteslice
, gauge >=0.2.4
, natural-arithmetic
, primitive
, text-short
, byteslice
ghc-options: -Wall -O2
default-language: Haskell2010
hs-source-dirs: bench, common
main-is: Main.hs
ghc-options: -O2
hs-source-dirs: bench common
main-is: Main.hs
other-modules:
Cell
HexWord64
SimpleCsv
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 ScopedTypeVariables #-}
{-# language DataKinds #-}
{-# language UnboxedTuples #-}
{-# language MagicHash #-}
{-# language PolyKinds #-}
{-# language TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnboxedTuples #-}
module HexWord64
( word64PaddedUpperHex
@ -15,34 +15,37 @@ module HexWord64
-- the hoop jumping, the explicit loop used here is still outperformed
-- by just inlining the loop.
import GHC.ST (ST(ST))
import Data.Bits
import Data.Bytes.Builder.Bounded.Unsafe (Builder,construct)
import Data.Bytes.Builder.Bounded.Unsafe (Builder, construct)
import Data.Primitive
import Data.Word
import GHC.Exts
import GHC.ST (ST (ST))
import qualified Control.Monad.Primitive as PM
type ST# s (a :: TYPE (r :: RuntimeRep)) = State# s -> (# State# s, a #)
word64PaddedUpperHex :: Word64 -> Builder 16
word64PaddedUpperHex w = construct $ \a b -> ST
(\s0 -> case word64PaddedUpperHexLoop w 60 a b s0 of
(# s1, i #) -> (# s1, I# i #)
)
word64PaddedUpperHex w = construct $ \a b ->
ST
( \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 !w !shiftAmount !arr !i@(I# i#) s0 = if shiftAmount >= 0
then case PM.internal @(ST s) (writeByteArray arr i (toHexUpper (unsafeShiftR w shiftAmount))) s0 of
(# s1, (_ :: ()) #) -> word64PaddedUpperHexLoop w (shiftAmount - 4) arr (i + 1) s1
else (# s0, i# #)
word64PaddedUpperHexLoop !w !shiftAmount !arr !i@(I# i#) s0 =
if shiftAmount >= 0
then case PM.internal @(ST s) (writeByteArray arr i (toHexUpper (unsafeShiftR w shiftAmount))) s0 of
(# s1, (_ :: ()) #) -> word64PaddedUpperHexLoop w (shiftAmount - 4) arr (i + 1) s1
else (# s0, i# #)
toHexUpper :: Word64 -> Word8
toHexUpper w' = fromIntegral
$ (complement theMask .&. loSolved)
.|. (theMask .&. hiSolved)
where
toHexUpper w' =
fromIntegral $
(complement theMask .&. loSolved)
.|. (theMask .&. hiSolved)
where
w = w' .&. 0xF
-- This is all ones if the value was >= 10
theMask = (1 .&. unsafeShiftR (w - 10) 63) - 1

93
common/Word16Tree.hs
View file

@ -1,4 +1,4 @@
{-# language BangPatterns #-}
{-# LANGUAGE BangPatterns #-}
module Word16Tree
( Word16Tree
@ -9,11 +9,11 @@ module Word16Tree
, expectedSmall
) where
import Data.Bytes.Builder as B
import Data.Word (Word16)
import Data.Primitive (ByteArray)
import qualified Data.Bytes as Bytes
import Data.Bytes.Builder as B
import qualified Data.Bytes.Text.Ascii
import Data.Primitive (ByteArray)
import Data.Word (Word16)
data Word16Tree
= Branch !Word16Tree !Word16Tree
@ -23,63 +23,62 @@ encode :: Word16Tree -> Builder
encode (Leaf w) = B.word16PaddedUpperHex w
encode (Branch a b) =
B.ascii '('
<>
encode a
<>
B.ascii ','
<>
encode b
<>
B.ascii ')'
<> encode a
<> B.ascii ','
<> encode b
<> B.ascii ')'
expectedSmall :: ByteArray
expectedSmall = Bytes.toByteArray $ Data.Bytes.Text.Ascii.fromString
"((AB59,(1F33,2E71)),((((FA9A,247B),890C),(0F13,((55BF,7CF1),389B))),1205))"
expectedSmall =
Bytes.toByteArray $
Data.Bytes.Text.Ascii.fromString
"((AB59,(1F33,2E71)),((((FA9A,247B),890C),(0F13,((55BF,7CF1),389B))),1205))"
exampleSmall :: Word16Tree
exampleSmall = Branch
(Branch
(Leaf 0xAB59)
(Branch
(Leaf 0x1F33)
(Leaf 0x2E71)
)
)
(Branch
(Branch
(Branch
(Branch
(Leaf 0xFA9A)
(Leaf 0x247B)
exampleSmall =
Branch
( Branch
(Leaf 0xAB59)
( Branch
(Leaf 0x1F33)
(Leaf 0x2E71)
)
(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
{-# noinline example2000 #-}
{-# NOINLINE example2000 #-}
example2000 = balanced 0 2000
example9000 :: Word16Tree
{-# noinline example9000 #-}
{-# NOINLINE example9000 #-}
example9000 = balanced 0 9000
balanced :: Word16 -> Word16 -> Word16Tree
balanced !off !n
| n == 0 = Leaf off
| n == 1 = Leaf (off + 1)
| otherwise = let x = div n 2 in
Branch (balanced off x) (balanced (off + x) (n - x))
| otherwise =
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.
-- The name of the directory is a little misleading.
@ -14,40 +14,40 @@ module Compat
, word32ToWord#
) where
import GHC.Exts (Int#,Word#)
import GHC.Exts (Int#, Word#)
int8ToInt# :: Int# -> Int#
{-# inline int8ToInt# #-}
{-# INLINE int8ToInt# #-}
int8ToInt# x = x
int16ToInt# :: Int# -> Int#
{-# inline int16ToInt# #-}
{-# INLINE int16ToInt# #-}
int16ToInt# x = x
int32ToInt# :: Int# -> Int#
{-# inline int32ToInt# #-}
{-# INLINE int32ToInt# #-}
int32ToInt# x = x
wordToWord8# :: Word# -> Word#
{-# inline wordToWord8# #-}
wordToWord8# x = x
{-# INLINE wordToWord8# #-}
wordToWord8# x = x
wordToWord16# :: Word# -> Word#
{-# inline wordToWord16# #-}
{-# INLINE wordToWord16# #-}
wordToWord16# x = x
wordToWord32# :: Word# -> Word#
{-# inline wordToWord32# #-}
{-# INLINE wordToWord32# #-}
wordToWord32# x = x
word8ToWord# :: Word# -> Word#
{-# inline word8ToWord# #-}
{-# INLINE word8ToWord# #-}
word8ToWord# x = x
word16ToWord# :: Word# -> Word#
{-# inline word16ToWord# #-}
{-# INLINE word16ToWord# #-}
word16ToWord# x = x
word32ToWord# :: Word# -> Word#
{-# inline word32ToWord# #-}
{-# INLINE word32ToWord# #-}
word32ToWord# x = x

6
src-9.2/Compat.hs
View file

@ -1,10 +1,10 @@
{-# language MagicHash #-}
{-# LANGUAGE MagicHash #-}
module Compat
module Compat
( int8ToInt#
, int16ToInt#
, int32ToInt#
, wordToWord8#
, wordToWord8#
, wordToWord16#
, wordToWord32#
, word8ToWord#

16
src-checked/Op.hs
View file

@ -1,5 +1,5 @@
{-# language MagicHash #-}
{-# language UnboxedTuples #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
module Op
( writeCharArray#
@ -7,9 +7,9 @@ module Op
, copyMutableByteArray#
) where
import GHC.Exts ((<#),(>=#),State#,Int#,MutableByteArray#,ByteArray#,Char#)
import GHC.Int (Int(I#))
import GHC.Exts (ByteArray#, Char#, Int#, MutableByteArray#, State#, (<#), (>=#))
import qualified GHC.Exts as Exts
import GHC.Int (Int (I#))
writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
writeCharArray# arr i v st = case i <# 0# of
@ -27,8 +27,8 @@ copyByteArray# src soff dst doff len s0 =
, I# doff >= 0
, I# len >= 0
, I# doff + I# len <= I# sz
, I# soff + I# len <= I# (Exts.sizeofByteArray# src)
-> Exts.copyByteArray# src soff dst doff len s1
, I# soff + I# len <= I# (Exts.sizeofByteArray# src) ->
Exts.copyByteArray# src soff dst doff len s1
| otherwise -> error "copyByteArray#: index range out of bounds"
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# len >= 0
, I# doff + I# len <= I# szDst
, I# soff + I# len <= I# szSrc
-> Exts.copyMutableByteArray# src soff dst doff len s2
, I# soff + I# len <= I# szSrc ->
Exts.copyMutableByteArray# src soff dst doff len s2
| 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
( writeCharArray#
@ -6,4 +6,4 @@ module Op
, copyMutableByteArray#
) 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
-- module are just aliases for other functions. Avro uses zig-zag LEB128
-- for all integral types.
{- | Builders for encoding data with Apache Avro. Most functions in this
module are just aliases for other functions. Avro uses zig-zag LEB128
for all integral types.
-}
module Data.Bytes.Builder.Avro
( int
, int32
@ -13,21 +14,22 @@ module Data.Bytes.Builder.Avro
, bytes
, chunks
, text
-- * Maps
, map2
) where
import Data.Int
import Data.Word
import Data.Bytes.Builder (Builder)
import Data.Text (Text)
import Data.Bytes (Bytes)
import Data.WideWord (Word128)
import Data.Bytes.Builder (Builder)
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.Chunks as Chunks
import qualified Data.Bytes.Builder as B
import qualified Data.Bytes.Chunks as Chunks
import qualified Data.Bytes.Text.Utf8 as Utf8
int32 :: Int32 -> Builder
@ -39,19 +41,22 @@ int64 = B.int64LEB128
int :: Int -> Builder
int = B.intLEB128
-- | Note: This results in a zigzag encoded number. Avro does not have
-- unsigned types.
{- | Note: This results in a zigzag encoded number. Avro does not have
unsigned types.
-}
word16 :: Word16 -> Builder
word16 = B.int32LEB128 . fromIntegral
-- | Note: This results in a zigzag encoded number. Avro does not have
-- unsigned types.
{- | Note: This results in a zigzag encoded number. Avro does not have
unsigned types.
-}
word32 :: Word32 -> Builder
word32 = B.int64LEB128 . fromIntegral
-- | Note: This results in a @fixed@ encoded value of length 16. In the
-- schema, the type must be @{"type": "fixed", "name": "...", "size": 16}@.
-- A big-endian encoding is used.
{- | Note: This results in a @fixed@ encoded value of length 16. In the
schema, the type must be @{"type": "fixed", "name": "...", "size": 16}@.
A big-endian encoding is used.
-}
word128 :: Word128 -> Builder
word128 = B.word128BE
@ -64,14 +69,19 @@ chunks !b = int (Chunks.length b) <> B.chunks b
text :: Text -> Builder
text = bytes . Utf8.fromText
-- | 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
-- a map with two keys: @avro.schema@ and @avro.codec@.
{- | 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
a map with two keys: @avro.schema@ and @avro.codec@.
-}
map2 ::
Text -- ^ First key
-> Builder -- ^ First value (already encoded)
-> Text -- ^ Second key
-> Builder -- ^ Second value (already encoded)
-> Builder
{-# inline map2 #-}
-- | First key
Text ->
-- | First value (already encoded)
Builder ->
-- | Second key
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

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 TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Bytes.Builder.Bounded.Class
( ToBoundedBuilder(..)
( ToBoundedBuilder (..)
) where
import Data.Int
@ -11,14 +11,15 @@ import Data.Word
import qualified Data.Bytes.Builder.Bounded as Bounded
import qualified GHC.TypeNats as GHC
-- | 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
-- decimal characters. UTF-8 is preferred for textual types. For types
-- that represent arbitrary bytes (e.g. Bytes, ByteString), the bytes
-- are preserved.
--
-- The goal of this typeclass is to reduce the size of builders produced
-- by quasiquotation.
{- | 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
decimal characters. UTF-8 is preferred for textual types. For types
that represent arbitrary bytes (e.g. Bytes, ByteString), the bytes
are preserved.
The goal of this typeclass is to reduce the size of builders produced
by quasiquotation.
-}
class ToBoundedBuilder a where
type BoundedBuilderLength a :: GHC.Nat
toBuilder :: a -> Bounded.Builder (BoundedBuilderLength a)

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

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

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

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

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

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

651
test/Main.hs
View file

@ -1,53 +1,50 @@
{-# language BangPatterns #-}
{-# language NumericUnderscores #-}
{-# language OverloadedStrings #-}
{-# language QuasiQuotes #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
import Prelude hiding (replicate)
import Control.Applicative (liftA2)
import Control.Monad.ST (runST)
import Data.Bytes.Builder
import Data.Bytes.Builder.Template (bldr)
import Data.Bytes.Types (MutableBytes(MutableBytes))
import Data.Char (ord,chr)
import Data.IORef (IORef,newIORef,readIORef,writeIORef)
import Data.Bytes.Types (MutableBytes (MutableBytes))
import Data.Char (chr, ord)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import Data.Primitive (ByteArray)
import Data.Primitive (PrimArray)
import Data.Primitive (ByteArray, PrimArray)
import Data.Text.Short (ShortText)
import Data.WideWord (Word128(Word128),Word256(Word256))
import Data.WideWord (Word128 (Word128), Word256 (Word256))
import Data.Word
import Numeric.Natural (Natural)
import Test.QuickCheck ((===),Arbitrary)
import Test.QuickCheck (Arbitrary, (===))
import Test.QuickCheck.Instances.Natural ()
import Test.Tasty (defaultMain,testGroup,TestTree)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit ((@=?))
import Text.Printf (printf)
import qualified Arithmetic.Nat as Nat
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.Builder as Builder
import qualified Data.Bytes.Builder.Bounded as Bounded
import qualified Data.Bytes.Chunks as Chunks
import qualified Data.Bytes.Text.Ascii as Ascii
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.Primitive as PM
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified GHC.Exts as Exts
import qualified Prelude
import qualified Test.Tasty.HUnit as THU
import qualified Test.Tasty.QuickCheck as TQC
import qualified Prelude
import qualified HexWord64
import qualified Word16Tree
@ -56,299 +53,309 @@ main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "Tests"
[ testGroup "live"
[ TQC.testProperty "word64Dec" $ \w ->
runConcat 1 (word64Dec w) === pack (show w)
, TQC.testProperty "word64Dec-x3" $ \x y z ->
runConcat 1 (word64Dec x <> word64Dec y <> word64Dec z)
===
pack (show x ++ show y ++ show z)
, TQC.testProperty "int64Dec-x3" $ \x y z ->
runConcat 1 (int64Dec x <> int64Dec y <> int64Dec z)
===
pack (show x ++ show y ++ show 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)))
, TQC.testProperty "word256PaddedLowerHex" $ \w ->
Bounded.run Nat.constant (Bounded.word256PaddedLowerHex w)
===
pack (showWord256PaddedLowerHex w)
, TQC.testProperty "word128PaddedUpperHex" $ \w ->
Bounded.run Nat.constant (Bounded.word128PaddedUpperHex w)
===
pack (showWord128PaddedUpperHex w)
, TQC.testProperty "word64PaddedUpperHex" $ \w ->
runConcat 1 (word64PaddedUpperHex w)
===
pack (showWord64PaddedUpperHex w)
, TQC.testProperty "word16PaddedLowerHex" $ \w ->
runConcat 1 (word16PaddedLowerHex w)
===
pack (showWord16PaddedLowerHex w)
, TQC.testProperty "wordPaddedDec2" $ TQC.forAll (TQC.choose (0,99)) $ \w ->
Bounded.run Nat.two (Bounded.wordPaddedDec2 w)
===
pack (zeroPadL 2 (show w))
, TQC.testProperty "wordPaddedDec4" $ TQC.forAll (TQC.choose (0,9999)) $ \w ->
Bounded.run Nat.constant (Bounded.wordPaddedDec4 w)
===
pack (zeroPadL 4 (show w))
, TQC.testProperty "wordPaddedDec9" $ TQC.forAll (TQC.choose (0,999999999)) $ \w ->
Bounded.run Nat.constant (Bounded.wordPaddedDec9 w)
===
pack (zeroPadL 9 (show w))
, TQC.testProperty "word8Dec" $ \w ->
runConcat 1 (word8Dec w)
===
pack (show w)
, TQC.testProperty "consLength32BE" $ \w ->
runConcat 1 (consLength32BE (word8Dec w))
===
pack ('\x00' : '\x00' : '\x00' : chr (L.length (show w)) : show w)
, TQC.testProperty "consLength64BE-uni" $ \w ->
pack
( '\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
tests =
testGroup
"Tests"
[ testGroup
"live"
[ TQC.testProperty "word64Dec" $ \w ->
runConcat 1 (word64Dec w) === pack (show w)
, TQC.testProperty "word64Dec-x3" $ \x y z ->
runConcat 1 (word64Dec x <> word64Dec y <> word64Dec z)
=== pack (show x ++ show y ++ show z)
, TQC.testProperty "int64Dec-x3" $ \x y z ->
runConcat 1 (int64Dec x <> int64Dec y <> int64Dec z)
=== pack (show x ++ show y ++ show 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)))
, TQC.testProperty "word256PaddedLowerHex" $ \w ->
Bounded.run Nat.constant (Bounded.word256PaddedLowerHex w)
=== pack (showWord256PaddedLowerHex w)
, TQC.testProperty "word128PaddedUpperHex" $ \w ->
Bounded.run Nat.constant (Bounded.word128PaddedUpperHex w)
=== pack (showWord128PaddedUpperHex w)
, TQC.testProperty "word64PaddedUpperHex" $ \w ->
runConcat 1 (word64PaddedUpperHex w)
=== pack (showWord64PaddedUpperHex w)
, TQC.testProperty "word16PaddedLowerHex" $ \w ->
runConcat 1 (word16PaddedLowerHex w)
=== pack (showWord16PaddedLowerHex w)
, TQC.testProperty "wordPaddedDec2" $ TQC.forAll (TQC.choose (0, 99)) $ \w ->
Bounded.run Nat.two (Bounded.wordPaddedDec2 w)
=== pack (zeroPadL 2 (show w))
, TQC.testProperty "wordPaddedDec4" $ TQC.forAll (TQC.choose (0, 9999)) $ \w ->
Bounded.run Nat.constant (Bounded.wordPaddedDec4 w)
=== pack (zeroPadL 4 (show w))
, TQC.testProperty "wordPaddedDec9" $ TQC.forAll (TQC.choose (0, 999999999)) $ \w ->
Bounded.run Nat.constant (Bounded.wordPaddedDec9 w)
=== pack (zeroPadL 9 (show w))
, TQC.testProperty "word8Dec" $ \w ->
runConcat 1 (word8Dec w)
=== pack (show w)
, TQC.testProperty "consLength32BE" $ \w ->
runConcat 1 (consLength32BE (word8Dec w))
=== pack ('\x00' : '\x00' : '\x00' : chr (L.length (show w)) : show w)
, TQC.testProperty "consLength64BE-uni" $ \w ->
pack
( '\x00'
: '\x00'
: '\x00'
: '\x00'
: '\x00'
: '\x00'
: '\x00'
: chr (L.length (show w))
: show w
)
, 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"
]
=== 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]) ->
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 ::
IORef [PM.ByteArray]
-> MutableBytes Exts.RealWorld
-> IO ()
IORef [PM.ByteArray] ->
MutableBytes Exts.RealWorld ->
IO ()
bytesOntoRef !ref (MutableBytes buf off len) = do
rs <- readIORef ref
dst <- PM.newByteArray len
@ -391,9 +398,10 @@ newtype AsciiByteArray = AsciiByteArray ByteArray
deriving (Eq)
instance Show AsciiByteArray where
show (AsciiByteArray b) = if Bytes.all (\w -> w >= 32 && w < 127) (Bytes.fromByteArray b)
then Latin1.toString (Bytes.fromByteArray b)
else show (show b)
show (AsciiByteArray b) =
if Bytes.all (\w -> w >= 32 && w < 127) (Bytes.fromByteArray b)
then Latin1.toString (Bytes.fromByteArray b)
else show (show b)
instance Arbitrary Word128 where
arbitrary = liftA2 Word128 TQC.arbitrary TQC.arbitrary
@ -409,29 +417,30 @@ zeroPadL n s
naiveLeb128 :: Natural -> ByteArray
naiveLeb128 x =
Bytes.toByteArray (Bytes.unsafeDrop 1 (Exts.fromList (0xFF : go [] x)))
where
where
go !xs !n =
let (q,r) = quotRem n 128
let (q, r) = quotRem n 128
r' = fromIntegral @Natural @Word8 r
w = if q == 0
then r'
else Bits.setBit r' 7
w =
if q == 0
then r'
else Bits.setBit r' 7
xs' = w : xs
in if q == 0
in if q == 0
then L.reverse xs'
else go xs' q
naiveVlq :: Natural -> ByteArray
naiveVlq x =
Bytes.toByteArray (Bytes.unsafeDrop 1 (Exts.fromList (0xFF : go [] x)))
where
where
go !xs !n =
let (q,r) = quotRem n 128
let (q, r) = quotRem n 128
r' = fromIntegral @Natural @Word8 r
w = case xs of
[] -> r'
_ -> Bits.setBit r' 7
xs' = w : xs
in if q == 0
in if q == 0
then xs'
else go xs' q